OpenTP1 Version 7 TP1/Client User's Guide TP1/Client/W, TP1/Client/P
Subsection 3.3.1 provides the configuration for CUP and SPP. The following shows how to create this CUP in COBOL.
000010 * 000020 ************************************************** 000030 * CUP sample program * 000040 ************************************************** 000050 * 000060 IDENTIFICATION DIVISION. 000070 PROGRAM-ID. CUP01. 000080 * 000090 ************************************************** 000100 * Set the data area * 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 * Start CUP * 000850 ************************************************** 000860 PROCEDURE DIVISION. 000870 MAIN SECTION. 000880 PROG-START. 000890 * 000900 ************************************************** 000910 * Request client user authentication * 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) failed. CODE=' 001080 DCCLS-CLTIN-STATUS-CODE IN DCCLS-CLTIN-ARG 001090 GO TO PROG-EXIT 001100 END-IF. 001110 * 001120 ************************************************** 001130 * RPC-OPEN(initialize RPC environment) * 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) failed. 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 '****** BBS Menu ******' 001360 DISPLAY 'Read Message .... [1]' 001370 'Send Message .... [2]' 001380 DISPLAY 'End ............. [9]' 001390 DISPLAY 'Enter a number =>' 001400 ACCEPT INDATA 001410 EVALUATE INDATA 001420 WHEN '1' 001430 * 001440 * ********************************************* 001450 * * RPC-CALL(execute 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) failed. CODE=' 001740 DCRPS-CALL-STATUS-CODE IN DCRPS-CALL-ARG1 001750 GO TO PROG-END 001760 END-IF 001770 DISPLAY 'BBS Contents: ' DCRPS-CALL-OUTDATA 001780 IN DCRPS-CALL-ARG3 001790 WHEN '2' 001800 DISPLAY 'Enter your message =>' 001810 ACCEPT INDATA 001820 IF INDATA = SPACE 001830 THEN 001840 MOVE 'No message' TO INDATA 001850 END-IF 001860 * 001870 * ********************************************* 001880 * * RPC-CALL(execute 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) failed. 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(reset RPC environment) * 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.
All Rights Reserved. Copyright (C) 2006, 2009, Hitachi, Ltd.