IDENTIFICATION DIVISION. PROGRAM-ID. CLIENTC2. ***************************************************************** * SAMPLE CSA PROGRAM TO ILLUSTRATE ESTABLISHING A * ConnectION TO A REMOTE SERVER, EXECUTING SQL REQUEST, * RETRIEVING THE RESULTS AND ANY MESSAGES (WRITING THEM TO A TEMP * STORAGE QUEUE STRICTLY FOR EXAMPLE), AND THEN DETACHING * FROM THE REMOTE SERVER. * *****************************************************************
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.
***************************************************************** * POINTERS. *****************************************************************
01 WS-POINTERS.
05 SPAREA-PTR POINTER.
05 SQLDA-PTR POINTER.
05 SQL-REQ-PTR POINTER.
***************************************************************** * COUNTERS AND VARIOUS INTEGERS. *****************************************************************
01 WS-VARIABLES.
05 CICSRC PIC S9(8) COMP VALUE +0.
05 RESCHECK-CNT PIC 9(03) VALUE ZEROES.
05 SPSTATUS-CNT PIC 9(03) VALUE ZEROES.
***************************************************************** * ATTACHMENT DEFINITION NAME. FOR SIMPLICITY OF EXAMPLE, * THIS PROGRAM ASSUMES THAT THE ATTACHMENT RECORD CONTAINS THE * USERID AND PASSWORD (OR ELSE THAT NONE ARE NEEDED). IN AN * ACTUAL PRODUCTION ENVIRONMENT, USERID, PASSWORD, OR BOTH COULD * BE SPECIFIED AT RUNTIME. *****************************************************************
01 ATTACH-NAME PIC X(32) VALUE 'SQLSERVE'.
***************************************************************** * SQL STATEMENT TO EXECUTE. WILL SELECT ALL ROWS FROM THE SQL * SERVER SAMPLE PUBS DATABASE TABLE "SALES." MULTIPLE SQL * REQUESTS CAN BE SENT IN ONE REQUEST BUFFER, AS LONG AS THEY ARE * SEPARATED BY SEMICOLONS. *****************************************************************
01 WS-SELECT-STMT.
05 SELECT-STMT PIC X(80)
VALUE 'SELECT * FROM pubs2.sales'.
***************************************************************** * FLAGS. *****************************************************************
01 WS-RESCHECK-DONE-SW PIC X(01) VALUE 'N'.
88 RESCHECK-DONE VALUE 'Y'.
88 RESCHECK-NOT-DONE VALUE 'N'.
88 LAST-SPSTATUS-SPACES VALUE ' '.
01 WS-SPAREA-INIT-SW PIC X(01) VALUE 'N'.
88 SPAREA-INIT-OK VALUE 'Y'.
88 SPAREA-INIT-BAD VALUE 'N'.
01 WS-ATTACH-TO-SERVER-SW PIC X(01) VALUE 'N'.
88 ATTACH-OK VALUE 'Y'.
88 ATTACH-FAILED VALUE 'N'.
***************************************************************** * ERROR MESSAGES. *****************************************************************
01 WS-STUB-ERROR-MSG.
03 FILLER PIC X(09)
VALUE 'CALL TO: '
03 WS-STUB-NAME PIC X(08) VALUE SPACES.
03 FILLER PIC X(18)
VALUE ' - RECEIVED SPRC: '
03 WS-STUB-SPRC PIC X(03) VALUE '000'.
03 FILLER PIC X(03) VALUE ' - '.
03 WS-STUB-SPMSG PIC X(100) VALUE SPACES.
01 WS-RESCHECK-MSG.
03 FILLER PIC X(33)
VALUE 'RESCHECK NON-BLANK STATUS - REC: '.
03 WS-RESCHECK-NUMBER PIC 9(03) VALUE ZEROES.
03 FILLER PIC X(16)
VALUE ' - SPSTATUS IS: '.
03 WS-SPSTATUS-OUT PIC X(02) VALUE SPACES.
03 FILLER PIC X(11)
VALUE ' - SPCODE: '.
03 WS-SPCODE-OUT PIC X(03) VALUE SPACES.
03 FILLER PIC X(10)
VALUE ' - SPIND: '.
03 WS-SPIND-OUT PIC X(01) VALUE SPACE.
***************************************************************** * FORMATTED SALES DATA RECORD TO BE WRITTEN TO TEMP STORAGE. *****************************************************************
01 SALES-ROW.
03 SALES-STOR-ID PIC X(04) VALUE SPACES.
03 FILLER PIC X(01) VALUE SPACE.
03 SALES-ORD-NUM PIC X(20) VALUE SPACES.
03 FILLER PIC X(01) VALUE SPACE.
03 SALES-DATE PIC X(10) VALUE SPACES.
03 FILLER PIC X(01) VALUE SPACE.
03 SALES-QTY PIC 9(04) VALUE 0.
03 FILLER PIC X(01) VALUE SPACE.
03 SALES-PAY-TERMS PIC X(12) VALUE SPACES.
03 FILLER PIC X(01) VALUE SPACE.
03 SALES-TITLE-ID PIC X(06) VALUE SPACES.
LINKAGE SECTION.
***************************************************************** * UNLIKE A NORMAL RSP, WHERE THE SPAREA IS SUPPLIED VIA THE COMM * AREA BY MAINFRAMEConnect BEFORE LINKING TO THE RSP, IN A CSA, * THIS PROGRAM SUPPLIES THE SPAREA, WHICH IS * THEN INITIALIZED BY THE CALL TO CSSETUP. *****************************************************************
01 STORE-PROC-AREA.
COPY SPAREAC.
***************************************************************** * SQL REQUEST BUFFER THAT WILL BE PASSED TO THE REMOTE SERVER VIA * REQEXEC CALL. IT CONSISTS OF A HALFWORD LENGTH FIELD, AND THE * ACTUAL REQUEST STATEMENT. *****************************************************************
01 SQL-BUFFER.
03 SQL-LENGTH PIC S9(4) COMP.
03 SQL-REQUEST PIC X(80).
***************************************************************** * SQLDA FOR DB2-FORMAT INPUT PIPE THAT WILL RETURN THE RESULT * ROWS FROM THE SALES TABLE. HARDCODED FOR SIX OCCURENCES OF * SQLVAR SINCE WE KNOW AHEAD OF TIME THAT IS THE NUMBER OF * COLUMNS THE SALES TABLE HAS. THE ACTUAL SQLDA WILL BE BUILT * AND A POINTER SUPPLIED TO IT WHEN WE OPEN THE DB2-FORMAT INPUT * PIPE TO READ RESULTS. *****************************************************************
01 SALES-SQLDA.
03 SALES-SQLDAID PIC X(08).
03 SALES-SQLDABC PIC S9(8) COMP.
03 SALES-SQLN PIC S9(4) COMP.
03 SALES-SQLD PIC S9(4) COMP.
03 SALES-SQLVAR OCCURS 6 TIMES.
05 SALES-SQLTYPE PIC S9(4) COMP.
05 SALES-SQLLEN PIC S9(4) COMP.
05 SALES-SQLDATA POINTER.
05 SALES-SQLIND POINTER.
05 SALES-SQLNAME PIC X(32).
***************************************************************** * DATA FIELDS POINTED TO BY THE SQLDATA POINTERS. * NOTE THAT VARCHAR FIELDS ARE PRECEEDED BY A LENGTH FIELD. * OTHER DATATYPES HAVE THEIR OWN REQUIREMENTS. CHECK THE IBM * DXT REFERENCE MANUAL OR MODELRSP IN THE RSP PROGRAMMER'S REF. *****************************************************************
01 STORE-ID PIC X(04).
01 ORDER-NUMBER.
03 ORD-NUM-LENGTH PIC S9(4) COMP.
03 ORD-NUM.
05 ORD-NUMCHAR PIC X(01)
OCCURS 20 TIMES DEPENDING ON ORD-NUM-LENGTH.
01 ORDER-DATE PIC X(10).
01 QUANTITY PIC S9(4) COMP.
01 PAY-TERMS.
03 PAY-TERM-LEN PIC S9(4) COMP.
03 PAY-TERM.
05 PAY-TERM-CHAR PIC X(01)
OCCURS 12 TIMES DEPENDING ON PAY-TERM-LEN.
01 TITLE-ID-ENT.
03 TITLE-ID-LEN PIC S9(4) COMP.
03 TITLE-ID.
05 TITLE-ID-CHAR PIC X(01)
OCCURS 6 TIMES DEPENDING ON TITLE-ID-LEN.
*************************************************************** PROCEDURE DIVISION. ***************************************************************
0000-MAIN-PROCESSING.
PERFORM 1000-SPAREA-INIT THRU 1000-EXIT.
PERFORM 5000-PROCESS-REQUEST THRU 5000-EXIT.
0000-GET-OUT-NOW.
EXEC CICS
RETURN
END-EXEC.
0000-EXIT.
EXIT.
***************************************************************** * GET AN SPAREA, AND CALL CSA TO INITIALIZE IT. *****************************************************************
1000-SPAREA-INIT.
EXEC CICS
DELETEQ TS QUEUE('CSEXQUE')
RESP(CICSRC)
END-EXEC.
***************************************************************** * THIS GETMAIN MAKES THE SPAREA AVAILABLE TO OPEN CLIENTConnect. *****************************************************************
EXEC CICS
GETMAIN SET(SPAREA-PTR)
LENGTH(LENGTH OF SPAREA) NOSUSPEND
RESP(CICSRC)
END-EXEC.
IF CICSRC = DFHRESP(NORMAL)
SET ADDRESS OF STORE-PROC-AREA TO SPAREA-PTR
PERFORM 1100-CALL-CSSETUP THRU 1100-EXIT
END-IF.
1000-EXIT.
EXIT.
***************************************************************** * CALL CSA TO INITIALIZE SPAREA ****************************************************************
1100-CALL-CSSETUP.
MOVE 'Y' TO SPTRCOPT.
CALL 'CSSETUP' USING SPAREA.
IF SPRC = '000'
MOVE 'Y' TO WS-SPAREA-INIT-SW
ELSE
MOVE 'CSSETUP' TO WS-STUB-NAME
PERFORM 6900-STUB-CALL-ERROR THRU 6900-EXIT
GO TO 0000-GET-OUT-NOW
END-IF.
1100-EXIT.
EXIT.
***************************************************************** * CONTROL THE PROCESS OF ATTACHING TO SQL SERVER, EXECUTING THE * SELECT REQUEST, AND RETRIEVING THE RESULTS. *****************************************************************
5000-PROCESS-REQUEST.
PERFORM 5100-ATTACH-TO-SQL-SERVER THRU 5100-EXIT.
IF ATTACH-OK
PERFORM 5500-SEND-REQUEST THRU 5500-EXIT
PERFORM 5700-READ-RESULTS THRU 5700-EXIT
PERFORM 5800-CALL-DETACH THRU 5800-EXIT.
5000-EXIT.
EXIT.
***************************************************************** * CALL CLIENT SERVICES TO ATTACH TO THE SQL SERVER. *****************************************************************
5100-ATTACH-TO-SQL-SERVER.
MOVE ATTACH-NAME TO SPSERVER.
CALL 'ATTACH' USING SPAREA.
IF SPRC = '000'
MOVE 'Y' TO WS-ATTACH-TO-SERVER-SW
ELSE
MOVE 'ATTACH' TO WS-STUB-NAME
PERFORM 6900-STUB-CALL-ERROR THRU 6900-EXIT
GO TO 0000-GET-OUT-NOW
END-IF
5100-EXIT.
EXIT.
***************************************************************** * EXECUTE THE SQL REQUEST AGAINST THE REMOTE SERVER. *****************************************************************
5500-SEND-REQUEST.
EXEC CICS
GETMAIN SET(SQL-REQ-PTR)
LENGTH(LENGTH OF SQL-BUFFER)
NOSUSPEND RESP(CICSRC)
END-EXEC.
SET ADDRESS OF SQL-BUFFER TO SQL-REQ-PTR.
SET SPSQL TO SQL-REQ-PTR.
IF CICSRC = DFHRESP(NORMAL)
MOVE SELECT-STMT TO SQL-REQUEST
MOVE LENGTH OF SELECT-STMT TO SQL-LENGTH
CALL 'REQEXEC' USING SPAREA
IF SPRC = '000'
PERFORM 6000-RESCHECK-SEARCH THRU 6000-EXIT
UNTIL RESCHECK-DONE
END-IF
END-IF.
5500-EXIT.
EXIT.
***************************************************************** * RETRIEVE ANY RESULT ROWS BY OPENING DB2 INPUT PIPE. *****************************************************************
5700-READ-RESULTS.
PERFORM 5710-OPEN-GETPIPE THRU 5710-EXIT.
PERFORM 5720-GETPIPE-LOOP THRU 5720-EXIT
UNTIL SPRC NOT = '000'.
5700-EXIT.
EXIT.
***************************************************************** * OPEN THE DB2 INPUT PIPE. *****************************************************************
5710-OPEN-GETPIPE.
MOVE 'INPUT ' TO SPMODE.
MOVE 'DB2' TO SPFORMAT.
CALL 'OPENPIPE' USING SPAREA.
IF SPRC = '000'
SET ADDRESS OF SALES-SQLDA TO SPSQLDA
SET ADDRESS OF STORE-ID TO SALES-SQLDATA(1)
SET ADDRESS OF ORDER-NUMBER TO SALES-SQLDATA(2)
SET ADDRESS OF ORDER-DATE TO SALES-SQLDATA(3)
SET ADDRESS OF QUANTITY TO SALES-SQLDATA(4)
SET ADDRESS OF PAY-TERMS TO SALES-SQLDATA(5)
SET ADDRESS OF TITLE-ID-ENT TO SALES-SQLDATA(6)
ELSE
MOVE 'OPENPIPE' TO WS-STUB-NAME
PERFORM 6900-STUB-CALL-ERROR THRU 6900-EXIT
GO TO 0000-GET-OUT-NOW
END-IF.
5710-EXIT.
EXIT.
***************************************************************** USE GETPIPE TO RETRIEVE ANY RESULT ROWS. ***************************************************************** 5720-GETPIPE-LOOP.
CALL 'GETPIPE' USING SPAREA.
IF SPRC = '000'
MOVE SPACES TO SALES-ROW
MOVE STORE-ID TO SALES-STOR-ID
MOVE ORD-NUM TO SALES-ORD-NUM
MOVE ORDER-DATE TO SALES-DATE
MOVE QUANTITY TO SALES-QTY
MOVE PAY-TERM TO SALES-PAY-TERMS
MOVE TITLE-ID TO SALES-TITLE-ID
EXEC CICS
WRITEQ TS QUEUE('CSEXQUE')
FROM(SALES-ROW) NOSUSPEND
RESP(CICSRC)
END-EXEC
ELSE
IF SPRC NOT = 'EOF'
MOVE 'GETPIPE' TO WS-STUB-NAME
PERFORM 6900-STUB-CALL-ERROR THRU 6900-EXIT
GO TO 0000-GET-OUT-NOW
END-IF
END-IF.
IF SPIND = 'M'
PERFORM 6100-GET-MESSAGES THRU 6100-EXIT
UNTIL SPIND NOT = 'M'
END-IF.
5700-EXIT.
EXIT.
***************************************************************** * CALL THE DETACH STUB TO DETACH FROM A REMOTE SERVER. *****************************************************************
5800-CALL-DETACH.
CALL 'DETACH' USING SPAREA.
IF SPRC NOT = '000'
MOVE 'DETACH' TO WS-STUB-NAME
PERFORM 6900-STUB-CALL-ERROR THRU 6900-EXIT
GO TO 0000-GET-OUT-NOW.
5800-EXIT.
EXIT.
***************************************************************** * CHECK RESCHECK TO LOCATE ANY ERROR MESSAGES RETURNED FROM LAN. * ALWAYS LOG ANY NON-ZERO STATUS AFTER A CALL TO REQEXEC. *****************************************************************
6000-RESCHECK-SEARCH.
ADD 1 TO RESCHECK-CNT.
IF SPSTATUS NOT = ‘ ‘(space)
MOVE ‘N’ TO WS-RESCHECK-DONE-SW
ADD 1 TO SPSTATUS-CNT
MOVE SPSTATUS-CNT TO WS-RESCHECK-NUMBER
MOVE SPSTATUS TO WS-SPSTATUS-OUT
MOVE SPCODE TO WS-SPCODE-OUT
MOVE SPIND TO WS-SPIND-OUT
EXEC CICS
WRITEQ TS QUEUE('CSEXQUE')
FROM(WS-RESCHECK-MSG) NOSUSPEND
RESP(CICSRC)
END-EXEC
IF SPIND NOT = SPACES
PERFORM 6100-GET-MESSAGES THRU 6100-EXIT
UNTIL SPIND NOT = 'M'
END-IF
ELSE
IF LAST-SPSTATUS-SPACES
MOVE 'Y' TO WS-RESCHECK-DONE-SW
ELSE
MOVE ' ' TO WS-RESCHECK-DONE-SW
END-IF
END-IF.
IF NOT RESCHECK-DONE
CALL 'RESCHECK' USING SPAREA.
6000-EXIT.
EXIT.
***************************************************************** * RETRIEVE ANY OUTSTANDING MESSAGES FOR A REQUEST. *****************************************************************
6100-GET-MESSAGES.
CALL 'GETMSG' USING SPAREA
IF SPMSG NOT = SPACES
EXEC CICS
WRITEQ TS QUEUE('CSEXQUE')
FROM(SPMSG) NOSUSPEND
RESP(CICSRC)
END-EXEC
END-IF.
6100-EXIT.
EXIT.
***************************************************************** * FORMAT AND WRITE STUB-CALL ERROR INFO TO TS QUEUE. *****************************************************************
6900-STUB-CALL-ERROR.
MOVE SPRC TO WS-STUB-SPRC.
MOVE SPMSG TO WS-STUB-SPMSG.
EXEC CICS
WRITEQ TS QUEUE('CSEXQUE')
FROM(WS-STUB-ERROR-MSG) NOSUSPEND
RESP(CICSRC)
END-EXEC.
6900-EXIT.
EXIT.
