| 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: am_sml.ML Sprache: CobolOriginal von: verschiedene© |
|
||||||
|
CBL XOPTS(ANSI85)
CBL NODYNAM,LIB,OBJECT,RENT,RES,APOST * * * ------------------------------------------------------------- * IDENTIFICATION DIVISION. * ------------------------------------------------------------- * PROGRAM-ID. CSQ4CVJ1. *REMARKS * ***************************************************************** * @START_COPYRIGHT@ * * Statement: Licensed Materials - Property of IBM * * * * 5695-137 * * (C) Copyright IBM Corporation. 1993. 1997 * * * * Status: Version 1 Release 2 * * @END_COPYRIGHT@ * * * * Module Name : CSQ4CVJ1 * * * * Environment : CICS/ESA Version 3.3; COBOL II * * * * CICS Transaction Name : MVGT * * * * Description : Sample program to get a number of messages * * from a queue. These messages are written to * * a CICS temporary storage queue. * * * * Notes : The maximum message length is 9950. Messages * * greater than this will not cause an error but * * will be truncated. * * The syncpoint option is ignored when browsing. * * * ***************************************************************** * * * Program Logic * * -------------- * * * * * * MAIN * * ---- * * * * Receive the parameter list from CICS. * * If parameter list is invalid then * * Call USAGE-ERROR and exit. * * * * Create a CICS temporary storage queue. * * * * Open the specified message queue (MQOPEN). * * If open failed then * * Call DISPLAY-ERROR-MESSAGE and exit. * * * * Set the get message options. * * Loop while the messages are received * * Get message from queue (MQGET) * * If get failed * * Call DISPLAY-MESSAGE * * Break from loop * * Else * * Put the message to the CICS TSQ * * Endif * * Endloop. * * If no error occurred * * Display number of messages put to the queue. * * Endif * * * * If syncpoint variable set then * * Execute syncpoint. * * * * Close the message queue. * * If close failed then * * Call DISPLAY-ERROR-MESSAGE. * * * * Return control to CICS. * * * * * *---------------------------------------------------------------* * * * USAGE-ERROR * * ----------- * * * * Print message showing correct usage for program. * * * * * *---------------------------------------------------------------* * * * DISPLAY-ERROR-MESSAGE * * --------------------- * * * * Create error message. * * Print error message to CICS screen. * * * * * *---------------------------------------------------------------* * * * DISPLAY-MESSAGE * * --------------- * * * * Sends valid message to CICS screen. * * * * * ***************************************************************** * ------------------------------------------------------------- * ENVIRONMENT DIVISION. * ------------------------------------------------------------- * * ------------------------------------------------------------- * DATA DIVISION. * ------------------------------------------------------------- * FILE SECTION. * ------------------------------------------------------------- * WORKING-STORAGE SECTION. * ------------------------------------------------------------- * * * W00 - General work variables * 01 W00-RETURN-CODE PIC S9(4) BINARY VALUE ZERO. 01 W00-LOOP PIC S9(9) BINARY VALUE 0. 01 W00-LOOP-CHAR PIC X(9) VALUE SPACES. 01 W00-NUMGETS PIC S9(9) BINARY VALUE 0. 01 W00-NUMGETS-CHAR PIC X(9) VALUE SPACES. 01 W00-ERROR-MESSAGE PIC X(10) VALUE SPACES. 01 W00-MESSAGE PIC X(80) VALUE SPACES. 01 W00-TSQMESSAGE PIC X(9999) VALUE SPACES. 01 W00-TSQMESSAGE-LENGTH PIC S9(4) BINARY VALUE 0. 01 W00-MSGBUFFER. 02 W00-MSGBUFFER-ARRAY PIC X(1) OCCURS 9950 TIMES. 01 W00-DATALENGTH PIC S9(9) BINARY VALUE 0. 01 W00-DATALENGTH-CHAR PIC X(9) VALUE SPACES. * * Parameter variables * 01 W00-PARM-LEN PIC S9(03) BINARY. 01 W00-PARM-STRING. 02 W00-PARM-STRING-ARRAY PIC X(1) OCCURS 100 TIMES. * 01 W00-TRANSNAME PIC X(8) VALUE SPACES. 01 W00-QNAME PIC X(48) VALUE SPACES. 01 W00-NUMMSGS-CHAR PIC X(4) VALUE SPACES. 01 W00-NUMMSGS PIC S9(9) BINARY VALUE 1. 01 W00-MSGLENGTH PIC S9(9) BINARY VALUE 9950. 01 W00-MSGLENGTH-CHAR PIC X(9) VALUE SPACES. 01 W00-BROWSE-GET PIC X(1) VALUE 'D'. 88 BROWSE-GET VALUE 'B'. 88 DESTRUCTIVE-GET VALUE 'D'. 01 W00-SYNCPOINT PIC X(1) VALUE 'N'. 88 SYNCPOINT VALUE 'S'. 88 NO-SYNCPOINT VALUE 'N'. * * W03 - API fields * 01 W03-HCONN PIC S9(9) BINARY VALUE 0. 01 W03-HOBJ PIC S9(9) BINARY VALUE 0. 01 W03-OPENOPTIONS PIC S9(9) BINARY. 01 W03-COMPCODE PIC S9(9) BINARY. 01 W03-COMPCODE-CHAR PIC X(9) VALUE SPACES. 01 W03-REASON PIC S9(9) BINARY. 01 W03-REASON-CHAR PIC X(9) VALUE SPACES. * * API control blocks * 01 MQM-OBJECT-DESCRIPTOR. COPY CMQODV. 01 MQM-MESSAGE-DESCRIPTOR. COPY CMQMDV. 01 MQM-GET-MESSAGE-OPTIONS. COPY CMQGMOV. * * MQV contains constants (for filling in the control blocks) * and return codes (for testing the result of a call) * 01 MQM-CONSTANTS. COPY CMQV SUPPRESS. * * * DFHAID contains the constants used for checking for * attention identifiers * COPY DFHAID SUPPRESS. * * * ------------------------------------------------------------- * LINKAGE SECTION. * ------------------------------------------------------------- * EJECT * ------------------------------------------------------------- * PROCEDURE DIVISION. * ------------------------------------------------------------- * * ------------------------------------------------------------- * A-MAIN SECTION. * ------------------------------------------------------------- * * * Receive the parameter list from CICS * MOVE SPACES TO W00-PARM-STRING. * EXEC CICS RECEIVE INTO( W00-PARM-STRING ) LENGTH( W00-PARM-LEN ) END-EXEC. * * * If parameter list is invalid then display * error message and exit program * IF (W00-PARM-LEN < 15) THEN PERFORM USAGE-ERROR MOVE 8 TO W00-RETURN-CODE GO TO A-MAIN-END END-IF. * IF ((W00-PARM-STRING-ARRAY(5) NOT = ',') OR (W00-PARM-STRING-ARRAY(10) NOT = ',') OR (W00-PARM-STRING-ARRAY(12) NOT = ',') OR (W00-PARM-STRING-ARRAY(14) NOT = ',')) THEN * PERFORM USAGE-ERROR MOVE 8 TO W00-RETURN-CODE GO TO A-MAIN-END END-IF. * UNSTRING W00-PARM-STRING DELIMITED BY ALL ',' INTO W00-TRANSNAME W00-NUMMSGS-CHAR W00-BROWSE-GET W00-SYNCPOINT W00-QNAME. MOVE W00-NUMMSGS-CHAR TO W00-NUMMSGS. * * Create a CICS temporary storage queue to hold * all the messages received from the queue * EXEC CICS IGNORE CONDITION QIDERR END-EXEC. EXEC CICS IGNORE CONDITION LENGERR END-EXEC. EXEC CICS DELETEQ TS QUEUE( W00-TRANSNAME ) END-EXEC. * * * * Open queue for input shared and browse * COMPUTE W03-OPENOPTIONS = MQOO-INPUT-SHARED + MQOO-BROWSE. MOVE W00-QNAME TO MQOD-OBJECTNAME. * CALL 'MQOPEN' USING W03-HCONN MQOD W03-OPENOPTIONS W03-HOBJ W03-COMPCODE W03-REASON. * * If open failed display error message and exit * IF (W03-COMPCODE NOT = MQCC-OK) THEN MOVE 'MQOPEN' TO W00-ERROR-MESSAGE PERFORM DISPLAY-ERROR-MESSAGE MOVE W03-REASON TO W00-RETURN-CODE GO TO A-MAIN-END END-IF. * * * * Setup MQGMO-OPTIONS depending on parameters passed * into program. * COMPUTE MQGMO-OPTIONS = MQGMO-NO-WAIT + MQGMO-ACCEPT-TRUNCATED-MSG. IF SYNCPOINT AND DESTRUCTIVE-GET THEN ADD MQGMO-SYNCPOINT TO MQGMO-OPTIONS ELSE ADD MQGMO-NO-SYNCPOINT TO MQGMO-OPTIONS END-IF. * IF BROWSE-GET THEN ADD MQGMO-BROWSE-FIRST TO MQGMO-OPTIONS END-IF. * * * Loop getting the messages. * The message ID and Correl ID * are blanked before each MQGET. * PERFORM WITH TEST BEFORE VARYING W00-LOOP FROM 0 BY 1 UNTIL (W00-LOOP >= W00-NUMMSGS) * MOVE SPACES TO W00-MSGBUFFER MOVE MQMI-NONE TO MQMD-MSGID MOVE MQCI-NONE TO MQMD-CORRELID * CALL 'MQGET' USING W03-HCONN W03-HOBJ MQMD MQGMO W00-MSGLENGTH W00-MSGBUFFER W00-DATALENGTH W03-COMPCODE W03-REASON * * If get failed, display the error message and * break out of the loop. * Otherwise put the message to the CICS * temporary storage queue. * ADD 1 TO W00-NUMGETS IF (W03-COMPCODE = MQCC-FAILED) THEN MOVE W00-NUMGETS TO W00-NUMGETS-CHAR MOVE W03-COMPCODE TO W03-COMPCODE-CHAR MOVE W03-REASON TO W03-REASON-CHAR * MOVE SPACES TO W00-MESSAGE STRING 'MQGET ', W00-NUMGETS-CHAR, ' failed' ' * CC : ', W03-COMPCODE-CHAR, ' * RC : ', W03-REASON-CHAR, ' *' DELIMITED BY SIZE INTO W00-MESSAGE PERFORM DISPLAY-MESSAGE MOVE W00-NUMMSGS TO W00-LOOP * ELSE MOVE W00-LOOP TO W00-LOOP-CHAR MOVE W00-DATALENGTH TO W00-DATALENGTH-CHAR MOVE W00-MSGLENGTH TO W00-MSGLENGTH-CHAR MOVE SPACES TO W00-TSQMESSAGE * IF W03-REASON = MQRC-TRUNCATED-MSG-ACCEPTED THEN STRING W00-LOOP-CHAR, ' : ', W00-DATALENGTH-CHAR, ' : Truncated to ', W00-MSGLENGTH-CHAR, ' : ', W00-MSGBUFFER(1:W00-MSGLENGTH) DELIMITED BY SIZE INTO W00-TSQMESSAGE COMPUTE W00-TSQMESSAGE-LENGTH = W00-MSGLENGTH + 49 ELSE STRING W00-LOOP-CHAR, ' : ', W00-DATALENGTH-CHAR, ' : ', W00-MSGBUFFER(1:W00-DATALENGTH) DELIMITED BY SIZE INTO W00-TSQMESSAGE COMPUTE W00-TSQMESSAGE-LENGTH = W00-DATALENGTH + 24 END-IF * EXEC CICS WRITEQ TS QUEUE( W00-TRANSNAME ) FROM( W00-TSQMESSAGE ) LENGTH( W00-TSQMESSAGE-LENGTH ) END-EXEC END-IF * * If browsing the queue then change the * MQGMO-OPTIONS browse options. * IF (W00-LOOP = 0) AND BROWSE-GET THEN SUBTRACT MQGMO-BROWSE-FIRST FROM MQGMO-OPTIONS ADD MQGMO-BROWSE-NEXT TO MQGMO-OPTIONS END-IF * END-PERFORM. * * * If no error occurred, display the number of messages * successfully got from the queue * IF (W03-COMPCODE < MQCC-FAILED) THEN MOVE SPACES TO W00-MESSAGE MOVE W00-NUMGETS TO W00-NUMGETS-CHAR STRING W00-NUMGETS-CHAR, ' MESSAGES GOT FROM QUEUE' DELIMITED BY SIZE INTO W00-MESSAGE PERFORM DISPLAY-MESSAGE END-IF * * * If program started with syncpoint and destructive get * then execute syncpoint * IF SYNCPOINT AND DESTRUCTIVE-GET THEN EXEC CICS SYNCPOINT END-EXEC END-IF. * * * CLOSE the queue * CALL 'MQCLOSE' USING W03-HCONN W03-HOBJ MQCO-NONE W03-COMPCODE W03-REASON. * * If close failed then display error message * IF (W03-COMPCODE NOT = MQCC-OK) THEN MOVE 'MQCLOSE' TO W00-ERROR-MESSAGE PERFORM DISPLAY-ERROR-MESSAGE MOVE W03-REASON TO W00-RETURN-CODE END-IF. * * * A-MAIN-END. * * MOVE W00-RETURN-CODE TO RETURN-CODE EXEC CICS RETURN END-EXEC. * GOBACK. EJECT * * ------------------------------------------------------------- * USAGE-ERROR SECTION. * ------------------------------------------------------------- * * MOVE SPACES TO W00-MESSAGE. MOVE '=Usage : MVGT,9999,B,S,QUEUE.NAME=' TO W00-MESSAGE. PERFORM DISPLAY-MESSAGE. * USAGE-ERROR-END. * * RETURN TO PERFORMING FUNCTION * EXIT. * * ------------------------------------------------------------- * DISPLAY-ERROR-MESSAGE SECTION. * ------------------------------------------------------------- * * MOVE W03-COMPCODE TO W03-COMPCODE-CHAR. MOVE W03-REASON TO W03-REASON-CHAR. * MOVE SPACES TO W00-MESSAGE. STRING '* ', W00-ERROR-MESSAGE, ' * CC : ', W03-COMPCODE-CHAR, ' * RC : ', W03-REASON-CHAR, ' *' DELIMITED BY SIZE INTO W00-MESSAGE. PERFORM DISPLAY-MESSAGE. * DISPLAY-ERROR-MESSAGE-END. * * RETURN TO PERFORMING FUNCTION * EXIT. * * ------------------------------------------------------------- * DISPLAY-MESSAGE SECTION. * ------------------------------------------------------------- * * EXEC CICS SEND FROM( W00-MESSAGE ) LENGTH( 79 ) ERASE END-EXEC. MOVE SPACES TO W00-MESSAGE. * DISPLAY-MESSAGE-END. * * RETURN TO PERFORMING FUNCTION * EXIT. * * ------------------------------------------------------------- * * END OF PROGRAM * ------------------------------------------------------------- * ¤ Dauer der Verarbeitung: 0.28 Sekunden (vorverarbeitet) ¤ |
schauen Sie vor die Tür
Fenster
Die Firma ist wie angegeben erreichbar.Die farbliche Syntaxdarstellung ist noch experimentell.Bot Zugriff |
