|
CBL XOPTS(ANSI85)
CBL NODYNAM,LIB,OBJECT,RENT,RES,APOST
* *
* ------------------------------------------------------------- *
IDENTIFICATION DIVISION.
* ------------------------------------------------------------- *
PROGRAM-ID. CSQ4CVK1.
*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 : CSQ4CVK1 *
* *
* Environment : CICS/ESA Version 3.3; COBOL II *
* *
* CICS Transaction Name : MVPT *
* *
* Description : Sample program to put a number of messages *
* to a queue. *
* *
* Note : The maximum message length is 65535. Messages *
* greater than this will not cause an error but *
* will be truncated. *
* *
*****************************************************************
* *
* Program Logic *
* -------------- *
* *
* main *
* ---- *
* *
* Receive the parameter list from CICS. *
* If parameter list is invalid then *
* Call USAGE-ERROR and exit. *
* *
* Setup message buffer. *
* *
* Open the specified message queue (MQOPEN). *
* If open failed then *
* Call DISPLAY-ERROR-MESSAGE and exit. *
* *
* Set the put message options. *
* Loop while the messages are put to queue *
* Put message to queue (MQPUT) *
* If put failed *
* Call DISPLAY-MESSAGE *
* Break from loop *
* Endif *
* Endloop. *
* If no error occurred *
* Display number of messages put to the queue. *
* Endif *
* *
* 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 fields
*
01 W00-RETURN-CODE PIC S9(4) BINARY VALUE ZERO.
01 W00-LOOP PIC S9(9) BINARY VALUE 0.
01 W00-NUMPUTS-CHAR PIC X(9) VALUE SPACES.
01 W00-NUMPUTS PIC S9(9) BINARY VALUE 0.
01 W00-ERROR-MESSAGE PIC X(10) VALUE SPACES.
01 W00-MESSAGE PIC X(80) 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 ' '.
01 W00-QNAME PIC X(48) VALUE SPACES.
01 W00-PADCHAR PIC X(1) VALUE '*'.
01 W00-MSGBUFFER.
02 W00-MSGBUFFER-ARRAY PIC X(1) OCCURS 65535 TIMES.
01 W00-NUMMSGS-CHAR PIC X(4) VALUE SPACES.
01 W00-NUMMSGS PIC S9(9) BINARY VALUE 1.
01 W00-MSGLENGTH-CHAR PIC X(4) VALUE SPACES.
01 W00-MSGLENGTH PIC S9(9) BINARY VALUE 100.
01 W00-PERSISTENCE PIC X(1) VALUE 'N'.
88 PERSISTENT VALUE 'P'.
88 NOT-PERSISTENT VALUE 'N'.
*
* W03 - API fields
*
01 W03-HCONN PIC S9(9) BINARY VALUE ZERO.
01 W03-HOBJ PIC S9(9) BINARY VALUE ZERO.
01 W03-OPENOPTIONS PIC S9(9) BINARY VALUE ZERO.
01 W03-COMPCODE PIC S9(9) BINARY VALUE ZERO.
01 W03-COMPCODE-CHAR PIC X(9) VALUE SPACES.
01 W03-REASON PIC S9(9) BINARY VALUE ZERO.
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-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.
*
* 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 passed in by CICS
*
MOVE SPACES TO W00-PARM-STRING.
EXEC CICS IGNORE CONDITION LENGERR END-EXEC.
EXEC CICS RECEIVE
INTO( W00-PARM-STRING )
LENGTH( W00-PARM-LEN )
END-EXEC.
*
* If parameter list invalid then call USAGE-ERROR
* and exit
*
IF (W00-PARM-LEN < 20) 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(17) NOT = ',') OR
(W00-PARM-STRING-ARRAY(19) NOT = ',')) THEN
*
PERFORM USAGE-ERROR
MOVE 8 TO W00-RETURN-CODE
GO TO A-MAIN-END
END-IF.
*
* Move parameters into corresponding variables
*
UNSTRING W00-PARM-STRING DELIMITED BY ALL ','
INTO W00-TRANSNAME
W00-NUMMSGS-CHAR
W00-PADCHAR
W00-MSGLENGTH-CHAR
W00-PERSISTENCE
W00-QNAME.
MOVE W00-MSGLENGTH-CHAR TO W00-MSGLENGTH.
MOVE W00-NUMMSGS-CHAR TO W00-NUMMSGS.
*
*
* Setup the message buffer
*
PERFORM WITH TEST BEFORE VARYING W00-LOOP FROM 1 BY 1
UNTIL (W00-LOOP > W00-MSGLENGTH)
*
MOVE W00-PADCHAR TO W00-MSGBUFFER-ARRAY(W00-LOOP)
*
END-PERFORM.
*
*
*
* Open the queue for output
*
MOVE MQOO-OUTPUT TO W03-OPENOPTIONS.
MOVE W00-QNAME TO MQOD-OBJECTNAME.
*
CALL 'MQOPEN' USING W03-HCONN
MQOD
W03-OPENOPTIONS
W03-HOBJ
W03-COMPCODE
W03-REASON.
*
* If open failed then 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.
*
*
* Set persistence depending on parameter passed
*
IF PERSISTENT THEN
MOVE MQPER-PERSISTENT TO MQMD-PERSISTENCE
ELSE
MOVE MQPER-NOT-PERSISTENT TO MQMD-PERSISTENCE
END-IF.
*
* Loop until specified number of messages put to queue
*
PERFORM WITH TEST BEFORE VARYING W00-LOOP FROM 0 BY 1
UNTIL (W00-LOOP >= W00-NUMMSGS)
*
MOVE MQMI-NONE TO MQMD-MSGID
MOVE MQCI-NONE TO MQMD-CORRELID
*
CALL 'MQPUT' USING W03-HCONN
W03-HOBJ
MQMD
MQPMO
W00-MSGLENGTH
W00-MSGBUFFER
W03-COMPCODE
W03-REASON
*
* If put failed then display error message
* and break out of loop
*
ADD 1 TO W00-NUMPUTS
IF (W03-COMPCODE NOT = MQCC-OK) THEN
MOVE W00-NUMPUTS TO W00-NUMPUTS-CHAR
MOVE W03-COMPCODE TO W03-COMPCODE-CHAR
MOVE W03-REASON TO W03-REASON-CHAR
*
MOVE SPACES TO W00-MESSAGE
STRING 'MQPUT ', W00-NUMPUTS-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
MOVE W03-REASON TO W00-RETURN-CODE
END-IF
*
END-PERFORM.
*
* If no error occurred, display the number of messages
* successfully put to the queue
*
IF (W03-COMPCODE = MQCC-OK) THEN
MOVE W00-NUMPUTS TO W00-NUMPUTS-CHAR
MOVE SPACES TO W00-MESSAGE
STRING W00-NUMPUTS-CHAR, ' MESSAGES PUT TO QUEUE'
DELIMITED BY SIZE INTO W00-MESSAGE
PERFORM DISPLAY-MESSAGE
END-IF
*
*
*
*
* Close the queue
*
CALL 'MQCLOSE' USING W03-HCONN
W03-HOBJ
MQCO-NONE
W03-COMPCODE
W03-REASON.
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 : MVPT,9999,*,9999,P,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.8 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.
|
