|
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 *
* ------------------------------------------------------------- *
¤ Dauer der Verarbeitung: 0.34 Sekunden
(vorverarbeitet)
¤
|
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.
|
