|
CBL XOPTS(ANSI85)
CBL NODYNAM,LIB,OBJECT,RENT,RES,APOST
* *
* ------------------------------------------------------------- *
IDENTIFICATION DIVISION.
* ------------------------------------------------------------- *
PROGRAM-ID. CSQ4CVJ1.
*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 : CSQ4CVJ1 *
* *
* Environment : CICS/ESA Version 3.3; COBOL II *
* *
* CICS Transaction Name : MVGT *
* *
* Description : Sample program to get a number of messages *
* from a queue. These messages are written to *
* a CICS temporary storage queue. *
* *
* Notes : The maximum message length is 9950. Messages *
* greater than this will not cause an error but *
* will be truncated. *
* The syncpoint option is ignored when browsing. *
* *
*****************************************************************
* *
* Program Logic *
* -------------- *
* *
* *
* MAIN *
* ---- *
* *
* Receive the parameter list from CICS. *
* If parameter list is invalid then *
* Call USAGE-ERROR and exit. *
* *
* Create a CICS temporary storage queue. *
* *
* Open the specified message queue (MQOPEN). *
* If open failed then *
* Call DISPLAY-ERROR-MESSAGE and exit. *
* *
* Set the get message options. *
* Loop while the messages are received *
* Get message from queue (MQGET) *
* If get failed *
* Call DISPLAY-MESSAGE *
* Break from loop *
* Else *
* Put the message to the CICS TSQ *
* Endif *
* Endloop. *
* If no error occurred *
* Display number of messages put to the queue. *
* Endif *
* *
* If syncpoint variable set then *
* Execute syncpoint. *
* *
* 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 variables
*
01 W00-RETURN-CODE PIC S9(4) BINARY VALUE ZERO.
01 W00-LOOP PIC S9(9) BINARY VALUE 0.
01 W00-LOOP-CHAR PIC X(9) VALUE SPACES.
01 W00-NUMGETS PIC S9(9) BINARY VALUE 0.
01 W00-NUMGETS-CHAR PIC X(9) VALUE SPACES.
01 W00-ERROR-MESSAGE PIC X(10) VALUE SPACES.
01 W00-MESSAGE PIC X(80) VALUE SPACES.
01 W00-TSQMESSAGE PIC X(9999) VALUE SPACES.
01 W00-TSQMESSAGE-LENGTH PIC S9(4) BINARY VALUE 0.
01 W00-MSGBUFFER.
02 W00-MSGBUFFER-ARRAY PIC X(1) OCCURS 9950 TIMES.
01 W00-DATALENGTH PIC S9(9) BINARY VALUE 0.
01 W00-DATALENGTH-CHAR PIC X(9) 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 SPACES.
01 W00-QNAME PIC X(48) VALUE SPACES.
01 W00-NUMMSGS-CHAR PIC X(4) VALUE SPACES.
01 W00-NUMMSGS PIC S9(9) BINARY VALUE 1.
01 W00-MSGLENGTH PIC S9(9) BINARY VALUE 9950.
01 W00-MSGLENGTH-CHAR PIC X(9) VALUE SPACES.
01 W00-BROWSE-GET PIC X(1) VALUE 'D'.
88 BROWSE-GET VALUE 'B'.
88 DESTRUCTIVE-GET VALUE 'D'.
01 W00-SYNCPOINT PIC X(1) VALUE 'N'.
88 SYNCPOINT VALUE 'S'.
88 NO-SYNCPOINT VALUE 'N'.
*
* W03 - API fields
*
01 W03-HCONN PIC S9(9) BINARY VALUE 0.
01 W03-HOBJ PIC S9(9) BINARY VALUE 0.
01 W03-OPENOPTIONS PIC S9(9) BINARY.
01 W03-COMPCODE PIC S9(9) BINARY.
01 W03-COMPCODE-CHAR PIC X(9) VALUE SPACES.
01 W03-REASON PIC S9(9) BINARY.
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-GET-MESSAGE-OPTIONS.
COPY CMQGMOV.
*
* 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 from CICS
*
MOVE SPACES TO W00-PARM-STRING.
*
EXEC CICS RECEIVE
INTO( W00-PARM-STRING )
LENGTH( W00-PARM-LEN )
END-EXEC.
*
*
* If parameter list is invalid then display
* error message and exit program
*
IF (W00-PARM-LEN < 15) 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(14) NOT = ',')) THEN
*
PERFORM USAGE-ERROR
MOVE 8 TO W00-RETURN-CODE
GO TO A-MAIN-END
END-IF.
*
UNSTRING W00-PARM-STRING DELIMITED BY ALL ','
INTO W00-TRANSNAME
W00-NUMMSGS-CHAR
W00-BROWSE-GET
W00-SYNCPOINT
W00-QNAME.
MOVE W00-NUMMSGS-CHAR TO W00-NUMMSGS.
*
* Create a CICS temporary storage queue to hold
* all the messages received from the queue
*
EXEC CICS IGNORE CONDITION QIDERR END-EXEC.
EXEC CICS IGNORE CONDITION LENGERR END-EXEC.
EXEC CICS DELETEQ TS QUEUE( W00-TRANSNAME ) END-EXEC.
*
*
*
* Open queue for input shared and browse
*
COMPUTE W03-OPENOPTIONS = MQOO-INPUT-SHARED +
MQOO-BROWSE.
MOVE W00-QNAME TO MQOD-OBJECTNAME.
*
CALL 'MQOPEN' USING W03-HCONN
MQOD
W03-OPENOPTIONS
W03-HOBJ
W03-COMPCODE
W03-REASON.
*
* If open failed 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.
*
*
*
* Setup MQGMO-OPTIONS depending on parameters passed
* into program.
*
COMPUTE MQGMO-OPTIONS = MQGMO-NO-WAIT +
MQGMO-ACCEPT-TRUNCATED-MSG.
IF SYNCPOINT AND DESTRUCTIVE-GET THEN
ADD MQGMO-SYNCPOINT TO MQGMO-OPTIONS
ELSE
ADD MQGMO-NO-SYNCPOINT TO MQGMO-OPTIONS
END-IF.
*
IF BROWSE-GET THEN
ADD MQGMO-BROWSE-FIRST TO MQGMO-OPTIONS
END-IF.
*
*
* Loop getting the messages.
* The message ID and Correl ID
* are blanked before each MQGET.
*
PERFORM WITH TEST BEFORE VARYING W00-LOOP FROM 0 BY 1
UNTIL (W00-LOOP >= W00-NUMMSGS)
*
MOVE SPACES TO W00-MSGBUFFER
MOVE MQMI-NONE TO MQMD-MSGID
MOVE MQCI-NONE TO MQMD-CORRELID
*
CALL 'MQGET' USING W03-HCONN
W03-HOBJ
MQMD
MQGMO
W00-MSGLENGTH
W00-MSGBUFFER
W00-DATALENGTH
W03-COMPCODE
W03-REASON
*
* If get failed, display the error message and
* break out of the loop.
* Otherwise put the message to the CICS
* temporary storage queue.
*
ADD 1 TO W00-NUMGETS
IF (W03-COMPCODE = MQCC-FAILED) THEN
MOVE W00-NUMGETS TO W00-NUMGETS-CHAR
MOVE W03-COMPCODE TO W03-COMPCODE-CHAR
MOVE W03-REASON TO W03-REASON-CHAR
*
MOVE SPACES TO W00-MESSAGE
STRING 'MQGET ', W00-NUMGETS-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
*
ELSE
MOVE W00-LOOP TO W00-LOOP-CHAR
MOVE W00-DATALENGTH TO W00-DATALENGTH-CHAR
MOVE W00-MSGLENGTH TO W00-MSGLENGTH-CHAR
MOVE SPACES TO W00-TSQMESSAGE
*
IF W03-REASON = MQRC-TRUNCATED-MSG-ACCEPTED THEN
STRING W00-LOOP-CHAR, ' : ', W00-DATALENGTH-CHAR,
' : Truncated to ', W00-MSGLENGTH-CHAR,
' : ', W00-MSGBUFFER(1:W00-MSGLENGTH)
DELIMITED BY SIZE INTO W00-TSQMESSAGE
COMPUTE W00-TSQMESSAGE-LENGTH = W00-MSGLENGTH + 49
ELSE
STRING W00-LOOP-CHAR, ' : ', W00-DATALENGTH-CHAR,
' : ', W00-MSGBUFFER(1:W00-DATALENGTH)
DELIMITED BY SIZE INTO W00-TSQMESSAGE
COMPUTE W00-TSQMESSAGE-LENGTH = W00-DATALENGTH + 24
END-IF
*
EXEC CICS WRITEQ TS QUEUE( W00-TRANSNAME )
FROM( W00-TSQMESSAGE )
LENGTH( W00-TSQMESSAGE-LENGTH )
END-EXEC
END-IF
*
* If browsing the queue then change the
* MQGMO-OPTIONS browse options.
*
IF (W00-LOOP = 0) AND BROWSE-GET THEN
SUBTRACT MQGMO-BROWSE-FIRST FROM MQGMO-OPTIONS
ADD MQGMO-BROWSE-NEXT TO MQGMO-OPTIONS
END-IF
*
END-PERFORM.
*
*
* If no error occurred, display the number of messages
* successfully got from the queue
*
IF (W03-COMPCODE < MQCC-FAILED) THEN
MOVE SPACES TO W00-MESSAGE
MOVE W00-NUMGETS TO W00-NUMGETS-CHAR
STRING W00-NUMGETS-CHAR, ' MESSAGES GOT FROM QUEUE'
DELIMITED BY SIZE INTO W00-MESSAGE
PERFORM DISPLAY-MESSAGE
END-IF
*
*
* If program started with syncpoint and destructive get
* then execute syncpoint
*
IF SYNCPOINT AND DESTRUCTIVE-GET THEN
EXEC CICS SYNCPOINT END-EXEC
END-IF.
*
*
* CLOSE the queue
*
CALL 'MQCLOSE' USING W03-HCONN
W03-HOBJ
MQCO-NONE
W03-COMPCODE
W03-REASON.
*
* If close failed then display error message
*
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 : MVGT,9999,B,S,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.35 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.
|
