OpenTP1 Version 7 TP1/Client User's Guide TP1/Client/W, TP1/Client/P

[Contents][Index][Back][Next]

5.4.1 Creating CUPs and SPPs

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.