Quellcode-Bibliothek

^© Kompilation durch diese Firma

[Weder Korrektheit noch Funktionsfähigkeit der Software werden zugesichert.]

Datei: sybasecics.cbl Sprache: Cobol

Original von: verschiedene^©

       IDENTIFICATION DIVISION.
      PROGRAM-ID.  OSCICS4C.
      DATE-WRITTEN. 12/17/96.
      DATE-COMPILED.
     ******************************************************************
     **
     **       (c) 1995 by Sybase, Inc. All Rights Reserved
     **
     ******************************************************************

     ******************************************************************
     ** PROGRAM:    OSCICS4C
     **
     ** THIS PROGRAM IS A THE OPEN SERVER VERSION OF RSP4C.
     ** It will receive one of 2 Keywords @ERRORMSG or @WARNMSG and
     ** Other Keywords. Will reply with the keywords and data.
     ** If @ERRORMSG AND/OR @WARNMSG are 'Y' that type of message
     ** will be returned...
     ** exec SY4C @WARNMSG=Y,@ERRORMSG=Y.........
     ******************************************************************

      ENVIRONMENT DIVISION.

      DATA DIVISION.

      WORKING-STORAGE SECTION.

     ******************************************************************
     * COPY IN THE OS SERVER LIBRARYS
     ******************************************************************
      COPY SYGWCOB.
     ******************************************************************
     *OPEN SERVER WORK VARIBLES FOR OS CALL TO USE ...
     ******************************************************************
      01  WS-GWL-WORK-VARIBLES.
          05  GWL-PROC                POINTER.
          05  GWL-INIT-HANDLE         POINTER.
          05  GWL-RC                  PIC S9(9) COMP.
          05  GWL-INFPRM-ID           PIC S9(9) COMP.
          05  GWL-INFPRM-TYPE         PIC S9(9) COMP.
          05  GWL-INFPRM-DATA-L       PIC S9(9) COMP.
          05  GWL-INFPRM-MAX-DATA-L   PIC S9(9) COMP.
          05  GWL-INFPRM-STATUS       PIC S9(9) COMP.
          05  GWL-INFPRM-NAME         PIC X(30).
          05  GWL-INFPRM-NAME-L       PIC S9(9) COMP.
          05  GWL-INFPRM-USER-DATA    PIC S9(9) COMP.
          05  GWL-INFUDT-USER-TYPE    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-COMM-STATE          PIC S9(9) COMP.
          05  GWL-STATUS-RETURN-CODE  PIC S9(9) COMP.
          05  GWL-STATUS-SUBCODE      PIC S9(9) COMP.
          05  GWL-NUMPRM-PARMS        PIC S9(9) COMP.
          05  GWL-RCVPRM-DATA-L       PIC S9(9) COMP.
          05  GWL-SETPRM-ID           PIC S9(9) COMP.
          05  GWL-SETPRM-TYPE         PIC S9(9) COMP.
          05  GWL-SETPRM-DATA-L       PIC S9(9) COMP.
          05  GWL-SETPRM-USER-DATA    PIC S9(9) COMP.
          05  GWL-CONVRT-SCALE        PIC S9(9) COMP VALUE 2.
          05  GWL-SETBCD-SCALE        PIC S9(9) COMP VALUE 0.
          05  GWL-INFBCD-LENGTH       PIC S9(9) COMP.
          05  GWL-INFBCD-SCALE        PIC S9(9) COMP.
          05  GWL-RETURN-ROWS         PIC S9(9) COMP VALUE +0.
          05  SNA-CONN-NAME           PIC X(8)  VALUE SPACES.
          05  SNA-SUBC                PIC S9(9) COMP.
          05  WRK-DONE-STATUS         PIC S9(9) COMP.
          05  GWL-ACTUAL-LEN          PIC S9(9) COMP.
          05  GWL-TRAN-LEN            PIC S9(9) COMP.
          05  GWL-MSG-LEN             PIC S9(9) COMP.
          05  WS-NUMPRM-PARMS         PIC S9(9) COMP.
          05  GWL-REQUEST-TYP         PIC S9(9) COMP.
          05  GWL-RPC-NAME            PIC X(30) VALUE SPACES.
          05  GWL-COMM-STATE          PIC S9(9) COMP.
          05  I                       PIC S9(9) COMP.
          05  WS-ERROR-MSG            PIC S9(9) COMP VALUE ZERO.
          05  WS-ERROR-SEV            PIC S9(9) COMP VALUE ZERO.

      01  DESCRIPTION-FIELDS.
          05 COLUMN-NUMBER          PIC S9(09) COMP VALUE +0.
          05 HOST-TYPE              PIC S9(09) COMP VALUE +0.
          05 HOST-LEN               PIC S9(09) COMP VALUE +0.
          05 COLUMN-LEN             PIC S9(09) COMP VALUE +0.
          05 COLUMN-NAME-LEN        PIC S9(09) COMP VALUE +0.
          05 WS-ZERO                PIC S9(09) COMP VALUE +0.

      01  WS-MSG-WORK-VARS.
          05 MSG-NR                   PIC S9(9) COMP VALUE +9999.

      01  WS-INPUT-LEN                PIC S9(9) COMP  VALUE +55.
      01  WS-INPUT-DATA               PIC X(55)       VALUE SPACES.

      01  WS-LENGTH                   PIC S9(9) COMP  VALUE ZERO.
      01  WS-WARNMSG                  PIC X(8)        VALUE '@WARNMSG'.
      01  WS-WARNMSG-ID               PIC S9(9) COMP  VALUE ZERO.
      01  WS-WARNMSG-88               PIC X(1)        VALUE 'N'.
          88 WARNING-MSG                              VALUE 'Y'.

      01  WS-ERRORMSG                 PIC X(9)       VALUE '@ERRORMSG'.
      01  WS-ERRORMSG-ID              PIC S9(9) COMP VALUE ZERO.
      01  WS-ERRORMSG-88              PIC X(1)        VALUE 'N'.
          88 ERROR-MSG                                VALUE 'Y'.
      01  WS-OUTPUT-DATA              PIC X(55)      VALUE SPACES.

      01  WS-OUTPUT-COL-NAME          PIC X(13)
          VALUE 'OUTPUT_COLUMN'.

      01  WS-QUEUE-NAME.
          05  WS-TRANID               PIC X(4) VALUE 'SY3C'.
          05  WS-TRMID                PIC X(4) VALUE SPACES.
      01  CICSRC                      PIC S9(8) COMP.
      01  CICSRC-DIS                  PIC S9(8).

     ******************************************************************
     * MESSAGES                                                       *
     ******************************************************************

      01  WS-MSG.
          05  FILLER                    PIC  X(17)
              VALUE 'ERROR IN OS CALL '.
          05  WS-MSG-FUNC               PIC  X(10).
          05  FILLER                    PIC  X(04)
              VALUE 'RC='.
          05  WS-MSG-RC                 PIC S9(9).
          05  FILLER                    PIC  X(18)
              VALUE ' SUBCODE ERROR = '.
          05  MSG-SUBC                  PIC  9(9) VALUE 0.
          05  WS-MSG-TEXT               PIC X(50) VALUE SPACES.

      01  WS-HOLD-MSG                   PIC X(107) VALUE SPACES.
      01  WS-WARN-MSG                   PIC X(107) VALUE
          'THIS IS A WARNING MESSAGE........'.
      01  WS-ERR-MSG                    PIC X(107) VALUE
          'THIS IS A ERROR MESSAGE........'.


      01  WORK-SRVIN-INFO.
          05  WK-INFO-TBL-ID        PIC S9(8) COMP.
          05  WK-INFO-TBL-NAME      PIC  X(30).
          05  WK-INFO-TBL-VALUE     PIC  X(10).


      LINKAGE SECTION.
     **************************************************************
     * THE LINKAGE SECTION DEFINES MASKS FOR DATA AREAS THAT ARE
     * PASSED BETWEEN THIS PROGRAM.
     **************************************************************

      01  DFHCOMMAREA                PIC  X(1).


      PROCEDURE DIVISION.

      000-MAIN-PROCESSING.

          PERFORM 100-INITIALIZE            THRU 100-EXIT.

          PERFORM 200-PROCESS-INPUT         THRU 200-EXIT.

          PERFORM 300-PROCESS-OUTPUT        THRU 300-EXIT.

          PERFORM 900-ALL-DONE              THRU 900-EXIT.

          GOBACK.

      000-EXIT.
          EXIT.

      100-INITIALIZE.

     ******************************************************
     * INTIALIZED THE TDS CONNECTION AND CONFIRM THAT IS
     * WAS AN RPC CALL,  ........
     ******************************************************
     *==> INITIAL QUEUE NAME            <===*
          MOVE EIBTRMID    TO WS-TRMID.

     *==> ESTABLISH GATEWAY ENVIRONMENT <===*

          CALL 'TDINIT' USING DFHEIBLK, GWL-RC, GWL-INIT-HANDLE.
          IF GWL-RC NOT = TDS-OK THEN
             PERFORM 910-ERR-PROCESS  THRU 910-EXIT
          END-IF.

     *==> ACCEPT CLIENT REQUEST <===*

          CALL 'TDACCEPT' USING GWL-PROC, GWL-RC, GWL-INIT-HANDLE,
                                SNA-CONN-NAME, SNA-SUBC.
          IF GWL-RC NOT = TDS-OK THEN
             PERFORM 910-ERR-PROCESS  THRU 910-EXIT
          END-IF.

     *==> TO MAKE SURE WE WERE STARTED BY RPC REQUEST... <===*

          CALL 'TDINFRPC' USING GWL-PROC,        GWL-RC,
                                GWL-REQUEST-TYP, GWL-RPC-NAME,
                                GWL-COMM-STATE.
          IF GWL-RC          NOT = TDS-OK    OR
             GWL-REQUEST-TYP NOT = TDS-RPC-EVENT
             THEN
                MOVE GWL-RC         TO WS-MSG-RC
                MOVE 'TDINFRPC'     TO WS-MSG-FUNC
                PERFORM 920-SEND-MESSAGE THRU 920-EXIT
                PERFORM 910-ERR-PROCESS  THRU 910-EXIT
          END-IF.

      100-EXIT.
          EXIT.


      200-PROCESS-INPUT.
     ****************************************************************
     * RECEIVE THE INPUT PARAMETER INTO HOST VARIBLE, SEND ROW DATA *
     * BACK DOWN TO CLIENT                                          *
     ****************************************************************

     *---> Find out how many parms are being passed <---*

          CALL 'TDNUMPRM' USING GWL-PROC, GWL-NUMPRM-PARMS.

     *---> NO PARMS, pump back a message            <---*

          IF GWL-NUMPRM-PARMS < +1 THEN
             MOVE 'At least one parm is needed'
                                 TO WS-MSG-TEXT
             MOVE GWL-RC         TO WS-MSG-RC
             MOVE 'TDNUMPRM'     TO WS-MSG-FUNC
             MOVE WS-MSG         TO WS-HOLD-MSG
             MOVE TDS-ERROR-MSG  TO WS-ERROR-MSG
             MOVE TDS-ERROR-SEV  TO WS-ERROR-SEV
             PERFORM 920-SEND-MESSAGE THRU 920-EXIT
             PERFORM 910-ERR-PROCESS  THRU 910-EXIT
          END-IF.

     *---> TEST TO SEE IF THE KEYWORDS "WARNMSG" AND <---*
     *---> OR ERRORMSG WHERE SENT....                <---*
          MOVE LENGTH OF WS-WARNMSG     TO WS-LENGTH.
          CALL 'TDLOCPRM' USING GWL-PROC, WS-WARNMSG-ID,
                                WS-WARNMSG, WS-LENGTH.

          MOVE LENGTH OF WS-ERRORMSG     TO WS-LENGTH.
          CALL 'TDLOCPRM' USING GWL-PROC, WS-ERRORMSG-ID,
                                WS-ERRORMSG, WS-LENGTH.

     *---> SAVE THE NUMBER OF PARMS FOR THE LOOP <---*
          MOVE GWL-NUMPRM-PARMS  TO WS-NUMPRM-PARMS.

     *---> LOOP THRU THE PARMS AND WRITE TO TEMP STORAGE <----*
             PERFORM  VARYING GWL-NUMPRM-PARMS FROM 1 BY 1
                   UNTIL GWL-NUMPRM-PARMS > WS-NUMPRM-PARMS
             PERFORM 210-GET-PARM     THRU       210-EXIT
             PERFORM 220-WRITE-TS     THRU       220-EXIT

          END-PERFORM.
      200-EXIT.
          EXIT.
      210-GET-PARM.
     ****************************************************************
     * *---> Get that parm into into the host varible <---*         *
     ****************************************************************

             CALL 'TDRCVPRM' USING GWL-PROC, GWL-RC,
                                   GWL-NUMPRM-PARMS,
                                   WS-INPUT-DATA,
                                   TDSCHAR,
                                   WS-INPUT-LEN,
                                   GWL-ACTUAL-LEN
             IF GWL-RC NOT = TDS-OK THEN
                MOVE GWL-RC         TO WS-MSG-RC
                MOVE 'TDRCVPRM'     TO WS-MSG-FUNC
                MOVE WS-MSG         TO WS-HOLD-MSG
                MOVE TDS-ERROR-MSG  TO WS-ERROR-MSG
                MOVE TDS-ERROR-SEV  TO WS-ERROR-SEV
                PERFORM 920-SEND-MESSAGE THRU 920-EXIT
                PERFORM 910-ERR-PROCESS  THRU 910-EXIT
             END-IF.

      210-EXIT.
          EXIT.
      220-WRITE-TS.
     ****************************************************************
     * *---> WRITE PARMS TO TEMP STORAGE, LATER RETURN PARMS <---*  *
     * *---> BACK DOWN TO CLIENT AS OUTPUT                   <---*  *
     ****************************************************************

           EXEC CICS
                WRITEQ TS QUEUE(WS-QUEUE-NAME)
                         FROM (WS-INPUT-DATA)
                         LENGTH(LENGTH OF WS-INPUT-DATA)
                         RESP (CICSRC)
           END-EXEC.
           IF CICSRC NOT = DFHRESP(NORMAL)
                MOVE CICSRC       TO CICSRC-DIS
                MOVE CICSRC-DIS   TO WS-MSG-RC
                MOVE 'WRITEQ'     TO WS-MSG-FUNC
                MOVE WS-MSG         TO WS-HOLD-MSG
                MOVE TDS-ERROR-MSG  TO WS-ERROR-MSG
                MOVE TDS-ERROR-SEV  TO WS-ERROR-SEV
                PERFORM 920-SEND-MESSAGE THRU 920-EXIT
                PERFORM 910-ERR-PROCESS  THRU 910-EXIT
           END-IF.

      220-EXIT.
          EXIT.
      300-PROCESS-OUTPUT.
     ****************************************************************
     * READ TEMP STORAGE QUEUE AND SEND ROWS TO CLIENT              *
     ****************************************************************

          PERFORM 310-DEFINE-OUTPUT  THRU 310-EXIT.

          PERFORM VARYING I FROM 1 BY 1 UNTIL I > WS-NUMPRM-PARMS
             PERFORM 320-READQ-TS   THRU     320-EXIT
             PERFORM 330-SEND-ROW   THRU     330-EXIT
          END-PERFORM.

     *---> PROCESS WARNMSG AND/OR ERRORMSG AFTER SENDING ROWS. <---*
          IF WARNING-MSG
          THEN
             MOVE TDS-INFO-MSG  TO WS-ERROR-MSG
             MOVE TDS-INFO-SEV  TO WS-ERROR-SEV
             MOVE WS-WARN-MSG   TO WS-HOLD-MSG
             PERFORM 920-SEND-MESSAGE THRU 920-EXIT
          END-IF.
          IF ERROR-MSG
          THEN
             MOVE TDS-ERROR-MSG  TO WS-ERROR-MSG
             MOVE TDS-ERROR-SEV  TO WS-ERROR-SEV
             MOVE WS-ERR-MSG     TO WS-HOLD-MSG
             PERFORM 920-SEND-MESSAGE THRU 920-EXIT
          END-IF.
      300-EXIT.
          EXIT.


      310-DEFINE-OUTPUT.
     ****************************************************************
     * DEFINE THE OUTPUT COLUM AS CHAR OF 55 BYTES                  *
     ****************************************************************

          MOVE +1                                TO COLUMN-NUMBER.
          MOVE LENGTH OF WS-OUTPUT-DATA          TO HOST-LEN
                                                    COLUMN-LEN.
          MOVE LENGTH OF WS-OUTPUT-COL-NAME      TO COLUMN-NAME-LEN.
          CALL 'TDESCRIB' USING GWL-PROC,
                                GWL-RC,
                                COLUMN-NUMBER,
                                TDSCHAR,
                                HOST-LEN,
                                WS-OUTPUT-DATA,
                                TDS-ZERO,
                                TDS-FALSE,
                                TDSCHAR,
                                COLUMN-LEN,
                                WS-OUTPUT-COL-NAME,
                                COLUMN-NAME-LEN.

          IF GWL-RC NOT = TDS-OK THEN
             MOVE GWL-RC         TO WS-MSG-RC
             MOVE 'TDESCRIB'     TO WS-MSG-FUNC
             MOVE WS-MSG         TO WS-HOLD-MSG
             MOVE TDS-ERROR-MSG  TO WS-ERROR-MSG
             MOVE TDS-ERROR-SEV  TO WS-ERROR-SEV
             PERFORM 920-SEND-MESSAGE THRU 920-EXIT
             PERFORM 910-ERR-PROCESS  THRU 910-EXIT
          END-IF.

      310-EXIT.
          EXIT.
      320-READQ-TS.
     ****************************************************************
     * READ THE INPUT TEMP STORAGE QUEUE
     ****************************************************************
          EXEC CICS
               READQ TS QUEUE(WS-QUEUE-NAME)
                        INTO (WS-OUTPUT-DATA)
                        LENGTH(LENGTH OF WS-OUTPUT-DATA)
                        NEXT
                        RESP (CICSRC)
          END-EXEC.
          IF CICSRC NOT = DFHRESP(NORMAL)
               MOVE CICSRC       TO CICSRC-DIS
               MOVE CICSRC-DIS   TO WS-MSG-RC
               MOVE 'READQ'      TO WS-MSG-FUNC
               MOVE WS-MSG         TO WS-HOLD-MSG
               MOVE TDS-ERROR-MSG  TO WS-ERROR-MSG
               MOVE TDS-ERROR-SEV  TO WS-ERROR-SEV
               PERFORM 920-SEND-MESSAGE THRU 920-EXIT
               PERFORM 910-ERR-PROCESS  THRU 910-EXIT
          END-IF.
     *---> PROCESS WARNMSG AND/OR ERRORMSG PARMS IF YES... <---*
          IF WS-WARNMSG-ID = I AND WS-OUTPUT-DATA = 'Y'
             MOVE 'Y'          TO WS-WARNMSG-88.
          IF WS-ERRORMSG-ID = I AND WS-OUTPUT-DATA = 'Y'
             MOVE 'Y'          TO WS-ERRORMSG-88.
      320-EXIT.
          EXIT.

      330-SEND-ROW.
     ****************************************************************
     * SEND ROW OF DATA TO CLIENT....
     *****************************************************************

          CALL 'TDSNDROW' USING GWL-PROC, GWL-RC
          IF GWL-RC NOT = TDS-OK
          THEN
             MOVE GWL-RC         TO WS-MSG-RC
             MOVE 'TDSNDROW'     TO WS-MSG-FUNC
             MOVE WS-MSG         TO WS-HOLD-MSG
             MOVE TDS-ERROR-MSG  TO WS-ERROR-MSG
             MOVE TDS-ERROR-SEV  TO WS-ERROR-SEV
             PERFORM 920-SEND-MESSAGE THRU 920-EXIT
             PERFORM 910-ERR-PROCESS  THRU 910-EXIT
          END-IF.

      330-EXIT.
          EXIT.
          EJECT
      900-ALL-DONE.
     ******************************************************************
     * CLOSE CONNECTION TO CLIENT AND RETURN TO CICS...               *
     ******************************************************************

          CALL 'TDSNDDON' USING GWL-PROC, GWL-RC, WRK-DONE-STATUS,
                                GWL-RETURN-ROWS, TDS-ZERO, TDS-ENDRPC.
          IF GWL-RC NOT = TDS-OK THEN
             PERFORM 980-CICS-DUMP    THRU 980-EXIT
             PERFORM 990-CICS-RETURN  THRU 990-EXIT
          END-IF.

          CALL 'TDFREE' USING GWL-PROC, GWL-RC.

          EXEC CICS
                DELETEQ TS QUEUE(WS-QUEUE-NAME)
                           RESP (CICSRC)
          END-EXEC.
          IF CICSRC NOT = DFHRESP(NORMAL)
                MOVE CICSRC       TO CICSRC-DIS
                MOVE CICSRC-DIS   TO WS-MSG-RC
                MOVE 'DELETEQ'    TO WS-MSG-FUNC
                MOVE WS-MSG         TO WS-HOLD-MSG
                MOVE TDS-ERROR-MSG  TO WS-ERROR-MSG
                MOVE TDS-ERROR-SEV  TO WS-ERROR-SEV
                PERFORM 920-SEND-MESSAGE THRU 920-EXIT
                PERFORM 910-ERR-PROCESS  THRU 910-EXIT
          END-IF.

          PERFORM 990-CICS-RETURN     THRU 990-EXIT.

      900-EXIT.
          EXIT.

      910-ERR-PROCESS.
     ******************************************************************
     * PERFORM ALL-DONE IN A ERROR STATE                              *
     ******************************************************************

          MOVE ZERO             TO  GWL-RETURN-ROWS.
          MOVE TDS-DONE-ERROR   TO  WRK-DONE-STATUS.
          PERFORM 900-ALL-DONE  THRU 900-EXIT.

      910-EXIT.
          EXIT.

      920-SEND-MESSAGE.
     ******************************************************************
     * SEND ERROR MESSAGE DOWN TO CLIENT                              *
     ******************************************************************
          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.

     *==> ENSURE THAT WE ARE IN THE CORRECT STATE TO SEND A MESSAGE <=*
          IF GWL-RC NOT = TDS-OK THEN
             PERFORM 980-CICS-DUMP       THRU 980-EXIT
             PERFORM 990-CICS-RETURN     THRU 990-EXIT
          END-IF.

          IF GWL-STATUS-COMM = TDS-RECEIVE THEN
             CALL 'TDCANCEL' USING GWL-PROC, GWL-RC.


          MOVE LENGTH OF EIBTRNID      TO GWL-TRAN-LEN.
          MOVE LENGTH OF WS-HOLD-MSG   TO GWL-MSG-LEN.
          CALL 'TDSNDMSG' USING GWL-PROC, GWL-RC, WS-ERROR-MSG,
                               MSG-NR, WS-ERROR-SEV, TDS-ZERO,
                               TDS-ZERO, EIBTRNID, GWL-TRAN-LEN,
                               WS-HOLD-MSG, GWL-MSG-LEN.

      920-EXIT.
          EXIT.

      980-CICS-DUMP.
     ******************************************************************
     * CAUSE A CICS TRANSACTION DUMP USUALLY BECAUSE SOMETHING IS BAD *
     ******************************************************************
          EXEC CICS
               DUMP DUMPCODE('SY3C') NOHANDLE
          END-EXEC.

      980-EXIT.
          EXIT.

      990-CICS-RETURN.
     ******************************************************************
     * RETURN TO CICS...                                              *
     ******************************************************************

          EXEC CICS
               RETURN
          END-EXEC.

      990-EXIT.
          EXIT.

¤ Dauer der Verarbeitung: 0.16 Sekunden (vorverarbeitet) ¤

Download des Quellennavigators
Download des sprechenden Kalenders
in der Quellcodebibliothek suchen

Haftungshinweis

Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.

Bemerkung:

Die farbliche Syntaxdarstellung ist noch experimentell.