Quelle  csq4cvc1.cob   Sprache: Cobol

CBL XOPTS(ANSI85)
CBL NODYNAM,LIB,OBJECT,RENT,RES,APOST
      * ------------------------------------------------------------- *
       IDENTIFICATION DIVISION.
      * ------------------------------------------------------------- *
       PROGRAM-ID. CSQ4CVC1.
      *REMARKS
      *****************************************************************
      * @START_COPYRIGHT@                                             *
      *   Statement:     Licensed Materials - Property of IBM         *
      *                                                               *
      *                  5695-137                                     *
      *                  (C) Copyright IBM Corporation. 1993, 1997    *
      *                                                               *
      *   Status:        Version 1 Release 2                          *
      * @END_COPYRIGHT@                                               *
      *                                                               *
      * ************************************************************* *
      *                                                               *
      *  Product Number        : 5695-137                             *
      *                                                               *
      *  Module Name           : CSQ4CVC1                             *
      *                                                               *
      *  Environment           : CICS/ESA Version 3.3; COBOL II       *
      *                                                               *
      *  CICS Transaction Name : MVC1                                 *
      *                                                               *
      *  Description : Sample program to set and inquire about        *
      *                two queue attributes                           *
      *                                                               *
      *  Function    : This program allows the user to set and        *
      *                inquire about the INHIBIT-PUT and INHIBIT-GET  *
      *                attributes of a local queue                    *
      *                                                               *
      *  Restriction : The queue name must start with 'CSQ4SAMP'.     *
      *                This is to avoid any accidental interference   *
      *                with the queues at the user's installation     *
      *                                                               *
      * ************************************************************* *
      *                                                               *
      *                    Program logic                              *
      *                    -------------                              *
      *                                                               *
      *   Start    (A-MAIN SECTION)                                   *
      *   -----                                                       *
      *                                                               *
      *       Do while PF3 key is not pressed                         *
      *                                                               *
      *          Display the screen map and wait for input data       *
      *                                                               *
      *          If Help (PF1) key pressed                            *
      *             Perform DISPLAY-HELP                              *
      *          Else if Enter key pressed                            *
      *             If queue name does not begin with 'CSQ4SAMP'      *
      *                build error message                            *
      *             Else                                              *
      *                Evaluate request                               *
      *                   When 'INQUIRE'  perform INQUIRY             *
      *                   When 'INHIBIT'  perform INHIBIT             *
      *                   When 'ALLOW'    perform ALLOW               *
      *                   Otherwise build error message               *
      *                End-evaluate                                   *
      *             End-if                                            *
      *          Else                                                 *
      *             Do nothing                                        *
      *          End-if                                               *
      *                                                               *
      *       End-do                                                  *
      *                                                               *
      *   Exit                                                        *
      *   ----                                                        *
      *                                                               *
      *       Clear the screen                                        *
      *       Return to CICS                                          *
      *                                                               *
      *   Inquiry  (B-INQUIRY SECTION)                                *
      *   -------                                                     *
      *                                                               *
      *       Perform open (E-OPEN-QUEUE)                             *
      *       If open is successful                                   *
      *          Inquire about INHIBIT-GET and INHIBIT-PUT attributes *
      *             If inquire is successful                          *
      *                Build response screen                          *
      *             Else                                              *
      *                Build error message                            *
      *             End-if                                            *
      *          Perform close (F-CLOSE-QUEUE)                        *
      *       End-if                                                  *
      *                                                               *
      *   Inhibit  (C-INHIBIT SECTION)                                *
      *   -------                                                     *
      *                                                               *
      *       Perform open (E-OPEN-QUEUE)                             *
      *       If open is successful                                   *
      *          Set INHIBIT-GET attribute to GET-INHIBITED           *
      *          Set INHIBIT-PUT attribute to PUT-INHIBITED           *
      *          If set is successful                                 *
      *             Build response screen                             *
      *          Else                                                 *
      *             Build error message                               *
      *          End-if                                               *
      *          Perform close (F-CLOSE-QUEUE)                        *
      *       End-if                                                  *
      *                                                               *
      *   Allow    (D-ALLOW SECTION)                                  *
      *   -----                                                       *
      *                                                               *
      *       Perform open (E-OPEN-QUEUE)                             *
      *       If open is successful                                   *
      *          Set INHIBIT-GET attribute to GET-ALLOWED             *
      *          Set INHIBIT-PUT attribute to PUT-ALLOWED             *
      *          If set is successful                                 *
      *             Build response screen                             *
      *          Else                                                 *
      *             Build error message                               *
      *          End-if                                               *
      *          Perform close (F-CLOSE-QUEUE)                        *
      *       End-if                                                  *
      *                                                               *
      *   Open     (E-OPEN-QUEUE SECTION)                             *
      *   ----                                                        *
      *                                                               *
      *       Initialize the object descriptor (MQOD)                 *
      *       Set the open options for inquire and set                *
      *       Open the queue                                          *
      *          If open is not successful                            *
      *             Build error message                               *
      *          End-if                                               *
      *                                                               *
      *   Close    (F-CLOSE-QUEUE SECTION)                            *
      *   -----                                                       *
      *                                                               *
      *       Close the queue                                         *
      *          If close is not successful                           *
      *             Build error message                               *
      *          End-if                                               *
      *                                                               *
      *   Display help (DISPLAY-HELP SECTION)                         *
      *   ------------                                                *
      *                                                               *
      *      Do until PF12 key is pressed                             *
      *         Exec CICS send help screen map                        *
      *         Exec CICS receive help screen map                     *
      *      End-do                                                   *
      *                                                               *
      *      Return to performing section                             *
      *                                                               *
      * ************************************************************* *
      * ------------------------------------------------------------- *
       ENVIRONMENT DIVISION.
      * ------------------------------------------------------------- *
      * ------------------------------------------------------------- *
       DATA DIVISION.
      * ------------------------------------------------------------- *
      * ------------------------------------------------------------- *
       WORKING-STORAGE SECTION.
      * ------------------------------------------------------------- *
      *
      *    W00 - General work fields
      *
       01  W00-MAPSETID                PIC X(08)  VALUE 'CSQ4VCM'.
       01  W00-MAPID                   PIC X(08)  VALUE 'CSQ4VC1'.
       01  W00-MAPIDHLP                PIC X(08)  VALUE 'CSQ4VC2'.
      *
      *    W01 - Fields derived from the command area input
      *
       01  W01-ACTION                  PIC X(08).
       01  W01-OBJECT                  PIC X(48).
      *
      *    W02 - MQM API fields
      *
       01  W02-SELECTORCOUNT           PIC S9(9) BINARY VALUE 2.
       01  W02-INTATTRCOUNT            PIC S9(9) BINARY VALUE 2.
       01  W02-CHARATTRLENGTH          PIC S9(9) BINARY VALUE ZERO.
       01  W02-CHARATTRS               PIC X     VALUE LOW-VALUES.
       01  W02-HCONN                   PIC S9(9) BINARY VALUE ZERO.
       01  W02-OPTIONS                 PIC S9(9) BINARY.
       01  W02-HOBJ                    PIC S9(9) BINARY.
       01  W02-COMPCODE                PIC S9(9) BINARY.
       01  W02-REASON                  PIC S9(9) BINARY.
       01  W02-SELECTORS-TABLE.
           05  W02-SELECTORS           PIC S9(9) BINARY OCCURS 2 TIMES.
       01  W02-INTATTRS-TABLE.
           05  W02-INTATTRS            PIC S9(9) BINARY OCCURS 2 TIMES.
      *
      *    CSQ4VMSG contains error messages used by sample programs
      *
       COPY CSQ4VMSG.
      *
      *    CMQODV defines the object descriptor (MQOD)
      *
       01  MQM-OBJECT-DESCRIPTOR.
           COPY CMQODV.
      *
      *    CMQV contains constants (for setting or testing field values)
      *    and return codes (for testing the result of a call)
      *
       01  MQM-CONSTANTS.
       COPY CMQV SUPPRESS.
      *
      *    CSQ4VCM defines the screen maps used by the sample programs
      *
       COPY CSQ4VCM.
      *
      *    DFHAID contains the constants used for checking for
      *    attention identifiers
      *
       COPY DFHAID SUPPRESS.
      *
      * ------------------------------------------------------------- *
       LINKAGE SECTION.
      * ------------------------------------------------------------- *
      *
       EJECT
      * ------------------------------------------------------------- *
       PROCEDURE DIVISION.
      * ------------------------------------------------------------- *
      * ------------------------------------------------------------- *
       A-MAIN SECTION.
      * ------------------------------------------------------------- *
      *                                                               *
      * This section handles the interaction between the user and the *
      * program                                                       *
      *                                                               *
      * The program enters a loop which sends the screen map,         *
      * receives the screen, and validates the data.  A help screen   *
      * can be called from the screen. One of three sections is       *
      * performed, depending on the action selected by the user       *
      *                                                               *
      * ------------------------------------------------------------- *
      *
      *    Clear the output message field and initialize the map
      *
           MOVE SPACES     TO M00-MESSAGE.
           MOVE LOW-VALUES TO CSQ4VC1O.
           MOVE EIBTRNID   TO QTRNIDO.
           MOVE EIBTRNID   TO QTRNHO.
      *
           EXEC CICS IGNORE CONDITION
                     MAPFAIL
           END-EXEC.
      *
      *    Loop from here to END-PERFORM until the PF3 key is pressed
      *
           PERFORM WITH TEST BEFORE UNTIL (EIBAID = DFHPF3   OR
                                           EIBAID = DFHPF15)
      *
      *        Move the message field into the corresponding
      *        screen map field
      *
               MOVE M00-MESSAGE TO VC1MSGO
      *
      *        Send the screen map, then receive it
      *
               EXEC CICS SEND
                         MAP(W00-MAPID)
                         MAPSET(W00-MAPSETID)
                         FROM(CSQ4VC1O)
                         ERASE
               END-EXEC
      *
               EXEC CICS RECEIVE
                         MAP(W00-MAPID)
                         MAPSET(W00-MAPSETID)
                         INTO(CSQ4VC1I)
               END-EXEC
      *
               MOVE SPACES TO M00-MESSAGE
      *
               EVALUATE TRUE
                   WHEN EIBAID = DFHPF1 OR EIBAID = DFHPF13
                       PERFORM DISPLAY-HELP
      *
                   WHEN EIBAID = DFHENTER
      *
      *                Move the screen map fields into the
      *                corresponding working storage fields
      *
                       MOVE QACTNI TO W01-ACTION
                       MOVE QNAMEI TO W01-OBJECT
      *
      * ---------------------------------------------------------- *
      *                 START OF RESTRICTION
      *
      *   W01-OBJECT - The first 8 bytes must contain 'CSQ4SAMP'
      *
      *   To remove this restriction, delete the next three lines
      *   and the one indicated after END-EVALUATE
      *
                       IF W01-OBJECT(1:8) NOT = 'CSQ4SAMP' THEN
                           MOVE M01-MESSAGE-5 TO M00-MESSAGE
                       ELSE
      *
      *                 END OF RESTRICTION
      * ---------------------------------------------------------- *
      *
      *                    Process depending on the action
      *                    entered by the user
      *
                           EVALUATE TRUE
                               WHEN W01-ACTION = 'INQUIRE'
                                   PERFORM B-INQUIRY
                               WHEN W01-ACTION = 'INHIBIT'
                                   PERFORM C-INHIBIT
                               WHEN W01-ACTION = 'ALLOW'
                                   PERFORM D-ALLOW
                               WHEN OTHER
                                   MOVE M01-MESSAGE-1 TO M00-MESSAGE
                                   MOVE -1 TO QACTNL
                           END-EVALUATE
      *
      * ------------------------------------------------------------- *
      *                 START OF RESTRICTION
      *
      *   Remove the next line (END-IF) if you remove the restriction
      *   above
      *
                       END-IF
      *
      *                 END OF RESTRICTION
      * ------------------------------------------------------------- *
               END-EVALUATE
           END-PERFORM.
      *
      *    Clear the screen, reset the keyboard and send the
      *    termination message
      *
           MOVE M01-MESSAGE-7 TO M00-MESSAGE.
      *
           EXEC CICS SEND
                     TEXT
                     NOEDIT
                     FROM(M00-MESSAGE)
                     FREEKB
                     ERASE
           END-EXEC.
      *
      * Return to CICS
      *
           EXEC CICS RETURN
           END-EXEC.
      *
           GOBACK.
           EJECT
      *
      * ------------------------------------------------------------- *
       B-INQUIRY SECTION.
      * ------------------------------------------------------------- *
      *                                                               *
      * This section inquires about the INHIBIT-GET and INHIBIT-PUT   *
      * attributes of the queue.  The results are displayed by A-MAIN,*
      * on return                                                     *
      *                                                               *
      * ------------------------------------------------------------- *
      *
      *    Open the queue
      *
           PERFORM E-OPEN-QUEUE.
      *
      *    Test for an error.  If an error occurred, exit
      *
           IF W02-COMPCODE NOT = MQCC-OK
              GO TO B-INQUIRY-EXIT
           END-IF.
      *
      *    Set the variables for the call
      *     - Set W02-SELECTORS-TABLE to the attributes whose status is
      *        required
      *     - All other variables are already initialized
      *
           MOVE MQIA-INHIBIT-GET TO W02-SELECTORS(1).
           MOVE MQIA-INHIBIT-PUT TO W02-SELECTORS(2).
      *
      *    Inquire on the attributes
      *
           CALL 'MQINQ' USING W02-HCONN
                              W02-HOBJ
                              W02-SELECTORCOUNT
                              W02-SELECTORS-TABLE
                              W02-INTATTRCOUNT
                              W02-INTATTRS-TABLE
                              W02-CHARATTRLENGTH
                              W02-CHARATTRS
                              W02-COMPCODE
                              W02-REASON.
      *
      *    Test the output from the call:
      *
      *     - If the completion code is not OK, display an error
      *       message showing the completion and reason codes
      *
      *     - Otherwise, move the correct attribute status into
      *       the relevant screen map fields
      *
           IF W02-COMPCODE NOT = MQCC-OK
              MOVE 'MQINQ'       TO M01-MSG4-OPERATION
              MOVE W02-COMPCODE  TO M01-MSG4-COMPCODE
              MOVE W02-REASON    TO M01-MSG4-REASON
              MOVE M01-MESSAGE-4 TO M00-MESSAGE
      *
           ELSE
      *
              IF W02-INTATTRS(1) = MQQA-GET-ALLOWED
                 MOVE 'ALLOWED'   TO QGSTATO
              ELSE
                 MOVE 'INHIBITED' TO QGSTATO
              END-IF
      *
              IF W02-INTATTRS(2) = MQQA-PUT-ALLOWED
                 MOVE 'ALLOWED'   TO QPSTATO
              ELSE
                 MOVE 'INHIBITED' TO QPSTATO
              END-IF
           END-IF.
      *
      *    Close the queue
      *
           PERFORM F-CLOSE-QUEUE.
      *
       B-INQUIRY-EXIT.
      *
      *    Return to A-MAIN
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       C-INHIBIT SECTION.
      * ------------------------------------------------------------- *
      *                                                               *
      * This section changes the INHIBIT-GET and INHIBIT-PUT          *
      * attributes of the queue to 'INHIBITED'                        *
      *                                                               *
      * ------------------------------------------------------------- *
      *
      *    Open the queue
      *
           PERFORM E-OPEN-QUEUE.
      *
      *    Test for an error.  If an error occurred, exit
      *
           IF W02-COMPCODE NOT = MQCC-OK
              GO TO C-INHIBIT-EXIT
           END-IF.
      *
      *    Set the variables required for the call
      *     - Set W02-SELECTORS-TABLE to the required attributes
      *     - Set W02-INTATTRS-TABLE  to the required status
      *     - All other variables are already initialized
      *
           MOVE MQIA-INHIBIT-GET   TO W02-SELECTORS(1).
           MOVE MQIA-INHIBIT-PUT   TO W02-SELECTORS(2).
           MOVE MQQA-GET-INHIBITED TO W02-INTATTRS(1).
           MOVE MQQA-PUT-INHIBITED TO W02-INTATTRS(2).
      *
      *    Set the attributes
      *
           CALL 'MQSET' USING W02-HCONN
                              W02-HOBJ
                              W02-SELECTORCOUNT
                              W02-SELECTORS-TABLE
                              W02-INTATTRCOUNT
                              W02-INTATTRS-TABLE
                              W02-CHARATTRLENGTH
                              W02-CHARATTRS
                              W02-COMPCODE
                              W02-REASON.
      *
      *    Test the output from the call:
      *
      *     - If the completion code is not OK, display an error
      *       message showing the completion and reason codes
      *
      *     - Otherwise, move 'INHIBITED' into the relevant screen map
      *       fields
      *
           IF W02-COMPCODE NOT = MQCC-OK
              MOVE 'MQSET'       TO M01-MSG4-OPERATION
              MOVE W02-COMPCODE  TO M01-MSG4-COMPCODE
              MOVE W02-REASON    TO M01-MSG4-REASON
              MOVE M01-MESSAGE-4 TO M00-MESSAGE
           ELSE
              MOVE 'INHIBITED'   TO QGSTATO
              MOVE 'INHIBITED'   TO QPSTATO
           END-IF.
      *
      *    Close the queue
      *
           PERFORM F-CLOSE-QUEUE.
      *
       C-INHIBIT-EXIT.
      *
      *    Return to A-MAIN
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       D-ALLOW SECTION.
      * ------------------------------------------------------------- *
      *                                                               *
      * This section changes the INHIBIT-GET and INHIBIT-PUT          *
      * attributes of the queue to 'ALLOWED'                          *
      *                                                               *
      * ------------------------------------------------------------- *
      *
      *    Open the queue
      *
           PERFORM E-OPEN-QUEUE.
      *
      *    Test for an error.  If an error occurred, exit
      *
           IF W02-COMPCODE NOT = MQCC-OK
              GO TO D-ALLOW-EXIT
           END-IF.
      *
      *    Set the variables required for the call
      *     - Set W02-SELECTORS-TABLE to the required attributes
      *     - Set W02-INTATTRS-TABLE  to the required status
      *     - All other variables are already initialized
      *
           MOVE MQIA-INHIBIT-GET TO W02-SELECTORS(1).
           MOVE MQIA-INHIBIT-PUT TO W02-SELECTORS(2).
           MOVE MQQA-GET-ALLOWED TO W02-INTATTRS(1).
           MOVE MQQA-PUT-ALLOWED TO W02-INTATTRS(2).
      *
      *    Set the attributes
      *
           CALL 'MQSET' USING W02-HCONN
                              W02-HOBJ
                              W02-SELECTORCOUNT
                              W02-SELECTORS-TABLE
                              W02-INTATTRCOUNT
                              W02-INTATTRS-TABLE
                              W02-CHARATTRLENGTH
                              W02-CHARATTRS
                              W02-COMPCODE
                              W02-REASON.
      *
      *    Test the output from the call:
      *
      *     - If the completion code is not OK, display an error
      *       message showing the completion and reason codes
      *
      *     - Otherwise, move 'ALLOWED' into the relevant screen map
      *       fields
      *
           IF W02-COMPCODE NOT = MQCC-OK
              MOVE 'MQSET'       TO M01-MSG4-OPERATION
              MOVE W02-COMPCODE  TO M01-MSG4-COMPCODE
              MOVE W02-REASON    TO M01-MSG4-REASON
              MOVE M01-MESSAGE-4 TO M00-MESSAGE
           ELSE
              MOVE 'ALLOWED'     TO QGSTATO
              MOVE 'ALLOWED'     TO QPSTATO
           END-IF.
      *
      *    Close the queue
      *
           PERFORM F-CLOSE-QUEUE.
      *
       D-ALLOW-EXIT.
      *
      *    Return to A-MAIN
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       E-OPEN-QUEUE SECTION.
      * ------------------------------------------------------------- *
      *                                                               *
      * This section opens the queue                                  *
      *                                                               *
      * ------------------------------------------------------------- *
      *
      *    Initialize the Object Descriptor (MQOD) control block
      *    (the copy book initializes the remaining fields)
      *
           MOVE MQOT-Q         TO MQOD-OBJECTTYPE.
           MOVE W01-OBJECT     TO MQOD-OBJECTNAME.
      *
      *    Initialize W02-OPTIONS to open the queue for both inquiring
      *    about and setting attributes
      *
           COMPUTE W02-OPTIONS = MQOO-INQUIRE + MQOO-SET.
      *
      *    Open the queue
      *
           CALL 'MQOPEN' USING W02-HCONN
                               MQOD
                               W02-OPTIONS
                               W02-HOBJ
                               W02-COMPCODE
                               W02-REASON.
      *
      *    Test the output from the open.
      *    If the completion code is not OK, display an error message
      *
           IF W02-COMPCODE NOT = MQCC-OK
               EVALUATE TRUE
      *
                   WHEN W02-REASON = MQRC-Q-MGR-NOT-AVAILABLE
                       MOVE M01-MESSAGE-6 TO M00-MESSAGE
      *
                   WHEN W02-REASON = MQRC-CONNECTION-BROKEN
                       MOVE M01-MESSAGE-6 TO M00-MESSAGE
      *
                   WHEN W02-REASON = MQRC-UNKNOWN-OBJECT-NAME
                       MOVE M01-MESSAGE-2 TO M00-MESSAGE
      *
                   WHEN W02-REASON = MQRC-NOT-AUTHORIZED
                       MOVE M01-MESSAGE-3 TO M00-MESSAGE
      *
                   WHEN OTHER
                       MOVE 'MQOPEN'      TO M01-MSG4-OPERATION
                       MOVE W02-COMPCODE  TO M01-MSG4-COMPCODE
                       MOVE W02-REASON    TO M01-MSG4-REASON
                       MOVE M01-MESSAGE-4 TO M00-MESSAGE
               END-EVALUATE
           END-IF.
      *
       E-OPEN-QUEUE-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       F-CLOSE-QUEUE SECTION.
      * ------------------------------------------------------------- *
      *                                                               *
      * This section closes the queue                                 *
      *                                                               *
      * ------------------------------------------------------------- *
      *
      *    Close the queue
      *
           CALL 'MQCLOSE' USING W02-HCONN
                                W02-HOBJ
                                MQCO-NONE
                                W02-COMPCODE
                                W02-REASON.
      *
      *    Test the output from the close
      *
      *    If the completion code is not OK, display an error
      *    message showing the completion and reason codes
      *
           IF W02-COMPCODE NOT = MQCC-OK
               MOVE 'MQCLOSE'     TO M01-MSG4-OPERATION
               MOVE W02-COMPCODE  TO M01-MSG4-COMPCODE
               MOVE W02-REASON    TO M01-MSG4-REASON
               MOVE M01-MESSAGE-4 TO M00-MESSAGE
           END-IF.
      *
       F-CLOSE-QUEUE-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       DISPLAY-HELP SECTION.
      * ------------------------------------------------------------- *
      *                                                               *
      *  This section displays the help panel until PF12 is pressed   *
      *                                                               *
      * ------------------------------------------------------------- *
      *
           PERFORM WITH TEST BEFORE UNTIL EIBAID = DFHPF12
                                       OR EIBAID = DFHPF24
      *
               EXEC CICS SEND
                         MAP(W00-MAPIDHLP)
                         MAPSET(W00-MAPSETID)
                         FROM(CSQ4VC2O)
                         ERASE
               END-EXEC
      *
               EXEC CICS RECEIVE
                         MAP(W00-MAPIDHLP)
                         MAPSET(W00-MAPSETID)
                         INTO(CSQ4VC2I)
               END-EXEC
      *
           END-PERFORM.
      *
       DISPLAY-HELP-EXIT.
      *
           EXIT.
      *
      * ------------------------------------------------------------- *
      *                    End of program                             *
      * ------------------------------------------------------------- *