System Routines
For a complete list of supported system routines, Appendix D.
CBL_GC_GETOPT
CBL_GC_GETOPT provides the quite well-known option parser, getopt, for
GnuCOBOL.
The usage of this system routine is described by the following example.
identification division.
program-id. prog.
data division.
working-storage section.
78 shortoptions value "jkl".
01 longoptions.
05 optionrecord occurs 2 times.
10 optionname pic x(25).
10 has-value pic 9.
10 valpoint pointer value NULL.
10 return-value pic x(4).
01 longind pic 99.
01 long-only pic 9 value 1.
01 return-char pic x(4).
01 opt-val pic x(10).
01 counter pic 9 value 0.
We first need to define the necessary fields for getopt’s shortoptions (so), longoptions (lo), longoption index (longind), long-only-option (long-only) and also the fields for return values return-char and opt-val (arbitrary size with trimming, see return codes).
The shortoptions are written down as an alphanumeric field (i.e., a string with arbitrary size) as follows:
"ab:c::d"
This means we want getopt to look for shortoptions named a, b, c or d and we demand an option value for b and we are accepting an optional one for c.
The longoptions are defined as a table of records with oname, has-value, valpoint and val.
oname defines the name of a longoption.
has-value defines if an option value is demanded (has-val = 1), optional (has-val = 2) or not required (has-val = 0).
valpoint is a pointer used to specify an address to save getopt’s return value to. The pointer
is optional. If it is
NULL, getopt returns a value as usual. If you use the pointer it has to point to aPIC X(4)field.The field val is a
PIC X(4)character which is returned if the longoption was recognized.
The longoption structure is immutable! You can only vary the number of records.
Now we have the tools to run CBL_GC_GETOPT within the procedure division.
procedure division.
move "version" to optionname (1).
move 0 to has-value (1).
move "v" to return-value (1).
move "verbose" to optionname (2).
move 0 to has-value (2).
move "V" to return-value (2).
perform with test after until return-code = -1
call 'CBL_GC_GETOPT' using
by reference shortoptions longoptions longind
by value long-only
by reference return-char opt-val
end-call
display return-char end-display
display opt-val end-display
end-perform
stop run.
The example shows how we initialize all parameters and call the routine until
CBL_GC_GETOPT runs out of options and returns -1.
If the option is recognized, return-char contains the option character. Otherwise, return-char will contain one of the following:
?undefined or ambiguous option
1non-option (only if first byte of so is ‘
-‘)0valpoint != NULLand we are writing the return value to the specified address-1no more options (or reached the first non-option if first byte of so is ‘
+‘)
The return-code of CBL_GC_GETOPT is one of:
1a non-option (only if first byte of so is ‘
-‘)0valpoint != NULLand we are writing the return value to the specified address-1no more options (or reach the first non-option if first byte of so is ‘
+‘)2truncated option value in opt-val (because opt-val was too small)
3regular answer from
getopt
CBL_GC_HOSTED
CBL_GC_HOSTED provides access to the following C hosted variables:
argcto binary-long by valueargvto pointer to char **stdin,stdout,stderrto pointererrnogiving address of errno in pointer to binary-long, use based for more direct access
and conditional access to the following variables:
tznamepointer to pointer to array of two char pointerstimezoneC long, will be seconds west of UTCdaylightC int, will be 1 during daylight savings
System will need to HAVE_TIMEZONE defined for these to return
anything meaningful. Attempts made when they are not available return
1 from CBL_GC_HOSTED.
It returns 0 when match, 1 on failure, case matters as does length,
arg won’t match.
The usage of this system routine is described by the following example.
HOSTED identification division.
program-id. hosted.
data division.
working-storage section.
01 argc usage binary-long.
01 argv usage pointer.
01 stdin usage pointer.
01 stdout usage pointer.
01 stderr usage pointer.
01 errno usage pointer.
01 err usage binary-long based.
01 domain usage float-long value 3.0.
01 tzname usage pointer.
01 tznames usage pointer based.
05 tzs usage pointer occurs 2 times.
01 timezone usage binary-long.
01 daylight usage binary-short.
*> Testing CBL_GC_HOSTED
procedure division.
call "CBL_GC_HOSTED" using stdin "stdin"
display "stdin : " stdin
call "feof" using by value stdin
display "feof stdin : " return-code
call "CBL_GC_HOSTED" using stdout "stdout"
display "stdout : " stdout
call "fprintf" using by value stdout by content "Hello" & x"0a"
call "CBL_GC_HOSTED" using stderr "stderr"
display "stderr : " stderr
call "fprintf" using by value stderr by content "on err" & x"0a"
call "CBL_GC_HOSTED" using argc "argc"
display "argc : " argc
call "CBL_GC_HOSTED" using argv "argv"
display "argv : " argv
call "args" using by value argc argv
call "CBL_GC_HOSTED" using errno "errno"
display "&errno : " errno
set address of err to errno
display "errno : " err
call "acos" using by value domain
display "errno after acos(3.0): " err ", EDOM is 33"
call "CBL_GC_HOSTED" using argc "arg"
display "'arg' lookup : " return-code
call "CBL_GC_HOSTED" using null "argc"
display "null with argc : " return-code
display "argc is still : " argc
*> the following only returns zero if the system has HAVE_TIMEZONE set
call "CBL_GC_HOSTED" using daylight "daylight "
display "'timezone' lookup : " return-code
if return-code not = 0
display "system doesn't has timezone"
else
display "timezone is : " timezone
call "CBL_GC_HOSTED" using daylight "daylight "
display "'daylight' lookup : " return-code
display "daylight is : " daylight
set environment "TZ" to "PST8PDT"
call static "tzset" returning omitted on exception continue end-call
call "CBL_GC_HOSTED" using tzname "tzname"
display "'tzname' lookup : " return-code
*> tzs(1) will point to z"PST" and tzs(2) to z"PDT"
if return-code equal 0 and tzname not equal null then
set address of tznames to tzname
if tzs(1) not equal null then
display "tzs #1 : " tzs(1)
end-if
if tzs(2) not equal null then
display "tzs #2 : " tzs(2)
end-if
end-if
end-if
goback.
end program hosted.
CBL_GC_NANOSLEEP
CBL_GC_NANOSLEEP allows you to pause the program for nanoseconds.
The actual precision depends on the system.
*> Waiting a half second
call "CBL_GC_NANOSLEEP" using "500000000" end-call
*> Waiting five seconds using compiler string catenation for readability
call "CBL_GC_NANOSLEEP" using "500" & "0000000" end-call
CBL_GC_FORK
CBL_GC_FORK allows you to fork the current COBOL process to a new one.
The current content of the process’ storage (including LOCAL-STORAGE)
will be identical, any file handles get invalid in the new process, positions
and file / record locks are only available to the original process.
This system routine is not available on Windows (exception: GCC on Cygwin).
Parameters
none
Returns
PID (the child process gets ‘
0‘ returned, the calling process gets the PID of the created children). Negative values are returned for system dependent error codes and -1 if the function is not available on the current system.
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 CHILD-PID PIC S9(9) BINARY.
01 WAIT-STS PIC S9(9) BINARY.
PROCEDURE DIVISION.
CALL "CBL_GC_FORK" RETURNING CHILD-PID END-CALL
EVALUATE TRUE
WHEN CHILD-PID = ZERO
PERFORM CHILD-CODE
WHEN CHILD-PID > ZERO
PERFORM PARENT-CODE
WHEN CHILD-PID = -1
DISPLAY 'CBL_GC_FORK is not available '
'on the current system!'
END-DISPLAY
PERFORM CHILD-CODE
MOVE 0 TO CHILD-PID
PERFORM PARENT-CODE
WHEN OTHER
MULTIPLY CHILD-PID BY -1 END-MULTIPLY
DISPLAY 'CBL_GC_FORK returned system error: '
CHILD-PID
END-DISPLAY
END-EVALUATE
STOP RUN.
CHILD-CODE.
CALL "C$SLEEP" USING 1 END-CALL
DISPLAY "Hello, I am the child"
END-DISPLAY
MOVE 2 TO RETURN-CODE
CONTINUE.
PARENT-CODE.
DISPLAY "Hello, I am the parent"
END-DISPLAY
CALL "CBL_GC_WAITPID" USING CHILD-PID RETURNING WAIT-STS
END-CALL
MOVE 0 TO RETURN-CODE
EVALUATE TRUE
WHEN WAIT-STS >= 0
DISPLAY 'Child ended with status: '
WAIT-STS
END-DISPLAY
WHEN WAIT-STS = -1
DISPLAY 'CBL_GC_WAITPID is not available '
'on the current system!'
END-DISPLAY
WHEN WAIT-STS < -1
MULTIPLY -1 BY WAIT-STS END-MULTIPLY
DISPLAY 'CBL_GC_WAITPID returned system error: ' WAIT-STS
END-DISPLAY
END-EVALUATE
CONTINUE.
CBL_GC_WAITPID
CBL_GC_WAITPID allows you to wait until another system process ended.
Additional you can check the process’ return code.
Parameters: none Returns: function-status / child-status Negative values are returned for system dependent error codes and -1 if the function is not available on the current system.
CALL "CBL_GC_WAITPID" USING CHILD-PID RETURNING WAIT-STS
END-CALL
MOVE 0 TO RETURN-CODE
DISPLAY 'CBL_GC_WAITPID ended with status: ' WAIT-STS
END-DISPLAY