How does Cobol to transform a variable of this format 1234,5 to 0000000001234,50.
01 VAR1 X(16) '1234,5'
01 VAR2 X(16)
01 VAROUT REDEFINES VAR2
03 VAROUT-INT X(13)
03 VAROUT-PNT X(01)
03 VAROUT-DEC X(02)
STRING VAR1 DELIMITED BY ',' INTO VAR-INT
I have used one of the general methods of editing a PICTURE clause - Simple Insertion editing - to achieve the expected result.
IDENTIFICATION DIVISION.
PROGRAM-ID. HELLO-WORLD.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 WS-A PIC X(16) VALUE '1234,5'.
01 WS-B PIC 9999999999999,90.
PROCEDURE DIVISION.
MOVE WS-A TO WS-B.
DISPLAY WS-B.
STOP RUN.
Result:
0000000001234,50
This is the simplest way I know.
identification division.
program-id. dpic.
environment division.
configuration section.
special-names.
decimal-point is comma.
data division.
working-storage section.
1 var1 pic x(16) value "1234,5".
1 var2.
2 var2-num pic 9(13),99.
procedure division.
begin.
display var1
move function numval (var1) to var2-num
display var2
stop run
.
The result is:
1234,5
0000000001234,50
Related
I'm a C++/Python developer dabbling in COBOL, using open-cobol (cobc) on Linux.
I have several related functions which I would like to keep together. Normally, in COBOL, there is only one function per linkage section. What I currently do is
CALL "GEAR-FUNCS" USING DO-SOMETHING PARAMS...
and it executes the relevant function depending on the value of DO-SOMETHING. This reduces the number of files but it means that I have to pass the same number of parameters every time, even though some of them are not relevant.
The ultimate aim is to reduce the number of files on the compile line. I don't want to end up with one big main file and lots of little linkage files which I have to pull in every time. I would like to have just a few linkage files. Currently, the only methods I know of are either my function lookup or to create a library which contains all the linkage functions.
I was wondering whether there is a better way of doing this. For instance, is there something that will allow multiple linkage sections or procedure divisions in a single source?
This is not an answer - the answer is in Can multiple Cobol subroutines be in the same modulehttps://stackoverflow.com/a/48949229/2041317. This is just a series of examples for reference. There are two functions defined - LN-FUNC and LN-OBJ-FUNC.
The COBOL-85 multiple program method
IDENTIFICATION DIVISION.
PROGRAM-ID. LN-FUNC.
DATA DIVISION.
LINKAGE SECTION.
77 VAR1 PIC 9(2).
77 VAR2 PIC 9(2).
77 RESULT PIC ZZ9.
PROCEDURE DIVISION USING VAR1, VAR2, RESULT.
COMPUTE RESULT = VAR1 + VAR2.
* This is the return statement
GOBACK.
END PROGRAM LN-FUNC.
********************************************
IDENTIFICATION DIVISION.
PROGRAM-ID. LN-OBJ-FUNC.
DATA DIVISION.
LINKAGE SECTION.
01 VAR-OBJ.
02 OBJ-VAR1 PIC 9(2).
02 OBJ-VAR2 PIC 9(2).
77 RESULT PIC ZZ9.
PROCEDURE DIVISION USING VAR-OBJ, RESULT.
* Another function entry point
COMPUTE RESULT = OBJ-VAR1 + OBJ-VAR2.
* Alternative to GOBACK.
EXIT PROGRAM.
END PROGRAM LN-OBJ-FUNC.
Using nested programs. These need to be nested like
(AAA (BBB (CCC)))
not
(AAA (BBB) (CCC))
Example
IDENTIFICATION DIVISION.
PROGRAM-ID. NESTED.
PROCEDURE DIVISION.
DISPLAY "SURPRISE - THIS GOT EXECUTED?".
********************************************
* First nested linkage
********************************************
IDENTIFICATION DIVISION.
PROGRAM-ID. LN-FUNC.
DATA DIVISION.
LINKAGE SECTION.
77 VAR1 PIC 9(2).
77 VAR2 PIC 9(2).
77 RESULT PIC ZZ9.
PROCEDURE DIVISION USING VAR1, VAR2, RESULT.
COMPUTE RESULT = VAR1 + VAR2.
* This is the return statement
GOBACK.
********************************************
* Second nested linkage
********************************************
IDENTIFICATION DIVISION.
PROGRAM-ID. LN-OBJ-FUNC.
DATA DIVISION.
LINKAGE SECTION.
01 VAR-OBJ.
02 OBJ-VAR1 PIC 9(2).
02 OBJ-VAR2 PIC 9(2).
77 RESULT PIC ZZ9.
PROCEDURE DIVISION USING VAR-OBJ, RESULT.
* Another function entry point
COMPUTE RESULT = OBJ-VAR1 + OBJ-VAR2.
* Alternative to GOBACK.
EXIT PROGRAM.
END PROGRAM LN-OBJ-FUNC.
END PROGRAM LN-FUNC.
END PROGRAM NESTED.
Using entry
IDENTIFICATION DIVISION.
PROGRAM-ID. USE-ENTRY.
DATA DIVISION.
LINKAGE SECTION.
* For LN-FUNC
77 VAR1 PIC 9(2).
77 VAR2 PIC 9(2).
77 RESULT PIC ZZ9.
* For LN-OBJ-FUNC
01 VAR-OBJ.
02 OBJ-VAR1 PIC 9(2).
02 OBJ-VAR2 PIC 9(2).
PROCEDURE DIVISION.
* This never gets displayed
DISPLAY "Starting multi".
* This is a function entry point
ENTRY "LN-FUNC" USING VAR1, VAR2, RESULT.
COMPUTE RESULT = VAR1 + VAR2.
* This is the return statement
GOBACK.
* Another function entry point
ENTRY "LN-OBJ-FUNC" USING VAR-OBJ, RESULT.
COMPUTE RESULT = OBJ-VAR1 + OBJ-VAR2.
* Alternative return statement
EXIT PROGRAM.
END PROGRAM USE-ENTRY.
COMPLETE NOOB here just trying to learn some COBOL. I'm following a YT video and the code I have written verbatim just won't run because of this error. Do I need to install another extension?
>>SOURCE FORMAT FREE
IDENTIFICATION DIVISION.
PROGRAM-ID. coboltut.
AUTHOR. John Doe.
DATE-WRITTEN. November 24th 2021
ENVIRONMENT DIVISION.
DATA DIVISION.
FILE SECTION.
WORKING-STORAGE SECTION.
01 UserName PIC X(30) VALUE "You".
01 Num1 PIC 9 VALUE ZEROS.
01 Num2 PIC 9 VALUE ZEROS.
01 Total PIC 99 VALUE 0.
01 SSNum.
02 SSArea PIC 999
03 SSGroup PIC 99
03 SSSerial PIC 9999
PROCEDURE DIVISION.
DISPLAY "WHAT IS YOUR NAME " WITH NO ADVANCING
ACCEPT UserName
DISPLAY "Hello " USERNAME
STOP RUN.
Try this:
$ cat coboltut.cbl
IDENTIFICATION DIVISION.
PROGRAM-ID. coboltut.
AUTHOR. John Doe.
DATE-WRITTEN. November 24th 2021
ENVIRONMENT DIVISION.
DATA DIVISION.
FILE SECTION.
WORKING-STORAGE SECTION.
01 UserName PIC X(30) VALUE "You".
01 Num1 PIC 9 VALUE ZEROS.
01 Num2 PIC 9 VALUE ZEROS.
01 Total PIC 99 VALUE ZEROS.
01 SSNum.
03 SSArea PIC 999.
03 SSGroup PIC 99.
03 SSSerial PIC 9999.
PROCEDURE DIVISION.
DISPLAY "WHAT IS YOUR NAME " WITH NO ADVANCING
ACCEPT UserName
DISPLAY "Hello " USERNAME
STOP RUN.
Execution:
$ cobc -F -x coboltut.cbl
$ ./coboltut
WHAT IS YOUR NAME Halley
Hello Halley
IDENTIFICATION DIVISION.
PROGRAM-ID. 11.
WORKING-STORAGE SECTION.
01 NUM1 PIC X(010) VALUE "*".
01 NUM2 PIC S9(001) VALUE +2 COMP.
PROCEDURE DIVISION.
PERFORM TRI 6 TIMES
STOP RUN.
TRI.
DISPLAY NUM1
ADD +2 TO NUM2
MOVE "*" TO NUM1(NUM2:6).
COBOL code to print triangle of asterisks in the middle of the screen is given below.
IDENTIFICATION DIVISION.
PROGRAM-ID. HELLO-WORLD.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 WS-OUT PIC X(80) VALUE SPACES.
01 WS-N PIC 9(2) VALUE 0.
01 WS-CENTER PIC 9(2) VALUE 40.
PROCEDURE DIVISION.
PERFORM VARYING WS-N FROM 1 BY 2 UNTIL WS-N > 20
MOVE ALL '*' TO WS-OUT(WS-CENTER:WS-N)
COMPUTE WS-CENTER = WS-CENTER - 1
DISPLAY WS-OUT
END-PERFORM.
STOP RUN.
Output:
*
***
*****
*******
*********
***********
*************
***************
*****************
*******************
Run it here
Thanks to Rick Smith for the suggestions.
I need help writing a small program in COBOL.
I wrote this piece of code:
IDENTIFICATION DIVISION.
PROGRAM-ID. CallC.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 INITBUF PIC X(10).
01 SHOWBUF PIC X(10).
01 BUF USAGE IS POINTER.
01 NUM PIC 9(10).
PROCEDURE DIVISION.
MOVE 10 to NUM.
CALL "getBuffer" USING BY VALUE NUM RETURNING BUF.
CALL "initBuffer" USING BY VALUE BUF RETURNING INITBUF.
CALL "showBuffer" USING BY VALUE BUF RETURNING SHOWBUF.
DISPLAY SHOWBUF.
STOP RUN.
How do I go about writing the DISPLAY result to a file?
Bill. Declare the file as in the example below. Move whatever you want to output into the output variable then Write outputVar
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT PARM-OUT ASSIGN TO PARMOUT.
*************************************************
DATA DIVISION.
FILE SECTION.
FD PARM-OUT
RECORDING MODE F.
01 PARMIN-REC.
05 PSID-IN PIC 9(09).
05 PCID-IN PIC 9(08).
05 IN-PCIDSEQ PIC 9(03).
I'm new to the site as well as COBOL. I am trying to write a program that reads in an 80 byte file, and finds a certain string and grabs another string that is positioned right after that. The only issue I'm having with this is that the starting position of the string is not always in the same byte throughout the file. For example, the string I am trying to find below is the LENGTH(#####) string that appears twice throughout the file:
LENGTH(14909135) FILEID(DD:EDIREC) MSGDATE(130723) MSGDATELONG(20130723)
MSGTIME(091053) MSGSEQO(001390) MSGNAME(00008557) MSGSEQNO(00001)
SESSIONKEY(XXXXXXXX) DELIMITED(E) SYSNAME(XXXXX-XX) SYSLEVEL(XXXX) TIMEZONE(L)
DATATYPE(E) EDITYPE(XXX) SENDERFILE(#####) RECFM(????) RECLEN(#) RECDLM(E)
UNIQUEID(XXXXXXXX) SYSTYPE(##) SYSVER(#);
RECEIVED ACCOUNT(XXXX) USERID(XXXXXXXX) CLASS(#E2) CHARGE(3) LENGTH(14911043)
FILEID(DD:EDIREC) MSGDATE(130723) MSGDATELONG(20130723) MSGTIME(093045)
MSGSEQO(001392) MSGSEQNO(00000) SESSIONKEY(XXXXXXXX) DELIMITED(C)
SYSNAME(XXXXX-XX) SYSLEVEL(XXXX) TIMEZONE(L) DATATYPE(E) EDITYPE(UNFORMATTED)
SENDERFILE(XXXXXXXXXXXXX) RECFM(????) RECLEN(0) RECDLM(C) UNIQUEID(XXXXXXXX)
SYSTYPE(24) SYSVER(5);
Notice the two LENGTH(#####) strings. The below code manages to count the amount of times the length string appears as well as grab the final length string count (what I really want, the numbers within the length string), but only when they are in these two positions:
WORKING-STORAGE SECTION.
01 WS-INPUT-RECORD PIC X(80).
01 WS-STRINGS.
05 LENGTH-STRING PIC X(7) VALUE 'LENGTH('.
01 WS-COUNTERS.
05 WS-MSG-COUNT PIC 9(11).
01 WS-CHAR-TOTALS.
05 CHAR-TOTAL PIC 9(11) VALUE ZEROS.
05 TMP-TOTAL PIC X(11) VALUE ZEROS.
......
PROCEDURE DIVISION.
2200-GET-MSG-TOTAL.
INSPECT WS-INPUT-RECORD
TALLYING WS-MSG-COUNT FOR ALL LENGTH-STRING.
2300-CHAR-TOTAL.
IF WS-INPUT-RECORD(1:7) = LENGTH-STRING
MOVE WS-INPUT-RECORD(8:9) TO TMP-TOTAL
UNSTRING TMP-TOTAL DELIMITED BY ')'
INTO CHAR-TOTAL
END-IF
IF WS-INPUT-RECORD(61:7) = LENGTH-STRING
MOVE WS-INPUT-RECORD(68:9) TO TMP-TOTAL
UNSTRING TMP-TOTAL DELIMITED BY ')'
INTO CHAR-TOTAL
END-IF
The code works great for the two positions shown in the example input above. But it won't work if LENGTH(####) ends up in any other byte position. Other than coding 80 IF statements to check for every byte in the file for the string, is there an easier way to go about getting those values inside of the length parens? I've checked a lot of other posts and I've thought about using pointers or tables but I can't quite seem to figure it out.
Use INSPECT to establish that LENGTH( is on the current record.
Only if present, do the following:
UNSTRING using LENGTH( as a delimiter with two receiving fields.
UNSTRING second receiving field delimited by ) leaving you with the number.
For example:
01 delimiting-field PIC X(7) VALUE "LENGTH(".
01 desitnation-field-1 PIC X.
01 destination-field-2 PIC X(18) JUST RIGHT.
UNSTRING source-field DELIMITED BY delimiting-field INTO desitnation-field-1
destination-field-2
Abandon destination-field-1. Use destination-field-2 for input to the second UNSTRING.
Use meaningful names, rather than those I have shown to illuminate the example.
So,
01 WS-INPUT-RECORD PIC X(80).
01 NUMBER-OF-LENGTHS BINARY PIC 9(4).
01 DELIMITER-COUNT BINARY PIC 9(4).
88 NO-DELIMITERS VALUE ZERO.
88 ONE-DELIMITER VALUE 1.
01 LENGTH-OPEN-PAREN PIC X(7)
VALUE "LENGTH(".
01 DATA-TO-IGNORE PIC X.
01 DATA-WITH-LENGTH-VALUE PIC X(80).
01 CLOSING-PAREN PIC X VALUE ")".
01 VALUE-OF-LENGTH-AN PIC X(18) JUST RIGHT.
THE-STUFF.
SET NO-DELIMITERS TO TRUE
INSPECT WS-INPUT-RECORD TALLYING DELIMITER-COUNT
FOR ALL LENGTH-OPEN-PAREN
EVALUATE TRUE
WHEN NO-DELIMITERS
CONTINUE
WHEN ONE-DELIMITER
PERFORM GET-THE-DATA
WHEN OTHER
PERFORM OH-DEAR-MORE-THAN-ONE
END-EVALUATE
.
GET-THE-DATA.
UNSTRING WS-INPUT-RECORD DELIMITED BY
LENGTH-OPEN-PAREN
INTO DATA-TO-IGNORE
DATA-WITH-LENGTH-VALUE
UNSTRING DATA-WITH-LENGTH-VALUE
DELIMITED BY CLOSING-PAREN
INTO VALUE-OF-LENGTH-AN
DISPLAY "THIS IS WHAT WE FOUND"
DISPLAY ">"
VALUE-OF-LENGTH-AN
"<"
.
OH-DEAR-MORE-THAN-ONE.
DISPLAY "THE FOLLOWING LINE HAS MORE THAN ONE LENGTH("
DISPLAY ">"
WS-INPUT-RECORD
"<"
.
The technique with the INSPECT to see if the "string" is present can be applied to the other solution accepted so that only if the line contains the value desired is it "searched".
You can use a "perform varying" loop to look at each block of the string within each line, where each block is a string the length of the string you are looking for. Here is an example that works in OpenCobol:
IDENTIFICATION DIVISION.
PROGRAM-ID. FIND-STRING.
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT IN-FILE ASSIGN TO 'SAMPLE-LEN.TXT'
ORGANIZATION IS LINE SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD IN-FILE.
01 IN-RECORD PIC X(80).
WORKING-STORAGE SECTION.
01 END-OF-FILE-SWITCH PIC XXX VALUE 'NO '.
88 END-OF-FILE VALUE 'YES'.
01 STRING-MARKER PIC X(7) VALUE 'LENGTH('.
01 STRING-MARKER-LENGTH PIC 99 VALUE 7.
01 STRING-SOUGHT PIC X(11).
01 STRING-INDEX PIC 99.
01 RECORD-LENGTH PIC 99 VALUE 80.
PROCEDURE DIVISION.
MAIN.
OPEN INPUT IN-FILE
PERFORM UNTIL END-OF-FILE
READ IN-FILE
AT END
SET END-OF-FILE TO TRUE
NOT AT END
PERFORM FIND-STRING
END-READ
END-PERFORM
CLOSE IN-FILE
STOP RUN
.
FIND-STRING.
PERFORM VARYING STRING-INDEX FROM 1 BY 1
UNTIL STRING-INDEX > (RECORD-LENGTH
- STRING-MARKER-LENGTH)
IF IN-RECORD(STRING-INDEX:STRING-MARKER-LENGTH) =
STRING-MARKER
UNSTRING IN-RECORD(STRING-INDEX
+ STRING-MARKER-LENGTH : 10)
DELIMITED BY ')' INTO STRING-SOUGHT
END-UNSTRING
DISPLAY STRING-SOUGHT END-DISPLAY
END-IF
END-PERFORM
.
Based on Bill Woodger's comments, here is a better solution. Thank's Bill, for teaching me not to slouch :) I still like looping through each record as a way to catch multiple matches on one line, so I kept that part.
IDENTIFICATION DIVISION.
PROGRAM-ID. FIND-STRING-2.
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT IN-FILE ASSIGN TO 'SAMPLE-LEN.TXT'
ORGANIZATION IS LINE SEQUENTIAL
FILE STATUS IS IN-FILE-STATUS.
DATA DIVISION.
FILE SECTION.
FD IN-FILE.
01 IN-RECORD PIC X(80).
WORKING-STORAGE SECTION.
01 IN-FILE-STATUS PIC XX.
01 END-OF-FILE-SWITCH PIC XXX VALUE 'NO '.
88 END-OF-FILE VALUE 'YES'.
01 STRING-MARKER-LEFT PIC X(7) VALUE 'LENGTH('.
01 STRING-MARKER-RIGHT PIC X VALUE ')'.
01 STRING-MARKER-LENGTH PIC 99 USAGE BINARY.
01 STRING-INDEX PIC 99 USAGE BINARY.
01 START-INDEX PIC 99 USAGE BINARY.
01 END-INDEX PIC 99 USAGE BINARY.
01 RECORD-LENGTH PIC 99 USAGE BINARY.
01 SEARCH-LENGTH PIC 99 USAGE BINARY.
01 IS-END-FOUND PIC XXX VALUE 'NO '.
88 END-FOUND VALUE 'YES'.
88 END-NOT-FOUND VALUE 'NO '.
PROCEDURE DIVISION.
MAIN.
OPEN INPUT IN-FILE
IF IN-FILE-STATUS NOT = '00'
DISPLAY 'FILE READ ERROR ' IN-FILE-STATUS
END-DISPLAY
PERFORM EXIT-PROGRAM
END-IF
PERFORM INITIALIZE-LENGTHS
PERFORM UNTIL END-OF-FILE
READ IN-FILE
AT END
SET END-OF-FILE TO TRUE
NOT AT END
PERFORM FIND-STRING
END-READ
END-PERFORM
PERFORM EXIT-PROGRAM
.
INITIALIZE-LENGTHS.
MOVE FUNCTION LENGTH(IN-RECORD) TO RECORD-LENGTH
COMPUTE STRING-MARKER-LENGTH = FUNCTION LENGTH(
STRING-MARKER-LEFT)
END-COMPUTE
COMPUTE SEARCH-LENGTH = RECORD-LENGTH - STRING-MARKER-LENGTH
END-COMPUTE
.
FIND-STRING.
PERFORM VARYING STRING-INDEX FROM 1 BY 1
UNTIL STRING-INDEX > SEARCH-LENGTH
IF IN-RECORD(STRING-INDEX:STRING-MARKER-LENGTH) =
STRING-MARKER-LEFT
COMPUTE START-INDEX = STRING-INDEX
+ STRING-MARKER-LENGTH
END-COMPUTE
SET END-NOT-FOUND TO TRUE
PERFORM VARYING END-INDEX FROM START-INDEX BY 1
UNTIL END-INDEX > RECORD-LENGTH OR END-FOUND
IF IN-RECORD(END-INDEX:
FUNCTION LENGTH(STRING-MARKER-RIGHT)) =
STRING-MARKER-RIGHT
SET END-FOUND TO TRUE
END-IF
END-PERFORM
COMPUTE END-INDEX = END-INDEX - START-INDEX - 1
END-COMPUTE
DISPLAY IN-RECORD(START-INDEX:END-INDEX)
END-DISPLAY
END-IF
END-PERFORM
.
EXIT-PROGRAM.
CLOSE IN-FILE
STOP RUN
.