I want to detect a key press event in COBOL, using isCOBOL compiler. How to do that?
EX in C:
if(time==despert_time){
while(!kbhit()){
Beep(500,500);
}
}
It looks like you want to get a user interaction from console.
If it isn't happening within a time frame: beep
PERFORM FOREVER *> or UNTIL EXIT or UNTIL 0 = 1, depending on the available extensions
ACCEPT OMITTED *> or ACCEPT DUMMY [which you'd define as 77 DUMMY PIC X.], depending on the available extensions
BEFORE TIME 500 *> [or WITH TIMEOUT 500] this is a more or less common extension, with most vendors using a different time scale --> may need to change the 500
END-ACCEPT
IF keypressed NOT = timeout *> the actual var to be checked and the timeout value need to be checked in the docs
EXIT PERFORM
END-IF
CALL x'E5'
ON EXCEPTION *> the system call x'E5' for beep may not be available
DISPLAY SPACE AT 2080 WITH BEEP *> may not be available, too...
END-CALL
END-PERFORM
Check the online documentation that ships with your compiler (it is "available for clients only", therefore we can not check).
Related
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.
I have this Cobol paragraph that will search one table which at this point in my example would have a table counter of 2 which is what the first INDEX loop does. The variable A represents an Occurs that is defined in a file (include) which has 5 occurrences. I can get to the if statement but it returns false. I read the information out of a ParmCard and store that in the table which is Table-B and the ParmCard is correct.
I did get it to find one value when was changing values around (conditional statements) but I know that both of the values that it is looking for in the ParmCard are in the file and should be found and it should find two results. I would have tried Expeditor but the system was down at work.
Is there something wrong with the index or may be I think that the perform's are working one way but they are really working a different way? This Search paragraph gets executed with every read of the ID file thus it will look in the table as many times as the ID file has an ID and ID symbols are unique.
Question: Why would the IF-STATEMENT not be working?
Code:
SEARCH-PARAGRAPH.
PERFORM VARYING SUB FROM 1 BY 1 UNTIL SUB > 2 <--DUPLICATE INDEXER
IF A(TAB) = TABLE-B(SUB) THEN
MOVE 6 TO TAB
MOVE 'TRUE' TO FOUND-IS
PERFORM WRITE-FILE THRU X-WF
PERFORM LOG-RESULT THRU X-LR
END-IF
END-PERFORM
X-SP. EXIT.
SEARCH-INDEX.
PERFORM VARYING I FROM 1 BY 1 UNTIL I > 2
DISPLAY 'INDEX --> ' I
PERFORM VARYING TAB FROM 1 BY 1 UNTIL TAB > 5
DISPLAY 'TAB --> ' TAB
PERFORM SEARCH-PARAGRPAH THRU X-SP
END-PERFORM
END-PERFORM.
X-SEARCH-INDEX. EXIT.
Here is the way that it works now and I do get the results I want. It is difficult to past the company code up because you never know who might have a problem.
New Code:
READ-PROV.
READ P-FILE
AT END
MOVE 'Y' TO EOF2
GO TO X-READ-PROV
NOT AT END
ADD 1 TO T-REC-READ
MOVE P-RECORD TO TEST-RECORD
PERFORM CHECK-MATCH THRU X-CHECK-MATCH
END-READ.
X-READ-PROV. EXIT.
CHECK-MATCH.
PERFORM VARYING SUB FROM 1 BY 1 UNTIL SUB > TABLECOUNTER
IF PID >= FROM(SUB) AND
PID <= THRU(SUB) THEN
IF TODAY < P-END-DTE THEN
IF TOTAL-PD = 0 AND
TOTAL-PD = 0 AND
TOTAL-PD = 0 AND
TOTAL-PD = 0 AND
TOTAL-PD = 0 THEN
IF PBILLIND NOT EQUAL 'Y'
PERFORM VARYING TAB FROM 1 BY 1 UNTIL TAB > 5
IF P-CD(TAB) = TY(SUB) THEN
MOVE 6 TO TAB
DISPLAY('***Found***')
ADD 1 TO T-REC-FOUND
END-IF
END-PERFORM
END-IF
END-IF
END-IF
END-IF
END-PERFORM.
X-CM. EXIT.
We can't tell.
There is nothing "wrong" with your nested PERFORM. The IF test is failing simply because it is never true.
We can't get you further with that without seeing your data-definitions, sample input and expected output.
However... my guess would be that the problem is with your data from the PARM in the JCL. That is the most likely area.
It is of course possible that the problem is with the other definition.
A couple of things whilst waiting.
Please always post the actual code, always. We don't want to look for errors in what you have typed here, we want to see the actual code. You have not shown the actual code, because it will not compile, as INDEX is a Reserved Word in COBOL, so you can't use it for a data-name.
Please always bear in mind that what you think may be wrong may not be the problem, so post everything we are likely to need (data-definitions, data you used, actual results you got with the code (including anything you've added for problem-determination), results which were expected).
Some tips.
A paragraph requires a full-stop/period after the paragraph-name and before the next paragraph. If you put that second full-stop/period on a line of its own, and have no full-stops/periods attached to your PROCEDURE code itself, you'll make things look neater and avoid problems when you want to copy some lines which happen to have a full-stop/period to a place where they cause you a mess.
You are using literal values. This is bad. When the number of entries in one of your tables changes, you have to change those literal values. Say the 2 needs to be changed to 5. You have to look at every occurrence of the literal 2 and decide if it needs to be changed. Then change it to 5. Then you get another request, to change the table which originally had five entries so that it will have six. See how difficult/error-prone life can be?
If instead you have unique and well-named data-names for your maximum number of entries, you only have one place to make a change, and you know it can be changed without reference to the rest of the code (assuming someone clever hasn't seen it has a value they want for something, and use it despite its name, of course...).
The content of those fields you can set automatically:
01 TABLE-1.
05 FILLER OCCURS 2 TIMES.
10 A PIC X(10).
01 TABLE-2.
05 FILLER OCCURS 5 TIMES.
10 TABLE-B PIC X(10).
01 TABLE-1-NO-OF-ENTRIES COMP PIC 9(4).
01 TABLE-2-NO-OF-ENTRIES COMP PIC 9(4).
...
PROCEDURE DIVISION.
...
COMPUTE TABLE-1-NO-OF-ENTRIES = LENGTH OF TABLE-1
/ LENGTH OF A
COMPUTE TABLE-2-NO-OF-ENTRIES = LENGTH OF TABLE-2
/ LENGTH OF TABLE-B
DISPLAY TABLE-1-NO-OF-ENTRIES
DISPLAY TABLE-2-NO-OF-ENTRIES
That gives you the output 2 and 5.
The names I've used are a mixture of yours and some for demonstration purposes only. Make everything meaningful, and by that I don't mean trite, as my example names would be in real life.
If you insist on escaping from within your PERFORM like that (and take note of Bruce Martin's comment), you can calculate your escape value by using new, aptly-named, fields and giving them the value of the above plus one.
To do a nested loop when the outer loop only has two entries is overkill. You don't need to escape out of the loops like you do, if you have a termination condition on the loop.
That'll do for now until we see your definitions, data and results.
Can someone please help me understand call x"91" function 11 and function 12 with simple example. I have tried to search and couldn't understand it. Right now I an using this code in COBOL under UNIX environment,Does this call works in windows environment as well?
http://opencobol.add1tocobol.com/#what-are-the-xf4-xf5-and-x91-routines
The CALL's X"F4", X"F5", X"91" are from MF.
You can find them in the online MF doc under
Library Routines.
F4/F5 are for packing/unpacking bits from/to bytes.
91 is a multi-use call. Implemented are the subfunctions
get/set cobol switches (11, 12) and get number of call params (16).
Use
CALL X"F4" USING
BYTE-VAR
ARRAY-VAR
RETURNING STATUS-VAR
to pack the last bit of each byte in the 8 byte ARRAY-VAR into corresponding bits of the 1 byte BYTE-VAR.
The X”F5” routine takes the eight bits of byte and moves them to the corresponding occurrence within array.
X”91” is a multi-function routine.
CALL X"91" USING
RESULT-VAR
FUNCTION-NUM
PARAMETER-VAR
RETURNING STATUS-VAR
As mentioned by Roger, OpenCOBOL supports FUNCTION-NUM of 11, 12 and 16.
11 and 12 get and set the on off status of the 8 (eight) run-time OpenCOBOL switches definable in the SPECIAL-NAMES paragraph. 16 returns the number of call parameters given to the current module.
x'91' is a general library routine, for a complete list of those see the MF documentation.
This documentation also specifies what its function 11 and function 12 do: they set/read the COBOL runtime switches 0-7 and the internal debugging mode switch.
Other than these library routines you can also read them one by one from COBOL and set "some" switches via the SET statement.
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
I've been working on Issue 14 on the PascalScript scripting engine, in which using a Goto command to jump out of a Case block produces a compiler error, even though this is perfectly valid (if ugly) Object Pascal code.
Turns out the ProcessCase routine in the compiler calls HasInvalidJumps, which scans for any Gotos that lead outside of the Case block, and gives a compiler error if it finds one. If I comment that check out, it compiles just fine, but ends up crashing at runtime. A disassembly of the bytecode shows why. I've annotated it with the original script code:
[TYPES]
<SNIPPED>
[VARS]
Var [0]: 27 Class TFORM
Var [1]: 28 Class TAPPLICATION
Var [2]: 11 S32 //i: integer
[PROCS]
Proc [0] Export: !MAIN -1
{begin}
[0] ASSIGN GlobalVar[2], [1]
{ i := 1;}
[15] PUSHTYPE 11(S32) // 1
[20] ASSIGN Base[1], GlobalVar[2]
{ case i of}
[31] PUSHTYPE 25(U8) // 2
{ 0:}
[36] COMPARE into Base[2]: [0] = Base[1]
[57] COND_NOT_GOTO currpos + 5 Base[2] [72]
{ end;}
[67] GOTO currpos + 41 [113]
{ 1:}
[72] COMPARE into Base[2]: [1] = Base[1]
[93] COND_NOT_GOTO currpos + 10 Base[2] [113]
{ goto L1;}
[103] GOTO currpos + 8 [116]
{ end;}
[108] GOTO currpos + 0 [113]
{ end; //<-- case}
[113] POP // 1
[114] POP // 0
{ Exit;}
[115] RET
{L1:
Writeln('Label L1');}
[116] PUSHTYPE 17(WideString) // 1
[121] ASSIGN Base[1], ['????????']
[144] CALL 1
{end.}
[149] POP // 0
[150] RET
Proc [1]: External Decl: \00\00 WRITELN
The "goto L1;" statement at 103 skips the cleanup pops at 113 and 114, which leaves the stack in an invalid state.
Delphi doesn't have any trouble with this, because it doesn't use a calculation stack. PascalScript, though, is not as fortunate. I need some way to make this work, as this pattern is very common in some legacy scripts from a much simpler system with little in the way of control structures that I've translated to PascalScript and need to be able to support.
Anyone have any ideas how to patch the codegen so it'll clean up the stack properly?
IIRC the goto rules in classic pascals were:
jumps are only allowed out of a block (iow from a higher to a lower nesting level on the "same" branch of the tree)
from local procedures to their parents.
The later was afaik never supported by Borland derived Pascals, but the first still holds.
So you need to generate exiting code like Martin says, but possibly it can be for multiple block levels, so you can't have a could codegeneration for each goto, but must generate code (to exit the precise number of needed blocks).
A typical test pattern is to exit from multiple nested ifs (possibly within a loop) using a goto, since that was a classic microoptimization that was faster at least up to D7.
Keep in mind that the if evaluation(s) and the begin..end blocks of their branches might have generated temps that need cleanup.
---------- added later
I think the codegenerator needs a way to walk the scopes between the goto and its endpoint, generating the relevant exit code for blocks along the way. That way a fix works for the general case and not just this example.
Since you can only jump out of scopes, and not into it that might not that be that hard.
IOW generate something that is equivalent to (for a hypothetical double case block)
Lgoto1gluecode:
// exit code first block
pop x
pop y
// exit code first block
pop A
pop B
goto real_goto_destination
Additional analysis can be done. E.g. if there is only one scope, and it has already a cleanup exit label, you can jump directly. If you know for certain that the above pop's are only discarded values (and not saves of registers) you can do them at once with add $16,%esp (4*4 byte values) etc.
The straightforward solution would be:
When generating a GOTO for goto statement, prefix the GOTO with the same cleanup code that comes before RET.
It looks to me like the calculation of how far to jump forward is the problem. I would have to spend some time looking at the implementation of the parser to help further, but my guess would be that additional handling must be performed when using a goto and there are values on the stack AND the goto would be placed after those values would be removed from the stack. Of course to determine this you would need to save the current location being parsed (the goto) and the forward parse to the target location watching for stack changes, and if so then to either adjust the goto location backwards, or inject the code as Martin suggested.