|
CBL NODYNAM,LIB,OBJECT,RENT,RES,APOST
* *
* ------------------------------------------------------------- *
IDENTIFICATION DIVISION.
* ------------------------------------------------------------- *
PROGRAM-ID. CSQ4BVA1.
*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 : CSQ4BVA1 *
* *
* Environment : MVS Batch; COBOL II *
* *
* Description : Sample program to print messages from a *
* specified queue. *
* *
* Function : This program prints a report showing all *
* the messages in a specified queue in a *
* specified queue manager *
* *
* The program processes the first 80 bytes *
* only of each message. It uses the BROWSE *
* option of the MQGET call to ensure that *
* data is not lost *
* *
* Return Values : 0 - Successful completion *
* 4 - Parameter error, eg: wrong number *
* of parameters passed *
* 8 - Error in MQ call, eg: unknown object *
* name *
* *
* ************************************************************* *
* *
* Program logic *
* ------------- *
* *
* Start (A-MAIN SECTION) *
* ----- *
* *
* Open print file *
* Print first line of header (Perform PRINT-HEADER-1) *
* *
* Obtain the input data from PARM=(aaa,bbb): *
* - aaa is the name of the queue manager *
* - bbb is the name of the queue *
* *
* If the name of the queue manager is missing *
* Build a warning message and move it into data line*
* Print the line (Perform PRINT-LINE) *
* Continue (using default queue manager name) *
* End-if *
* *
* If the name of the queue is missing *
* Build an error message and move it into data line *
* Print the line (Perform PRINT-LINE) *
* Branch to Exit2 *
* End-if *
* *
* Print the rest of the header (Perform PRINT-HEADER-2) *
* *
* Connect to the queue manager *
* If an error occurs *
* Build an error message and move it into data line *
* Print the line (Perform PRINT-LINE) *
* Branch to Exit2 *
* End-if *
* *
* Open the queue *
* If an error occurs *
* Build an error message and move it into data line *
* Print the line (Perform PRINT-LINE) *
* Branch to Exit1 *
* End-if *
* *
* Get the first message (using BROWSE-FIRST option) *
* *
* Do while no error *
* *
* Add 1 to relative message number *
* Move message into print line (maximum 80 bytes) *
* Print the line (Perform PRINT-LINE) *
* *
* Get next message (using BROWSE-NEXT option) *
* *
* End-do *
* *
* When an error occurs *
* If no more messages *
* Do nothing *
* else *
* Build an error message and move it into data line *
* Print the line (Perform PRINT-LINE) *
* End-if *
* End-if *
* *
* Close the queue *
* If an error occurs *
* Build an error message and move it into data line *
* Print the line (Perform PRINT-LINE) *
* End-if *
* *
* Exit1 (A-MAIN-DISCONNECT) *
* ----- *
* *
* Disconnect from the queue manager *
* If an error occurs *
* Build an error message and move it into data line *
* Print the line (Perform PRINT-LINE) *
* End-if *
* *
* Exit2 (A-MAIN-END) *
* ----- *
* *
* Set the return code *
* *
* Close print file *
* *
* Stop run *
* *
* Print line (PRINT-LINE SECTION) *
* ---------- *
* *
* If number of lines printed is greater than page maximum *
* Print first line of header (Perform PRINT-HEADER-1) *
* Print the rest of the header (Perform PRINT-HEADER-2)*
* End-if *
* *
* Print data line *
* *
* Add 1 to count of lines printed *
* *
* Return to performing section *
* *
* Print first line of header (PRINT-HEADER-1 SECTION) *
* -------------------------- *
* *
* Add 1 to page number *
* *
* Print first line after jumping to top of page *
* *
* Set number of lines printed to 1 *
* *
* Return to performing section *
* *
* Print rest of header (PRINT-HEADER-2 SECTION) *
* -------------------- *
* *
* Print remaining header lines *
* *
* Return to performing section *
* *
* ************************************************************* *
* ------------------------------------------------------------- *
ENVIRONMENT DIVISION.
* ------------------------------------------------------------- *
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT SYSPRINT ASSIGN TO UT-S-SYSPRINT.
* ------------------------------------------------------------- *
DATA DIVISION.
* ------------------------------------------------------------- *
FILE SECTION.
FD SYSPRINT
BLOCK CONTAINS 0 RECORDS
RECORDING MODE IS F.
01 PRINT-REC.
05 CARRIAGE-CONTROL PIC X.
05 PRINT-DATA PIC X(132).
* ------------------------------------------------------------- *
WORKING-STORAGE SECTION.
* ------------------------------------------------------------- *
*
* W00 - General work fields
*
01 W00-MAX-LINES PIC S9(04) BINARY VALUE +60.
01 W00-LINE-COUNT PIC S9(04) BINARY VALUE ZERO.
01 W00-PAGE-NUMBER PIC S9(04) BINARY VALUE ZERO.
01 W00-MESSAGE-COUNT PIC S9(09) BINARY VALUE ZERO.
01 W00-DATE.
05 W00-YY PIC 99.
05 W00-MM PIC 99.
05 W00-DD PIC 99.
01 W00-PRINT-DATA PIC X(132).
01 W00-RETURN-CODE PIC S9(04) BINARY VALUE ZERO. .
*
* W01 - Lines of the print report
*
01 W01-HEADER-1.
05 FILLER PIC X(10) VALUE SPACES.
05 W01-MM PIC 99.
05 FILLER PIC X VALUE '/'.
05 W01-DD PIC 99.
05 FILLER PIC X VALUE '/'.
05 W01-YY PIC 99.
05 FILLER PIC X(38) VALUE SPACES.
05 FILLER PIC X(19) VALUE
'SAMPLE QUEUE REPORT'.
05 FILLER PIC X(38) VALUE SPACES.
05 FILLER PIC X(05) VALUE 'PAGE '.
05 W01-PAGE PIC ZZZ9.
05 FILLER PIC X(10) VALUE SPACES.
01 W01-HEADER-2.
05 FILLER PIC X(25) VALUE SPACES.
05 FILLER PIC X(29) VALUE
' QUEUE MANAGER NAME : '.
05 W01-MQM-NAME PIC X(48) VALUE SPACES.
05 FILLER PIC X(30) VALUE SPACES.
01 W01-HEADER-3.
05 FILLER PIC X(37) VALUE SPACES.
05 FILLER PIC X(17) VALUE
' QUEUE NAME : '.
05 W01-QUEUE-NAME PIC X(48) VALUE SPACES.
05 FILLER PIC X(30) VALUE SPACES.
01 W01-HEADER-4.
05 FILLER PIC X(16) VALUE SPACES.
05 FILLER PIC X(116) VALUE ' RELATIVE'.
01 W01-HEADER-5.
05 FILLER PIC X(16) VALUE SPACES.
05 FILLER PIC X(10) VALUE ' MESSAGE'.
05 FILLER PIC X(106) VALUE ' MESSAGE'.
01 W01-HEADER-6.
05 FILLER PIC X(16) VALUE SPACES.
05 FILLER PIC X(10) VALUE ' NUMBER '.
05 FILLER PIC X(10) VALUE ' LENGTH '.
05 FILLER PIC X(96) VALUE
'--------------------------------- MESSAGE DATA
- ' ---------------------------------'.
01 W01-REPORT-LINE.
05 FILLER PIC X(16) VALUE SPACES.
05 W01-MESSAGE-NUMBER PIC Z(8)9.
05 FILLER PIC X VALUE SPACE.
05 W01-MESSAGE-LENGTH PIC Z(8)9.
05 FILLER PIC X VALUE SPACE.
05 W01-DATA PIC X(80).
05 FILLER PIC X(16) VALUE SPACES.
*
* W02 - Data fields derived from the PARM field
*
01 W02-MQM PIC X(48) VALUE SPACES.
01 W02-OBJECT PIC X(48) VALUE SPACES.
*
* W03 - MQM API fields
*
01 W03-BUFFER-LENGTH PIC S9(9) BINARY VALUE 80.
01 W03-HCONN PIC S9(9) BINARY.
01 W03-OPTIONS PIC S9(9) BINARY.
01 W03-HOBJ PIC S9(9) BINARY.
01 W03-DATA-LENGTH PIC S9(9) BINARY.
01 W03-COMPCODE PIC S9(9) BINARY.
01 W03-REASON PIC S9(9) BINARY.
01 W03-MESSAGE-DATA PIC X(80) VALUE SPACES.
*
* W04 - Error and information messages
*
01 W04-MESSAGE-0.
05 FILLER PIC X(48) VALUE SPACES.
05 FILLER PIC X(35) VALUE
'********** END OF REPORT **********'.
05 FILLER PIC X(49) VALUE SPACES.
01 W04-MESSAGE-1.
05 FILLER PIC X(10) VALUE SPACES.
05 FILLER PIC X(122) VALUE
'********** NO DATA PASSED TO PROGRAM. PROGRAM REQUIRES A
- 'QUEUE MANAGER NAME AND A QUEUE NAME. **********'.
01 W04-MESSAGE-2.
05 FILLER PIC X(25) VALUE SPACES.
05 FILLER PIC X(107) VALUE
'********** NO QUEUE MANAGER NAME PASSED TO PROGRAM - DEFA
- 'ULT USED *****'.
01 W04-MESSAGE-3.
05 FILLER PIC X(38) VALUE SPACES.
05 FILLER PIC X(94) VALUE
'********** NO QUEUE NAME PASSED TO PROGRAM. **********'.
01 W04-MESSAGE-4.
05 FILLER PIC X(13) VALUE SPACES.
05 FILLER PIC X(32) VALUE
'********** AN ERROR OCCURRED IN '.
05 W04-MSG4-TYPE PIC X(10).
05 FILLER PIC X(20) VALUE
'. COMPLETION CODE = '.
05 W04-MSG4-COMPCODE PIC Z(8)9.
05 FILLER PIC X(15) VALUE ' REASON CODE ='.
05 W04-MSG4-REASON PIC Z(8)9.
05 FILLER PIC X(24) VALUE ' **********'.
*
* The following copy files define API control blocks.
*
01 W05-MQM-OBJECT-DESCRIPTOR.
COPY CMQODV.
01 W05-MQM-MESSAGE-DESCRIPTOR.
COPY CMQMDV.
01 W05-MQM-GET-MESSAGE-OPTIONS.
COPY CMQGMOV.
*
* Copy file of constants (for filling in the control blocks)
* and return codes (for testing the result of a call)
*
01 W05-MQM-CONSTANTS.
COPY CMQV.
*
* W06 - Return values
*
01 W06-CSQ4-OK PIC S9(4) VALUE 0.
01 W06-CSQ4-WARNING PIC S9(4) VALUE 4.
01 W06-CSQ4-ERROR PIC S9(4) VALUE 8.
*
* ------------------------------------------------------------- *
LINKAGE SECTION.
* ------------------------------------------------------------- *
01 PARMDATA.
05 PARM-LEN PIC S9(03) BINARY.
05 PARM-STRING PIC X(100).
*
EJECT
* ------------------------------------------------------------- *
PROCEDURE DIVISION USING PARMDATA.
* ------------------------------------------------------------- *
* ------------------------------------------------------------- *
A-MAIN SECTION.
* ------------------------------------------------------------- *
* *
* This section receives the names of the queue manager and the *
* queue from the PARM statement in the JCL. It opens the queue, *
* reads all the messages, and prints them *
* *
* This section uses the MQGET call with the BROWSE option to *
* ensure that the data is not removed from the queue *
* *
* ------------------------------------------------------------- *
*
* Open the print file, initialize the fields for the
* header date and the page number, and print the first
* line of the header
*
OPEN OUTPUT SYSPRINT.
*
ACCEPT W00-DATE FROM DATE.
MOVE W00-MM TO W01-MM.
MOVE W00-DD TO W01-DD.
MOVE W00-YY TO W01-YY.
*
PERFORM PRINT-HEADER-1.
*
* If no data was passed, create a message, print it, and
* exit
*
IF PARM-LEN = 0 THEN
MOVE W04-MESSAGE-1 TO W00-PRINT-DATA
PERFORM PRINT-LINE
MOVE W06-CSQ4-WARNING TO W00-RETURN-CODE
GO TO A-MAIN-END
END-IF.
*
* Separate into the relevant fields any data passed in the
* PARM statement
*
UNSTRING PARM-STRING DELIMITED BY ALL ','
INTO W02-MQM
W02-OBJECT.
*
* Move the data (spaces if nothing is entered) into the
* relevant print fields
*
MOVE W02-MQM TO W01-MQM-NAME.
MOVE W02-OBJECT TO W01-QUEUE-NAME.
*
* Print a message if the queue manager name is missing, the
* default queue manager will be used
*
IF W02-MQM = SPACES OR W02-MQM = LOW-VALUES THEN
MOVE W04-MESSAGE-2 TO W00-PRINT-DATA
PERFORM PRINT-LINE
END-IF.
*
* Print a message if the queue name is missing and exit from
* program
*
IF W02-OBJECT = SPACES OR W02-OBJECT = LOW-VALUES THEN
MOVE W04-MESSAGE-3 TO W00-PRINT-DATA
PERFORM PRINT-LINE
MOVE W06-CSQ4-WARNING TO W00-RETURN-CODE
GO TO A-MAIN-END
END-IF.
*
* Print the remaining header lines
*
PERFORM PRINT-HEADER-2.
*
* Connect to the specified queue manager.
*
CALL 'MQCONN' USING W02-MQM
W03-HCONN
W03-COMPCODE
W03-REASON.
*
* Test the output of the connect call. If the call failed,
* print an error message showing the completion code and
* reason code
*
IF (W03-COMPCODE NOT = MQCC-OK) THEN
MOVE 'CONNECT' TO W04-MSG4-TYPE
MOVE W03-COMPCODE TO W04-MSG4-COMPCODE
MOVE W03-REASON TO W04-MSG4-REASON
MOVE W04-MESSAGE-4 TO W00-PRINT-DATA
PERFORM PRINT-LINE
MOVE W06-CSQ4-ERROR TO W00-RETURN-CODE
GO TO A-MAIN-END
END-IF.
*
* Initialize the object descriptor (MQOD) control block.
* (The copy file initializes all the other fields)
*
MOVE MQOT-Q TO MQOD-OBJECTTYPE.
MOVE W02-OBJECT TO MQOD-OBJECTNAME.
*
* Initialize the working storage fields required to open
* the queue
*
* W03-OPTIONS is set to open the queue for browsing
* W03-HOBJ is set by the MQOPEN call and is used by the
* MQGET and MQCLOSE calls
*
MOVE MQOO-BROWSE TO W03-OPTIONS.
*
* Open the queue.
*
CALL 'MQOPEN' USING W03-HCONN
MQOD
W03-OPTIONS
W03-HOBJ
W03-COMPCODE
W03-REASON.
*
* Test the output of the open call. If the call failed, print
* an error message showing the completion code and reason code
*
IF (W03-COMPCODE NOT = MQCC-OK) THEN
MOVE 'OPEN' TO W04-MSG4-TYPE
MOVE W03-COMPCODE TO W04-MSG4-COMPCODE
MOVE W03-REASON TO W04-MSG4-REASON
MOVE W04-MESSAGE-4 TO W00-PRINT-DATA
PERFORM PRINT-LINE
MOVE W06-CSQ4-ERROR TO W00-RETURN-CODE
GO TO A-MAIN-DISCONNECT
END-IF.
*
* No need to change the Message Descriptor (MQMD) control
* block because the copy file initializes all the fields
*
* Initialize the Get Message Options (MQGMO) control block.
* (The copy file initializes all the other fields)
*
MOVE MQGMO-NO-WAIT TO MQGMO-OPTIONS.
ADD MQGMO-ACCEPT-TRUNCATED-MSG TO MQGMO-OPTIONS.
ADD MQGMO-BROWSE-FIRST TO MQGMO-OPTIONS.
*
* Make the first get call outside the loop because this call
* uses the BROWSE-FIRST option
*
CALL 'MQGET' USING W03-HCONN
W03-HOBJ
MQMD
MQGMO
W03-BUFFER-LENGTH
W03-MESSAGE-DATA
W03-DATA-LENGTH
W03-COMPCODE
W03-REASON.
*
* Test the output of the get call using the PERFORM loop
* that follows.
*
* Change the MQGMO Options field to BROWSE-NEXT.
*
MOVE MQGMO-NO-WAIT TO MQGMO-OPTIONS.
ADD MQGMO-ACCEPT-TRUNCATED-MSG TO MQGMO-OPTIONS.
ADD MQGMO-BROWSE-NEXT TO MQGMO-OPTIONS.
*
* Loop from here to END-PERFORM until the get call fails
* - we test for call not successful and the one condition
* after which we want to continue within the loop
* (the received message has been truncated)
*
PERFORM WITH TEST BEFORE
UNTIL W03-COMPCODE NOT = MQCC-OK
AND NOT (W03-COMPCODE = MQCC-WARNING AND
W03-REASON = MQRC-TRUNCATED-MSG-ACCEPTED)
*
* Increment the relative message number. Move the message
* number and the message data into the print line
*
ADD 1 TO W00-MESSAGE-COUNT
MOVE W00-MESSAGE-COUNT TO W01-MESSAGE-NUMBER
MOVE W03-DATA-LENGTH TO W01-MESSAGE-LENGTH
MOVE W03-MESSAGE-DATA TO W01-DATA
MOVE W01-REPORT-LINE TO W00-PRINT-DATA
*
* Print the message line
*
PERFORM PRINT-LINE
*
******************************************************************
* MQMD-MSGID and MQMD-CORRELID are input/output fields that *
* are filled and read by MQGET. Clear them before the next *
* MQGET call to ensure that all messages are retrieved. *
******************************************************************
*
MOVE MQMI-NONE TO MQMD-MSGID
MOVE MQCI-NONE TO MQMD-CORRELID
*
* Clear the message data field before the next get call to
* ensure that no old data remains if the next line is shorter
*
MOVE SPACES TO W03-MESSAGE-DATA
*
* Get the next message
*
CALL 'MQGET' USING W03-HCONN
W03-HOBJ
MQMD
MQGMO
W03-BUFFER-LENGTH
W03-MESSAGE-DATA
W03-DATA-LENGTH
W03-COMPCODE
W03-REASON
*
* Test the output of the MQGET call at the top of the loop.
* Exit the loop if an error occurs
*
END-PERFORM.
*
* Test the output of the get call
*
* When the loop reaches the end of the messages, the
* completion code is MQCC-FAILED and the reason code
* is MQRC-NO-MSG-AVAILABLE
*
* If the call failed for any other reason,
* print an error message showing the completion code and
* reason code
*
IF (W03-COMPCODE = MQCC-FAILED) AND
(W03-REASON = MQRC-NO-MSG-AVAILABLE) THEN
*
MOVE W04-MESSAGE-0 TO W00-PRINT-DATA
*
ELSE
MOVE 'GET' TO W04-MSG4-TYPE
MOVE W03-COMPCODE TO W04-MSG4-COMPCODE
MOVE W03-REASON TO W04-MSG4-REASON
MOVE W04-MESSAGE-4 TO W00-PRINT-DATA
END-IF.
*
PERFORM PRINT-LINE
*
* Close the queue
*
MOVE MQCO-NONE TO W03-OPTIONS.
*
CALL 'MQCLOSE' USING W03-HCONN
W03-HOBJ
W03-OPTIONS
W03-COMPCODE
W03-REASON.
*
* Test the output of the MQCLOSE call. If the call failed,
* print an error message showing the completion code and reason
* code
*
IF (W03-COMPCODE NOT = MQCC-OK) THEN
MOVE 'CLOSE' TO W04-MSG4-TYPE
MOVE W03-COMPCODE TO W04-MSG4-COMPCODE
MOVE W03-REASON TO W04-MSG4-REASON
MOVE W04-MESSAGE-4 TO W00-PRINT-DATA
PERFORM PRINT-LINE
MOVE W06-CSQ4-ERROR TO W00-RETURN-CODE
END-IF.
*
A-MAIN-DISCONNECT.
*
* Disconnect from the queue manager
*
CALL 'MQDISC' USING W03-HCONN
W03-COMPCODE
W03-REASON.
*
* Test the output of the disconnect call. If the call failed,
* print an error message showing the completion code and
* reason code
*
IF (W03-COMPCODE NOT = MQCC-OK) THEN
MOVE 'DISCONNECT' TO W04-MSG4-TYPE
MOVE W03-COMPCODE TO W04-MSG4-COMPCODE
MOVE W03-REASON TO W04-MSG4-REASON
MOVE W04-MESSAGE-4 TO W00-PRINT-DATA
MOVE W06-CSQ4-ERROR TO W00-RETURN-CODE
PERFORM PRINT-LINE
END-IF.
*
A-MAIN-END.
*
* Set the return code
*
MOVE W00-RETURN-CODE to RETURN-CODE.
*
* Close the print file and stop
*
CLOSE SYSPRINT.
STOP RUN.
*
******************************************************************
*
PRINT-LINE SECTION.
*
* This section prints all data lines produced by the program
*
* If the maximum number of lines for a page has been printed,
* start a new page
*
IF W00-LINE-COUNT > W00-MAX-LINES
PERFORM PRINT-HEADER-1
PERFORM PRINT-HEADER-2
END-IF.
*
MOVE W00-PRINT-DATA TO PRINT-DATA.
WRITE PRINT-REC AFTER ADVANCING 1.
*
ADD 1 TO W00-LINE-COUNT.
*
PRINT-LINE-END.
EXIT.
*
******************************************************************
*
PRINT-HEADER-1 SECTION.
*
* This section prints the first line of the report.
* This is separate from the section that prints the other
* header lines because the first line is needed every time
* the program runs
*
ADD 1 TO W00-PAGE-NUMBER.
MOVE W00-PAGE-NUMBER TO W01-PAGE.
MOVE W01-HEADER-1 TO PRINT-DATA.
WRITE PRINT-REC AFTER ADVANCING PAGE.
*
MOVE 1 TO W00-LINE-COUNT.
*
PRINT-HEADER-1-END.
EXIT.
*
******************************************************************
*
PRINT-HEADER-2 SECTION.
*
* This section prints the remaining header lines
*
MOVE W01-HEADER-2 TO PRINT-DATA.
WRITE PRINT-REC AFTER ADVANCING 2.
ADD 2 TO W00-LINE-COUNT.
*
MOVE W01-HEADER-3 TO PRINT-DATA.
WRITE PRINT-REC AFTER ADVANCING 1.
ADD 1 TO W00-LINE-COUNT.
*
MOVE W01-HEADER-4 TO PRINT-DATA.
WRITE PRINT-REC AFTER ADVANCING 2.
ADD 2 TO W00-LINE-COUNT.
*
MOVE W01-HEADER-5 TO PRINT-DATA.
WRITE PRINT-REC AFTER ADVANCING 1.
ADD 1 TO W00-LINE-COUNT.
*
MOVE W01-HEADER-6 TO PRINT-DATA.
WRITE PRINT-REC AFTER ADVANCING 1.
ADD 1 TO W00-LINE-COUNT.
*
MOVE SPACES TO PRINT-DATA.
WRITE PRINT-REC AFTER ADVANCING 1.
ADD 1 TO W00-LINE-COUNT.
*
PRINT-HEADER-2-END.
EXIT.
* --------------------------------------------------------------- *
* End of program *
* --------------------------------------------------------------- *
¤ Dauer der Verarbeitung: 0.53 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.
|
