Quellcode-Bibliothek

^© Kompilation durch diese Firma

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

Datei: csq4cvk1.cob Sprache: Cobol

Original von: verschiedene^©

CBL XOPTS(ANSI85)
CBL NODYNAM,LIB,OBJECT,RENT,RES,APOST
      *                                                               *
      * ------------------------------------------------------------- *
       IDENTIFICATION DIVISION.
      * ------------------------------------------------------------- *
       PROGRAM-ID. CSQ4CVK1.
      *REMARKS
      *****************************************************************
      *   @START_COPYRIGHT@                                           *
      *   Statement:     Licensed Materials - Property of IBM         *
      *                                                               *
      *                  5695-137                                     *
      *                  (C) Copyright IBM Corporation. 1993, 1997    *
      *                                                               *
      *   Status:        Version 1 Release 2                          *
      *   @END_COPYRIGHT@                                             *
      *                                                               *
      *  Module Name           : CSQ4CVK1                             *
      *                                                               *
      *  Environment           : CICS/ESA Version 3.3; COBOL II       *
      *                                                               *
      *  CICS Transaction Name : MVPT                                 *
      *                                                               *
      *  Description : Sample program to put a number of messages     *
      *                to a queue.                                    *
      *                                                               *
      *  Note        : The maximum message length is 65535. Messages  *
      *                greater than this will not cause an error but  *
      *                will be truncated.                             *
      *                                                               *
      *****************************************************************
      *                                                               *
      *                       Program  Logic                          *
      *                       --------------                          *
      *                                                               *
      *  main                                                         *
      *  ----                                                         *
      *                                                               *
      *   Receive the parameter list from CICS.                       *
      *   If parameter list is invalid then                           *
      *            Call USAGE-ERROR and exit.                         *
      *                                                               *
      *   Setup message buffer.                                       *
      *                                                               *
      *   Open the specified message queue (MQOPEN).                  *
      *   If open failed then                                         *
      *            Call DISPLAY-ERROR-MESSAGE and exit.               *
      *                                                               *
      *   Set the put message options.                                *
      *   Loop while the messages are put to queue                    *
      *            Put message to queue (MQPUT)                       *
      *            If put failed                                      *
      *                     Call DISPLAY-MESSAGE                      *
      *                     Break from loop                           *
      *            Endif                                              *
      *   Endloop.                                                    *
      *   If no error occurred                                        *
      *      Display number of messages put to the queue.             *
      *   Endif                                                       *
      *                                                               *
      *   Close the message queue.                                    *
      *   If close failed then                                        *
      *            Call DISPLAY-ERROR-MESSAGE.                        *
      *                                                               *
      *   Return control to CICS.                                     *
      *                                                               *
      *                                                               *
      *---------------------------------------------------------------*
      *                                                               *
      *  USAGE-ERROR                                                  *
      *  -----------                                                  *
      *                                                               *
      *   Print message showing correct usage for program.            *
      *                                                               *
      *                                                               *
      *---------------------------------------------------------------*
      *                                                               *
      *  DISPLAY-ERROR-MESSAGE                                        *
      *  ---------------------                                        *
      *                                                               *
      *   Create error message.                                       *
      *   Print error message to CICS screen.                         *
      *                                                               *
      *                                                               *
      *---------------------------------------------------------------*
      *                                                               *
      *  DISPLAY-MESSAGE                                              *
      *  ---------------                                              *
      *                                                               *
      *   Sends valid message to CICS screen.                         *
      *                                                               *
      *                                                               *
      *****************************************************************
      * ------------------------------------------------------------- *
       ENVIRONMENT DIVISION.
      * ------------------------------------------------------------- *
      * ------------------------------------------------------------- *
       DATA DIVISION.
      * ------------------------------------------------------------- *
       FILE SECTION.
      * ------------------------------------------------------------- *
       WORKING-STORAGE SECTION.
      * ------------------------------------------------------------- *
      *
      *    W00 - General work fields
      *
       01  W00-RETURN-CODE             PIC S9(4) BINARY VALUE ZERO.
       01  W00-LOOP                    PIC S9(9) BINARY VALUE 0.
       01  W00-NUMPUTS-CHAR            PIC X(9) VALUE SPACES.
       01  W00-NUMPUTS                 PIC S9(9) BINARY VALUE 0.
       01  W00-ERROR-MESSAGE           PIC X(10) VALUE SPACES.
       01  W00-MESSAGE                 PIC X(80) VALUE SPACES.
      *
      *   Parameter variables
      *
       01  W00-PARM-LEN                PIC S9(03) BINARY.
       01  W00-PARM-STRING.
         02  W00-PARM-STRING-ARRAY       PIC X(1) OCCURS 100 TIMES.
      *
       01  W00-TRANSNAME               PIC X(8) VALUE ' '.
       01  W00-QNAME                   PIC X(48) VALUE SPACES.
       01  W00-PADCHAR                 PIC X(1) VALUE '*'.
       01  W00-MSGBUFFER.
         02  W00-MSGBUFFER-ARRAY         PIC X(1) OCCURS 65535 TIMES.
       01  W00-NUMMSGS-CHAR            PIC X(4) VALUE SPACES.
       01  W00-NUMMSGS                 PIC S9(9) BINARY VALUE 1.
       01  W00-MSGLENGTH-CHAR          PIC X(4) VALUE SPACES.
       01  W00-MSGLENGTH               PIC S9(9) BINARY VALUE 100.
       01  W00-PERSISTENCE             PIC X(1) VALUE 'N'.
           88 PERSISTENT     VALUE 'P'.
           88 NOT-PERSISTENT VALUE 'N'.
      *
      *    W03 - API fields
      *
       01  W03-HCONN                   PIC S9(9) BINARY VALUE ZERO.
       01  W03-HOBJ                    PIC S9(9) BINARY VALUE ZERO.
       01  W03-OPENOPTIONS             PIC S9(9) BINARY VALUE ZERO.
       01  W03-COMPCODE                PIC S9(9) BINARY VALUE ZERO.
       01  W03-COMPCODE-CHAR           PIC X(9) VALUE SPACES.
       01  W03-REASON                  PIC S9(9) BINARY VALUE ZERO.
       01  W03-REASON-CHAR             PIC X(9) VALUE SPACES.
      *
      *    API control blocks
      *
       01  MQM-OBJECT-DESCRIPTOR.
           COPY CMQODV.
       01  MQM-MESSAGE-DESCRIPTOR.
           COPY CMQMDV.
       01  MQM-PUT-MESSAGE-OPTIONS.
           COPY CMQPMOV.
      *
      *    MQV contains constants (for filling in the control blocks)
      *    and return codes (for testing the result of a call)
      *
       01  MQM-CONSTANTS.
           COPY CMQV SUPPRESS.
      *
      *    DFHAID contains the constants used for checking for
      *    attention identifiers
      *
       COPY DFHAID SUPPRESS.
      *
      *
      * ------------------------------------------------------------- *
       LINKAGE SECTION.
      * ------------------------------------------------------------- *
           EJECT
      * ------------------------------------------------------------- *
       PROCEDURE DIVISION.
      * ------------------------------------------------------------- *
      * ------------------------------------------------------------- *
       A-MAIN SECTION.
      * ------------------------------------------------------------- *
      *
      *   Receive the parameter list passed in by CICS
      *
           MOVE SPACES TO W00-PARM-STRING.
           EXEC CICS IGNORE CONDITION LENGERR END-EXEC.
           EXEC CICS RECEIVE
                     INTO( W00-PARM-STRING )
                     LENGTH( W00-PARM-LEN )
           END-EXEC.
      *
      *    If parameter list invalid then call USAGE-ERROR
      *    and exit
      *
           IF (W00-PARM-LEN < 20) THEN
              PERFORM USAGE-ERROR
              MOVE 8 TO W00-RETURN-CODE
              GO TO A-MAIN-END
           END-IF.
      *
           IF ((W00-PARM-STRING-ARRAY(5)  NOT = ',') OR
               (W00-PARM-STRING-ARRAY(10) NOT = ',') OR
               (W00-PARM-STRING-ARRAY(12) NOT = ',') OR
               (W00-PARM-STRING-ARRAY(17) NOT = ',') OR
               (W00-PARM-STRING-ARRAY(19) NOT = ',')) THEN
      *
              PERFORM USAGE-ERROR
              MOVE 8 TO W00-RETURN-CODE
              GO TO A-MAIN-END
           END-IF.
      *
      *    Move parameters into corresponding variables
      *
           UNSTRING W00-PARM-STRING DELIMITED BY ALL ','
                        INTO W00-TRANSNAME
                             W00-NUMMSGS-CHAR
                             W00-PADCHAR
                             W00-MSGLENGTH-CHAR
                             W00-PERSISTENCE
                             W00-QNAME.
           MOVE W00-MSGLENGTH-CHAR TO W00-MSGLENGTH.
           MOVE W00-NUMMSGS-CHAR   TO W00-NUMMSGS.
      *
      *
      *    Setup the message buffer
      *
           PERFORM WITH TEST BEFORE VARYING W00-LOOP FROM 1 BY 1
               UNTIL (W00-LOOP > W00-MSGLENGTH)
      *
               MOVE W00-PADCHAR TO W00-MSGBUFFER-ARRAY(W00-LOOP)
      *
           END-PERFORM.
      *
      *
      *
      *    Open the queue for output
      *
           MOVE MQOO-OUTPUT TO W03-OPENOPTIONS.
           MOVE W00-QNAME   TO MQOD-OBJECTNAME.
      *
           CALL 'MQOPEN' USING W03-HCONN
                               MQOD
                               W03-OPENOPTIONS
                               W03-HOBJ
                               W03-COMPCODE
                               W03-REASON.
      *
      *    If open failed then display error message and exit
      *
           IF (W03-COMPCODE NOT = MQCC-OK) THEN
              MOVE 'MQOPEN'   TO W00-ERROR-MESSAGE
              PERFORM DISPLAY-ERROR-MESSAGE
              MOVE W03-REASON TO W00-RETURN-CODE
              GO TO A-MAIN-END
           END-IF.
      *
      *
      *    Set persistence depending on parameter passed
      *
           IF PERSISTENT THEN
              MOVE MQPER-PERSISTENT     TO MQMD-PERSISTENCE
           ELSE
              MOVE MQPER-NOT-PERSISTENT TO MQMD-PERSISTENCE
           END-IF.
      *
      *    Loop until specified number of messages put to queue
      *
           PERFORM WITH TEST BEFORE VARYING W00-LOOP FROM 0 BY 1
               UNTIL (W00-LOOP >= W00-NUMMSGS)
      *
               MOVE MQMI-NONE TO MQMD-MSGID
               MOVE MQCI-NONE TO MQMD-CORRELID
      *
               CALL 'MQPUT' USING W03-HCONN
                                  W03-HOBJ
                                  MQMD
                                  MQPMO
                                  W00-MSGLENGTH
                                  W00-MSGBUFFER
                                  W03-COMPCODE
                                  W03-REASON
      *
      *    If put failed then display error message
      *    and break out of loop
      *
               ADD 1 TO W00-NUMPUTS
               IF (W03-COMPCODE NOT = MQCC-OK) THEN
                   MOVE W00-NUMPUTS TO W00-NUMPUTS-CHAR
                   MOVE W03-COMPCODE TO W03-COMPCODE-CHAR
                   MOVE W03-REASON   TO W03-REASON-CHAR
      *
                   MOVE SPACES TO W00-MESSAGE
                   STRING 'MQPUT ', W00-NUMPUTS-CHAR, ' failed'
                          ' * CC : ', W03-COMPCODE-CHAR,
                          ' * RC : ', W03-REASON-CHAR, ' *'
                          DELIMITED BY SIZE INTO W00-MESSAGE
                   PERFORM DISPLAY-MESSAGE
      *
                   MOVE W00-NUMMSGS TO W00-LOOP
                   MOVE W03-REASON  TO W00-RETURN-CODE
               END-IF
      *
           END-PERFORM.
      *
      *    If no error occurred, display the number of messages
      *    successfully put to the queue
      *
           IF (W03-COMPCODE = MQCC-OK) THEN
               MOVE W00-NUMPUTS TO W00-NUMPUTS-CHAR
               MOVE SPACES TO W00-MESSAGE
               STRING W00-NUMPUTS-CHAR, ' MESSAGES PUT TO QUEUE'
                      DELIMITED BY SIZE INTO W00-MESSAGE
               PERFORM DISPLAY-MESSAGE
           END-IF
      *
      *
      *
      *
      *    Close the queue
      *
           CALL 'MQCLOSE' USING W03-HCONN
                                W03-HOBJ
                                MQCO-NONE
                                W03-COMPCODE
                                W03-REASON.
           IF (W03-COMPCODE NOT = MQCC-OK) THEN
              MOVE 'MQCLOSE'  TO W00-ERROR-MESSAGE
              PERFORM DISPLAY-ERROR-MESSAGE
              MOVE W03-REASON TO W00-RETURN-CODE
           END-IF.
      *
      *
      *
       A-MAIN-END.
      *
      *
           MOVE W00-RETURN-CODE TO RETURN-CODE
           EXEC CICS RETURN END-EXEC.
      *
           GOBACK.
           EJECT
      *
      * ------------------------------------------------------------- *
       USAGE-ERROR SECTION.
      * ------------------------------------------------------------- *
      *
           MOVE SPACES TO W00-MESSAGE.
           MOVE '=Usage : MVPT,9999,*,9999,P,QUEUE.NAME=' TO
                                                      W00-MESSAGE.
           PERFORM DISPLAY-MESSAGE.
      *
       USAGE-ERROR-END.
      *
      *    RETURN TO PERFORMING FUNCTION
      *
           EXIT.
      *
      * ------------------------------------------------------------- *
       DISPLAY-ERROR-MESSAGE SECTION.
      * ------------------------------------------------------------- *
      *
           MOVE W03-COMPCODE TO W03-COMPCODE-CHAR.
           MOVE W03-REASON   TO W03-REASON-CHAR.
      *
           MOVE SPACES TO W00-MESSAGE.
           STRING '* ', W00-ERROR-MESSAGE,
                  ' * CC : ', W03-COMPCODE-CHAR,
                  ' * RC : ', W03-REASON-CHAR, ' *'
                  DELIMITED BY SIZE INTO W00-MESSAGE.
           PERFORM DISPLAY-MESSAGE.
      *
       DISPLAY-ERROR-MESSAGE-END.
      *
      *    RETURN TO PERFORMING FUNCTION
      *
           EXIT.
      *
      * ------------------------------------------------------------- *
       DISPLAY-MESSAGE SECTION.
      * ------------------------------------------------------------- *
      *
           EXEC CICS SEND
                     FROM( W00-MESSAGE )
                     LENGTH( 79 )
                     ERASE
           END-EXEC.
           MOVE SPACES TO W00-MESSAGE.
      *
       DISPLAY-MESSAGE-END.
      *
      *    RETURN TO PERFORMING FUNCTION
      *
           EXIT.
      *
      *
      * ------------------------------------------------------------- *
      *                        END OF PROGRAM
      * ------------------------------------------------------------- *

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