OpenTP1 Version 7 Programming Reference COBOL Language
The figure below shows an example of a client/server configuration UAP.
Figure 6-1 Client/server UAP configuration sample (DAM access)
This section presents a coding example based on the configuration sample shown in the figure.
The following shows a coding example for SUP.
10 * 20 ********************************************** 30 * SUP01 * 40 ********************************************** 50 * 60 IDENTIFICATION DIVISION. 70 * 80 PROGRAM-ID. MAIN. 90 * 100 ********************************************** 110 * Set the data area * 120 ********************************************** 130 * 140 DATA DIVISION. 150 WORKING-STORAGE SECTION. 160 01 RPC-ARG1. 170 02 REQUEST PIC X(8) VALUE SPACE. 180 02 STATUS-CODE PIC X(5) VALUE SPACE. 190 02 FILLER PIC X(3). 200 02 FLAGS PIC S9(9) COMP VALUE ZERO. 210 * 220 01 RPC-ARG2. 230 02 REQUEST PIC X(8) VALUE SPACE. 240 02 STATUS-CODE PIC X(5) VALUE SPACE. 250 02 FILLER PIC X(3). 260 02 FLAGS PIC S9(9) COMP VALUE ZERO. 270 02 DESCRIPTOR PIC S9(9) COMP VALUE ZERO. 280 02 S-NAME PIC X(32) VALUE SPACE. 290 02 G-NAME PIC X(32) VALUE SPACE. 300 * 310 01 RPC-ARG3. 320 02 SEND-DATA-LENG PIC S9(9) COMP VALUE ZERO. 330 02 SEND-DATA PIC X(32) VALUE SPACE. 340 * 350 01 RPC-ARG4. 360 02 RECEIVE-DATA-LENG PIC S9(9) COMP VALUE ZERO. 370 02 RECEIVE-DATA PIC X(32) VALUE SPACE. 380 * 390 01 ADM-ARG1. 400 02 REQUEST PIC X(8) VALUE SPACE. 410 02 STATUS-CODE PIC X(5) VALUE SPACE. 420 02 FILLER PIC X(3). 430 02 FLAGS PIC S9(9) COMP VALUE ZERO. 440 02 FILLER PIC X(3). 450 * 460 01 TRN-ARG1. 470 02 REQUEST PIC X(8) VALUE SPACE. 480 02 STATUS-CODE PIC X(5) VALUE SPACE. 490 * 500 PROCEDURE DIVISION. 510 * 520 ********************************************** 530 * RPC-OPEN (start the UAP) * 540 ********************************************** 550 * 560 MOVE 'OPEN' TO REQUEST OF RPC-ARG1. 570 MOVE ZERO TO FLAGS OF RPC-ARG1. 580 CALL 'CBLDCRPC' USING RPC-ARG1. 590 IF STATUS-CODE OF RPC-ARG1 NOT = '00000' THEN 600 DISPLAY 'SUP01:RPC-OPEN FAILED. CODE = ' 610 STATUS-CODE OF RPC-ARG1 620 GO TO PROG-END 630 END-IF. 640 * 650 ********************************************* 660 * ADM-COMPLETE (report completion of * 665 * user server start processing) * 670 ********************************************* 680 * 690 MOVE 'COMPLETE' TO REQUEST OF ADM-ARG1. 700 CALL 'CBLDCADM' USING ADM-ARG1. 710 IF STATUS-CODE OF ADM-ARG1 NOT = '00000' THEN 720 DISPLAY 'SUP01:RPC-COMPLETE FAILED. CODE = ' 730 STATUS-CODE OF ADM-ARG1 740 GO TO PROG-END 750 END-IF. 760 * 770 ********************************************* 780 * TRN_BEGIN (start the transaction) * 790 ********************************************* 800 * 810 MOVE 'BEGIN' TO REQUEST OF TRN-ARG1. 820 CALL 'CBLDCTRN' USING TRN-ARG1. 830 IF STATUS-CODE OF TRN-ARG1 NOT = '00000' THEN 840 DISPLAY 'SUP01:TRN-BEGIN FAILED. CODE = ' 850 STATUS-CODE OF TRN-ARG1 860 GO TO TRAN-END 870 END-IF. 880 * 890 ********************************************* 900 * RPC-CALL (request a remote service) * 910 ********************************************* 920 * 930 MOVE 'CALL' TO REQUEST OF RPC-ARG2. 940 MOVE 'SPP01' TO G-NAME OF RPC-ARG2. 950 MOVE 'SVR01' TO S-NAME OF RPC-ARG2. 960 MOVE 'SUP01:DATA OpenTP1' TO SEND-DATA OF RPC-ARG3. 970 MOVE 32 TO SEND-DATA-LENG OF RPC-ARG3. 980 MOVE 32 TO RECEIVE-DATA-LENG OF RPC-ARG4. 990 CALL 'CBLDCRPC' USING RPC-ARG2 RPC-ARG3 RPC-ARG4. 1000 IF STATUS-CODE OF RPC-ARG2 NOT = '00000' THEN 1010 DISPLAY 'SUP01:RPC-CALL RETURN CODE = ' 1020 STATUS-CODE OF RPC-ARG2 1030 GO TO TRAN-END 1040 END-IF. 1050 DISPLAY 'SERVICE FUNCTION RETURN = ' RECEIVE-DATA. 1060 TRAN-END. 1070 * 1080 ********************************************* 1090 * TRN-UNCHAINED-COMMIT * 1095 * (commit in unchained mode) * 1100 ********************************************* 1110 * 1120 MOVE 'U-COMMIT' TO REQUEST OF TRN-ARG1. 1130 CALL 'CBLDCTRN' USING TRN-ARG1. 1140 IF STATUS-CODE OF TRN-ARG1 NOT = '00000' THEN 1150 DISPLAY 'SUP01:TRN-UNCHAINED-COMMIT FAILED. CODE = ' 1160 STATUS-CODE OF TRN-ARG1 1170 END-IF. 1180 PROG-END. 1190 * 1200 ********************************************* 1210 * RPC-CLOSE (terminate the UAP) * 1220 ********************************************* 1230 * 1240 MOVE 'CLOSE' TO REQUEST OF RPC-ARG1. 1250 MOVE ZERO TO FLAGS OF RPC-ARG1. 1260 CALL 'CBLDCRPC' USING RPC-ARG1. 1270 DISPLAY 'SUP01:SUP PROCESS ENDED'. 1280 STOP RUN.
The following shows a coding example for the SPP main program.
10 * 20 ********************************************** 30 * SPP01 main program * 40 ********************************************** 50 * 60 IDENTIFICATION DIVISION. 70 * 80 PROGRAM-ID. MAIN. 90 * 100 ******************************************************** 110 * Set the data area * 120 ******************************************************** 130 * 140 DATA DIVISION. 150 WORKING-STORAGE SECTION. 160 01 FD-ID EXTERNAL. 170 10 FD-SAVE PIC S9(9) COMP. 180 01 RPC-ARG1. 190 02 REQ-CODE PIC X(8) VALUE SPACE. 200 02 STATUS-CODE PIC X(5) VALUE SPACE. 210 02 FILLER PIC X(3). 220 02 FLAGS PIC S9(9) COMP. 230 01 DAM-ARG1. 240 02 REQUEST PIC X(8) VALUE SPACE. 250 02 STATUS-CODE PIC X(5) VALUE SPACE. 260 02 FILLER PIC X(3). 270 02 FILE-NAME PIC X(8). 280 02 FILLER PIC S9(9) COMP. 290 02 FILLER PIC S9(9) COMP. 300 02 FILDES PIC S9(9) COMP VALUE ZERO. 310 02 FILLER PIC X(28). 320 01 DAM-ARG2. 330 02 ACCESS-CODE PIC X(4). 340 02 FLAG1 PIC X(1). 350 02 FILLER PIC X(1). 360 02 FILLER PIC X(1). 370 02 FILLER PIC X(1). 380 02 FLAGS PIC S9(9) COMP VALUE ZERO. 390 * 400 PROCEDURE DIVISION. 410 * 420 ********************************************** 430 * RPC-OPEN (start the UAP) * 440 ********************************************** 450 * 460 MOVE 'OPEN' TO REQ-CODE OF RPC-ARG1. 470 MOVE ZERO TO FLAGS OF RPC-ARG1. 480 CALL 'CBLDCRPC' USING RPC-ARG1. 490 IF STATUS-CODE OF RPC-ARG1 NOT = '00000' THEN 500 DISPLAY 'SPP01:RPC-OPEN FAILED. CODE = ' 510 STATUS-CODE OF RPC-ARG1 520 GO TO PROG-END 530 END-IF. 540 * 550 ********************************************** 560 * DAM-OPEN (open a logical file) * 570 ********************************************** 580 * 590 MOVE 'DCDAMSVC' TO REQUEST OF DAM-ARG1. 600 MOVE 'damfile0' TO FILE-NAME OF DAM-ARG1. 610 MOVE 'OPEN' TO ACCESS-CODE OF DAM-ARG2. 620 MOVE 'B' TO FLAG1 OF DAM-ARG2. 630 CALL 'CBLDCDAM' USING DAM-ARG1 DAM-ARG2. 640 IF STATUS-CODE OF DAM-ARG1 NOT = '00000' THEN 650 DISPLAY 'SPP01:DAM-OPEN FAILED. CODE = ' 660 STATUS-CODE OF DAM-ARG1 670 GO TO DAM-END 680 END-IF. 690 MOVE FILDES TO FD-SAVE. 700 * 710 ********************************************** 720 * RPC-MAINLOOP (start the SPP service) * 730 ********************************************** 740 * 750 DISPLAY 'SPP01: MAINLOOP START.' 760 MOVE 'MAINLOOP' TO REQ-CODE OF RPC-ARG1. 770 MOVE ZERO TO FLAGS OF RPC-ARG1. 780 CALL 'CBLDCRSV' USING RPC-ARG1. 790 IF STATUS-CODE OF RPC-ARG1 NOT = '00000' THEN 800 DISPLAY 'SPP01:RPC-MAINLOOP FAILED. CODE =' 810 STATUS-CODE OF RPC-ARG1 820 END-IF. 830 DAM-END. 840 * 850 ********************************************** 860 * DAM-CLOSE (close the logical file) * 870 ********************************************** 880 * 890 MOVE 'damfile0' TO FILE-NAME OF DAM-ARG1. 900 MOVE FD-SAVE TO FILDES OF DAM-ARG1. 910 MOVE 'CLOS' TO ACCESS-CODE OF DAM-ARG2. 920 CALL 'CBLDCDAM' USING DAM-ARG1 DAM-ARG2. 930 IF STATUS-CODE OF DAM-ARG1 NOT = '00000' THEN 940 DISPLAY 'SPP01:DAM-CLOSE FAILED. CODE = ' 950 STATUS-CODE OF DAM-ARG1 960 END-IF. 970 PROG-END. 980 * 990 ********************************************** 1000 * RPC-CLOSE (terminate the UAP) * 1010 ********************************************** 1020 * 1030 MOVE 'CLOSE' TO REQ-CODE OF RPC-ARG1. 1040 MOVE ZERO TO FLAGS OF RPC-ARG1. 1050 CALL 'CBLDCRPC' USING RPC-ARG1. 1060 * 1070 ********************************************** 1080 * Terminate processing * 1090 ********************************************** 1100 * 1110 DISPLAY 'SPP01:Good-by!' 1120 STOP RUN.
The following shows a coding example for the SPP service program.
10 * 20 ********************************************** 30 * SPP service program SVR01 * 40 ********************************************** 50 * 60 IDENTIFICATION DIVISION. 70 * 80 PROGRAM-ID. SVR01. 90 * 100 ********************************************** 110 * Set the data area * 120 ********************************************** 130 * 140 DATA DIVISION. 150 WORKING-STORAGE SECTION. 160 01 FD-ID EXTERNAL. 170 10 FD-SAVE PIC S9(9) COMP. 180 01 DAM-ARG1. 190 02 REQUEST PIC X(8) VALUE SPACE. 200 02 STATUS-CODE PIC X(5) VALUE SPACE. 210 02 FILLER PIC X(3). 220 02 FILE-NAME PIC X(8). 230 02 KEY-NO PIC S9(9) COMP VALUE ZERO. 240 02 BUFFER-LEN PIC S9(9) COMP VALUE ZERO. 250 02 FILDES PIC S9(9) COMP VALUE ZERO. 260 02 FILLER PIC X(28). 270 01 DAM-ARG2. 280 02 ACCESS-CODE PIC X(4). 290 02 FLAG1 PIC X(1). 300 02 FLAG2 PIC X(1). 310 02 FLAG3 PIC X(1). 320 02 FLAG4 PIC X(1). 330 02 FLAGS PIC S9(9) COMP VALUE ZERO. 340 02 DAMKEY. 350 03 FIRST-BLOCK-NO PIC S9(9) COMP. 360 03 LAST-BLOCK-NO PIC S9(9) COMP. 370 * 380 01 CNTL-BUFFER. 390 02 W-COUNT PIC S9(9) COMP. 400 02 RWT-DATA PIC X(18) VALUE SPACE. 410 02 FILLER PIC X(483) VALUE SPACE. 420 * 430 01 W-BUFFER. 440 02 FILLER PIC X(504). 450 * 460 LINKAGE SECTION. 470 77 IN-DATA PIC X(32). 480 77 IN-LENG PIC S9(9) COMP. 490 77 OUT-DATA PIC X(32). 500 77 OUT-LENG PIC S9(9) COMP. 510 * 520 PROCEDURE DIVISION USING IN-DATA IN-LENG OUT-DATA OUT-LENG. 530 SVR01 SECTION. 540 DISPLAY 'SVR01:PROCEDURE START' . 550 * 560 ********************************************* 570 * DAM_READ(read logical file blocks) * 580 ********************************************* 590 * 600 MOVE 'DCDAMSVC' TO REQUEST OF DAM-ARG1. 610 MOVE 'damfile0' TO FILE-NAME OF DAM-ARG1. 620 MOVE 1 TO KEY-NO OF DAM-ARG1. 630 MOVE 504 TO BUFFER-LEN OF DAM-ARG1. 640 MOVE FD-SAVE TO FILDES OF DAM-ARG1. 650 MOVE 'READ' TO ACCESS-CODE OF DAM-ARG2. 660 MOVE 'M' TO FLAG1 OF DAM-ARG2. 670 MOVE SPACE TO FLAG2 OF DAM-ARG2. 680 MOVE 0 TO FIRST-BLOCK-NO OF DAMKEY. 690 MOVE 0 TO LAST-BLOCK-NO OF DAMKEY. 700 CALL 'CBLDCDAM' USING DAM-ARG1 DAM-ARG2 CNTL-BUFFER. 710 IF STATUS-CODE OF DAM-ARG1 NOT = '00000' THEN 720 DISPLAY 'SVR01:DAM-READ FAILED. CODE =' 730 STATUS-CODE OF DAM-ARG1 740 MOVE 'SVR01: DAM READ FAILED' TO OUT-DATA 750 MOVE 25 TO OUT-LENG 760 GO TO PROG-END 770 END-IF. 780 * 790 ********************************************* 800 * DAM_WRITE (write to logical file blocks) * 810 ********************************************* 820 * 830 DAM-WRITE. 840 ADD 1 TO W-COUNT OF CNTL-BUFFER. 850 MOVE 'DCDAMSVC' TO REQUEST OF DAM-ARG1. 860 MOVE 'damfile0' TO FILE-NAME OF DAM-ARG1. 870 MOVE 1 TO KEY-NO OF DAM-ARG1. 880 MOVE 504 TO BUFFER-LEN OF DAM-ARG1. 890 MOVE FD-SAVE TO FILDES OF DAM-ARG1. 900 MOVE 'WRIT' TO ACCESS-CODE OF DAM-ARG2. 910 MOVE W-COUNT OF CNTL-BUFFER TO FIRST-BLOCK-NO OF DAMKEY. 920 MOVE 0 TO LAST-BLOCK-NO OF DAMKEY. 930 MOVE IN-DATA TO W-BUFFER. 940 CALL 'CBLDCDAM' USING DAM-ARG1 DAM-ARG2 W-BUFFER. 950 IF STATUS-CODE OF DAM-ARG1 NOT = '00000' THEN 960 IF STATUS-CODE OF DAM-ARG1 = '01606' THEN 970 MOVE 0 TO W-COUNT OF CNTL-BUFFER 980 GO TO DAM-WRITE 990 END-IF 1000 DISPLAY 'SVR01:DAM-WRITE FAILED. CODE = ' 1010 STATUS-CODE OF DAM-ARG1 1020 MOVE 'SVR01:DAM WRITE FAILED' TO OUT-DATA 1030 MOVE 26 TO OUT-LENG 1040 GO TO PROG-END 1050 END-IF. 1060 * 1070 ********************************************* 1080 * DAM_REWRITE (update logical file blocks) * 1090 ********************************************* 1100 * 1110 MOVE 'DCDAMSVC' TO REQUEST OF DAM-ARG1. 1120 MOVE 'damfile0' TO FILE-NAME OF DAM-ARG1. 1130 MOVE 1 TO KEY-NO OF DAM-ARG1. 1140 MOVE 504 TO BUFFER-LEN OF DAM-ARG1. 1150 MOVE FD-SAVE TO FILDES OF DAM-ARG1. 1160 MOVE 'REWT' TO ACCESS-CODE OF DAM-ARG2. 1170 MOVE 'U' TO FLAG1 OF DAM-ARG2. 1180 MOVE 0 TO FIRST-BLOCK-NO OF DAMKEY. 1190 MOVE 0 TO LAST-BLOCK-NO OF DAMKEY. 1200 MOVE 'REWRITE COMPLETE' TO RWT-DATA OF CNTL-BUFFER. 1210 CALL 'CBLDCDAM' USING DAM-ARG1 DAM-ARG2 CNTL-BUFFER. 1220 IF STATUS-CODE OF DAM-ARG1 NOT = '00000' THEN 1230 DISPLAY 'SVR01:DAM-REWRITE FAILED. CODE = ' 1240 STATUS-CODE OF DAM-ARG1 1250 MOVE 'SVR01:DAM REWRITE FAILED' TO OUT-DATA 1260 MOVE 28 TO OUT-LENG 1270 GO TO PROG-END 1280 END-IF. 1290 MOVE 'SVR01:PROCESS COMPLETE' TO OUT-DATA. 1300 MOVE 26 TO OUT-LENG. 1310 PROG-END. 1320 DISPLAY 'SVR01:Good-By!!'. 1330 END PROGRAM SVR01.
All Rights Reserved. Copyright (C) 2006, 2010, Hitachi, Ltd.