Trailing-Edge
-
PDP-10 Archives
-
k20v7c
-
mfg/src/strco1.cbl
There are no other files named strco1.cbl in the archive.
IDENTIFICATION DIVISION.
PROGRAM-ID. STRCOM.
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT MASTER-FILE ASSIGN TO DSK RECORDING MODE ASCII.
SELECT SLAVE-FILE ASSIGN TO DSK RECORDING MODE ASCII.
SELECT RPT-FILE ASSIGN TO DSK RECORDING MODE ASCII.
DATA DIVISION.
FILE SECTION.
FD MASTER-FILE
LABEL RECORDS STANDARD
VALUE OF ID MAST-NAME.
01 M-REC.
05 M-rec-TEST.
10 FILLER PIC X.
10 M-str-TEST.
15 M-BOG-TEST.
20 M-F-TEST PIC X(3).
20 FILLER PIC X(5).
15 FILLER PIC X(2).
05 FILLER PIC X(59).
FD SLAVE-FILE
LABEL RECORDS STANDARD
VALUE OF ID S-NAME.
01 S-REC.
05 FILLER PIC X.
05 S-REC-TEST.
10 S-BOG-TEST.
15 S-F-TEST PIC X(3).
15 FILLER PIC X(5).
10 FILLER PIC X(2).
05 FILLER PIC X(59).
FD RPT-FILE
LABEL RECORDS STANDARD
VALUE OF ID "STRCOMRPT".
01 RPT-REC DISPLAY-7.
05 RPT-ITEM PIC X(20).
05 FILLER PIC X.
05 RPT-COM PIC X(10).
01 RPT-LONG-REC DISPLAY-7.
05 RPT-L-ITEM PIC X(20).
05 FILLER PIC X.
05 RPT-L-COM PIC X(50).
WORKING-STORAGE SECTION.
01 MAST-NAME.
05 M-STR PIC X(6).
05 FILLER PIC X(3) VALUE "DIR".
01 M-DIR PIC X(40).
01 IN-STR PIC X(7).
01 STR-IN.
05 FILLER PIC XXX.
05 D-STR PIC X(6).
01 S-NAME.
05 S-STR PIC X(6).
05 FILLER PIC X(3) VALUE "DIR".
01 S-DIR PIC X(40).
01 SAVE-BUFF OCCURS 4 TIMES INDEXED BY SAVE-INDEX.
05 SAVE-LINE PIC X(4).
05 SAVE-MARK PIC X.
01 S-BUFF OCCURS 2999 TIMES INDEXED BY S-INDEX.
05 S-LINE.
10 S-STR-TEST PIC X(11).
10 FILLER PIC X(59).
05 S-MARK PIC X.
01 EOF-FLG PIC 9.
01 EOB-FLG PIC 9.
01 DIR-FLG PIC 9.
01 EOD-FLG PIC 9.
01 FILE-MISSING-FLG PIC 9.
01 BOGUS-FLG PIC 9.
01 D-FILE-IN.
05 FILLER PIC X.
05 D-FILE-NAME PIC X(35).
01 STR-PNT PIC 99.
01 SIZE-COMP PIC X.
01 DATE-COMP PIC X.
01 M-FILE-ATT.
05 M-FILE-PROT PIC X(7).
05 M-FILE-COMP PIC X(43).
01 M-FILE-SIZE PIC X(20).
01 M-FILE-DATE PIC X(20).
01 S-FILE-ATT.
05 S-FILE-PROT PIC X(7).
05 S-FILE-COMP PIC X(43).
01 S-FILE-SIZE PIC X(20).
01 S-FILE-DATE PIC X(20).
01 M-FILE-FULL PIC X(35).
01 M-FILE-NAME.
05 M-FILE-QUICK PIC X(4).
05 FILLER PIC X(26).
01 M-FILE-EXT PIC X(30).
01 M-FILE-GEN PIC X(4).
01 S-FILE-NAME.
05 S-FILE-QUICK PIC X(4).
05 FILLER PIC X(26).
01 S-FILE-EXT PIC X(30).
01 S-FILE-GEN PIC X(4).
01 FILE-DIFF-FLG PIC 9.
PROCEDURE DIVISION.
INIT.
SET S-INDEX TO 1
SET SAVE-INDEX TO 1.
DISPLAY " ".
DISPLAY "Structure Files compare routine".
Display " ".
GET-M-STR.
MOVE SPACES TO M-STR.
Display "Master Structure: " with no advancing.
accept IN-STR.
UNSTRING IN-STR DELIMITED BY ":" INTO M-STR.
IF M-STR = SPACES
DISPLAY "? - Input error."
GO TO GET-M-STR.
GET-S-STR.
MOVE SPACES TO S-STR.
DISPLAY "Slave Structure: " with no advancing.
accept IN-STR.
UNSTRING IN-STR DELIMITED BY ":" INTO S-STR.
IF S-STR = SPACES
DISPLAY "? - Input error."
GO TO GET-S-STR.
FILE-INIT.
OPEN INPUT SLAVE-FILE.
MOVE 0 TO EOF-FLG.
SET S-INDEX TO 1.
PERFORM LOAD-S-BUFF THRU LOAD-S-BUFF-EXIT UNTIL EOF-FLG = 1
OR S-INDEX = 2999.
IF EOF-FLG NOT = 1
DISPLAY "% - Buffer Overflow... Continue ? " with no advancing.
Display " ".
MOVE "Z" TO S-MARK (S-INDEX).
OPEN OUTPUT RPT-FILE.
MOVE 0 TO EOF-FLG.
OPEN INPUT MASTER-FILE.
GET-FIRST-M-DIR.
MOVE "***" TO D-STR
PERFORM SEARCH-M-STR THRU SEARCH-M-STR-EXIT
UNTIL EOF-FLG = 1 OR D-STR = M-STR.
IF EOF-FLG = 1
DISPLAY "? - Can't find structure name in master directory!"
Stop run.
DISPLAY M-DIR.
PERFORM WRITE-M-DIR.
SET S-INDEX TO 1.
GO TO NXT-S-DIR.
GET-NXT-M-DIR.
MOVE "***" TO D-STR
PERFORM SEARCH-M-STR THRU SEARCH-M-STR-EXIT
UNTIL EOF-FLG = 1 OR D-STR = M-STR.
IF EOF-FLG = 1
DISPLAY " "
DISPLAY "Done!"
Stop run.
DISPLAY M-DIR.
PERFORM WRITE-M-DIR.
NXT-S-DIR.
MOVE 0 TO DIR-FLG.
MOVE 0 TO EOB-FLG.
* SET S-INDEX TO 1.
MOVE "***" TO D-STR.
* PERFORM READ-S-DIR VARYING S-INDEX FROM 1 BY 1
PERFORM READ-S-DIR VARYING S-INDEX FROM S-INDEX BY 1
UNTIL S-MARK (S-INDEX) = "Z"
OR D-STR = S-STR AND S-DIR = M-DIR.
IF S-MARK (S-INDEX) NOT = "Z"
SET SAVE-INDEX TO S-INDEX
GO TO NXT-M-FILE.
MISSING-DIRECTORY.
* MOVE SPACES TO RPT-REC.
MOVE M-DIR TO RPT-ITEM.
MOVE " Missing!" to RPT-COM.
WRITE RPT-REC.
SET S-INDEX TO 1.
GO TO GET-NXT-M-DIR.
NXT-M-FILE.
IF EOF-FLG = 1 GO TO DONE-M-DIR.
READ MASTER-FILE AT END MOVE 1 TO EOF-FLG
GO TO DONE-M-DIR.
PERFORM TEST-M-LINE.
IF BOGUS-FLG = 1
GO TO NXT-M-FILE.
*NEXT LINE???
MOVE SPACES TO M-FILE-ATT.
UNSTRING M-STR-TEST DELIMITED BY ":" INTO D-FILE-IN M-FILE-ATT.
IF M-FILE-ATT NOT = SPACES
GO TO DONE-M-DIR.
MOVE SPACES TO M-FILE-ATT.
UNSTRING M-REC DELIMITED BY ";" INTO D-FILE-IN M-FILE-ATT.
MOVE D-FILE-NAME TO M-FILE-FULL.
IF M-FILE-ATT = SPACES
DISPLAY "? - Missing file attributes in Master directory!".
UNSTRING D-FILE-NAME DELIMITED BY "." INTO
M-FILE-NAME, M-FILE-EXT, M-FILE-GEN.
*TEST
MOVE 1 TO STR-PNT.
UNSTRING M-FILE-COMP DELIMITED BY ")" INTO M-FILE-SIZE
WITH POINTER STR-PNT.
STRING ")" DELIMITED BY SIZE INTO M-FILE-SIZE
WITH POINTER STR-PNT.
MOVE 0 TO EOD-FLG.
MOVE 0 TO EOB-FLG.
*
MOVE "***" TO S-FILE-NAME.
PERFORM SEARCH-S-FILE THRU SEARCH-S-FILE-EXIT
UNTIL EOD-FLG = 1
OR EOB-FLG = 1
*FOR SPEED
OR M-FILE-NAME = S-FILE-NAME
AND M-FILE-EXT = S-FILE-EXT.
IF EOD-FLG = 1 OR EOB-FLG = 1
GO TO FILE-MISSING.
S-FILE-FOUND.
*NEVER GO BACKWARDS FROM A FILE THAT'S FOUND.
SET SAVE-INDEX TO S-INDEX.
FILE-COMP.
IF M-FILE-COMP NOT = S-FILE-COMP
MOVE 1 TO FILE-DIFF-FLG
MOVE M-FILE-FULL TO RPT-L-ITEM
MOVE M-FILE-ATT TO RPT-L-COM
WRITE RPT-LONG-REC
MOVE SPACES TO RPT-L-ITEM
MOVE S-FILE-ATT TO RPT-L-COM
WRITE RPT-LONG-REC.
*IN CASE OF MULTIPLE GENS
* SET S-INDEX DOWN BY 1.
GO TO NXT-M-FILE.
FILE-MISSING.
MOVE 1 TO FILE-MISSING-FLG.
MOVE M-FILE-FULL TO RPT-ITEM.
MOVE " Missing" TO RPT-COM.
WRITE RPT-REC.
SET S-INDEX TO SAVE-INDEX.
GO TO NXT-M-FILE.
DONE-M-DIR.
IF FILE-MISSING-FLG = 0 AND FILE-DIFF-FLG = 0
MOVE M-DIR TO RPT-ITEM
MOVE " Same " to RPT-COM
WRITE RPT-REC.
MOVE 0 TO FILE-MISSING-FLG.
MOVE 0 TO FILE-DIFF-FLG.
IF EOF-FLG = 1
GO TO FINI.
UNSTRING M-REC DELIMITED BY ":" INTO STR-IN M-DIR.
PERFORM WRITE-M-DIR.
DISPLAY M-DIR.
GO TO NXT-S-DIR.
FINI.
CLOSE MASTER-FILE.
MOVE SPACES TO RPT-REC. WRITE RPT-REC.
CLOSE RPT-FILE.
DISPLAY "Done!".
STOP RUN.
******************************
SEARCH-M-STR.
IF EOF-FLG = 1
GO TO SEARCH-M-STR-EXIT.
READ MASTER-FILE AT END MOVE 1 TO EOF-FLG.
PERFORM TEST-M-LINE.
IF BOGUS-FLG = 1
GO TO SEARCH-M-STR.
MOVE SPACES TO M-DIR.
UNSTRING M-STR-TEST DELIMITED BY ":" INTO STR-IN M-DIR.
IF M-DIR NOT = SPACES
UNSTRING M-REC DELIMITED BY ":" INTO STR-IN M-DIR.
SEARCH-M-STR-EXIT. EXIT.
READ-S-DIR.
UNSTRING S-LINE (S-INDEX) DELIMITED BY ":" INTO STR-IN S-DIR.
LOAD-S-BUFF.
READ SLAVE-FILE AT END MOVE 1 TO EOF-FLG
GO TO LOAD-S-BUFF-EXIT.
IF S-F-TEST = SPACES
GO TO LOAD-S-BUFF-EXIT.
IF S-BOG-TEST = ("TOTAL OF" OR "GRAND TO")
GO TO LOAD-S-BUFF-EXIT.
MOVE S-REC TO S-LINE (S-INDEX).
MOVE "G" TO S-MARK (S-INDEX).
SET S-INDEX UP BY 1.
LOAD-S-BUFF-EXIT. EXIT.
SEARCH-S-FILE.
* DISPLAY S-INDEX.
IF S-MARK (S-INDEX) = "Z"
MOVE 1 TO EOB-FLG
GO TO SEARCH-S-FILE-EXIT.
MOVE SPACES TO S-FILE-ATT.
UNSTRING S-STR-TEST (S-INDEX) DELIMITED BY ":" INTO
D-FILE-IN S-FILE-ATT.
IF S-FILE-ATT NOT = SPACES
MOVE 1 TO EOD-FLG
GO TO SEARCH-S-FILE-EXIT.
UNSTRING S-LINE (S-INDEX) DELIMITED BY ";" INTO
D-FILE-IN S-FILE-ATT.
IF S-FILE-ATT = SPACES
DISPLAY "? - Missing file attributes in Slave directory!".
UNSTRING D-FILE-NAME DELIMITED BY "." INTO
S-FILE-NAME, S-FILE-EXT, S-FILE-GEN.
*TEST
MOVE 1 TO STR-PNT.
UNSTRING S-FILE-COMP DELIMITED BY ")" INTO S-FILE-SIZE
WITH POINTER STR-PNT.
STRING ")" DELIMITED BY SIZE INTO S-FILE-SIZE
WITH POINTER STR-PNT.
DISPLAY S-FILE-SIZE.
*SINCE DIR ALPHABETICALLY SORTED USE EOD FLAG IF GONE PAST.
IF M-FILE-QUICK < S-FILE-QUICK
MOVE 1 TO EOD-FLG
GO TO SEARCH-S-FILE-EXIT.
SET S-INDEX UP BY 1.
SEARCH-S-FILE-EXIT. EXIT.
TEST-M-LINE.
MOVE 0 TO BOGUS-FLG.
IF M-F-TEST = SPACES
GO TO NXT-M-FILE.
IF M-BOG-TEST = ("GRAND TO" OR "TOTAL OF")
MOVE 1 TO BOGUS-FLG.
WRITE-M-DIR.
MOVE SPACES TO RPT-REC. WRITE RPT-REC.
MOVE M-DIR TO RPT-REC. WRITE RPT-REC.
FOO.
DISPLAY "FOO".