6.1.1 SUPの例
SUPのコーディング例を次に示します。
10 * 20 ******************************************************** 30 * SUP01 * 40 ******************************************************** 50 * 60 IDENTIFICATION DIVISION. 70 * 80 PROGRAM-ID. MAIN. 90 * 100 ******************************************************** 110 * データ領域の設定 * 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(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(ユーザサーバの開始処理完了の報告) * 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(トランザクションの開始) * 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(遠隔サービスの要求) * 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(非連鎖モードのコミット) * 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(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.