IDENTIFICATION DIVISION.
*-----------------------
PROGRAM-ID. SYIXSAM2.
****** SYIXSAM2 - RPC REQUEST APPLICATION - COBOL2 - IMS ********
*
* TRANID: SYIXSAM2
* PROGRAM: SYIXSAM2
* PLAN NAME: N/A
* FILES: N/A
* TABLES: N/A
*
* This program is an example of a long-running transaction.
* It may also be used to stress test IMS Open Server. The
* program is executed via isql. The first parameter is
* a one byte character that is used to set up a reply
* row. The second parameter is the number of rows to
* return to the client.
*
* To execute from isql type:
*
* >isql -Usa -Sservername
*
* >exec SYIXSAM2 X, 100
*
* >go
*
* To end SYIXSAM2 type:
*
* >exec SYIXSAM2 X,0
*
* >go
*
* The SYIXSAM2 tran returns a 80 byte row containing the name
* client that initiated the RPC and a 71 byte pattern.
*
* Server Library calls:
*
* TDACCEPT accept request from client
* TDESCRIB describe a column
* TDFREE free TDPROC structure
* TDGETREQ get next set of parms
* TDINIT establish environment
* TDRCVPRM retrieve rpc parameter from client
* TDSNDDON send results-completion to client
* TDSNDMSG send message to client
* TDSNDROW send row to client
* TDSTATUS get status information
* TDSETPT pass type of program to gwlib
* TDTERM clean up control blocks
* CHANGE ACTIVITY:
* 9/93 - created for IMS MSP
**************************************************************
ENVIRONMENT DIVISION.
DATA DIVISION.
**************************************************************
WORKING-STORAGE SECTION.
**************************************************************
*-------------------------------------------------------------
* SERVER LIBRARY COBOL COPY BOOK
*-------------------------------------------------------------
COPY SYGWCOB.
*-------------------------------------------------------------
* WORK AREAS
*-------------------------------------------------------------
01 GW-LIB-MISC-FIELDS.
05 GWL-SPA-PTR POINTER.
05 GWL-PROC POINTER.
05 GWL-INIT-HANDLE POINTER.
05 GWL-RC PIC S9(9) COMP VALUE +0.
05 GWL-REQ-TYPE PIC S9(9) COMP VALUE +0.
05 GWL-WAIT-OPTION PIC S9(9) COMP VALUE +0.
05 GWL-STATUS-NR PIC S9(9) COMP VALUE +0.
05 GWL-STATUS-DONE PIC S9(9) COMP VALUE +0.
05 GWL-STATUS-COUNT PIC S9(9) COMP VALUE +0.
05 GWL-STATUS-COMM PIC S9(9) COMP VALUE +0.
05 GWL-STATUS-RETURN-CODE PIC S9(9) COMP VALUE +0.
05 GWL-STATUS-SUBCODE PIC S9(9) COMP VALUE +0.
05 GWL-PROG-TYPE PIC X(04) VALUE ‘MPP ‘.
05 GWL-TRAN-NAME PIC X(30) VALUE SPACES.
01 CPIC-RC PIC S9(9) COMP VALUE +0.
01 PARM-FIELDS.
05 PARM-L PIC S9(9) COMP VALUE +0.
05 PARM-ID1 PIC S9(9) COMP VALUE 1.
05 PARM-ID2 PIC S9(9) COMP VALUE 2.
05 PARM-PATTERN PIC X(1).
05 PARM-NR-ROWS PIC S9(9) COMP.
01 SNA-FIELDS.
05 SNA-SUBC PIC S9(9) COMP VALUE +0.
05 SNA-CONNECTION-NAME PIC X(8) VALUE SPACES.
01 COLUMN-NAME-FIELDS.
05 BANANA PIC X(06) VALUE ‘BANANA’.
01 DESCRIBE-BIND-FIELDS.
05 DB-HOST-TYPE PIC S9(9) COMP VALUE +0.
05 DB-CLIENT-TYPE PIC S9(9) COMP VALUE +0.
05 DB-NULL-INDICATOR PIC S9(4) COMP VALUE 0.
01 COUNTER-FIELDS.
05 CTR-COLUMN PIC S9(9) COMP VALUE 1.
05 CTR-ROWS PIC S9(9) COMP VALUE 0.
01 WROW.
05 WROW-LU PIC X(09).
05 WROW-PATTERN OCCURS 71 TIMES PIC X(01).
01 WORK-FIELDS.
05 WRKLEN1 PIC S9(9) COMP VALUE +0.
05 WRKLEN2 PIC S9(9) COMP VALUE +0.
05 WRK-DONE-STATUS PIC S9(9) COMP VALUE +0.
05 I PIC S9(9) COMP VALUE +0.
01 MESSAGE-FIELDS.
05 MSG-TYPE PIC S9(9) COMP VALUE +0.
05 MSG-SEVERITY PIC S9(9) COMP VALUE 11.
05 MSG-NR PIC S9(9) COMP VALUE 2.
05 MSG-RPC PIC X(8) VALUE ‘SYIXSAM2’.
05 MSG-RPC-L PIC S9(9) COMP VALUE +0.
05 MSG-TEXT PIC X(100).
05 MSG-TEXT-L PIC S9(9) COMP VALUE +0.
01 CANCEL-RECV-MSG.
05 FILLER PIC X(40) VALUE ‘CANCEL RECEIVED’.
01 CALL-ERROR-MESSAGE.
05 FILLER PIC X(5) VALUE SPACES.
05 CALL-PROG PIC X(10) VALUE ‘SYIXSAM2’.
05 FILLER PIC X(5) VALUE SPACES.
05 CALL-ERROR PIC X(10) VALUE SPACES.
05 FILLER PIC X(5) VALUE ‘ RC= ‘.
05 CALL-ERROR-RC PIC -9999.
01 SWITCHES.
05 ALL-DONE-SW PIC X VALUE ‘N’.
88 NOT-ALL-DONE VALUE ‘N’.
88 ALL-DONE VALUE ‘Y’.
05 SEND-DONE-SW PIC X VALUE ‘Y’.
88 SEND-DONE-ERROR VALUE ‘N’.
88 SEND-DONE-OK VALUE ‘Y’.
01 APSB PIC X(04) VALUE ‘APSB’.
01 DPSB PIC X(04) VALUE ‘DPSB’.
01 AIB.
05 AIBID PIC X(08).
05 AIBLEN PIC S9(9) COMP.
05 AIBSFUNC PIC X(08).
05 AIBRSNM1 PIC X(08).
05 FILLER PIC X(16).
05 AIBOALEN PIC S9(9) COMP.
05 AIBOAUSE PIC S9(9) COMP.
05 FILLER PIC X(12).
05 AIBRETRN PIC S9(9) COMP.
05 AIBREASN PIC S9(9) COMP.
05 FILLER PIC X(04).
05 AIBRSA1 PIC S9(9) COMP.
05 FILLER REDEFINES AIBRSA1.
10 AIBPTR POINTER.
05 FILLER PIC X(44).
LINKAGE SECTION.
01 PCB-ADDRESSES.
05 PCB-ADDRESS-LIST USAGE IS POINTER OCCURS 3 TIMES.
01 IO-PCB.
05 LTERM-NAME PIC X(8).
05 TERM-RESERVE PIC XX.
05 TERM-STATSUS PIC XX.
05 TERM-PREFIX.
15 FILLER PIC X.
15 JULIAN-DATE PIC S9(5) COMP-3.
15 TIME-O-DAY PIC S9(7) COMP-3.
15 FILLER PIC XXXX.
05 MODNAME PIC X(08).
**************************************************************
PROCEDURE DIVISION.
**************************************************************
*---------------------------------------------+---------------
INITIALIZE-PROGRAM.
*-------------------------------------------------------------
PERFORM ALLOC-AIB.
* -----------------------------------------------------------
* Establish Open Server environment
* ------------------------------------------------------------
CALL ‘TDINIT’ USING IO-PCB, GWL-RC, GWL-INIT-HANDLE.
IF GWL-RC NOT EQUAL TO ZEROES THEN
MOVE ‘TDINIT’ TO CALL-ERROR
PERFORM DISPLAY-CALL-ERROR
END-IF.
* ---------------------------------------------------------
* Set program type
* ---------------------------------------------------------
MOVE ‘EXPL’ to GWL-PROG-TYPE.
CALL ‘TDSETPT’ USING GWL-INIT-HANDLE, GWL-RC, GWL-PROG-TYPE
GWL-SPA-PTR, TDS-NULL, TDS-NULL.
IF GWL-RC NOT EQUAL TO ZEROES THEN
MOVE ‘TDSETPT’ TO CALL-ERROR
PERFORM DISPLAY-CALL-ERROR
END-IF.
* ---------------------------------------------------------
* accept client request
* ---------------------------------------------------------
CALL ‘TDACCEPT’ USING GWL-PROC, GWL-RC, GWL-INIT-HANDLE,
SNA-CONNECTION-NAME, SNA-SUBC.
IF GWL-RC NOT EQUAL TO ZEROES THEN
MOVE ‘TDACCEPT’ TO CALL-ERROR
PERFORM DISPLAY-CALL-ERROR
END-IF.
PERFORM READ-IN-USER-PARMS THRU READ-IN-EXIT
UNTIL (GWL-RC NOT EQUAL TO ZEROES).
GOBACK.
* ------------------------------------------------------------
READ-IN-USER-PARMS.
*-------------------------------------------------------------
* INITIALIZATION
*-------------------------------------------------------------
MOVE ‘Y’ TO SEND-DONE-SW.
MOVE ‘N’ TO ALL-DONE-SW.
MOVE SPACES TO CALL-ERROR.
MOVE ZEROES TO CALL-ERROR-RC CTR-ROWS.
MOVE 1 TO CTR-COLUMN.
*-------------------------------------------------------------
* GET PARM 1 - CHARACTER TO USE IN PATTERN
*-------------------------------------------------------------
MOVE LENGTH OF PARM-PATTERN TO WRKLEN1.
CALL ‘TDRCVPRM’ USING GWL-PROC, GWL-RC,
PARM-ID1,
PARM-PATTERN,
TDSCHAR,
WRKLEN1,
PARM-L.
IF GWL-RC NOT EQUAL TO ZEROES THEN
MOVE ‘TDRCVPRM-1’ TO CALL-ERROR
PERFORM DISPLAY-CALL-ERROR
END-IF.
MOVE BANANA TO WROW-LU.
PERFORM SET-UP-ROW-PATTERN
VARYING I FROM 1 BY 1
UNTIL I > 71.
*-------------------------------------------------------------
* GET PARM 2 - NUMBER OF ROWS TO SEND TO CLIENT
*-------------------------------------------------------------
MOVE LENGTH OF PARM-NR-ROWS TO WRKLEN1.
CALL ‘TDRCVPRM’ USING GWL-PROC, GWL-RC,
PARM-ID2,
PARM-NR-ROWS,
TDSINT4,
WRKLEN1,
PARM-L.
IF GWL-RC NOT EQUAL TO ZEROES THEN
MOVE ‘TDRCVPRM-2’ TO CALL-ERROR
PERFORM DISPLAY-CALL-ERROR
END-IF.
IF PARM-NR-ROWS = ZEROES THEN
GO TO SEND-DONE.
*-------------------------------------------------------------
* SETUP REPLY
*-------------------------------------------------------------
MOVE TDSCHAR TO DB-HOST-TYPE.
MOVE TDSCHAR TO DB-CLIENT-TYPE.
MOVE LENGTH OF WROW TO WRKLEN1.
MOVE LENGTH OF BANANA TO WRKLEN2.
CALL ‘TDESCRIB’ USING GWL-PROC, GWL-RC,
CTR-COLUMN,
DB-HOST-TYPE,
WRKLEN1,
WROW,
DB-NULL-INDICATOR,
TDS-FALSE,
DB-CLIENT-TYPE,
WRKLEN1,
BANANA,
WRKLEN2.
IF GWL-RC NOT EQUAL TO ZEROES THEN
MOVE ‘TDESCRIB’ TO CALL-ERROR
PERFORM DISPLAY-CALL-ERROR
END-IF.
*-------------------------------------------------------------
* SEND ROWS TO CLIENT
*-------------------------------------------------------------
MOVE ZEROES TO CTR-ROWS.
IF PARM-NR-ROWS = ZEROES THEN
MOVE ‘Y’ TO ALL-DONE-SW
ELSE
PERFORM SEND-ROWS
UNTIL ALL-DONE OR CTR-ROWS >= PARM-NR-ROWS.
IF SEND-DONE-OK
MOVE TDS-DONE-COUNT TO WRK-DONE-STATUS
ELSE
MOVE TDS-DONE-ERROR TO WRK-DONE-STATUS
MOVE ZERO TO CTR-ROWS
END-IF.
SEND-DONE.
IF PARM-NR-ROWS = ZEROES THEN
MOVE TDS-ENDRPC TO GWL-SEND-DONE
ELSE
MOVE TDS-ENDREPLY TO GWL-SEND-DONE.
*-------------------------------------------------------------
* ISSUE SEND DONE TO CLIENT
*-------------------------------------------------------------
CALL ‘TDSNDDON’ USING GWL-PROC, GWL-RC,
WRK-DONE-STATUS,
CTR-ROWS,
TDS-ZERO,
GWL-SEND-DONE.
IF GWL-RC NOT EQUAL TO ZEROES THEN
MOVE ‘TDSNDDON’ TO CALL-ERROR
PERFORM DISPLAY-CALL-ERROR
END-IF.
IF PARM-NR-ROWS = ZEROES THEN
PERFORM FREE-ALL-STORAGE
GOBACK.
* ----------------------------------------------------------
* GET NEXT CLIENT REQUEST
* ----------------------------------------------------------
MOVE TDS-TRUE TO GWL-WAIT-OPTION.
MOVE ZEROES TO GWL-REQ-TYPE.
MOVE SPACES TO GWL-TRAN-NAME.
CALL ‘TDGETREQ’ USING GWL-PROC, GWL-RC, GWL-WAIT-OPTION,
GWL-REQ-TYPE, GWL-TRAN-NAME.
EVALUATE GWL-RC
WHEN ZEROES
GO TO READ-IN-USER-PARMS
WHEN TDS-RESULTS-COMPLETE
PERFORM FREE-ALL-STORAGE
WHEN TDS-CONNECTION-TERMINATED
PERFORM FREE-ALL-STORAGE
WHEN TDS-CONNECTION-FAILED
PERFORM FREE-ALL-STORAGE
WHEN OTHER
MOVE ‘TDGETREQ’ TO CALL-ERROR
PERFORM DISPLAY-CALL-ERROR
END-EVALUATE.
GOBACK.
READ-IN-EXIT.
EXIT.
SET-UP-ROW-PATTERN.
MOVE PARM-PATTERN TO WROW-PATTERN (I).
SET-UP-ROW-PATTERN-EXIT.
EXIT.
*-------------------------------------------------------------
SEND-ROWS.
*-------------------------------------------------------------
CALL ‘TDSNDROW’ USING GWL-PROC, GWL-RC
EVALUATE GWL-RC
WHEN ZEROES
ADD 1 TO CTR-ROWS
WHEN TDS-CANCEL-RECEIVED
MOVE ‘Y’ TO ALL-DONE-SW
MOVE CANCEL-RECV-MSG to MSG-TEXT
MOVE LENGTH OF CANCEL-RECV-MSG TO MSG-TEXT-L
PERFORM SEND-MESSAGE
WHEN OTHER
PERFORM DISPLAY-CALL-ERROR
MOVE ‘Y’ TO SEND-DONE-SW
MOVE ‘Y’ TO ALL-DONE-SW
END-EVALUATE.
SEND-ROWS-EXIT.
EXIT.
*-------------------------------------------------------------
DISPLAY-CALL-ERROR.
*-------------------------------------------------------------
MOVE GWL-RC TO CALL-ERROR-RC.
MOVE CALL-ERROR-MESSAGE TO MSG-TEXT.
MOVE LENGTH OF CALL-ERROR-MESSAGE TO MSG-TEXT-L.
PERFORM SEND-MESSAGE.
DISPLAY CALL-ERROR-MESSAGE.
PERFORM FREE-ALL-STORAGE.
GOBACK.
DISPLAY-CALL-ERROR-EXIT.
EXIT.
*-------------------------------------------------------------
FREE-ALL-STORAGE.
*-------------------------------------------------------------
CALL ‘TDFREE’ USING GWL-PROC, GWL-RC
IF GWL-RC NOT EQUAL TO ZEROES THEN
MOVE GWL-RC TO CALL-ERROR-RC
MOVE ‘TDFREE’ TO CALL-ERROR
DISPLAY CALL-ERROR-MESSAGE
END-IF.
CALL ‘TDTERM’ USING GWL-INIT-HANDLE, GWL-RC.
IF GWL-RC NOT EQUAL TO ZEROES THEN
MOVE GWL-RC TO CALL-ERROR-RC
MOVE ‘TDTERM’ TO CALL-ERROR
DISPLAY CALL-ERROR-MESSAGE
END-IF.
PERFORM DEALLOC-AIB.
FREE-ALL-STORAGE-EXIT.
EXIT.
*-----------------------------------------------------------------
SEND-ERROR-MESSAGE.
*-----------------------------------------------------------------
MOVE 'N' TO SEND-DONE-SW.
MOVE TDS-ERROR-MSG TO MSG-TYPE.
MOVE LENGTH OF MSG-RPC TO MSG-RPC-L.
* Ensure we're in right state to send a message
CALL 'TDSTATUS' USING GWL-PROC, GWL-RC,
GWL-STATUS-NR,
GWL-STATUS-DONE,
GWL-STATUS-COUNT,
GWL-STATUS-COMM,
GWL-STATUS-RETURN-CODE,
GWL-STATUS-SUBCODE.
IF (GWL-RC = TDS-OK AND
GWL-STATUS-COMM = TDS-RECEIVE) THEN
CALL 'TDSNDMSG' USING GWL-PROC, GWL-RC,
MSG-TYPE, MSG-NR,
MSG-SEVERITY,
TDS-ZERO,
TDS-ZERO,
MSG-RPC, MSG-RPC-L,
MSG-TEXT, MSG-TEXT-L
END-IF.
SEND-MESSAGE-EXIT.
EXIT.
ALLOC-AIB.
* ---------------------------------------------------------
* Allocate AIB
* ---------------------------------------------------------
MOVE ‘DFSAIB ‘ TO AIBID.
MOVE ‘SYICSAM2’ TO AIBRSNM1.
MOVE 128 TO AIBLEN.
CALL ‘AIBTDLI’ USING APSB AIB.
IF AIBRETRN IS EQUAL TO ZEROES THEN
SET ADDRESS OF PCB-ADDRESSES TO AIBPTR
SET ADDRESS OF IO-PCB TO PCB-ADDRESS-LIST (1)
ELSE
DISPLAY ‘SYIXSAM2 - APSB CALL FAILED RC= ‘ AIBRETRN
DISPLAY ‘SYIXSAM2 - APSB CALL FAILED REASON= ‘ AIBREASN
GOBACK.
ALLOC-AIB-EXIT.
EXIT.
DEALLOC-AIB.
* ---------------------------------------------------------
* ISSUE SRRCMIT CALL
* ---------------------------------------------------------
CALL ‘SRRCMIT’ USING CPIC-RC.
IF CPIC-RC IS NOT EQUAL TO ZEROES THEN
DISPLAY ‘SYIXSAM2 SRRCMIT CALL FAILED CPIC-RC=’ CPIC-RC.
* ---------------------------------------------------------
* Deallocate AIB
* ---------------------------------------------------------
CALL ‘AIBTDLI’ USING DPSB AIB.
IF AIBRETRN IS NOT EQUAL TO ZEROES THEN
DISPLAY ‘SYIXSAM2 - DPSB CALL FAILED RC= ‘ AIBRETRN
DISPLAY ‘SYIXSAM2 - DPSB CALL FAILED REASON= ‘ AIBREASN.
DEALLOC-AIB-EXIT.
EXIT.
