IDENTIFICATION DIVISION.
*-----------------------
PROGRAM-ID. SYICSAD2.
****** SYICSAD2 - RPC REQUEST APPLICATION - COBOL2 - IMS *******
*
* TRANID: SYD2
* PROGRAM: SYICSAD2
* PLAN NAME: SYICSAD2
* FILES: n/a
* TABLES: SYBASE.SAMPLETB
*
* This program is executed via a client RPC request from sample
* dblib program ‘SYD2’ or from isql. The program expects one sample
* character parm which is equal to a department number in the DB2
* table SYBASE.SAMPLETB. The program then selects and returns all
* rows with that department number.
*
* To execute from iqsl type:
*
* >isql -Usa -Sservername
*
* >exec SYD2 ‘D11’
*
* >go
*
* NOTE: Add SYD2 using isql as follows:
*
* exec sgw_addrpc SYD2,SYD2,IMSLU62,none
*
* where IMSLU62 is the APPC name of your IMS region.
*
* 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
*
*-------------------------------------------------------------*
ENVIRONMENT DIVISION.
DATA DIVISION.
************************************************************
WORKING-STORAGE SECTION.
************************************************************
*-----------------------------------------------------------
* DB2 SQLCA
*-----------------------------------------------------------
EXEC SQL INCLUDE SQLCA END-EXEC.
*-----------------------------------------------------------
* 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.
05 GWL-REQ-TYPE PIC S9(9) COMP VALUE +0.
05 GWL-WAIT-OPTION PIC S9(9) COMP.
05 GWL-STATUS-NR PIC S9(9) COMP.
05 GWL-STATUS-DONE PIC S9(9) COMP.
05 GWL-STATUS-COUNT PIC S9(9) COMP.
05 GWL-STATUS-COMM PIC S9(9) COMP.
05 GWL-STATUS-RETURN-CODE PIC S9(9) COMP.
05 GWL-STATUS-SUBCODE PIC S9(9) COMP.
05 GWL-PROG-TYPE PIC X(04) VALUE ‘MPP ‘.
05 GWL-RPC-NAME PIC X(30) VALUE SPACES.
01 PARM-FIELDS.
05 PARM-L PIC S9(9) COMP.
05 PARM-ID1 PIC S9(9) COMP VALUE 1.
05 PARM-DEPT PIC X(3).
01 SNA-FIELDS.
05 SNA-SUBC PIC S9(9) COMP
05 SNA-CONNECTION-NAME PIC X(8) VALUE SPACES.
01 EMPLOYEE-FIELDS.
05 EMPLOYEE-LNM.
49 EMPLOYEE-LNM-LEN PIC S9(4) COMP.
49 EMPLOYEE-LNM-TEXT PIC X(15).
05 EMPLOYEE-DEPT PIC X(3).
05 EMPLOYEE-PH PIC X(4).
05 EMPLOYEE-SALARY PIC S9(6)V9(2) COMP-3.
01 COLUMN-NAME-FIELDS.
05 CN-LNM PIC X(10) VALUE ‘LAST_NAME ‘.
05 CN-DEPT PIC X(8) VALUE ‘EMP_DEPT’.
05 CN-PH PIC X(9) VALUE ‘EMP_PHONE’.
05 CN-SALARY PIC X(6) VALUE ‘SALARY’.
01 DESCRIBE-BIND-FIELDS.
05 DB-HOST-TYPE PIC S9(9) COMP.
05 DB-CLIENT-TYPE PIC S9(9) COMP.
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 WORK-FIELDS.
05 WRKLEN1 PIC S9(9) COMP.
05 WRKLEN2 PIC S9(9) COMP.
05 WRK-DONE-STATUS PIC S9(9) COMP.
01 MESSAGE-FIELDS.
05 MSG-TYPE PIC S9(9) COMP.
05 MSG-SEVERITY PIC S9(9) COMP VALUE 11.
05 MSG-NR PIC S9(9) COMP VALUE 2.
05 MSG-RPC PIC X(4) VALUE ‘SYD2’.
05 MSG-RPC-L PIC S9(9) COMP.
05 MSG-TEXT PIC X(100).
05 MSG-TEXT-L PIC S9(9) COMP.
05 MSG-BAD-CURSOR PIC X(27)
VALUE ‘ERROR - can not open cursor’.
05 MSG-BAD-FETCH PIC X(24)
VALUE ‘ERROR - fetch row failed’.
05 MSG-SQL-ERROR.
10 FILLER PIC X(10) VALUE ‘Sqlcode = ‘.
10 MSG-SQL-ERROR-C PIC -9(3) DISPLAY.
10 FILLER PIC X(16)
VALUE ‘, Error Tokens: ‘.
10 MSG-SQL-ERROR-K PIC X(70).
10 MSG-SQL-ERROR-K-CHARS
REDEFINES MSG-SQL-ERROR-K
OCCURS 70 TIMES
PIC X.
05 MSG-SQL-ERROR-SS PIC S9(4) COMP.
01 CALL-ERROR-MESSAGE.
05 FILLER PIC X(5) VALUE SPACES.
05 CALL-PROG PIC X(10) VALUE ‘SYICSAD2’.
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 -ZZZZ.
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’.
*---------------------------------------------------------------
* DECLARE CURSOR
*---------------------------------------------------------------
EXEC SQL
DECLARE ECURSOR CURSOR
FOR SELECT LASTNAME,
WORKDEPT, PHONENO, SALARY
FROM SYBASE.SAMPLETB
WHERE WORKDEPT = :PARM-DEPT
END-EXEC.
LINKAGE SECTION.
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.
****************************************************************
ENTRY ‘DLITCBL’ USING IO-PCB.
*---------------------------------------------------------------
INITIALIZE-PROGRAM.
*---------------------------------------------------------------
SET GWL-SPA-PTR TO NULL.
* -----------------------------------------------------------
* reset db2 error handlers
* -----------------------------------------------------------
EXEC SQL WHENEVER SQLWARNING CONTINUE END-EXEC.
EXEC SQL WHENEVER SQLERROR CONTINUE END-EXEC.
EXEC SQL WHENEVER NOT FOUND CONTINUE END-EXEC.
* -----------------------------------------------------------
* establish gateway 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
* -----------------------------------------------------------
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.
*---------------------------------------------------------------
READ-IN-USER-PARM.
*---------------------------------------------------------------
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.
MOVE LENGTH OF PARM-DEPT TO WRKLEN1.
CALL ‘TDRCVPRM’ USING GWL-PROC, GWL-RC,
PARM-ID1,
PARM-DEPT,
TDSCHAR,
WRKLEN1,
PARM-L.
IF GWL-RC NOT EQUAL TO ZEROES THEN
MOVE ‘TDRCVPRM’ TO CALL-ERROR
PERFORM DISPLAY-CALL-ERROR
END-IF.
*---------------------------------------------------------------
OPEN-DB2-CURSOR.
*---------------------------------------------------------------
EXEC SQL OPEN ECURSOR END-EXEC.
IF SQLCODE NOT = 0
DISPLAY ‘SQLCODE = ‘ SQLCODE
PERFORM OPEN-ERROR
GO TO FINISH-REPLY
END-IF.
*---------------------------------------------------------------
SETUP-REPLY-COLUMNS.
*---------------------------------------------------------------
MOVE TDSVARYCHAR TO DB-HOST-TYPE.
MOVE TDSCHAR TO DB-CLIENT-TYPE.
MOVE LENGTH OF EMPLOYEE-LNM-TEXT TO WRKLEN1.
MOVE LENGTH OF CN-LNM TO WRKLEN2.
CALL ‘TDESCRIB’ USING GWL-PROC, GWL-RC,
CTR-COLUMN,
DB-HOST-TYPE,
WRKLEN1,
EMPLOYEE-LNM,
DB-NULL-INDICATOR,
TDS-FALSE,
DB-CLIENT-TYPE,
WRKLEN1,
CN-LNM,
WRKLEN2.
IF GWL-RC NOT EQUAL TO ZEROES THEN
MOVE ‘TDESCRIB’ TO CALL-ERROR
PERFORM DISPLAY-CALL-ERROR
END-IF.
ADD 1 TO CTR-COLUMN.
MOVE TDSCHAR TO DB-HOST-TYPE.
MOVE TDSCHAR TO DB-CLIENT-TYPE.
MOVE LENGTH OF EMPLOYEE-DEPT TO WRKLEN1.
MOVE LENGTH OF CN-DEPT TO WRKLEN2.
CALL ‘TDESCRIB’ USING GWL-PROC, GWL-RC,
CTR-COLUMN,
DB-HOST-TYPE,
WRKLEN1,
EMPLOYEE-DEPT,
DB-NULL-INDICATOR,
TDS-FALSE,
DB-CLIENT-TYPE,
WRKLEN1, CN-DEPT,WRKLEN2.
IF GWL-RC NOT EQUAL TO ZEROES THEN
MOVE ‘TDESCRIB’ TO CALL-ERROR
PERFORM DISPLAY-CALL-ERROR
END-IF.
ADD 1 TO CTR-COLUMN.
MOVE LENGTH OF EMPLOYEE-PH TO WRKLEN1.
MOVE LENGTH OF CN-PH TO WRKLEN2.
CALL ‘TDESCRIB’ USING GWL-PROC, GWL-RC,
CTR-COLUMN,
DB-HOST-TYPE,
WRKLEN1,
EMPLOYEE-PH,
DB-NULL-INDICATOR,
TDS-FALSE,
DB-CLIENT-TYPE,
WRKLEN1, CN-PH, WRKLEN2.
IF GWL-RC NOT EQUAL TO ZEROES THEN
MOVE ‘TDESCRIB’ TO CALL-ERROR
PERFORM DISPLAY-CALL-ERROR
END-IF.
* -----------------------------------------------------------
* Here we let TDESCRIB convert from TDSDECIMAL to TDSMONEY.
* Note we’re taking the default scaling (2) for TDSDECIMAL
* input, though we could override with TDSETBCD if necessary.
* -----------------------------------------------------------
ADD 1 TO CTR-COLUMN.
MOVE LENGTH OF EMPLOYEE-SALARY TO WRKLEN1.
MOVE LENGTH OF CN-SALARY TO WRKLEN2.
CALL ‘TDESCRIB’ USING GWL-PROC, GWL-RC, CTR-COLUMN,
TDSDECIMAL,
WRKLEN1,
EMPLOYEE-SALARY,
DB-NULL-INDICATOR,
TDS-FALSE,
TDSMONEY,
TDS-DEFAULT-LENGTH,
CN-SALARY, WRKLEN2.
IF GWL-RC NOT EQUAL TO ZEROES THEN
MOVE ‘TDESCRIB’ TO CALL-ERROR
PERFORM DISPLAY-CALL-ERROR
END-IF.
*---------------------------------------------------------------
SEND-ROWS.
*---------------------------------------------------------------
PERFORM FETCH-AND-SEND-ROWS
UNTIL ALL-DONE.
FINISH-REPLY.
*----------------------------------------------------------
* close cursor
*----------------------------------------------------------
EXEC SQL CLOSE ECURSOR END-EXEC.
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.
CALL ‘TDSNDDON’ USING GWL-PROC, GWL-RC,
WRK-DONE-STATUS, CTR-ROWS, TDS-ZERO, TDS-ENDRPC.
IF GWL-RC NOT EQUAL TO ZEROES THEN
MOVE ‘TDSNDDON’ TO CALL-ERROR
PERFORM DISPLAY-CALL-ERROR
END-IF.
* -----------------------------------------------------------
* Get next client request
* -----------------------------------------------------------
MOVE TDS-TRUE TO GWL-WAIT-OPTION.
MOVE ZEROES TO GWL-REQ-TYPE.
MOVE SPACES TO GWL-RPC-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-PARM
WHEN TDS-RESULTS-COMPLETE
PERFORM FREE-ALL-STORAGE
WHEN TDS-CONNECTION-TERMINATED
PERFORM FREE-ALL-STORAGE
WHEN OTHER
MOVE ‘TDGETREQ’ TO CALL-ERROR
PERFORM DISPLAY-CALL-ERROR
END-EVALUATE.
GOBACK.
*---------------------------------------------------------------
FETCH-AND-SEND-ROWS.
*---------------------------------------------------------------
EXEC SQL FETCH ECURSOR INTO :EMPLOYEE-FIELDS
END-EXEC.
IF SQLCODE = 0 THEN
* ------------------------------------------------------
* send a row to the client
* ------------------------------------------------------
CALL ‘TDSNDROW’ USING GWL-PROC, GWL-RC
ADD 1 TO CTR-ROWS
IF GWL-RC = TDS-CANCEL-RECEIVED THEN
MOVE ‘Y’ TO ALL-DONE-SW
ELSE
IF GWL-RC NOT EQUAL TO ZEROES THEN
PERFORM DISPLAY-CALL-ERROR
MOVE ‘Y’ TO ALL-DONE-SW
END-IF
ELSE IF SQLCODE = +100 THEN
MOVE ‘Y’ TO ALL-DONE-SW
ELSE IF SQLCODE < 0 THEN
MOVE ‘Y’ TO ALL-DONE-SW
PERFORM FETCH-ERROR
END-IF.
*---------------------------------------------------------------
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.
*---------------------------------------------------------------
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.
*---------------------------------------------------------------
OPEN-ERROR.
*---------------------------------------------------------------
MOVE MSG-BAD-CURSOR TO MSG-TEXT.
MOVE LENGTH OF MSG-BAD-CURSOR TO MSG-TEXT-L.
PERFORM SEND-ERROR-MESSAGE.
PERFORM SEND-SQL-ERROR.
*---------------------------------------------------------------
FETCH-ERROR.
*---------------------------------------------------------------
MOVE MSG-BAD-FETCH TO MSG-TEXT.
MOVE LENGTH OF MSG-BAD-FETCH TO MSG-TEXT-L.
PERFORM SEND-ERROR-MESSAGE.
PERFORM SEND-SQL-ERROR.
*---------------------------------------------------------------
SEND-SQL-ERROR.
*---------------------------------------------------------------
MOVE SQLCODE TO MSG-SQL-ERROR-C.
MOVE SQLERRMC TO MSG-SQL-ERROR-K.
* -----------------------------------------------------------
* ensure possible non-printables translated to spaces
* -----------------------------------------------------------
PERFORM VARYING MSG-SQL-ERROR-SS FROM 1 BY 1
UNTIL MSG-SQL-ERROR-SS > SQLERRML
IF MSG-SQL-ERROR-K-CHARS(MSG-SQL-ERROR-SS) < SPACE OR
MSG-SQL-ERROR-K-CHARS(MSG-SQL-ERROR-SS) > ‘9’ THEN
MOVE SPACE TO MSG-SQL-ERROR-K-CHARS(MSG-SQL-ERROR-SS)
END-IF
END-PERFORM.
MOVE MSG-SQL-ERROR TO MSG-TEXT.
MOVE LENGTH OF MSG-SQL-ERROR TO MSG-TEXT-L.
PERFORM SEND-ERROR-MESSAGE.
*-----------------------------------------------------------------
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.
