「3.3.1 CUPとSPPの作成」に示すCUPとSPPの構成例の,CUPをCOBOL言語で作成した場合のコーディング例を次に示します。
000010 *
000020 **************************************************
000030 * CUPサンプルプログラム *
000040 **************************************************
000050 *
000060 IDENTIFICATION DIVISION.
000070 PROGRAM-ID. CUP01.
000080 *
000090 **************************************************
000100 * データ領域の設定 *
000110 **************************************************
000120 *
000130 DATA DIVISION.
000140 WORKING-STORAGE SECTION.
000150 01 DCCLS-CLTIN-ARG.
000160 02 DCCLS-CLTIN-REQUEST PIC X(8) VALUE 'CLTIN '.
000170 02 DCCLS-CLTIN-STATUS-CODE PIC X(5).
000180 02 FILLER PIC X(3).
000190 02 DCCLS-CLTIN-FLAGS PIC S9(9) COMP VALUE ZERO.
000200 02 DCCLS-CLTIN-T-HOST PIC X(64).
000210 02 DCCLS-CLTIN-LOGNAME PIC X(16).
000220 02 DCCLS-CLTIN-PASSWD PIC X(16).
000230 02 DCCLS-CLTIN-S-HOST PIC X(64).
000240 02 DCCLS-CLTIN-HWND PIC 9(4) COMP.
000250 02 FILLER PIC X(2).
000260 02 DCCLS-CLTIN-CLTID PIC 9(9) COMP.
000270 02 DCCLS-CLTIN-DEFPATH PIC X(256).
000280 *
000290 01 DCCLS-CLTOUT-ARG.
000300 02 DCCLS-CLTOUT-REQUEST PIC X(8) VALUE 'CLTOUT '.
000310 02 DCCLS-CLTOUT-STATUS-CODE PIC X(5).
000320 02 FILLER PIC X(3).
000330 02 DCCLS-CLTOUT-FLAGS PIC S9(9) COMP VALUE ZERO.
000340 02 DCCLS-CLTOUT-CLTID PIC 9(9) COMP.
000350 *
000360 01 DCRPS-OPEN-ARG1.
000370 02 DCRPS-OPEN-REQUEST PIC X(8) VALUE 'OPEN '.
000380 02 DCRPS-OPEN-STATUS-CODE PIC X(5).
000390 02 FILLER PIC X(3).
000400 02 DCRPS-OPEN-FLAGS PIC S9(9) COMP VALUE ZERO.
000410 02 DCRPS-OPEN-CLTID PIC 9(9) COMP.
000420 *
000430 01 DCRPS-OPEN-ARG2.
000440 02 FILLER PIC X(1).
000450 *
000460 01 DCRPS-OPEN-ARG3.
000470 02 FILLER PIC X(1).
000480 *
000490 01 DCRPS-CALL-ARG1.
000500 02 DCRPS-CALL-REQUEST PIC X(8) VALUE 'CALL '.
000510 02 DCRPS-CALL-STATUS-CODE PIC X(5).
000520 02 FILLER PIC X(3).
000530 02 DCRPS-CALL-FLAGS PIC S9(9) COMP VALUE ZERO.
000540 02 DCRPS-CALL-DESCRIPTER PIC S9(9) COMP.
000550 02 DCRPS-CALL-SVGROUP PIC X(32).
000560 02 DCRPS-CALL-SVNAME PIC X(32).
000570 02 DCRPS-CALL-CLTID PIC 9(9) COMP.
000580 *
000590 01 DCRPS-CALL-ARG2.
000600 02 DCRPS-CALL-INDATALEN PIC S9(9) COMP.
000610 02 DCRPS-CALL-INDATA PIC X(512).
000620 *
000630 01 DCRPS-CALL-ARG3.
000640 02 DCRPS-CALL-OUTDATALEN PIC S9(9) COMP.
000650 02 DCRPS-CALL-OUTDATA PIC X(512).
000660 *
000670 01 DCRPS-CLOSE-ARG1.
000680 02 DCRPS-CLOSE-REQUEST PIC X(8) VALUE 'CLOSE '.
000690 02 DCRPS-CLOSE-STATUS-CODE PIC X(5).
000700 02 FILLER PIC X(3).
000710 02 DCRPS-CLOSE-FLAGS PIC S9(9) COMP VALUE ZERO.
000720 02 DCRPS-CLOSE-CLTID PIC 9(9) COMP.
000730 *
000740 01 DCRPS-CLOSE-ARG2.
000750 02 FILLER PIC X(1).
000760 *
000770 01 DCRPS-CLOSE-ARG3.
000780 02 FILLER PIC X(1).
000790 *
000800 77 FOREVER-FLAG PIC 9 COMP VALUE ZERO.
000810 77 INDATA PIC X(512) VALUE SPACE.
000820 *
000830 **************************************************
000840 * CUPの開始 *
000850 **************************************************
000860 PROCEDURE DIVISION.
000870 MAIN SECTION.
000880 PROG-START.
000890 *
000900 **************************************************
000910 * クライアントユーザの認証要求 *
000920 **************************************************
000930 MOVE 'CLTIN ' TO DCCLS-CLTIN-REQUEST IN DCCLS-CLTIN-ARG.
000940 MOVE ZERO TO DCCLS-CLTIN-FLAGS IN DCCLS-CLTIN-ARG.
000950 MOVE SPACE TO DCCLS-CLTIN-T-HOST IN DCCLS-CLTIN-ARG.
000960 MOVE 'user01' TO DCCLS-CLTIN-LOGNAME IN DCCLS-CLTIN-ARG.
000970 MOVE 'puser01' TO DCCLS-CLTIN-PASSWD IN DCCLS-CLTIN-ARG.
000980 MOVE ZERO TO DCCLS-CLTIN-HWND IN DCCLS-CLTIN-ARG.
000990 MOVE SPACE TO DCCLS-CLTIN-DEFPATH IN DCCLS-CLTIN-ARG.
001000 *
001010 * *******************************
001020 CALL 'CBLDCCLS' USING DCCLS-CLTIN-ARG.
001030 * *******************************
001040 IF DCCLS-CLTIN-STATUS-CODE
001050 IN DCCLS-CLTIN-ARG NOT = '00000'
001060 THEN
001070 DISPLAY 'CUP01: CBLDCCLS(CLTIN)に失敗しました。CODE='
001080 DCCLS-CLTIN-STATUS-CODE IN DCCLS-CLTIN-ARG
001090 GO TO PROG-EXIT
001100 END-IF.
001110 *
001120 **************************************************
001130 * RPC-OPEN(RPC環境の初期設定) *
001140 **************************************************
001150 MOVE 'OPEN ' TO
001160 DCRPS-OPEN-REQUEST IN DCRPS-OPEN-ARG1.
001170 MOVE ZERO TO
001180 DCRPS-OPEN-FLAGS IN DCRPS-OPEN-ARG1.
001190 MOVE DCCLS-CLTIN-CLTID IN DCCLS-CLTIN-ARG TO
001200 DCRPS-OPEN-CLTID IN DCRPS-OPEN-ARG1.
001210 *
001220 * *******************************
001230 CALL 'CBLDCRPS' USING DCRPS-OPEN-ARG1
001240 DCRPS-OPEN-ARG2 DCRPS-OPEN-ARG3.
001250 * *******************************
001260 IF DCRPS-OPEN-STATUS-CODE IN DCRPS-OPEN-ARG1
001270 NOT = '00000'
001280 THEN
001290 DISPLAY 'CUP01: CBLDCRPS(OPEN)に失敗しました。CODE='
001300 DCRPS-OPEN-STATUS-CODE IN DCRPS-OPEN-ARG1
001310 GO TO PROG-END
001320 END-IF.
001330 *
001340 PERFORM UNTIL FOREVER-FLAG NOT = ZERO
001350 DISPLAY '****** 伝言板メニュー ******'
001360 DISPLAY '伝言の取り出し .... [1]'
001370 '伝言の書き込み .... [2]'
001380 DISPLAY '終了 .............. [9]'
001390 DISPLAY '番号を入力して下さい。=>'
001400 ACCEPT INDATA
001410 EVALUATE INDATA
001420 WHEN '1'
001430 *
001440 * *********************************************
001450 * * RPC-CALL(RPCの実行) *
001460 * *********************************************
001470 MOVE 'CALL ' TO
001480 DCRPS-CALL-REQUEST IN DCRPS-CALL-ARG1
001490 MOVE ZERO TO
001500 DCRPS-CALL-FLAGS IN DCRPS-CALL-ARG1
001510 MOVE 'spp01' TO
001520 DCRPS-CALL-SVGROUP IN DCRPS-CALL-ARG1
001530 MOVE 'get' TO
001540 DCRPS-CALL-SVNAME IN DCRPS-CALL-ARG1
001550 MOVE DCCLS-CLTIN-CLTID IN DCCLS-CLTIN-ARG TO
001560 DCRPS-CALL-CLTID IN DCRPS-CALL-ARG1
001570 MOVE 'cup01 ' TO
001580 DCRPS-CALL-INDATA IN DCRPS-CALL-ARG2
001590 MOVE 512 TO
001600 DCRPS-CALL-INDATALEN IN DCRPS-CALL-ARG2
001610 MOVE SPACE TO
001620 DCRPS-CALL-OUTDATA IN DCRPS-CALL-ARG3
001630 MOVE 512 TO
001640 DCRPS-CALL-OUTDATALEN IN DCRPS-CALL-ARG3
001650 *
001660 * **************************************************
001670 CALL 'CBLDCRPS' USING DCRPS-CALL-ARG1
001680 DCRPS-CALL-ARG2 DCRPS-CALL-ARG3
001690 * **************************************************
001700 IF DCRPS-CALL-STATUS-CODE IN DCRPS-CALL-ARG1
001710 NOT = '00000'
001720 THEN
001730 DISPLAY 'CUP01: CBLDCRPS(CALL)に失敗しました。CODE='
001740 DCRPS-CALL-STATUS-CODE IN DCRPS-CALL-ARG1
001750 GO TO PROG-END
001760 END-IF
001770 DISPLAY '伝言板の内容: ' DCRPS-CALL-OUTDATA
001780 IN DCRPS-CALL-ARG3
001790 WHEN '2'
001800 DISPLAY '伝言を入力して下さい =>'
001810 ACCEPT INDATA
001820 IF INDATA = SPACE
001830 THEN
001840 MOVE '伝言はありません。' TO INDATA
001850 END-IF
001860 *
001870 * *********************************************
001880 * * RPC-CALL(RPCの実行) *
001890 * *********************************************
001900 MOVE 'CALL ' TO
001910 DCRPS-CALL-REQUEST IN DCRPS-CALL-ARG1
001920 MOVE ZERO TO
001930 DCRPS-CALL-FLAGS IN DCRPS-CALL-ARG1
001940 MOVE 'spp01' TO
001950 DCRPS-CALL-SVGROUP IN DCRPS-CALL-ARG1
001960 MOVE 'put' TO
001970 DCRPS-CALL-SVNAME IN DCRPS-CALL-ARG1
001980 MOVE DCCLS-CLTIN-CLTID IN DCCLS-CLTIN-ARG TO
001990 DCRPS-CALL-CLTID IN DCRPS-CALL-ARG1
002000 MOVE INDATA TO
002010 DCRPS-CALL-INDATA IN DCRPS-CALL-ARG2
002020 MOVE 512 TO
002030 DCRPS-CALL-INDATALEN IN DCRPS-CALL-ARG2
002040 MOVE SPACE TO
002050 DCRPS-CALL-OUTDATA IN DCRPS-CALL-ARG3
002060 MOVE 512 TO
002070 DCRPS-CALL-OUTDATALEN IN DCRPS-CALL-ARG3
002080
002090 *
002100 * **************************************************
002110 CALL 'CBLDCRPS' USING DCRPS-CALL-ARG1
002120 DCRPS-CALL-ARG2 DCRPS-CALL-ARG3
002130 * **************************************************
002140 IF DCRPS-CALL-STATUS-CODE IN DCRPS-CALL-ARG1
002150 NOT = '00000'
002160 THEN
002170 DISPLAY 'CUP01: CBLDCRPS(CALL)に失敗しました。CODE='
002180 DCRPS-CALL-STATUS-CODE IN DCRPS-CALL-ARG1
002190 GO TO PROG-END
002200 END-IF
002210 DISPLAY DCRPS-CALL-OUTDATA IN DCRPS-CALL-ARG3
002220 WHEN '9'
002230 GO TO PROG-END
002240 WHEN OTHER
002250 CONTINUE
002260 END-EVALUATE
002270 END-PERFORM.
002280 PROG-END.
002290 *
002300 **************************************************
002310 * RPC-CLOSE(RPC環境の解除) *
002320 **************************************************
002330 MOVE 'CLOSE ' TO
002340 DCRPS-CLOSE-REQUEST IN DCRPS-CLOSE-ARG1.
002350 MOVE ZERO TO
002360 DCRPS-CLOSE-FLAGS IN DCRPS-CLOSE-ARG1.
002370 MOVE DCCLS-CLTIN-CLTID IN DCCLS-CLTIN-ARG TO
002380 DCRPS-CLOSE-CLTID IN DCRPS-CLOSE-ARG1.
002390 *
002400 * *******************************
002410 CALL 'CBLDCRPS' USING DCRPS-CLOSE-ARG1.
002420 * *******************************
002430 PROG-EXIT.
002440 MOVE 'CLTOUT ' TO
002450 DCCLS-CLTOUT-REQUEST IN DCCLS-CLTOUT-ARG.
002460 MOVE ZERO TO
002470 DCCLS-CLTOUT-FLAGS IN DCCLS-CLTOUT-ARG.
002480 MOVE DCCLS-CLTIN-CLTID IN DCCLS-CLTIN-ARG TO
002490 DCCLS-CLTOUT-CLTID IN DCCLS-CLTOUT-ARG.
002500 *
002510 * *******************************
002520 CALL 'CBLDCCLS' USING DCCLS-CLTOUT-ARG.
002530 * *******************************
002540 STOP RUN.
002550 *
002560 MAIN-EXIT SECTION.
002570 EXIT.