Quellcode-Bibliothek csq4cvk1.cob   Sprache: Cobol

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