use SHA1 with COBOL - sha1

I was wondering if there's any way to apply SHA1 hash with COBOL.
If there's at least some info of how the SHA1 algorithm works it will be usefull.
Thanks

You didn't say which Cobol platform. If you are on z/OS, there are a variety of cryptography services that are easily called from Cobol. And SHA1 is available among those services.

I did a small sample embedding Python in COBOL, and picked an MD5 checksum as an example.
I wouldn't necessarily go with Python, but if you are lucky enough to be able to use OpenCOBOL, then all the features of libcrypto are a simple CALL away.
For completeness, having mentioned the Python angle, but again that's pretty hefy baggage if the goal is simply cryptography. In which case OpenSSL would be a much tighter fit. This listing is very likely NOT suitable for your needs, but it shows off the power of CALL and the C application binary interface. Please excuse me if this is just noise.
From SourceForge:
Very high level Python embedding is pretty straight forward, been there, done that.
>>SOURCE FORMAT IS FIXED
*> *******************************************************
*> Author: Brian Tiffin
*> Date: 20130126
*> Purpose: Embed Python
*> Tectonics: cobc -x cobpy.cob -lpython2.6
*> *******************************************************
identification division.
program-id. cobpy.
procedure division.
call "Py_Initialize"
on exception
display "link cobpy with -lpython2.6" end-display
end-call
call "PyRun_SimpleString" using
by reference
"from time import time,ctime" & x"0a" &
"print('Today is', ctime(time()))" & x"0a" & x"00"
on exception continue
end-call
call "Py_Finalize" end-call
goback.
end program cobpy.
Giving
$ cobc -x cobpy.cob -lpython2.6
$ ./cobpy
('Today is', 'Sat Jan 26 20:01:41 2013')
Python dutifully displayed the tuple.
But what fun is Python if it is just for high level script side effects? Lots, but still.
Pure embedding.
>>SOURCE FORMAT IS FIXED
*> *******************************************************
*> Author: Brian Tiffin
*> Date: 20130126
*> Purpose: Embed Python
*> Tectonics: cobc -x cobkat.cob -lpython2.6
*> NOTES: leaks, no Py_DECREF macros called.
*> *******************************************************
identification division.
program-id. cobkat.
data division.
working-storage section.
77 python-name usage pointer.
77 python-module usage pointer.
77 python-dict usage pointer.
77 python-func usage pointer.
77 python-stringer usage pointer.
77 python-args usage pointer.
77 python-value usage pointer.
01 cobol-buffer-pointer usage pointer.
01 cobol-buffer pic x(80) based.
01 cobol-string pic x(80).
01 cobol-integer usage binary-long.
01 command-line-args pic x(80).
*> *******************************************************
procedure division.
call "Py_Initialize"
on exception
display "link cobpy with -lpython" end-display
end-call
*> Python likes module names in Unicode
call "PyUnicodeUCS4_FromString" using
by reference "pythonfile" & x"00"
returning python-name
on exception
display "unicode problem" end-display
end-call
*> import the module, using PYTHONPATH
call "PyImport_Import" using
by value python-name
returning python-module
on exception
display "this would be borked" end-display
end-call
if python-module equal null
display "no pythonfile.py in PYTHONPATH" end-display
end-if
*> within the module, an attribute is "pythonfunction"
call "PyObject_GetAttrString" using
by value python-module
by reference "pythonfunction" & x"00"
returning python-func
on exception continue
end-call
*>
*> error handling now skimped out on
*>
*> pythonfunction takes a single argument
call "PyTuple_New" using
by value 1
returning python-args
end-call
*> of type long, hard coded to the ultimate answer
call "PyLong_FromLong" using
by value 42
returning python-value
end-call
*> set first (only) element of the argument tuple
call "PyTuple_SetItem" using
by value python-args
by value 0
by value python-value
end-call
*> call the function, arguments marshalled for Python
call "PyObject_CallObject" using
by value python-func
by value python-args
returning python-value
end-call
*> we know we get a long back, hopefully 1764
call "PyLong_AsLong" using
by value python-value
returning cobol-integer
end-call
display "Python returned: " cobol-integer end-display
*> **************************************************** *<
*> a function taking string and returning string
call "PyObject_GetAttrString" using
by value python-module
by reference "pythonstringer" & x"00"
returning python-stringer
end-call
call "PyTuple_New" using
by value 1
returning python-args
end-call
*> Use the OpenCOBOL command argument
accept command-line-args from command-line end-accept
call "PyString_FromString" using
by reference
function concatenate(
function trim(command-line-args)
x"00")
returning python-value
end-call
*> Set the function argument tuple to the cli args
call "PyTuple_SetItem" using
by value python-args
by value 0
by value python-value
end-call
*> call the "pythonstringer" function
call "PyObject_CallObject" using
by value python-stringer
by value python-args
returning python-value
end-call
*> return as String (with the MD5 hex digest tacked on)
call "PyString_AsString" using
by value python-value
returning cobol-buffer-pointer
end-call
*> one way of removing null while pulling data out of C
set address of cobol-buffer to cobol-buffer-pointer
string
cobol-buffer delimited by x"00"
into cobol-string
end-string
display "Python returned: " cobol-string end-display
*> and clear out <*
call "Py_Finalize" end-call
goback.
end program cobkat.
with pythonfile.py
#
# Simple Python sample for OpenCOBOL embedding trial
#
def pythonfunction(i):
return i * i
import hashlib
def pythonstringer(s):
sum = hashlib.md5()
sum.update(s)
return s + ": " + sum.hexdigest()
Giving
$ ./cobkat Python will use this for MD5 hash
no pythonfile.py in PYTHONPATH
Attempt to reference unallocated memory (Signal SIGSEGV)
Abnormal termination - File contents may be incorrect
Oops
$ export PYTHONPATH=.
$ ./cobkat Python will use this for MD5 hash
Python returned: +0000001764
Python returned: Python will use this for MD5 hash: c5577e3ab8dea11adede20a1949b5fb3
Haven't done one of these in a while, fun.
Cheers,
Brian
Oh, in case you're reading along, 1764 is the ultimate answer, squared.

Here's a more on point source listing. Requires OpenCOBOL 1.1CE for the OC_CBL_DUMP
First up, is paying homage to the authors of OpenSSL. They deserve credits.
OpenSSL License
---------------
/* ====================================================================
* Copyright (c) 1998-2011 The OpenSSL Project. All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in
* the documentation and/or other materials provided with the
* distribution.
*
* 3. All advertising materials mentioning features or use of this
* software must display the following acknowledgment:
* "This product includes software developed by the OpenSSL Project
* for use in the OpenSSL Toolkit. (http://www.openssl.org/)"
*
* 4. The names "OpenSSL Toolkit" and "OpenSSL Project" must not be used to
* endorse or promote products derived from this software without
* prior written permission. For written permission, please contact
* openssl-core#openssl.org.
*
* 5. Products derived from this software may not be called "OpenSSL"
* nor may "OpenSSL" appear in their names without prior written
* permission of the OpenSSL Project.
*
* 6. Redistributions of any form whatsoever must retain the following
* acknowledgment:
* "This product includes software developed by the OpenSSL Project
* for use in the OpenSSL Toolkit (http://www.openssl.org/)"
*
* THIS SOFTWARE IS PROVIDED BY THE OpenSSL PROJECT ``AS IS'' AND ANY
* EXPRESSED OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE OpenSSL PROJECT OR
* ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
* NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
* OF THE POSSIBILITY OF SUCH DAMAGE.
* ====================================================================
*
* This product includes cryptographic software written by Eric Young
* (eay#cryptsoft.com). This product includes software written by Tim
* Hudson (tjh#cryptsoft.com).
*
*/
Original SSLeay License
-----------------------
/* Copyright (C) 1995-1998 Eric Young (eay#cryptsoft.com)
* All rights reserved.
*
* This package is an SSL implementation written
* by Eric Young (eay#cryptsoft.com).
* The implementation was written so as to conform with Netscapes SSL.
*
* This library is free for commercial and non-commercial use as long as
* the following conditions are aheared to. The following conditions
* apply to all code found in this distribution, be it the RC4, RSA,
* lhash, DES, etc., code; not just the SSL code. The SSL documentation
* included with this distribution is covered by the same copyright terms
* except that the holder is Tim Hudson (tjh#cryptsoft.com).
*
* Copyright remains Eric Young's, and as such any Copyright notices in
* the code are not to be removed.
* If this package is used in a product, Eric Young should be given attribution
* as the author of the parts of the library used.
* This can be in the form of a textual message at program startup or
* in documentation (online or textual) provided with the package.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. All advertising materials mentioning features or use of this software
* must display the following acknowledgement:
* "This product includes cryptographic software written by
* Eric Young (eay#cryptsoft.com)"
* The word 'cryptographic' can be left out if the rouines from the library
* being used are not cryptographic related :-).
* 4. If you include any Windows specific code (or a derivative thereof) from
* the apps directory (application code) you must include an acknowledgement:
* "This product includes software written by Tim Hudson (tjh#cryptsoft.com)"
*
* THIS SOFTWARE IS PROVIDED BY ERIC YOUNG ``AS IS'' AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
* SUCH DAMAGE.
*
* The licence and distribution terms for any publically available version or
* derivative of this code cannot be changed. i.e. this code cannot simply be
* copied and put under another distribution licence
* [including the GNU Public Licence.]
*/
And some COBOL to exercise the cryptography and the two forms of SHA1 hashing
>>source format is free
*> ***************************************************************
*> Author: Brian Tiffin
*> Date: 20130321
*> Purpose: Compute an SHA1 digest, whole
*> Tectonics: cobc -x sha1a.cob -lcrypto
*> ***************************************************************
IDENTIFICATION DIVISION.
program-id. sha1a.
data division.
working-storage section.
01 sha1-digest pic x(20).
01 digestable pic x(80) value "this message needs to be verified".
*> ***************************************************************
procedure division.
*> Compute disgest from block of memory
call "SHA1" using
by reference digestable
by value function length(function trim(digestable))
by reference sha1-digest
on exception
display "link sha1.cob with OpenSSL's libcrypto" end-display
end-call
*> Dump the hash, as it'll unlikely be printable
call "CBL_OC_DUMP" using
by reference sha1-digest
on exception continue
end-call
goback.
end program sha1a.
With a sample run of
$ cobc -x sha1a.cob
$ ./sha1a
link sha1.cob with OpenSSL's libcrypto
Offset HEX-- -- -- -5 -- -- -- -- 10 -- -- -- -- 15 -- CHARS----1----5-
000000 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
000016 20 20 20 20
$ cobc -x sha1a.cob -lcrypto
$ ./sha1a
Offset HEX-- -- -- -5 -- -- -- -- 10 -- -- -- -- 15 -- CHARS----1----5-
000000 c7 3b 52 0c 61 39 9b f9 a5 2f fe 3f 11 90 5e 10 .;R.a9.../.?..^.
000016 3b 0d 15 c5 ;...
And a more complete example, building the digest from multiple updates.
Assumptions here: This will crack on files with trailing spaces.
>>source format is free
*> ***************************************************************
*> Author: Brian Tiffin
*> Date: 20130321
*> Purpose: Compute an SHA1 digest, by piece
*> Tectonics: cobc -x sha1.cob -lcrypto
*> ***************************************************************
IDENTIFICATION DIVISION.
program-id. sha1.
environment division.
configuration section.
input-output section.
file-control.
select samplefile
assign to "sha1.cob"
organization is line sequential
file status is sample-status
.
DATA DIVISION.
file section.
fd samplefile.
01 input-line pic x(2048).
working-storage section.
01 sha1-context usage pointer.
01 sha1-libresult usage binary-long.
88 sha1-success value 1 when set to false is 0.
01 sha1-digest pic x(20).
01 sample-status pic 9999.
01 sample-file-state pic 9.
88 no-more-sample value 9 when set to false is 0.
01 sha-ctx-structure pic x(1024).
*> ***************************************************************
PROCEDURE DIVISION.
*> Compute disgest from a sequential file
open input samplefile
if sample-status not equal to zero
display "Status of " sample-status " returned from open" end-display
display "rest of sample run will be garbage" end-display
end-if
*> Init the SHA1 internals
set sha1-context to address of sha-ctx-structure
call "SHA1_Init" using
by value sha1-context
returning sha1-libresult
on exception
display "Can't find SHA1_Init. hint: cobc -x sha1 -lcrypto" end-display
end-call
if not sha1-success
display "Could not initialize SHA1 structures" end-display
display "normally you'd want to stop run and call the emergency hotline to wake up the support techs, but this is an example and blindly continues." end-display
end-if
*> loop across some data, ignoring issue of trailing spaces on input lines
read samplefile at end set no-more-sample to true end-read
if input-line equal spaces then
move x"0a" to input-line(1:1)
else
move function concatenate(function trim(input-line trailing), x"0a") to input-line
end-if
perform until no-more-sample
call "SHA1_Update" using
by value sha1-context
by content function trim(input-line trailing)
by value function length(function trim(input-line trailing))
on exception display "internal update failure of SHA1_Update" end-display
end-call
if not sha1-success
display "Could not update SHA1 structures" end-display
display "normally you'd want to stop run." end-display
end-if
read samplefile at end set no-more-sample to true end-read
if input-line equal spaces then
move x"0a" to input-line(1:1)
else
move function concatenate(function trim(input-line trailing), x"0a") to input-line
end-if
end-perform
*> finalize the disgest
call "SHA1_Final" using
by reference sha1-digest
by value sha1-context
on exception display "you're kidding right? internal failure of SHA1_Final" end-display
end-call
close samplefile
*> Dump the hash, as it'll unlikely be printable
call "CBL_OC_DUMP" using
by reference sha1-digest
on exception continue
end-call
goback.
END PROGRAM sha1.
and another sample run of
$ cobc -x sha1.cob -lcrypto
$ ./sha1
Offset HEX-- -- -- -5 -- -- -- -- 10 -- -- -- -- 15 -- CHARS----1----5-
000000 d4 04 4b ed 02 e8 ef 54 e0 c4 73 0b 6b 51 85 bc ..K....T..s.kQ..
000016 85 73 d3 16 .s..
$ openssl sha1 sha1.cob
SHA1(sha1.cob)= d4044bed02e8ef54e0c4730b6b5185bc8573d316

SHA1 rquires a lot of bitwise operations (XOR,AND,OR) which are not generally supported in COBOL (they are supported by a few compilers).
Your best bet would be to simply adjust one of the many C implementations so it can be easily called as a COBOL subroutine.
Information on your platform and compiler would be useful.

Yes, there's a way to apply SHA1 hash with COBOL.
I have written the SHA256 hashing algorithm in COBOL, with heaps of telemetry everywhere to let you know exactly what is going on at all points along the way.
If you can do SHA256 in COBOL, you can do SHA-1 in COBOL.
Don't squib it by hashing small input character strings.
Make sure your program works for reams of input characters, so that it can be used for document authentication.
If you've understood the entire specs, then your result for that will be correct as well.
And then, see if you can hash the hash - like bitcoin does.
That is a little bit more tricky than it looks like on face value.
I have assumed that you have to do the coding in COBOL itself,
so that YOU do the real work - not just call a subprogram which someone else has written.
Anyone could do that, so you wouldn't be asking if it was just that.
Look on Github to see how the SHA256 algorithm works.
It also shows example animated intermediate calculations, not just the final result.
IMO finding the full specification is BY FAR the hardest thing.
There's a number of youtube videos, but they are describing only a few tiny parts of the full story.
But if you have ANY weakness in your COBOL skills, especially table processing, but also in structuring your code, EVEN IF YOU FINALLY UNDERSTAND THE SPECS, you'll have a lot of trouble converting SPECS into working code, depending on how you want to get your code written. Transform centred design helps.
This link is a good help as well.
https://hackernoon.com/how-sha-2-works-a-step-by-step-tutorial-sha-256-46103t6k
Use it AND the Github stuff together, but they don't both use the same example input string.
In summary, this about your analysis skills, design skills, coding skills and testing skills - if you want it to be.
Good Luck.
Let us all know how you go.
Added 18th July 2021
FYI
https://github.com/DoHITB/CryptoCobol/blob/main/SHA1HEX.CBL

Related

PC COBOL program to JCL

I have the following simple COBOL program - written for the PC. It simply reads a file from the computer and writes to the file:
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT CUSTOMER-FILE ASSIGN TO
"C:Customers.dat"
ORGANIZATION IS LINE SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD CUSTOMER-FILE.
01 CUSTOMER-RECORD.
05 FIRST-NAME PIC X(20).
05 LAST-NAME PIC X(20).
WORKING-STORAGE SECTION.
01 WS-CUSTOMER-RECORD.
05 WS-FIRST-NAME PIC X(20).
05 WS-LAST-NAME PIC X(20).
01 WS-EOF PIC X.
PROCEDURE DIVISION.
OPEN OUTPUT CUSTOMER-FILE
PERFORM UNTIL CUSTOMER-RECORD = SPACES
DISPLAY "Enter the first and last name for the customer"
ACCEPT CUSTOMER-RECORD
WRITE CUSTOMER-RECORD
END-PERFORM
CLOSE CUSTOMER-FILE
DISPLAY "Output from the Customer File:"
OPEN INPUT CUSTOMER-FILE.
PERFORM UNTIL WS-EOF = 'Y'
READ CUSTOMER-FILE INTO WS-CUSTOMER-RECORD
AT END MOVE 'Y' TO WS-EOF
NOT AT END DISPLAY WS-CUSTOMER-RECORD
END-READ
END-PERFORM.
CLOSE CUSTOMER-FILE.
GOBACK.
My question: I'm not too familiar with JCL. So if I were to put this program on a mainframe, what would I do for the JCL?
I presume your Identification Division got lost in a cut & paste incident on its way to Stack Overflow; you'll need that.
The current incarnation of IBM Enterprise COBOL does not allow free format source so in order to get your code to compile you would have to reformat and follow the traditional fixed format.
Rather than referring to your data file by name, your Assign clause must refer to a name (limited to 8 characters) which corresponds to a DD name in your JCL. Pick something meaningful, to the extent you can in 8 characters, maybe CUSTOMER.
Since you're running with JCL, your Accept statement will work a bit differently. Probably data will come from a SYSIN DD.
Your JCL will look something like this...
[job card, which is shop-specific]
//TOMSPGM EXEC PGM=yourProgramName
//STEPLIB DD DISP=SHR,DSN=mainframe.dataset.where.you.bound.your.program
//SYSIN DD *
[your customer records]
//CUSTOMER DD DISP=(NEW,CATLG,DELETE),
// DSN=mainframe.dataset.where.your.data.should.end.up,
// LRECL=40,
// AVGREC=U,
// RECFM=FB,
// SPACE=(40,(10,10),RLSE) Adjust to your needs
//SYSOUT SYSOUT=*
//CEEDUMP SYSOUT=*
I'm not sure how this will work with your creating the customer file and then reading it in the same program. In 30 years of mainframe work I've never seen that.
Adding to answer from #cschneid.
Great to see AVGREC is being used on the DD statement to allocate space for the data set. This is much better than using the old-fashioned CYL, or TRK units.
Unfortunately, IMHO, the IBM z/OS architects missed to implement a more modern was to specify space: KiB, or MiB. (ISPF supports KB, and MB as space unit, JCL doesn't.)
With AVGREC you tell the system that the SPACE= primary and secondary space values are number of records, instead of physical units such as tracks, or cylinders.
//CUSTOMER DD ...
// AVGREC=U,
// SPACE=(40,(10,20),RLSE)
Above statement tells the system that the records written will have an average length of 40 bytes (this completely is independent of RECFM=, or LRECL=!). With AVGREC=U (U means units), this further tells the system to allocate initial (primary) space for 10 records, and to add additional space for 20 records each time more space is needed (with an upper limit).
Physical allocations are still in tracks, or cylinders under the hood. The system calculates tracks, or cylinders needed from
"average record length" * "number of records" * avgrec-unit
For the primary allocation, this is
40 * 10 * 1 = 400 bytes
Good. But how can we specify our space needs in KiB or MiB using these keywords?
Remember that the average record length in the SPACE= parameter is completely unreleated to the actual record length specified via LRECL=. Great, so we can freely choose the average record length, and set it to, say, 1. And let us also change the wording "number of records* in above forumla to "number of units". The formula becomes:
1 * "number of units" * avgrec-unit
or
"number of units" * avgrec-unit
AVGREC= supports the units U (1), K (1024), and M (1024*1024). So, to allocate space in megabytes (MiB), we simply code:
//CUSTOMER DD ...
// AVGREC=M,
// SPACE=(1,(10,20),RLSE)
This will allocate 10 MiB primary space, and 20 MiB secondary space. Each allocation is rounded up to the next integral number of tracks, or cylinders, depending on physical disk structures. You simply don't have to care anymore. Neat, isn't it?

An error rc=20 when I want to show an ispf panel from a cobol program

I want to display an ispf panel with a cobol program. With REXX is easy, no problems, but with cobol is not showing the panel.
When I submit the jcl, the compile and link step gives no errors but when it try to run an error is received: MAXCC=0020. In the jesysmsg I found
...
IEF236I ALLOC. FOR CBLMINE STEP2
IGD103I SMS ALLOCATED TO DDNAME STEPLIB
IEF237I JES2 ALLOCATED TO SYSOUT
IEF237I DMY ALLOCATED TO CEEDUMP
IEF237I DMY ALLOCATED TO SYSUDUMP
IEF142I CBLMINE STEP2 - STEP WAS EXECUTED - COND CODE 0020
IGD104I Z30952.PATO RETAINED,DDNAME=STEPLIB
IEF285I Z30952.CBLMINE.JOB04408.D0000103.? SYSOUT
...
According with the IBM manual the error is: ERROR. I/O error writing to update file, FILEDEF missing, or APNDUPD process option cancelled because of inconsistent file attributes.
Any practical help (with an example please)?
With an ispf panel :
)ATTR DEFAULT(+_%)
% TYPE(TEXT) COLOR(PINK) INTENS(HIGH)
$ TYPE(INPUT) INTENS(HIGH) PAD(_)
! TYPE(INPUT) INTENS(LOW) PAD(' ')
)BODY
%-------------------- *TITLE FOR ENTRY PANEL* --------------------------
%COMMAND ===>_ZCMD
%
&ZUSER &ZTIME &ZSCREEN &ZWIDTH &ZUS4S7
+ THIS DIRECTION LINE TELLS THE USER HOW TO USE THE PANEL:
%XXXXX:_X %YYY:$YYY %ZZZ:$ZZ%AAAAAAAA:$AAAAAAAA +
)END
With a cobol program:
IDENTIFICATION DIVISION.
PROGRAM-ID. CBLEX003
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.
77 PST1 PIC X(6) VALUE 'LIBDEF'.
77 PST2 PIC X(7) VALUE 'ISPPLIB'.
77 PST3 PIC X(7) VALUE 'DATASET'.
77 PST4 PIC X(15) VALUE 'Z30952.MINE.GML'.
77 PST5 PIC X(16) VALUE 'DISPLAY PANEL01'.
77 ISPLINK PIC X(7) VALUE 'ISPLINK'.
PROCEDURE DIVISION.
CALL ISPLINK USING PST1 PST2 PST3 PST4.
CALL ISPLINK USING PST5.
STOP RUN.
With a jcl:
//CBLMINE JOB 1,NOTIFY=&SYSUID,MSGLEVEL=(1,1)
//SETVAR SET THEPGM=CBLEX003
//SETVAR SET WHERES=&SYSUID..MINE.GML
//SETVAR SET LINKRU=&SYSUID..PATO
//COBRUN EXEC IGYWCL
//COBOL.SYSIN DD DSN=&WHERES(&THEPGM),DISP=SHR
//LKED.SYSLMOD DD DSN=&LINKRU(&THEPGM),DISP=SHR
// IF RC = 0 THEN
//STEP2 EXEC PGM=&THEPGM
//STEPLIB DD DSN=&LINKRU,DISP=SHR
//SYSOUT DD SYSOUT=*,OUTLIM=15000
//CEEDUMP DD DUMMY
//SYSUDUMP DD DUMMY
// ELSE
// ENDIF
If you want to use ISPF services like ISPLINK you must execute in an ISPF environment. IBM's documentation provides an example here, reproduced below.
//USERAA JOB (AA04,BIN1,000000),'I. M. USERAA',
// CLASS=L,MSGCLASS=A,NOTIFY=USERAA,MSGLEVEL=(1,1)
//*-------------------------------------------------------*/
//* EXECUTE ISPF COMMAND IN THE BACKGROUND */
//*-------------------------------------------------------*/
//*
//ISPFBACK EXEC PGM=IKJEFT01,DYNAMNBR=25,REGION=1024K
//*- - ALLOCATE PROFILE, PANELS, MSGS, PROCS, AND TABLES -*/
//ISPPROF DD DSN=USERAA.ISPF.PROFILE,DISP=OLD
//ISPPLIB DD DSN=ISP.SISPPENU,DISP=SHR
//ISPMLIB DD DSN=ISP.SISPMENU,DISP=SHR
//ISPSLIB DD DSN=ISP.SISPSENU,DISP=SHR
// DD DSN=ISP.SISPSLIB,DISP=SHR
//ISPTLIB DD DSN=USERAA.ISPF.TABLES,DISP=SHR
// DD DSN=ISP.SISPTENU,DISP=SHR
// DD DSN=ISP.SISPTLIB,DISP=SHR
//ISPTABL DD DSN=USERAA.ISPF.TABLES,DISP=SHR
//*
//*- - ALLOCATE ISPF LOG DATA SET - - - - - - - - - - - -*/
//ISPLOG DD DSN=USERAA.ISPF.LOG,DISP=SHR
//*
//*- - ALLOCATE DIALOG PROGRAM AND TSO COMMAND LIBRARIES -*/
//ISPLLIB DD DSN=USERAA.ISPF.LOAD,DISP=SHR
//SYSEXEC DD DSN=ISP.SISPEXEC,DISP=SHR
//SYSPROC DD DSN=ISP.SISPCLIB,DISP=SHR
//*
//*- - ALLOCATE TSO BACKGROUND OUTPUT AND INPUT DS - - - -*/
//SYSTSPRT DD DSNAME=USERAA.ISPF.ISPFPRNT,DISP=SHR
//SYSTSIN DD *
PROFILE PREFIX(USERAA) /* ESTABLISH PREFIX */
ISPSTART CMD(%TBUPDATE) /* INVOKE CLIST DIALOG */
/*
You must supply a valid jobcard and the correct ISPF library concatenations for your shop. Also, I believe you would use ISPSTART PGM(CBLEX003) instead of what the IBM sample has for starting a CLIST.
If you don't know your shop's ISPF library concatenations, you can probably determine them from what is displayed by the ISRDDN command from any ISPF command line.
There is also an ISPF Dialog Test facility, usually on the main ISPF menu. You can use this to test your panel.
I agree with what Bruce and cschneid have been stating. You can not invoke an ISPF service from a COBOL pgm using JCL unless the JCL is running ISPF in batch mode as in the example provided by cschneid. Without the ISPF environment ISPLINK will set rc=20 because it can not find an ISPF environment. Test your program via ISPF option 7 or write an exec to run it where you LIBDEF ISPLLIB to point at the load library containing your linked COBOL pgm.
address ISPEXEC
"LIBDEF ISPLLIB DATASET ID('userid.TEST.LOAD')"
"SELECT PGM(mycbl)"
"LIBDEF ISPLLIB"
You would normally not run a DISPLAY service via batch as you have been advised. It can be done by supplying all the values for the panel fields and then simulating an ENTER or END with the CONTROL service, but it would be easy to get in a DISPLAY loop if not careful.

Dynamic memory allocation in COBOL

I have a common C function that I want to call from C, Fortran and COBOL. It fetches x bytes of data from a database and places it in a char pointer supplied to it. My example below fetches 1024 bytes, but in the real situation I want to be able to fetch much larger chunks of data than 1024 bytes as well, hence the dynamic memory allocation.
void fetch_data(char *fetched)
{
static struct {unsigned long data_length; char some_data[1024];} a_struct;
// Fetch data into a_struct.
memcpy(fetched, &(a_struct.some_data), 1024);
}
I was able to call this function successfully from C.
char *mydata;
mydata = malloc(1024);
fetch_data(mydata);
// Do something with the data.
free(mydata);
I was also able to call this function successfully from Fortran.
INTEGER*4, ALLOCATABLE :: MYDATA(:)
ALLOCATE(MYDATA(1024))
CALL FETCH_DATA(MYDATA)
// Do something with the data.
DEALLOCATE(MYDATA)
But how do I allocate and deallocate dynamic memory in COBOL? I have been unable to find built-in functions/procedures for this purpose.
I also don't see an alternative where C could handle the allocation and deallocation for Fortran and COBOL, as they need to access the data outside C.
As you've only talked about "COBOL" without specifying any actual implementation I assume you mean "standard COBOL".
This could mean COBOL85 - which doesn't have this feature but allows you to just define DATA-FOR-C PIC X(1024) and pass this as reference (COBOL85 actually doesn't specify anything about calling into C space but this should work with most if not all COBOL implementations). Note: This is actually more a detail of Acorns answer.
If you want to use real dynamic memory allocation and you mean standard COBOL - no problem with COBOL 2002 as it introduced the statements ALLOCATE and FREE (Note: this is actually the detail of the comments from roygvib and Rick):
77 pointer-variable USAGE POINTER.
77 address-holder PIC X BASED.
ALLOCATE variable-number CHARACTERS RETURNING pointer-variable
SET ADDRESS OF address-holder TO pointer-variable
CALL "fetch_data" USING address-holder
PERFORM stuff
FREE pointer-variable
If you don't use a COBOL implementation that support these statements you'd have to use the implementor specific routines (normally via CALL) to get/release the memory.
MicroFocus/NetCOBOL (see answer of Rick): CBL_ALLOC_MEM/CBL_FREE_MEM[2]
ACUCOBOL: M$ALLOC/M$FREE
IBM: CEEGTST
any COBOL compiler and runtime that allows to directly call C functions (which may adds additional needs as specifying the appropriate CALL-CONVENTION for those): malloc/free
... see your implementor's manual ...
One example with a very old compiler (Micro Focus COBOL v3.2.50). Much of this is taken directly from the supplemental materials. And since I didn't have an equally old C compiler available, I included a COBOL program as a subtitute.
program-id. dynam.
data division.
working-storage section.
1 ptr pointer.
1 mem-size pic x(4) comp-5 value 1024.
1 flags pic x(4) comp-5 value 1.
1 status-code pic x(2) comp-5.
linkage section.
1 mem pic x(1024).
procedure division.
call "CBL_ALLOC_MEM" using ptr
by value mem-size flags
returning status-code
if status-code not = 0
display "memory allocation failed"
stop run
else
set address of mem to ptr
end-if
call "fetch_data" using mem
display mem
call "CBL_FREE_MEM" using mem
returning status-code
if status-code not = 0
display "memory deallocation failed"
stop run
else
set address of mem to null
end-if
stop run
.
end program dynam.
program-id. "fetch_data".
data division.
working-storage section.
1 some-struct pic x(1024) value all "abcd".
linkage section.
1 mem pic x(1024).
procedure division using mem.
move some-struct to mem
exit program
.
end program "fetch_data".
The display (trimmed) is:
abcdabcdabcdabcd...(for 1024 characters total)
Maybe that will be of some help.
If you do not need the entire data in memory, then consider working chunk-by-chunk: allocate fixed-size storage in COBOL, fetch a chunk into it using the C function, work with it and loop to continue with the next chunk. This way you can avoid allocating dynamic memory altogether.
If you are on Z or using Gnu Cobol you can simply call malloc():
CALL "malloc" USING BY VALUE MEM-SIZE
RETURNING MEM-PTR.
CALL "free" USING BY VALUE MEM-PTR.

Why doesn't GnuCOBOL's rounding syntax compile?

I would be very grateful for any pointer towards what exactly it is that I am doing wrong with the very minimal, very trivial COBOL program below. It performs a rounding of a result with COBOL's standard tool, the language element ROUNDED. The ulterior motive is to build a large application and apply a time metric to different modes of rounding, given a long series of operations and subsequent roundings for each mode. (The even more ulterior motive is to learn COBOL backwards, this is only a project within that plan, and then try to land a job using and developing COBOL).
The program is listed below. It performs one simple addition, and the result is passed to a variable with a smaller data width which enforces rounding.
000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. ROUNDINGTEST.
000300 ENVIRONMENT DIVISION.
000400 DATA DIVISION.
000500 WORKING-STORAGE SECTION.
000600 01 OPERAND01 PIC S9(2)V9(4) VALUE 1.4745.
000610 01 OPERAND02 PIC S9(2)V9(4) VALUE 1.9874.
000610 01 RESULT PIC S9(2)V9(2).
000700 PROCEDURE DIVISION.
000800 PROGRAM-BEGIN.
000900 COMPUTE RESULT ROUNDED MODE NEAREST-EVEN
001000 = OPERAND01 + OPERAND02
001010 END-COMPUTE
001020
001100 PROGRAM-DONE.
001200 STOP RUN.
Compilation with GnuCOBOL's compiler, as below, gives the results below.
martin#martin-1001PX:~/CobolProjects$ cobc -b ROUNDINGTEST.cob
ROUNDINGTEST.cob: In paragraph 'PROGRAM-BEGIN':
ROUNDINGTEST.cob:11: Error: syntax error, unexpected MODE
martin#martin-1001PX:~/CobolProjects$
No exchange of the indicated mode to any other, Truncation, Towards-Lesser...produces any change. Commenting out lines 000900, 001000 and 001010 gives an error-free response, so clearly the problem is not a cascading problem from earlier in the code or any kind of syntactical mishap later – it's the rounding that doesn't work.
GNU COBOL 2.0 (Formerly OpenCOBOL) [11FEB2012 Version] Programmer’s Guide
2nd Edition, 21 November 2013
has the COMPUTE syntax as below
COMPUTE { identifier-1 [ rounding-option ] } … =|EQUAL
arithmetic-expression-1 [ size-error-clause ] [ END-COMPUTE ]
and the syntax of the qualifier ROUNDED (the rounding-option above) as
AWAY-FROM-ZERO
NEAREST-AWAY-FROM-ZERO
NEAREST-EVEN
ROUNDED MODE IS NEAREST-TOWARD-ZERO
PROHIBITED
TOWARD-GREATER
TOWARD-LESSER
TRUNCATION
where the “IS” is a non-mandatory readability option.
Compact and trivial as this might seem, no amount of revision or testing has availed me to any success. Any meaningful communication on the matter would be much appreciated.
(This should likely be a comment, not an answer, but wanted the code listing to show up).
This works, as Bill pointed out:
000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. ROUNDINGTEST.
000300 ENVIRONMENT DIVISION.
000400 DATA DIVISION.
000500 WORKING-STORAGE SECTION.
000600 01 OPERAND01 PIC S9(2)V9(4) VALUE 1.4745.
000610 01 OPERAND02 PIC S9(2)V9(4) VALUE 1.9874.
000610 01 RESULT PIC S9(2)V9(2).
000700 PROCEDURE DIVISION.
000800 PROGRAM-BEGIN.
000900 COMPUTE RESULT ROUNDED MODE NEAREST-EVEN
001000 = OPERAND01 + OPERAND02
001010 END-COMPUTE
001020 .
001100 PROGRAM-DONE.
001200 STOP RUN.
The period on 1020 changes the state of the compiler from looking for another statement in the paragraph to looking for a new paragraph or statement, which might be a label.

Cobol interface with C

So, i'm work with C and OpenCobol, and, I whant to know if have an way to get the value of a internal cobol source...
for example (based on sample of this link):
http://www.opencobol.org/modules/bwiki/index.php?cmd=read&page=UserManual%2F2_3
---- say.cob ---------------------------
IDENTIFICATION DIVISION.
PROGRAM-ID. say.
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 TESTE PIC 9(9) VALUE ZEROS.
LINKAGE SECTION.
01 HELLO PIC X(6).
01 WORLD PIC X(6).
PROCEDURE DIVISION USING HELLO WORLD.
MOVE 456 TO TESTE.
DISPLAY TESTE.
DISPLAY HELLO WORLD.
*> RETURN TESTE. ??????
EXIT PROGRAM.
----------------------------------------
And, the C code when I use is that:
---- hello.c ---------------------------
#include <stdio.h>
#include <libcob.h>
extern int say(char *hello, char *world);
int
main()
{
int ret;
char hello[6] = "Hello ";
char world[6] = "World!";
cob_init(0, NULL);
ret = say(hello, world); // return the 000000456 ??????????
// How to make this :(
return ret;
}
----------------------------------------
Or, have an whay to get the cobol variable, something like this:
// ... code ...
int value = cob_getvar(TESTE);
// ... code ...
Look at page 7-7 of the OpenCOBOL Programmers Guide. For the data that you want to pass back to your C program, add another argument and pass it by reference to the COBOL program. Declare your TESTE as binary to match the C declaration. You can also pass back the automatically-defined RETURN-CODE, if you like. So your COBOL would be something like this:
DATA DIVISION.
LINKAGE SECTION.
01 HELLO PIC X(6).
01 WORLD PIC X(6).
01 TESTE PIC S9(9) USAGE BINARY-LONG.
PROCEDURE DIVISION USING
BY VALUE HELLO
BY VALUE WORLD
BY REFERENCE TESTE.
0000-MAIN-ROUTINE.
MOVE 456 TO TESTE
MOVE 1 TO RETURN-CODE
GOBACK.
And in your calling program:
int teste;
int returnCode;
char hello[6] = "Hello ";
char world[6] = "World!";
cob_init(0, NULL);
returnCode = say(hello, world, &teste);
Alexandre;
OpenCOBOL 2.0 will have FUNCTION-ID allowing for things like
MOVE FUNCTION nextbigthing(args) TO cobol-working-store
Until it is released though, we are "limited" to CALL, ENTRY, PROGRAM-ID and the like.
For an example of some low level function pointer related things, take a look at
http://opencobol.add1tocobol.com/#what-stock-call-library-does-opencobol-offer
which includes a snippet for setting error handlers and exit procedures. Scan that with an eye on
PROCEDURE-POINTER
ENTRY
SET proc-ptr TO ENTRY "link-name"
CALL ... USING ... RETURNING
with the caveat, that this is one way. There are others. The ENTRY lines can be full on PROGRAM-ID subprograms, etc. Section 5 of the OpenCOBOL FAQ is rife with routines that pass data back and forth from other languages and link libraries.
Also, look to cob_field in libcob/common.h. The C code generated by CALL sets up an array of the COBOL fields of the arguments, along with the actual call frame, and these COBOL field structures can be accessed from C functions through cob_module.
errorproc.cob
>>SOURCE FORMAT IS FIXED
*****************************************************************
* OpenCOBOL demonstration
* Author: Brian Tiffin
* Date: 26-Jun-2008
* History:
* 03-Jul-2008
* Updated to compile warning free according to standards
* Purpose:
* CBL_ERROR_PROC and CBL_EXIT_PROC call example
* CBL_ERROR_PROC installs or removes run-time error procedures
* CBL_EXIT_PROC installs or removes exit handlers
* Also demonstrates the difference between Run time errors
* and raised exceptions. Divide by zero raises an
* exception, it does not cause a run time error.
* NB:
* Please be advised that this example uses the functional but
* now obsolete ENTRY verb. Compiling with -Wall will display
* a warning. No warning will occur using -std=MF
* Tectonics: cobc -x errorproc.cob
identification division.
program-id. error_exit_proc.
data division.
working-storage section.
* entry point handlers are procedure addresses
01 install-address usage is procedure-pointer.
01 install-flag pic 9 comp-x value 0.
01 status-code pic s9(9) comp-5.
* exit handler address and priority (prio is IGNORED with OC1.1)
01 install-params.
02 exit-addr usage is procedure-pointer.
02 handler-prio pic 999 comp-x.
* indexing variable for back scannning error message strings
01 ind pic s9(9) comp-5.
* work variable to demonstrate raising exception, not RTE
01 val pic 9.
* mocked up error procedure reentrancy control, global level
01 once pic 9 value 0.
88 been-here value 1.
* mocked up non-reentrant value
01 global-value pic 99 value 99.
* LOCAL-STORAGE SECTION comes into play for ERROR_PROCs that
* may themselves cause run-time errors, handling reentry.
local-storage section.
01 reenter-value pic 99 value 11.
* Linkage section for the error message argument passed to proc
* By definition, error messages are 325 alphanumeric
linkage section.
01 err-msg pic x(325).
* example of OpenCOBOL error and exit procedures
procedure division.
* Demonstrate problem installing procedure
* get address of WRONG handler. NOTE: Invalid address
set exit-addr to entry "nogo-proc".
* flag: 0 to install, 1 to remove
call "CBL_EXIT_PROC" using install-flag
install-params
returning status-code
end-call.
* status-code 0 on success, in this case expect error.
if status-code not = 0
display
"Intentional problem installing EXIT PROC"
", Status: " status-code
end-display
end-if.
* Demonstrate install of an exit handler
* get address of exit handler
set exit-addr to entry "exit-proc".
* flag: 0 to install, 1 to remove
call "CBL_EXIT_PROC" using install-flag
install-params
returning status-code
end-call.
* status-code 0 on success.
if status-code not = 0
display
"Problem installing EXIT PROC"
", Status: " status-code
end-display
stop run
end-if.
* Demonstrate installation of an error procedure
* get the procedure entry address
set install-address to entry "err-proc".
* install error procedure. install-flag 0 installs, 1 removes
call "CBL_ERROR_PROC" using install-flag
install-address
returning status-code
end-call.
* status-code is 0 on success.
if status-code not = 0
display "Error installing ERROR PROC" end-display
stop run
end-if.
* example of error that raises exception, not a run-time error
divide 10 by 0 giving val end-divide.
* val will be a junk value, use at own risk
divide 10 by 0 giving val
on size error display "DIVIDE BY ZERO Exception" end-display
end-divide.
* intentional run-time error
call "erroneous" end-call. *> ** Intentional error **
* won't get here. RTS error handler will stop run
display
"procedure division, following run-time error"
end-display.
display
"global-value: " global-value
", reenter-value: " reenter-value
end-display.
exit program.
*****************************************************************
*****************************************************************
* Programmer controlled Exit Procedure:
entry "exit-proc".
display
"**Custom EXIT HANDLER (will pause 3 and 0.5 seconds)**"
end-display.
* sleep for 3 seconds
call "C$SLEEP" using "3" end-call.
* demonstrate nanosleep; argument in billionth's of seconds
* Note: also demonstrates OpenCOBOL's compile time
* string catenation using ampersand;
* 500 million being one half second
call "CBL_OC_NANOSLEEP" using "500" & "000000" end-call.
exit program.
*****************************************************************
* Programmer controlled Error Procedure:
entry "err-proc" using err-msg.
display "**ENTER error procedure**" end-display.
* These lines are to demonstrate local and working storage
display
"global-value: " global-value
", reenter-value: " reenter-value
end-display.
* As reenter-value is local-storage
* the 77 will NOT display on rentry, while the global 66 will
move 66 to global-value.
move 77 to reenter-value.
* Process err-msg.
* Determine Length of error message, looking for null terminator
perform varying ind from 1 by 1
until (err-msg(ind:1) = x"00") or (ind = length of err-msg)
continue
end-perform.
display err-msg(1:ind) end-display.
* demonstrate trapping an error caused in error-proc
if not been-here then
set been-here to true
display "Cause error while inside error-proc" end-display
call "very-erroneous" end-call *> Intentional error
end-if.
* In OpenCOBOL 1.1, the return-code is local and does
* not influence further error handlers
*move 1 to return-code.
move 0 to return-code.
display "**error procedure EXIT**" end-display.
exit program.

Resources