| products/sources/formale sprachen/Cobol/verschiedene-Autoren/MQ-Series/ |
|
Quellcode-Bibliothek© Kompilation durch diese Firma[Weder Korrektheit noch Funktionsfähigkeit der Software werden zugesichert.]Datei: Sprache: CobolUntersuchung verschiedene© |
|
||||||
|
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 --> -------------------- ¤ Dauer der Verarbeitung: 0.81 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.Bot Zugriff |
