Given this working version
IDENTIFICATION DIVISION.
PROGRAM-ID. HELLO-WORLD.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 UC-COUNTER PIC 99.
01 LC-COUNTER PIC 99.
PROCEDURE DIVISION.
INSPECT "My dog has fleas"
TALLYING UC-COUNTER FOR ALL 'A','B','C','D','E','F',
'G','H','I','J','K','L','M','N','O','P','Q','R','S','T',
'U','V','W','X','Y','Z'
LC-COUNTER FOR ALL 'a','b','c','d','e','f',
'g','h','i','j','k','l','m','n','o','p','q','r','s','t',
'u','v','w','x','y','z'.
DISPLAY UC-COUNTER " UPPER CASE CHARACTERS".
DISPLAY LC-COUNTER " LOWER CASE CHARACTERS".
GOBACK.
Is there a better way of expressing the alphabets? That is, can we have a SPECIAL-NAMES or something like that so that the instruction can be INSPECT TALLYING FOR ALL LATIN-UPPERCASE-LETTERS-ENGLISH or something similar.
LATER
Things like this don't appear to work (and given the GnuCOBOL docs, probably won't)
IDENTIFICATION DIVISION.
PROGRAM-ID. HELLO-WORLD.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES.
CLASS UPPER-CASE-ENGLISH-LETTERS IS
'A','B','C','D','E','F','G','H','I','J','K','L','M',
'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 UC-COUNTER PIC 99.
PROCEDURE DIVISION.
INSPECT "My dog has fleas"
TALLYING UC-COUNTER FOR ALL UPPER-CASE-ENGLISH-LETTERS.
DISPLAY UC-COUNTER " UPPER CASE CHARACTERS".
STOP RUN.
Is there a better way of expressing the alphabets?
COBOL has the class conditions ALPHABETIC-UPPER and ALPHABETIC-LOWER. Each of these includes space as part of the class condition. Unfortunately, for what you are requesting, class conditions cannot be used in an INSPECT statement.
It is necessary to simulate the INSPECT statement by using a loop to inspect each character to determine if it meets the class conditions while excluding spaces.
Code:
data division.
working-storage section.
01 uc-counter pic 99.
01 lc-counter pic 99.
01 str pic x(50).
01 n comp pic 9(4).
procedure division.
initialize uc-counter lc-counter
string "My dog has fleas" low-value delimited size
into str
perform varying n from 1 by 1
until str(n:1) = low-value
evaluate true
when str(n:1) = space
continue *> ignore space
when str(n:1) is alphabetic-upper
add 1 to uc-counter *> count upper-case letter
when str(n:1) is alphabetic-lower
add 1 to lc-counter *> count lower-case letter
when other
continue
end-evaluate
end-perform
display uc-counter " upper case characters"
display lc-counter " lower case characters"
goback
.
Output:
01 upper case characters
12 lower case characters
Depending on what character set you are using, if the characters are contiguous, then you could suffice with a few comparisons.
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.
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
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
.