Quellcode-Bibliothek

^© Kompilation durch diese Firma

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

Datei: cicscall.cbl Sprache: Cobol

Original von: verschiedene^©

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

      ******************************************************************
      ** PROGRAM:    OSCICS8C  TRAN:SY8C....
      **
      ** THIS PROGRAM IS A THE OPEN SERVER VERSION OF RSP8C.  RECEIVES
      ** A TEXT INPUT STRING(10,000 BYTES) AND RETURNS IT IN A 50 BYTE
      ** COLUMN ONE ROW AT A TIME...
      ** Example: exec sy8c 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx'
      ******************************************************************

      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  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 VALUE +0.
          05  J                       PIC S9(4) COMP VALUE +0.

      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.

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

      01  WS-INPUT-LEN                PIC s9(9) COMP VALUE +10000.
      01  WS-INPUT-DATA-HDR.
          03  WS-INPUT-DATA           PIC X(10000)   VALUE SPACES.
          03  WS-INPUT-REDEFINE REDEFINES WS-INPUT-DATA.
              05  WS-INPUT-TABLE OCCURS 10000 TIMES.
                  10  WS-INPUT-CHAR    PIC X.


      01  WS-OUTPUT-DATA-HDR.
          03  WS-OUTPUT-DATA           PIC X(50)   VALUE SPACES.
          03  WS-OUTPUT-REDEFINE REDEFINES WS-OUTPUT-DATA.
              05  WS-OUTPUT-TABLE OCCURS 50 TIMES.
                  10  WS-OUTPUT-CHAR    PIC X.

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

      ******************************************************************
      * 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  9(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  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 RECEIVE THE
      * RPC PARM........
      ******************************************************

      *==> 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
      ****************************************************************

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

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

      *---> More than one pump back a message        <---*

          IF GWL-NUMPRM-PARMS not = +1 THEN
             MOVE 'Invalid Number of Parameters'
                                 TO WS-MSG-TEXT
             MOVE GWL-RC         TO WS-MSG-RC
             MOVE 'TDNUMPRM'     TO WS-MSG-FUNC
             PERFORM 920-SEND-MESSAGE THRU 920-EXIT
             PERFORM 910-ERR-PROCESS  THRU 910-EXIT
          END-IF

      *---> Get that parm into into the host varible <---*

          IF GWL-NUMPRM-PARMS = +1 THEN
             CALL 'TDRCVPRM' USING GWL-PROC, GWL-RC,
                                   GWL-NUMPRM-PARMS,
                                   WS-INPUT-DATA,
                                   TDSLONGVARCHAR,
                                   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
                PERFORM 920-SEND-MESSAGE THRU 920-EXIT
                PERFORM 910-ERR-PROCESS  THRU 910-EXIT
             END-IF
          END-IF.
      200-EXIT.
          EXIT.
      300-PROCESS-OUTPUT.
      ****************************************************************
      * BREAK UP THE 10K INPUT FIELDS INTO A 50 BYTE COLUMN AND SEND
      ****************************************************************

          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
             PERFORM 920-SEND-MESSAGE THRU 920-EXIT
             PERFORM 910-ERR-PROCESS  THRU 910-EXIT
          END-IF.


          PERFORM VARYING I FROM 1 BY 1 UNTIL I > GWL-ACTUAL-LEN
             COMPUTE J = J + 1
             MOVE WS-INPUT-CHAR(I)      TO WS-OUTPUT-CHAR(J)
             IF J = 50
             THEN
                PERFORM 310-SEND-ROW     THRU 310-EXIT
                MOVE ZERO                TO   J
                MOVE SPACES              TO   WS-OUTPUT-DATA
             END-IF
          END-PERFORM.
          IF J > ZERO
             THEN PERFORM 310-SEND-ROW     THRU 310-EXIT.

      300-EXIT.
          EXIT.
      310-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
             PERFORM 920-SEND-MESSAGE THRU 920-EXIT
             PERFORM 910-ERR-PROCESS  THRU 910-EXIT
          END-IF.

      310-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.
          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-MSG   TO GWL-MSG-LEN.
          CALL 'TDSNDMSG' USING GWL-PROC, GWL-RC, TDS-ERROR-MSG,
                               MSG-NR, TDS-ERROR-SEV, TDS-ZERO,
                               TDS-ZERO, EIBTRNID, GWL-TRAN-LEN,
                               WS-MSG, GWL-MSG-LEN.

      920-EXIT.
          EXIT.

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

      980-EXIT.
          EXIT.

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

          EXEC CICS
               RETURN
          END-EXEC.

      990-EXIT.
          EXIT.

¤ Dauer der Verarbeitung: 0.7 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.