|
CBL NODYNAM,LIB,OBJECT,RENT,RES,APOST
* ------------------------------------------------------------- *
IDENTIFICATION DIVISION.
* ------------------------------------------------------------- *
PROGRAM-ID. CSQ4TVH3.
*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 : CSQ4TVH3 *
* *
* Environment : MVS TSO/ISPF; COBOL II *
* *
* Function : This program provides the message handling *
* facilities of the Message Handler sample *
* program. *
* See IBM message Queue Manager MVS/ESA *
* Application Programming Reference, document *
* number SC33-1212, for further details. *
* *
* Description : This program formats and displays a message *
* which is displayed on panel CSQ4CHP3. The *
* user may delete or forward this message to a *
* different queue. It is called from program *
* CSQ4TVH2. *
* *
*****************************************************************
* *
* Program Logic *
* *
*---------------------------------------------------------------*
* *
* A-MAIN SECTION *
* -------------- *
* *
* initialize variables used by ISPF *
* blank panel message line *
* get the chosen message from the queue *
* if unsuccessful *
* back out the get message *
* exit program *
* endif *
* create the message contents table *
* if unsuccessful *
* back out the get message *
* exit program *
* endif *
* go to top of message contents table *
* if unsuccessful *
* display error message *
* back out the get message *
* exit program *
* endif *
* loop until ready to quit the program *
* display the ISPF panel *
* if unsuccessful or quit is chosen *
* break from the loop *
* endif *
* check the action to be performed *
* if no action do nothing *
* if action is to delete message *
* delete message from queue by committing the MQGET *
* endif *
* if action is to forward queue *
* if there is no queue name to forward to *
* display error message *
* else *
* forward the message *
* endif *
* endif *
* if action is invalid *
* display error message *
* endif *
* endloop *
* blank panel message line *
* back out last get in case delete or forward not called *
* exit program *
* *
*---------------------------------------------------------------*
* *
* FORWARD-MESSAGE SECTION *
* ----------------------- *
* *
* if message has already been forwarded *
* display message *
* exit from section *
* endif *
* if the message contains a header block *
* strip the header block from message buffer *
* copy any altered message descriptor fields *
* endif *
* . *
* . *
* if no header block exists *
* copy message buffer as is *
* endif *
* get the forward to queue and queue manager names from ISPF *
* set up put variables for queue *
* set put options to pass context information *
* put the message to the forward to queue (MQPUT1) *
* if successful *
* set the message forwarded flag *
* call MQCMIT to commit put and initial get *
* display success message *
* else *
* display error message *
* endif *
* exit from section *
* *
*---------------------------------------------------------------*
* *
* DELETE-MESSAGE SECTION *
* ---------------------- *
* *
* if message already deleted *
* display message *
* exit from section *
* endif *
* commit the last destructive get of message (MQCMIT) *
* if successful *
* set message deleted flag *
* display success message *
* else *
* display error message *
* endif *
* exit from section *
* *
*---------------------------------------------------------------*
* *
* GET-MESSAGE SECTION *
* ------------------- *
* *
* set get options to get message in syncpoint *
* call MQGET for specified MsgId and CorrelId *
* if unsuccessful *
* display error message *
* exit from section *
* else *
* copy received information to ISPF *
* endif *
* open another handle to queue *
* browse for another message with same MsgId and CorrelId *
* if message found *
* display error message *
* else *
* MsgId and CorrelId are unique so no error *
* endif *
* close the second handle to queue *
* exit from section *
* *
*---------------------------------------------------------------*
* *
* CREATE-MESSAGE-CONTENTS SECTION *
* ------------------------------- *
* *
* create an ISPF table to hold message contents *
* if creation failed *
* display error message *
* exit from section *
* endif *
* add the message descriptor to message contents table *
* if message buffer contains header block *
* add header block to message contents table *
* if addition unsuccessful return from function *
* strip header block from message buffer *
* add message buffer to contents table *
* if addition unsuccessful return from function *
* endif *
* . *
* . *
* if no header blocks in message buffer *
* add message buffer, as is, to contents table *
* endif *
* exit from section *
* *
*---------------------------------------------------------------*
* *
* ADD-MSGBUFFER-2CONTENTS SECTION *
* ------------------------------- *
* *
* format the contents of the message buffer *
* add formatted information to message contents table *
* . *
* . *
* if addition of information unsuccessful *
* end the message contents table *
* display error message *
* endif *
* exit from section *
* *
*---------------------------------------------------------------*
* *
* ADD-MQMD-2CONTENTS SECTION *
* -------------------------- *
* *
* format the contents of the message descriptor *
* add formatted information to message contents table *
* . *
* . *
* if addition of information unsuccessful *
* end the message contents table *
* display error message *
* endif *
* exit from section *
* *
*---------------------------------------------------------------*
* *
* ADD-MQDLH-2CONTENTS SECTION *
* --------------------------- *
* *
* format contents of dead letter header *
* add formatted information to message contents table *
* . *
* . *
* if addition of information unsuccessful *
* end the message contents table *
* display error message *
* endif *
* exit from section *
* *
*---------------------------------------------------------------*
* *
* ADD-MQXQH-2CONTENTS SECTION *
* --------------------------- *
* *
* format contents of transmission queue header *
* add formatted information to message contents table *
* . *
* . *
* if addition of information unsuccessful *
* end the message contents table *
* display error message *
* endif *
* exit from section *
* *
*---------------------------------------------------------------*
* *
* ADD-LINE-2CONTENTS SECTION *
* -------------------------- *
* *
* add a line of text to message contents table *
* exit from section *
* *
*---------------------------------------------------------------*
* *
* ERROR-MESSAGE SECTION *
* --------------------- *
* *
* copy error message into panel message line variable *
* exit from section *
* *
*---------------------------------------------------------------*
* *
* PRINT-MESSAGE SECTION *
* --------------------- *
* *
* copy message into panel message line variable *
* exit from section *
* *
*---------------------------------------------------------------*
* *
* ISFP-INIT SECTION *
* ----------------- *
* *
* call VDEFINE for all variables to go into ISPF *
* shared variable pool *
* exit from section *
* *
*---------------------------------------------------------------*
* *
* DEC-2-HEX SECTION *
* ----------------- *
* *
* convert a binary variable into hexadecimal string with *
* equivalent value. *
* *
*****************************************************************
* ------------------------------------------------------------- *
ENVIRONMENT DIVISION.
* ------------------------------------------------------------- *
* ------------------------------------------------------------- *
DATA DIVISION.
* ------------------------------------------------------------- *
* ------------------------------------------------------------- *
WORKING-STORAGE SECTION.
* ------------------------------------------------------------- *
*
* W00 - General work fields
*
01 W00-ERRORMSG PIC X(40) VALUE SPACES.
01 W00-RETCODE PIC S9(09) BINARY.
01 W00-NUMLINESFULL PIC S9(09) BINARY.
01 W00-HALFWORD.
05 FILLER PIC X.
05 W00-HALFWORD-BYTE PIC X.
01 W00-HALFWORD-BIN REDEFINES W00-HALFWORD PIC S9(2) COMP.
01 W00-LOOP PIC S9(4) BINARY.
01 W00-STEP PIC S9(4) BINARY.
01 W00-INDEX PIC S9(4) BINARY.
01 W00-ELEMENT PIC S9(4) BINARY.
01 W00-DECIMAL PIC S9(8) BINARY.
01 W00-DEC-DIV-16 PIC S9(8) BINARY.
01 W00-HEX-DIGIT PIC S9(8) BINARY.
01 W00-OFFSET PIC S9(8) BINARY.
01 W00-OFFSET-CHAR.
05 W00-OFFSET-CHR OCCURS 8 TIMES.
10 W00-OFFSET-BYTE PIC X VALUE SPACE.
01 W00-LONG-CHAR PIC X(9) VALUE SPACES.
01 W00-DELETED-MESSAGE PIC X(1) VALUE '0'.
88 MESSAGE-DELETED VALUE '1'.
88 MESSAGE-AVAILABLE VALUE '0'.
01 W00-FORWARDED-MESSAGE PIC X(1) VALUE '0'.
88 MESSAGE-FORWARDED VALUE '1'.
88 MESSAGE-AVAILABLE VALUE '0'.
01 W00-TRUNCATED-MESSAGE PIC X(1) VALUE '0'.
88 MESSAGE-TRUNCATED VALUE '1'.
88 MESSAGE-WHOLE VALUE '0'.
*
* W01 - ISPF Variables
*
01 W01-QMGRNAME PIC X(48) VALUE SPACES.
01 W01-QNAME PIC X(48) VALUE SPACES.
01 W01-HCONN PIC S9(09) BINARY.
01 W01-HOBJ PIC S9(09) BINARY.
01 W01-MESSAGE PIC X(79) VALUE SPACES.
01 W01-ACTION PIC X(1) VALUE SPACES.
01 W01-FORQNAME PIC X(48) VALUE SPACES.
01 W01-FORQMGR PIC X(48) VALUE SPACES.
01 W01-TEXTLINE.
05 W01-TEXTLINE-ARRAY OCCURS 40 TIMES.
10 W01-TEXTLINE-CHAR PIC X(2) VALUE SPACE.
01 W01-HEXLINE.
05 W01-OFFSET PIC X(8) VALUE '00000000'.
05 FILLER PIC X(4) VALUE ' : '.
05 W01-HEXGROUP OCCURS 8 TIMES.
10 W01-HEX1 PIC X(2) VALUE SPACES.
10 W01-HEX2 PIC X(2) VALUE SPACES.
10 PIC X VALUE SPACE.
05 FILLER PIC X(2) VALUE ' `'.
05 W01-CHARGROUP OCCURS 16 TIMES.
10 W01-CHAR PIC X.
05 FILLER PIC X(2) VALUE '` '.
*
*
* W02 - MQAPI Variables
*
01 W02-COMPCODE PIC S9(09) BINARY.
01 W02-COMPCODE-CHAR PIC Z(1)9 VALUE SPACES.
01 W02-REASON PIC S9(09) BINARY.
01 W02-REASON-CHAR PIC Z(4)9 VALUE SPACES.
* MQINQ
01 W02-SELECTORS PIC X(1) VALUE SPACES.
01 W02-SELECTORCOUNT PIC S9(09) BINARY.
01 W02-INTATTRS PIC X(1) VALUE SPACES.
01 W02-INTATTRCOUNT PIC S9(09) BINARY.
01 W02-CHARATTRS PIC X(48) VALUE SPACES.
01 W02-CHARATTRLENGTH PIC S9(09) BINARY.
* MQOPEN
01 W02-OPENOPTIONS PIC S9(09) BINARY.
* MQGET
01 W02-DATALENGTH PIC S9(09) BINARY.
01 W02-BUFFERLENGTH PIC S9(09) BINARY.
01 W02-BUFFERLENGTH-CHAR PIC Z(7)9 VALUE SPACES.
01 W02-BUFFER.
05 W02-BUFFER-ELEMENT OCCURS 32768 TIMES.
10 W02-BUFFER-BYTE PIC X.
*
01 W02-MSGBUFFER.
05 W02-MSGBUFFER-ELEMENT OCCURS 32768 TIMES.
10 W02-MSGBUFFER-BYTE PIC X.
*
01 W02-XQHMSGBUFFER.
05 W02-MQXQH.
COPY CMQXQHV.
05 W02-MQXQH-MSGBUFFER.
10 W02-MQXQH-MSGBUFFER-ELEMENT OCCURS 32340 TIMES.
15 W02-MQXQH-MSGBUFFER-BYTE PIC X.
*
01 W02-DLHMSGBUFFER.
05 W02-MQDLH.
COPY CMQDLHV.
05 W02-MQDLH-MSGBUFFER.
10 W02-MQDLH-MSGBUFFER-ELEMENT OCCURS 32596 TIMES.
15 W02-MQDLH-MSGBUFFER-BYTE PIC X.
*
* TEMP MQ VARIABLE FOR USE IN GET-MESSAGE
01 W02-TEMPHOBJ PIC S9(09) BINARY.
01 TEMP-MESSAGE-DESCRIPTOR.
COPY CMQMDV.
*
* API control blocks
*
01 MQM-OBJECT-DESCRIPTOR.
COPY CMQODV.
01 MQM-MESSAGE-DESCRIPTOR.
COPY CMQMDV.
01 MQM-GET-MESSAGE-OPTIONS.
COPY CMQGMOV.
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.
*
* Hex Conversion Table
*
COPY CSQ4TVH0.
*
*
* ISPLINK Strings
*
01 IDISPLAY PIC X(8) VALUE 'DISPLAY '.
01 ISELECT PIC X(8) VALUE 'SELECT '.
01 ISHARED PIC X(8) VALUE 'SHARED '.
01 IVDEFINE PIC X(8) VALUE 'VDEFINE '.
01 IVPUT PIC X(8) VALUE 'VPUT '.
01 IVGET PIC X(8) VALUE 'VGET '.
01 ICOPY PIC X(8) VALUE 'COPY '.
01 ICHAR PIC X(8) VALUE 'CHAR '.
01 IFIXED PIC X(8) VALUE 'FIXED '.
01 IBIT PIC X(8) VALUE 'BIT '.
01 IPANEL3 PIC X(8) VALUE 'CSQ4CHP3'.
01 ITBTOP PIC X(8) VALUE 'TBTOP '.
01 ITBDISPL PIC X(8) VALUE 'TBDISPL '.
01 ITBGET PIC X(8) VALUE 'TBGET '.
01 ITBADD PIC X(8) VALUE 'TBADD '.
01 ITBEND PIC X(8) VALUE 'TBEND '.
01 ITBCREATE PIC X(8) VALUE 'TBCREATE'.
01 INOWRITE PIC X(8) VALUE 'NOWRITE '.
01 IREPLACE PIC X(8) VALUE 'REPLACE '.
01 IBLANK PIC X(8) VALUE ' '.
01 I2 PIC 9(6) VALUE 2 COMP.
01 I4 PIC 9(6) VALUE 4 COMP.
01 I24 PIC 9(6) VALUE 24 COMP.
01 I48 PIC 9(6) VALUE 48 COMP.
01 I79 PIC 9(6) VALUE 79 COMP.
01 I172 PIC 9(6) VALUE 172 COMP.
01 I428 PIC 9(6) VALUE 428 COMP.
01 I32768 PIC 9(6) VALUE 32768 COMP.
*
01 IA PIC X(8) VALUE 'A '.
01 IMESSAGE PIC X(8) VALUE 'MSG '.
01 IHOBJ PIC X(8) VALUE 'HOBJ '.
01 IHCONN PIC X(8) VALUE 'HCONN '.
01 IQNAME PIC X(8) VALUE 'QNAME '.
01 IQMGRNAME PIC X(8) VALUE 'QMGRNAME'.
01 IMSGID PIC X(8) VALUE 'MSGID '.
01 ICORRELID PIC X(8) VALUE 'CORRELID'.
01 IFORQMGR PIC X(8) VALUE 'FORQMGR '.
01 IFORQNAME PIC X(8) VALUE 'FORQNAME'.
01 ITEXTLINE PIC X(8) VALUE 'TEXTLINE'.
*
01 IMSG-DETAILS-TABLE PIC X(8) VALUE 'MESSAGE '.
01 IMSG-DETAILS-TEXTLINE PIC X(10) VALUE '(TEXTLINE)'.
*
* ------------------------------------------------------------- *
LINKAGE SECTION.
* ------------------------------------------------------------- *
EJECT
* ------------------------------------------------------------- *
PROCEDURE DIVISION.
* ------------------------------------------------------------- *
* ------------------------------------------------------------- *
A-MAIN SECTION.
* ------------------------------------------------------------- *
* *
* Set up variables used with ISPF *
* *
PERFORM ISPF-INIT.
* *
* Blank ISPF panel message *
* *
MOVE SPACES TO W01-MESSAGE.
PERFORM PRINT-MESSAGE.
* *
* Get the chosen message from the queue. *
* On failure then replace the message by calling *
* MQBACK and exit the program. *
* *
PERFORM GET-MESSAGE.
IF (1 = W02-REASON) THEN
SET MESSAGE-TRUNCATED TO TRUE
MOVE MQRC-NONE TO W02-REASON
END-IF.
IF (MQRC-NONE NOT = W02-REASON) THEN
GO TO A-MAIN-ERROR-EXIT
END-IF.
* *
* Create the message contents to be displayed on the ISPF *
* panel. *
* *
* If this creation fails then replace the message onto *
* queue and exit the program. *
* *
PERFORM CREATE-MESSAGE-CONTENTS.
IF (0 NOT = W02-REASON) THEN
GO TO A-MAIN-ERROR-EXIT
END-IF.
* *
* Set the message details table to the top. *
* On failure replace the message and exit. *
* *
CALL 'ISPLINK' USING ITBTOP IMSG-DETAILS-TABLE.
IF (0 NOT = RETURN-CODE) THEN
MOVE RETURN-CODE TO W02-REASON-CHAR
STRING 'Message Contents handling error. Return Code : ',
W02-REASON-CHAR,
DELIMITED BY SIZE INTO W01-MESSAGE
PERFORM PRINT-MESSAGE
GO TO A-MAIN-ERROR-EXIT
END-IF.
* *
* Loop until ready to quit the program *
* *
PERFORM WITH TEST AFTER UNTIL (0 NOT = RETURN-CODE)
* *
* Display the ISPF panel. *
* Upon user pressing PF3 *
* break from loop. *
* *
CALL 'ISPLINK' USING ITBDISPL IMSG-DETAILS-TABLE IPANEL3
IF (8 NOT = RETURN-CODE) THEN
* *
* Examine the action code returned from panel and *
* call appropriate function. *
* *
EVALUATE TRUE
WHEN (' ' = W01-ACTION)
CONTINUE
WHEN ('D' = W01-ACTION)
PERFORM DELETE-MESSAGE
* *
* If no forward to queue name exists then *
* display error message. *
* *
WHEN ('F' = W01-ACTION)
IF (SPACES NOT = W01-FORQNAME) THEN
IF MESSAGE-TRUNCATED THEN
MOVE 'Message is truncated' TO W01-MESSAGE
CALL 'ISPLINK' USING IVPUT IMESSAGE ISHARED
PERFORM PRINT-MESSAGE
ELSE
PERFORM FORWARD-MESSAGE
END-IF
ELSE
MOVE 'No forward to queue name available.'
TO W01-MESSAGE
CALL 'ISPLINK' USING IVPUT IMESSAGE ISHARED
PERFORM PRINT-MESSAGE
END-IF
WHEN OTHER
MOVE 'Invalid Action' TO W01-MESSAGE
PERFORM PRINT-MESSAGE
CALL 'ISPLINK' USING IVPUT IMESSAGE ISHARED
END-EVALUATE
*
END-IF
*
END-PERFORM.
* *
* Blank ISPF panel message *
* *
MOVE SPACES TO W01-MESSAGE.
PERFORM PRINT-MESSAGE.
* *
A-MAIN-ERROR-EXIT.
* *
* Replace the message in case delete or forward not called. *
* *
CALL 'MQBACK' USING W01-HCONN
W02-COMPCODE
W02-REASON.
*
A-MAIN-EXIT.
*
GOBACK.
EJECT
*
*
*---------------------------------------------------------------*
FORWARD-MESSAGE SECTION.
*---------------------------------------------------------------*
* This section attempts to forward the message to the queue *
* specified. *
* After the MQPUT the unit of work is committed. This will *
* commit the MQGET for the message as well, if the delete *
* function has not already been called. *
*---------------------------------------------------------------*
* *
* If the message has already been forwarded then *
* display message and return from function. *
* *
IF MESSAGE-FORWARDED THEN
MOVE 'Forward message already called.' TO W01-MESSAGE
PERFORM PRINT-MESSAGE
MOVE 1 TO W02-REASON
GO TO FORWARD-MESSAGE-EXIT
END-IF.
*
MOVE MQM-MESSAGE-DESCRIPTOR TO TEMP-MESSAGE-DESCRIPTOR.
* *
* Strip the header block if the message contains one. *
* Also reset the message descriptor variables changed to *
* the original values stored in the headers. *
* *
EVALUATE TRUE
WHEN (MQFMT-DEAD-LETTER-HEADER =
MQMD-FORMAT IN MQM-MESSAGE-DESCRIPTOR)
*
MOVE W02-MQDLH-MSGBUFFER TO W02-BUFFER
COMPUTE W02-BUFFERLENGTH = W02-DATALENGTH - I172
MOVE MQDLH-ENCODING TO
MQMD-ENCODING IN TEMP-MESSAGE-DESCRIPTOR
MOVE MQDLH-CODEDCHARSETID TO
MQMD-CODEDCHARSETID IN TEMP-MESSAGE-DESCRIPTOR
MOVE MQDLH-FORMAT TO
MQMD-FORMAT IN TEMP-MESSAGE-DESCRIPTOR
*
WHEN (MQFMT-XMIT-Q-HEADER =
MQMD-FORMAT IN MQM-MESSAGE-DESCRIPTOR)
*
MOVE W02-MQXQH-MSGBUFFER TO W02-BUFFER
COMPUTE W02-BUFFERLENGTH = W02-DATALENGTH - I428
MOVE MQXQH-MSGDESC TO TEMP-MESSAGE-DESCRIPTOR
*
WHEN OTHER
MOVE W02-MSGBUFFER TO W02-BUFFER
MOVE W02-DATALENGTH TO W02-BUFFERLENGTH
*
END-EVALUATE.
* *
* Get the name of the queue manager and queue name to *
* be forwarded to. *
* *
CALL 'ISPLINK' USING IVGET IFORQMGR ISHARED.
CALL 'ISPLINK' USING IVGET IFORQNAME ISHARED.
* *
* Set up the variables used in MQPUT1 *
* *
MOVE MQOT-Q TO MQOD-OBJECTTYPE.
MOVE W01-FORQNAME TO MQOD-OBJECTNAME.
MOVE W01-FORQMGR TO MQOD-OBJECTQMGRNAME.
* *
* Set pass all context as a put option so that the *
* context information of original message will be *
* forwarded along with message descriptor and *
* buffer. *
* *
COMPUTE MQPMO-OPTIONS = MQPMO-PASS-ALL-CONTEXT +
MQPMO-SYNCPOINT.
MOVE W01-HOBJ TO MQPMO-CONTEXT.
*
CALL 'MQPUT1' USING W01-HCONN
MQOD
TEMP-MESSAGE-DESCRIPTOR
MQPMO
W02-BUFFERLENGTH
W02-BUFFER
W02-COMPCODE
W02-REASON.
* *
* If successful then set the MESSAGE-FORWARDED flag, *
* commit the MQPUT (which also commits the get of the *
* message itself) and display success message. *
* Otherwise display error message. *
* *
IF (MQCC-OK = W02-COMPCODE) THEN
SET MESSAGE-FORWARDED TO TRUE
CALL 'MQCMIT' USING W01-HCONN,
W02-COMPCODE,
W02-REASON
MOVE 'Message has been forwarded.' TO W01-MESSAGE
PERFORM PRINT-MESSAGE
ELSE
MOVE 'Forward message failed.' TO W00-ERRORMSG
PERFORM ERROR-MESSAGE
END-IF.
*
FORWARD-MESSAGE-EXIT.
*
EXIT.
EJECT
*
*---------------------------------------------------------------*
DELETE-MESSAGE SECTION.
*---------------------------------------------------------------*
* This section deletes the chosen message from the queue by *
* committing the MQGET call which initially read the message. *
*---------------------------------------------------------------*
* *
* If delete function has already been called then display *
* message and return from function. *
* *
IF MESSAGE-DELETED THEN
MOVE 'Message already deleted.' TO W01-MESSAGE
PERFORM PRINT-MESSAGE
MOVE 1 TO W02-REASON
GO TO DELETE-MESSAGE-EXIT
END-IF.
* *
* Commit the last unit of work. *
* *
CALL 'MQCMIT' USING W01-HCONN
W02-COMPCODE
W02-REASON.
* *
* If commit was successful then set MESSAGE-DELETED *
* flag and display success message. *
* Otherwise display error message. *
* *
IF (MQCC-OK = W02-COMPCODE) THEN
SET MESSAGE-DELETED TO TRUE
MOVE 'Message has been deleted.' TO W01-MESSAGE
PERFORM PRINT-MESSAGE
ELSE
MOVE 'Delete message failed.' TO W01-MESSAGE
PERFORM PRINT-MESSAGE
END-IF.
*
DELETE-MESSAGE-EXIT.
*
EXIT.
EJECT
*
*---------------------------------------------------------------*
GET-MESSAGE SECTION.
*---------------------------------------------------------------*
* This section destructively gets a message from the queue *
* using the MsgId and CorrelId stored in the ISPF shared *
* variable pool. *
* If the get is successful then the queue is opened again for *
* browse, ensuring that the previous object handle will retain *
* the message context information. *
* This second handle to the queue is used to get another message*
* with the same MsgId and CorrelId. The MsgId and CorrelId must *
* be unique, so if the second get is successful then an error *
* has arisen and the function returns a failure. *
*---------------------------------------------------------------*
* *
* Set the get options to accept messages longer than *
* the message buffer size and to get the messages *
* in syncpoint. *
* *
COMPUTE MQGMO-OPTIONS = MQGMO-NO-WAIT +
MQGMO-ACCEPT-TRUNCATED-MSG +
MQGMO-SYNCPOINT;
*
CALL 'MQGET' USING W01-HCONN
W01-HOBJ
MQM-MESSAGE-DESCRIPTOR
MQGMO
I32768
W02-MSGBUFFER
W02-DATALENGTH
W02-COMPCODE
W02-REASON.
* *
* If the get failed then display error message and return. *
* Otherwise store the forward message details received in *
* the ISPF shared variable pool. *
* *
IF (MQCC-FAILED = W02-COMPCODE) THEN
MOVE 'Get from queue failed.' TO W00-ERRORMSG
PERFORM ERROR-MESSAGE
GO TO GET-MESSAGE-EXIT
ELSE
MOVE MQMD-REPLYTOQMGR IN MQM-MESSAGE-DESCRIPTOR TO
W01-FORQMGR
MOVE MQMD-REPLYTOQ IN MQM-MESSAGE-DESCRIPTOR TO
W01-FORQNAME
CALL 'ISPLINK' USING IVPUT IFORQMGR ISHARED
CALL 'ISPLINK' USING IVPUT IFORQNAME ISHARED
MOVE W02-MSGBUFFER TO W02-XQHMSGBUFFER
MOVE W02-MSGBUFFER TO W02-DLHMSGBUFFER
IF MQRC-TRUNCATED-MSG-ACCEPTED = W02-REASON THEN
MOVE 1 TO W02-REASON
END-IF
END-IF.
MOVE W02-REASON TO W00-RETCODE.
MOVE MQM-MESSAGE-DESCRIPTOR TO TEMP-MESSAGE-DESCRIPTOR.
*
MOVE MQOT-Q TO MQOD-OBJECTTYPE.
MOVE W01-QNAME TO MQOD-OBJECTNAME.
* *
* Open a second handle on the queue to secure context *
* information stored with first handle. *
* *
CALL 'MQOPEN' USING W01-HCONN
MQOD
MQOO-BROWSE
W02-TEMPHOBJ
W02-COMPCODE
W02-REASON.
* *
* Browse for the first message complying with MsgId and *
* CorrelId. *
* *
COMPUTE MQGMO-OPTIONS = MQGMO-BROWSE-FIRST +
MQGMO-ACCEPT-TRUNCATED-MSG.
*
CALL 'MQGET' USING W01-HCONN
W02-TEMPHOBJ
TEMP-MESSAGE-DESCRIPTOR
MQGMO
I32768
W02-BUFFER
W02-BUFFERLENGTH
W02-COMPCODE
W02-REASON.
* *
* If a message has been found then the MsgId/CorrelId *
* combination is not unique, so display error message. *
* *
IF (MQRC-NO-MSG-AVAILABLE = W02-REASON) THEN
MOVE W00-RETCODE TO W02-REASON
MOVE MQCC-OK TO W02-COMPCODE
ELSE
MOVE 'MsgId and CorrelId not unique.' TO W01-MESSAGE
PERFORM PRINT-MESSAGE
IF (MQRC-NONE = W02-REASON) THEN
MOVE 2 TO W02-REASON
END-IF
END-IF.
*
CALL 'MQCLOSE' USING W01-HCONN
W02-TEMPHOBJ
MQCO-NONE
W02-COMPCODE
W00-RETCODE.
*
GET-MESSAGE-EXIT.
*
EXIT.
EJECT
*
*---------------------------------------------------------------*
CREATE-MESSAGE-CONTENTS SECTION.
*---------------------------------------------------------------*
* This section creates a message contents table to be used *
* in the ISPF panel. *
* The message is formatted depending on the Format field in *
* the message descriptor. *
*---------------------------------------------------------------*
* *
* Create an ISPF table to hold the message details. *
* If create failed display an error message and *
* return from the function. *
* NB: a return code of 4 from TBCREATE means that *
* a new table has been created replacing an old *
* table of the same name. This is not an error. *
* *
CALL 'ISPLINK' USING ITBCREATE IMSG-DETAILS-TABLE
IBLANK IMSG-DETAILS-TEXTLINE
INOWRITE IREPLACE.
MOVE RETURN-CODE TO W02-REASON.
IF (4 = W02-REASON) THEN
MOVE 0 TO W02-REASON
END-IF.
MOVE W02-REASON TO W02-REASON-CHAR.
IF (MQRC-NONE NOT = W02-REASON) THEN
STRING
'Creation of message contents failed. Return Code: ',
W02-REASON-CHAR
DELIMITED BY SIZE INTO W01-MESSAGE
PERFORM PRINT-MESSAGE
GO TO CREATE-MESSAGE-CONTENTS-EXIT
END-IF.
* *
* Add the message descriptor details to the message *
* contents table. *
* If an error has occurred then return from the *
* function. *
* *
PERFORM ADD-MQMD-2CONTENTS.
IF (0 NOT = W02-REASON) THEN
GO TO CREATE-MESSAGE-CONTENTS-EXIT
END-IF.
* *
* If a header block is available then add the *
* header block to the message contents table, *
* followed by the remaining message buffer data. *
* If an error has occurred then exit from the *
* section. *
* *
EVALUATE TRUE
WHEN (MQFMT-DEAD-LETTER-HEADER =
MQMD-FORMAT IN MQM-MESSAGE-DESCRIPTOR)
*
PERFORM ADD-MQDLH-2CONTENTS
IF (0 NOT = W02-REASON) THEN
GO TO CREATE-MESSAGE-CONTENTS-EXIT
END-IF
MOVE W02-MQDLH-MSGBUFFER TO W02-BUFFER
COMPUTE W02-BUFFERLENGTH = W02-DATALENGTH - I172
PERFORM ADD-MSGBUFFER-2CONTENTS
IF (0 NOT = W02-REASON) THEN
GO TO CREATE-MESSAGE-CONTENTS-EXIT
END-IF
*
WHEN (MQFMT-XMIT-Q-HEADER =
MQMD-FORMAT IN MQM-MESSAGE-DESCRIPTOR)
*
PERFORM ADD-MQXQH-2CONTENTS
IF (0 NOT = W02-REASON) THEN
GO TO CREATE-MESSAGE-CONTENTS-EXIT
END-IF
MOVE W02-MQXQH-MSGBUFFER TO W02-BUFFER
COMPUTE W02-BUFFERLENGTH = W02-DATALENGTH - I428
PERFORM ADD-MSGBUFFER-2CONTENTS
IF (0 NOT = W02-REASON) THEN
GO TO CREATE-MESSAGE-CONTENTS-EXIT
END-IF
*
WHEN OTHER
MOVE W02-MSGBUFFER TO W02-BUFFER
MOVE W02-DATALENGTH TO W02-BUFFERLENGTH
PERFORM ADD-MSGBUFFER-2CONTENTS
IF (0 NOT = W02-REASON) THEN
GO TO CREATE-MESSAGE-CONTENTS-EXIT
END-IF
*
END-EVALUATE.
*
CREATE-MESSAGE-CONTENTS-EXIT.
*
EXIT.
EJECT
*
*---------------------------------------------------------------*
ADD-MSGBUFFER-2CONTENTS SECTION.
*---------------------------------------------------------------*
* This section formats and adds the message buffer contents *
* to the message contents table used in the ISPF panel. *
* *
* Line format : *
* Hex offset : Buffer details in hex 'Buffer details' *
* eg 00000010 : 5C5C 5C5C 5C5C 5C5C 5C5C .. '********** .. ' *
*---------------------------------------------------------------*
*
MOVE 0 TO W00-RETCODE.
MOVE 0 TO W00-OFFSET.
*
MOVE SPACES TO W01-TEXTLINE.
PERFORM ADD-LINE-2CONTENTS.
ADD W02-REASON TO W00-RETCODE.
*
MOVE W02-BUFFERLENGTH TO W02-BUFFERLENGTH-CHAR.
IF (W02-BUFFERLENGTH > 32768) THEN
STRING
'Message Buffer : ',
W02-BUFFERLENGTH-CHAR,
' byte(s) (first 32768 bytes displayed)'
DELIMITED BY SIZE INTO W01-TEXTLINE
MOVE 32768 TO W02-BUFFERLENGTH
ELSE
STRING
'Message Buffer : ',
W02-BUFFERLENGTH-CHAR,
' byte(s)'
DELIMITED BY SIZE INTO W01-TEXTLINE
END-IF.
*
PERFORM ADD-LINE-2CONTENTS.
MOVE W02-REASON TO W00-RETCODE.
*
COMPUTE W00-NUMLINESFULL = W02-BUFFERLENGTH / 16.
* *
* Loop for each new line which can be completely filled *
* with characters. *
* *
PERFORM WITH TEST BEFORE VARYING W00-LOOP FROM 1 BY 1
UNTIL (W00-LOOP > W00-NUMLINESFULL)
* *
* Add the hex value of the offset to the message line. *
* *
COMPUTE W00-OFFSET = (W00-LOOP - 1) * 16
PERFORM DEC-2-HEX
MOVE W00-OFFSET-CHAR TO W01-OFFSET
* *
* Print the hex value of each character of the message *
* line until the maximum characters per line is *
* reached. *
* Print also the actual buffer character. The conversion *
* table substitutes any unprintable characters with a *
* full-stop (.) *
* *
ADD 1 TO W00-OFFSET
PERFORM WITH TEST BEFORE VARYING W00-INDEX FROM 1 BY 1
UNTIL (W00-INDEX > 8)
*
MOVE LOW-VALUE TO W00-HALFWORD
MOVE W02-BUFFER-BYTE(W00-OFFSET) TO W00-HALFWORD-BYTE
MOVE W00-HALFWORD-BIN TO W00-ELEMENT
ADD 1 TO W00-ELEMENT
MOVE HEX-CHAR(W00-ELEMENT) TO
W01-HEX1(W00-INDEX)
COMPUTE W00-STEP = ((W00-INDEX - 1) * 2) + 1
MOVE CHAR(W00-ELEMENT) TO
W01-CHAR(W00-STEP)
*
ADD 1 TO W00-OFFSET
*
MOVE LOW-VALUE TO W00-HALFWORD
MOVE W02-BUFFER-BYTE(W00-OFFSET) TO W00-HALFWORD-BYTE
MOVE W00-HALFWORD-BIN TO W00-ELEMENT
ADD 1 TO W00-ELEMENT
MOVE HEX-CHAR(W00-ELEMENT) TO
W01-HEX2(W00-INDEX)
COMPUTE W00-STEP = ((W00-INDEX - 1) * 2) + 2
MOVE CHAR(W00-ELEMENT) TO
W01-CHAR(W00-STEP)
*
ADD 1 TO W00-OFFSET
*
END-PERFORM
*
MOVE W01-HEXLINE TO W01-TEXTLINE
PERFORM ADD-LINE-2CONTENTS
ADD W02-REASON TO W00-RETCODE
*
END-PERFORM.
* *
* Clean out the previous line of details *
* *
PERFORM WITH TEST BEFORE VARYING W00-INDEX FROM 1 BY 1
UNTIL (W00-INDEX > 16)
MOVE SPACE TO W01-CHARGROUP(W00-INDEX)
END-PERFORM.
*
PERFORM WITH TEST BEFORE VARYING W00-INDEX FROM 1 BY 1
UNTIL (W00-INDEX > 8)
MOVE SPACES TO W01-HEXGROUP(W00-INDEX)
END-PERFORM.
*
COMPUTE W00-OFFSET = W00-NUMLINESFULL * 16.
PERFORM DEC-2-HEX.
MOVE W00-OFFSET-CHAR TO W01-OFFSET.
IF (W00-OFFSET < W02-BUFFERLENGTH) THEN
* *
* If any characters remain which will not fill an *
* entire message line then add these to the table. *
* *
ADD 1 TO W00-OFFSET
PERFORM WITH TEST BEFORE VARYING W00-INDEX FROM 1 BY 1
UNTIL (W00-OFFSET > W02-BUFFERLENGTH)
*
MOVE LOW-VALUE TO W00-HALFWORD
MOVE W02-BUFFER-BYTE(W00-OFFSET) TO W00-HALFWORD-BYTE
MOVE W00-HALFWORD-BIN TO W00-ELEMENT
ADD 1 TO W00-ELEMENT
MOVE HEX-CHAR(W00-ELEMENT) TO
W01-HEX1(W00-INDEX)
COMPUTE W00-STEP = ((W00-INDEX - 1) * 2) + 1
MOVE CHAR(W00-ELEMENT) TO
W01-CHAR(W00-STEP)
ADD 1 TO W00-OFFSET
IF (W00-OFFSET NOT > W02-BUFFERLENGTH) THEN
MOVE LOW-VALUE TO W00-HALFWORD
MOVE W02-BUFFER-BYTE(W00-OFFSET) TO
W00-HALFWORD-BYTE
MOVE W00-HALFWORD-BIN TO W00-ELEMENT
ADD 1 TO W00-ELEMENT
MOVE HEX-CHAR(W00-ELEMENT) TO
W01-HEX2(W00-INDEX)
COMPUTE W00-STEP = ((W00-INDEX - 1) * 2) + 2
MOVE CHAR(W00-ELEMENT) TO
W01-CHAR(W00-STEP)
END-IF
ADD 1 TO W00-OFFSET
*
END-PERFORM
*
MOVE W01-HEXLINE TO W01-TEXTLINE
PERFORM ADD-LINE-2CONTENTS
ADD W02-REASON TO W00-RETCODE
*
END-IF.
* *
* If an error has occurred then end the message contents *
* table, display error message and exit from the *
* section. *
* *
MOVE W00-RETCODE TO W02-REASON.
MOVE W02-REASON TO W02-REASON-CHAR.
IF (MQRC-NONE NOT = W02-REASON) THEN
CALL 'ISPLINK' USING ITBEND IMSG-DETAILS-TABLE
STRING
'Display of Message Buffer failed. ',
'Return Code: ',
W02-REASON-CHAR
DELIMITED BY SIZE INTO W01-MESSAGE
PERFORM PRINT-MESSAGE
END-IF.
*
*
ADD-MSGBUFFER-2CONTENTS-EXIT.
*
EXIT.
EJECT
*
*---------------------------------------------------------------*
ADD-MQMD-2CONTENTS SECTION.
*---------------------------------------------------------------*
* This section formats and adds the message descriptor to the *
* message contents table used in the ISPF panel. *
* Where necessary some message descriptor fields are printed in *
* hex. *
*---------------------------------------------------------------*
*
MOVE 0 TO W00-RETCODE.
*
MOVE 'Message Descriptor' TO W01-TEXTLINE.
PERFORM ADD-LINE-2CONTENTS.
ADD W02-REASON TO W00-RETCODE.
*
STRING
' StrucId : `',
MQMD-STRUCID IN MQM-MESSAGE-DESCRIPTOR,
'` '
DELIMITED BY SIZE INTO W01-TEXTLINE.
PERFORM ADD-LINE-2CONTENTS.
ADD W02-REASON TO W00-RETCODE.
*
MOVE MQMD-VERSION IN MQM-MESSAGE-DESCRIPTOR
TO W00-LONG-CHAR.
STRING
' Version : ',
W00-LONG-CHAR
DELIMITED BY SIZE INTO W01-TEXTLINE.
PERFORM ADD-LINE-2CONTENTS.
ADD W02-REASON TO W00-RETCODE.
*
MOVE MQMD-REPORT IN MQM-MESSAGE-DESCRIPTOR
TO W00-LONG-CHAR.
STRING
' Report : ',
W00-LONG-CHAR
DELIMITED BY SIZE INTO W01-TEXTLINE.
PERFORM ADD-LINE-2CONTENTS.
ADD W02-REASON TO W00-RETCODE.
*
MOVE MQMD-MSGTYPE IN MQM-MESSAGE-DESCRIPTOR
TO W00-LONG-CHAR.
STRING
' MsgType : ',
W00-LONG-CHAR
DELIMITED BY SIZE INTO W01-TEXTLINE.
PERFORM ADD-LINE-2CONTENTS.
ADD W02-REASON TO W00-RETCODE.
*
MOVE MQMD-EXPIRY IN MQM-MESSAGE-DESCRIPTOR
TO W00-LONG-CHAR.
STRING
' Expiry : ',
W00-LONG-CHAR
DELIMITED BY SIZE INTO W01-TEXTLINE.
IF (MQMD-EXPIRY IN MQM-MESSAGE-DESCRIPTOR < 0) THEN
MOVE ' -' TO W01-TEXTLINE-CHAR(11)
END-IF.
PERFORM ADD-LINE-2CONTENTS.
ADD W02-REASON TO W00-RETCODE.
*
MOVE MQMD-FEEDBACK IN MQM-MESSAGE-DESCRIPTOR
TO W00-LONG-CHAR.
STRING
' Feedback : ',
W00-LONG-CHAR
DELIMITED BY SIZE INTO W01-TEXTLINE.
PERFORM ADD-LINE-2CONTENTS.
ADD W02-REASON TO W00-RETCODE.
*
MOVE MQMD-ENCODING IN MQM-MESSAGE-DESCRIPTOR
TO W00-LONG-CHAR.
STRING
' Encoding : ',
W00-LONG-CHAR
DELIMITED BY SIZE INTO W01-TEXTLINE.
PERFORM ADD-LINE-2CONTENTS.
ADD W02-REASON TO W00-RETCODE.
*
MOVE MQMD-CODEDCHARSETID IN MQM-MESSAGE-DESCRIPTOR
TO W00-LONG-CHAR.
STRING
' CodedCharSetId : ',
W00-LONG-CHAR
DELIMITED BY SIZE INTO W01-TEXTLINE.
IF (MQMD-CODEDCHARSETID IN MQM-MESSAGE-DESCRIPTOR < 0) THEN
MOVE ' -' TO W01-TEXTLINE-CHAR(11)
END-IF.
PERFORM ADD-LINE-2CONTENTS.
ADD W02-REASON TO W00-RETCODE.
*
STRING
' Format : `',
MQMD-FORMAT IN MQM-MESSAGE-DESCRIPTOR,
'` '
DELIMITED BY SIZE INTO W01-TEXTLINE.
PERFORM ADD-LINE-2CONTENTS.
ADD W02-REASON TO W00-RETCODE.
*
MOVE MQMD-PRIORITY IN MQM-MESSAGE-DESCRIPTOR
TO W00-LONG-CHAR.
STRING
' Priority : ',
--> --------------------
--> maximum size reached
--> --------------------
¤ Diese beiden folgenden Angebotsgruppen bietet das Unternehmen0.74Angebot
Wie Sie bei der Firma Beratungs- und Dienstleistungen beauftragen können
¤
|
Lebenszyklus
Die hierunter aufgelisteten Ziele sind für diese Firma wichtig
Ziele
Entwicklung einer Software für die statische Quellcodeanalyse
|
