Switch to standard view 
  Sybase logo
 
 
 



COBOL Code Sample:

      IDENTIFICATION DIVISION.

      PROGRAM-ID.  CSARESCK.

     *****************************************************************
     * SAMPLE CLIENT SERVICES PROGRAM TO ILLUSTRATE ESTABLISHING A
     * CONNECTION TO SQL SERVER, EXECUTING AN SQL REQUEST THAT HAS
     * SEVERAL INSERT STATEMENTS - ONE OF WHICH IS BAD - AND THEN
     * SCROLLING THROUGH THE GETMSG AND RESCHECK FEATURES TO DETER-
     * MINE WHICH SQL COMMAND(S) RECEIVED AN ERROR.
     *
     * NOTE: THIS APPROACH FOR BATCHING SQL COMMANDS ONLY WORKS IN
     * SITUATIONS WHERE SQL SERVER DOES NOT RECEIVE AN ERROR SEVERE
     * ENOUGH TO CAUSE A ROLLBACK TRANACTION (IN WHICH CASE THE CSA
     * WILL ONLY RECEIVE ONE ERROR MESSAGE FOR THE ENTIRE BATCH OF
     * COMMANDS).  IF A ROLLBACK TRANSACTION DOES NOT OCCUR, THEN
     * SQL SERVER WILL RETURN A SUCCESS/FAILURE MESSAGE FOR EACH OF
     * THE BATCHED SQL COMMANDS.
     *
     * TRANSID IN PCT: CRES         PROGRAM NAME IN PPT: CSARESCK
     *****************************************************************

      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(3) VALUE ZEROES.
          05  SPSTATUS-CNT             PIC 9(3) VALUE ZEROES.

     *****************************************************************
     * ATTACHMENT DEFINITION NAME.
     *****************************************************************
      O1  ATTACH-NAME                  PIC X(08) VALUE 'BREX   '.

     *****************************************************************
     * SWITCH FOR RESCHECK READS -
     *   THE IDEA IS TO KEEP CALLING RESCHECK UNTIL YOU'VE RECEIVED
     *   SPACES IN SPSTATUS TWICE IN A ROW - THEN YOU'RE DONE.
     *****************************************************************
      01  WS-SWITCHES.
          03  WS-RESCHECK-DONE-SW      PIC X VALUE 'N'.
              88  RESCHECK-DONE              VALUE 'Y'.
              88  RESCHECK-NOT-DONE          VALUE 'N'.
              88  LAST-SPSTATUS-SPACES       VALUE ' '.
     *****************************************************************
     * SQL STATEMENT TO EXECUTE.
     *****************************************************************
      01  MULTI-INSERT-STMT.
          03  INSERT-1.
              05  FILLER               PIC X(30) VALUE
              'INSERT INTO TESTABLE  VALUES ('.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(03) VALUE '001'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(02) VALUE ', '.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(16) VALUE
              'RECORD NUMBER 01'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(02) VALUE ', '.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(10) VALUE
              'FIRST RECD'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(04) VALUE ')   '.
              05  FILLER               PIC X(1975) VALUE SPACES.
      01  MULTI-INSERT-STMT-2.
          03  INSERT-1-2.
              05  FILLER               PIC X(30) VALUE
              'INSERT INTO TESTABLE  VALUES ('.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(03) VALUE '001'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(02) VALUE ', '.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(16) VALUE
              'RECORD NUMBER 01'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(02) VALUE ', '.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(10) VALUE
              'FIRST RECD'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(04) VALUE ') ; '.
          03  INSERT-2.
              05  FILLER               PIC X(30) VALUE
              'INSERT INTO TESTABLE  VALUES ('.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(03) VALUE '002'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(02) VALUE ', '.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(16) VALUE
              'RECORD NUMBER 02'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(02) VALUE ', '.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(10) VALUE
              'SECOND REC'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(04) VALUE ') ; '.
          03  INSERT-3-DUP.
              05  FILLER               PIC X(30) VALUE
              'INSERT INTO TESTABLE  VALUES ('.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(03) VALUE '002'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(02) VALUE ', '.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(16) VALUE
              'RECORD NUMBER 03'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(02) VALUE ', '.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(10) VALUE
              'THIRD RECD'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(04) VALUE ') ; '.
          03  INSERT-4.
              05  FILLER               PIC X(30) VALUE
              'INSERT INTO TESTABLE  VALUES ('.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(03) VALUE '004'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(02) VALUE ', '.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(16) VALUE
              'RECORD NUMBER 04'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(02) VALUE ', '.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(10) VALUE
              'FOURTH REC'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(04) VALUE ') ; '.
          03  INSERT-5-DUP.
              05  FILLER               PIC X(30) VALUE
              'INSERT INTO TESTABLE  VALUES ('.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(03) VALUE '004'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(02) VALUE ', '.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(16) VALUE
              'RECORD NUMBER 05'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(02) VALUE ', '.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(10) VALUE
              'FIFTH RECD'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(04) VALUE ') ; '.
          03  INSERT-6.
              05  FILLER               PIC X(30) VALUE
              'INSERT INTO TESTABLE  VALUES ('.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(03) VALUE '006'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(02) VALUE ', '.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(16) VALUE
              'RECORD NUMBER 06'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(02) VALUE ', '.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(10) VALUE
              'SIXTH RECD'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(04) VALUE ') ; '.
          03  INSERT-7-DUP.
              05  FILLER               PIC X(30) VALUE
              'INSERT INTO TESTABLE  VALUES ('.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(03) VALUE '006'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(02) VALUE ', '.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(16) VALUE
              'RECORD NUMBER 07'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(02) VALUE ', '.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(10) VALUE
              '7TH   RECD'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(04) VALUE ') ; '.
          03  INSERT-8.
              05  FILLER               PIC X(30) VALUE
              'INSERT INTO TESTABLE  VALUES ('.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(03) VALUE '008'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(02) VALUE ', '.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(16) VALUE
              'RECORD NUMBER 08'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(02) VALUE ', '.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(10) VALUE
              'LAST  RECD'.
              05  FILLER               PIC X(01) VALUE QUOTE.
              05  FILLER               PIC X(04) VALUE ')   '.

     *****************************************************************
     * FLAGS.
     *****************************************************************
      01  WS-INIT-SPAREA-SW            PIC X(01) VALUE '0'.
          88  INIT-SPAREA-OK           VALUE '1'.
          88  INIT-SPAREA-BAD          VALUE '0'.

      01  WS-ATTACH-SW                 PIC X(01) VALUE '0'.
          88  ATTACH-OK                VALUE '1'.
          88  ATTACH-BAD               VALUE '0'.

     *****************************************************************
     * 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-LAST-MSG.
          03  FILLER                   PIC X(30)
              VALUE '- FINAL RESCHECK READ COUNT : '.
          03  WS-RESCHECK-COUNT        PIC 9(03) VALUE ZEROES.

      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(09)
              VALUE ' - SPRC: '.
          03  WS-SPRC-OUT              PIC X(03) VALUE SPACE.
          03  FILLER                   PIC X(10)
              VALUE ' - SPIND: '.
          03  WS-SPIND-OUT             PIC X(01) VALUE SPACE.


      LINKAGE SECTION.

      01  STORED-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(3000).

     *==============================================================*
      PROCEDURE DIVISION.
     *==============================================================*
      0000-MAIN-PROCESSING.

          PERFORM 1000-SPAREA-INIT.

          IF INIT-SPAREA-OK
              PERFORM 2000-ATTACH-TO-SERVER.
              PERFORM 5000-EXEC-SQL-REQUEST
              PERFORM 6000-RESCHECK-REARCH
                      UNTIL RESCHECK-DONE
              PERFORM 7000-CLOSE-DETACH
              PERFORM 9000-FINAL-COUNT
          END-IF.

      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.

          EXEC CICS
               GETMAIN SET(SPAREA-PTR)
               LENGTH(LENGTH OF SPAREA)
               NOSUSPEND
               RESP(CICSRC)
          END-EXEC.

          IF CICSRC = DFHRESP(NORMAL)
              SET ADDRESS OF STORED-PROC-AREA TO SPAREA-PTR
              CALL 'CSSETUP' USING SPAREA
              IF SPRC = '000'
                  SET INIT-SPAREA-OK      TO TRUE
              ELSE
                  MOVE 'CSSETUP'          TO WS-STUB-NAME
                  PERFORM 6900-STUB-CALL-ERROR    THRU 6900-EXIT
                  GO TO 0000-GET-OUT-NOW
              END-IF
          END-IF.

      1000-EXIT.
          EXIT.

     *****************************************************************
     * CALL CLIENT SERVICES TO ATTACH TO REMOTE SERVER.
     *****************************************************************
      2000-ATTACH-TO-SERVER.

          MOVE ATTACH-NAME                TO SPATTACH.

          CALL 'ATTACH' USING SPAREA.

          IF SPRC = '000'
              SET ATTACH-OK               TO TRUE
          ELSE
              MOVE 'ATTACH'               TO WS-STUB-NAME
              PERFORM 6900-STUB-CALL-ERROR      THRU 6900-EXIT
              GO TO 0000-GET-OUT-NOW
          END-IF.

      2000-EXIT.
          EXIT.

     *****************************************************************
     * EXECUTE THE SQL REQUEST AGAINST THE REMOTE SERVER.
     *****************************************************************
      5000-EXEC-SQL-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 MULTI-INSERT-STMT      TO SQL-REQUEST
              MOVE LENGTH OF MULTI-INSERT-STMT TO SQL-LENGTH
              CALL 'REQEXEC' USING SPAREA
          END-IF.

      5000-EXIT.
          EXIT.

     *****************************************************************
     * CHECK RESCHECK TO LOCATE SQL STATEMENT IN ERROR.
     *****************************************************************
      6000-RESCHECK-REARCH.

          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 SPRC                   TO WS-SPRC-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 6500-GET-MESSAGES 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.
     *****************************************************************
      6500-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.

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

     *****************************************************************
     * FORMAT AND WRITE STUB-CALL ERROR INFO TO TS QUEUE.
     *****************************************************************
      7000-CLOSE-DETACH.

          CALL 'CLOSPIPE'   USING SPAREA.

          IF SPRC NOT = '000'
              MOVE 'CLOSPIPE'             TO WS-STUB-NAME
              PERFORM 6900-STUB-CALL-ERROR      THRU 6900-EXIT
              GO TO 0000-GET-OUT-NOW
          END-IF.

          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
          END-IF.

      7000-EXIT.
          EXIT.

     *****************************************************************
     * SEND THE FINAL RESCHECK READ NUMBER TO TEMP STORAGE QUE
     *****************************************************************
      9000-FINAL-COUNT.

          MOVE RESCHECK-CNT               TO WS-RESCHECK-COUNT.

          EXEC CICS
              WRITEQ TS QUEUE('CSEXQUE')
                     FROM(WS-RESCHECK-LAST-MSG) NOSUSPEND
                     RESP(CICSRC)
          END-EXEC.

      9000-EXIT.
          EXIT.

     *===============================================================*
     *    END OF PROGRAM.
     *===============================================================*



Back to Top
© Copyright 2010, Sybase Inc.