Sybase.com

COBOL code sample:

IDENTIFICATION DIVISION.

PROGRAM-ID. CLIENTC2.

*****************************************************************
* SAMPLE CLIENT SERVICES PROGRAM TO ILLUSTRATE ESTABLISHING A
* CONNECTION TO A REMOTE SERVER, EXECUTING AN SQL REQUEST,
* RETRIEVING THE RESULTS AND ANY MESSAGES (WRITING THEM TO A TEMP
* STORAGE QUEUE STRICTLY FOR ILLUSTRATION), 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 ILLUSTRATION,
* 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(08) VALUE 'SQLSERVE'.

*****************************************************************
* SQL STATEMENT TO EXECUTE. WILL SELECT ALL ROWS FROM THE SQL
* SERVER SAMPLE PUBS DATABASE TABLE "SALES." MULTIPLE SQL
* REQUESTS MAY 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 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 PCSQLDB2 BEFORE LINKING TO THE RSP, IN A CLIENT
* SERVICES PROGRAM, 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.

IF ATTACH-OK
PERFORM 5000-PROCESS-REQUEST THRU 5000-EXIT.

0000-GET-OUT-NOW.

EXEC CICS
RETURN
END-EXEC.

0000-EXIT.
EXIT.

*****************************************************************
* GET AN SPAREA, AND CALL CLIENT SERVICES TO INITIALIZE IT.
*****************************************************************
1000-SPAREA-INIT.

EXEC CICS
DELETEQ TS QUEUE('CSEXQUE')
RESP(CICSRC)
END-EXEC.

*****************************************************************
* THIS GETMAIN MAKES THE SPAREA AVAILABLE TO THE ACCESS SERVER.
*****************************************************************
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 CLIENT SERVICES TO INITIALIZE SPAREA
*****************************************************************
1100-CALL-CSSETUP.

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-TRANSFER-PROCESS.

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 SPATTACH.

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 NOT = '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 FROMLAN.
* ALWAYS LOG ANY NON-ZERO STATUS AFTER A CALL TO REQEXEC.
*****************************************************************
6000-RESCHECK-SEARCH.

ADD 1 TO RESCHECK-CNT.

IF SPSTATUS NOT = ' '
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.