OpenTP1 Version 7 Programming Reference COBOL Language
This subsection shows a coding example for an SUP that uses the X/Open TX interface. This SUP uses TX-interfaced transaction control for processing that was described in 6.1 Coding samples for client/server UAPs (SUP, SPP DAM access). See 6.1 Coding samples for client/server UAPs (SUP, SPP DAM access) for the process configuration and details of the SPP to which the service request is addressed. However, TX-RETURN-STATUS at line numbers 460 and 470 are redefined as RS REDEFINES TX-RETURN-STATUS because it cannot be correctly referenced if it is directly invoked from the process.
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 TX-RETURN-STATUS. 470 COPY TXSTATUS. 480 * 490 01 RS REDEFINES TX-RETURN-STATUS. 500 05 RSVAL PIC S9(9) COMP-5. 510 * 520 01 TX-INFO-AREA. 530 COPY TXINFDEF. 540 * 550 PROCEDURE DIVISION. 560 * 570 *************************************************** 580 * RPC-OPEN (start the UAP) * 590 *************************************************** 600 * 610 MOVE 'OPEN' TO REQUEST OF RPC-ARG1. 620 MOVE ZERO TO FLAGS OF RPC-ARG1. 630 CALL 'CBLDCRPC' USING RPC-ARG1. 640 IF STATUS-CODE OF RPC-ARG1 NOT = '00000' THEN 650 DISPLAY 'SUP01:RPC-OPEN FAILED. CODE = ' 660 STATUS-CODE OF RPC-ARG1 670 GO TO PROG-END 680 END-IF. 690 * 700 *************************************************** 710 * TX-OPEN (open the resource manager) * 720 *************************************************** 730 * 740 CALL 'TXOPEN' USING TX-RETURN-STATUS. 750 IF RSVAL OF RS NOT = 0 THEN 760 DISPLAY 'SUP01:TX-OPEN FAILED. CODE = ' 770 RSVAL OF RS 780 GO TO PROG-END 790 END-IF. 800 * 810 *************************************************** 820 * TX-SET-TRANSACTION-TIMEOUT * * (set the transaction monitoring interval) * 830 *************************************************** 840 * 850 MOVE 180 TO TRANSACTION-TIMEOUT OF TX-INFO-AREA. 860 CALL 'TXSETTIMEOUT' USING TX-INFO-AREA TX-RETURN-STATUS. 870 IF RSVAL OF RS NOT = 0 THEN 880 DISPLAY 'SUP01:TX-SET-TRANSACTION-TIMEOUT FAILED. CODE = ' 890 RSVAL OF RS 900 GO TO PROG-END 910 END-IF. 920 * 930 *************************************************** 940 * ADM-COMPLETE (report completion of user * * server start processing) * 950 *************************************************** 960 * 970 MOVE 'COMPLETE' TO REQUEST OF ADM-ARG1. 980 CALL 'CBLDCADM' USING ADM-ARG1. 990 IF STATUS-CODE OF ADM-ARG1 NOT = '00000' THEN 1000 DISPLAY 'SUP01:ADM-COMPLETE FAILED. CODE = ' 1010 STATUS-CODE OF ADM-ARG1 1020 GO TO PROG-END 1030 END-IF. 1040 * 1050 *************************************************** 1060 * TX-BEGIN (start the transaction) * 1070 *************************************************** 1080 * 1090 CALL 'TXBEGIN' USING TX-RETURN-STATUS. 1100 IF RSVAL OF RS NOT = 0 THEN 1110 DISPLAY 'SUP01:TX-BEGIN FAILED. CODE = ' 1120 RSVAL OF RS 1130 GO TO TRAN-END 1140 END-IF. 1150 * 1160 *************************************************** 1170 * TX-INFO (acquire transaction information) * 1180 *************************************************** 1190 * 1200 CALL 'TXINFORM' USING TX-INFO-AREA TX-RETURN-STATUS. 1210 IF RSVAL OF RS <= 0 THEN 1220 DISPLAY 'SUP01:NOT IN TRANSACTION. CODE = ' 1230 RSVAL OF RS 1240 GO TO PROG-END 1250 ELSE 1260 IF RSVAL OF RS = 1 THEN 1270 DISPLAY 'SUP01:RETURN = ' COMMIT-RETURN 1280 DISPLAY 'SUP01:CONTROL = ' TRANSACTION-CONTROL 1290 DISPLAY 'SUP01:TIMEOUT = ' TRANSACTION-TIMEOUT 1300 DISPLAY 'SUP01:STATE = ' TRANSACTION-STATE 1310 END-IF 1320 END-IF. 1330 *************************************************** 1340 * RPC-CALL (request a remote service) * 1350 *************************************************** 1360 * 1370 MOVE 'CALL' TO REQUEST OF RPC-ARG2. 1380 MOVE 'SVR01' TO G-NAME OF RPC-ARG2. 1390 MOVE 'SVR01' TO S-NAME OF RPC-ARG2. 1400 MOVE 'SUP01:DATA OpenTP1' TO SEND-DATA OF RPC-ARG3. 1410 MOVE 32 TO SEND-DATA-LENG OF RPC-ARG3. 1420 MOVE 32 TO RECEIVE-DATA-LENG OF RPC-ARG4. 1430 CALL 'CBLDCRPC' USING RPC-ARG2 RPC-ARG3 RPC-ARG4. 1440 IF STATUS-CODE OF RPC-ARG2 NOT = '00000' THEN 1450 DISPLAY 'SUP01:RPC-CALL RETURN CODE = ' 1460 STATUS-CODE OF RPC-ARG2 1470 * GO TO TRAN-END 1480 END-IF. 1490 DISPLAY 'SERVICE FUNCTION RETURN = ' RECEIVE-DATA. 1500 TRAN-END. 1510 * 1520 *************************************************** 1530 * TX-SET-TRANSACTION-CONTROL (set the unchained * 1535 * mode) * 1540 *************************************************** 1550 * 1560 MOVE 0 TO TRANSACTION-CONTROL OF TX-INFO-AREA. 1570 CALL 'TXSETTRANCTL' USING TX-INFO-AREA TX-RETURN-STATUS. 1580 IF RSVAL OF RS NOT = 0 THEN 1590 DISPLAY 'SUP01:TX-SET-TRANSACTION-CONTROL FAILED. CODE = ' 1600 RSVAL OF RS 1610 END-IF. 1620 * 1630 *************************************************** 1640 * TX-COMMIT (commit in unchained mode) * 1650 *************************************************** 1660 * 1670 CALL 'TXCOMMIT' USING TX-RETURN-STATUS. 1680 IF RSVAL OF RS NOT = 0 THEN 1690 DISPLAY 'SUP01:TX-COMMIT FAILED. CODE = ' 1700 RSVAL OF RS 1710 END-IF. 1720 PROG-END. 1730 * 1740 *************************************************** 1750 * RPC-CLOSE (terminate the UAP) * 1760 *************************************************** 1770 * 1780 MOVE 'CLOSE' TO REQUEST OF RPC-ARG1. 1790 MOVE ZERO TO FLAGS OF RPC-ARG1. 1800 CALL 'CBLDCRPC' USING RPC-ARG1. 1810 DISPLAY 'SUP01:SUP PROCESS ENDED'. 1820 STOP RUN.
All Rights Reserved. Copyright (C) 2006, 2010, Hitachi, Ltd.