| products/Sources/formale Sprachen/Cobol/verschiedene-Autoren/CICS/ |
|
Quellcode-Bibliothek© Kompilation durch diese Firma[Weder Korrektheit noch Funktionsfähigkeit der Software werden zugesichert.]Datei: Sprache: CobolOriginal von: verschiedene© |
|
||||||
|
IDENTIFICATION DIVISION.
PROGRAM-ID. OSCICS4C. DATE-WRITTEN. 12/17/96. DATE-COMPILED. ****************************************************************** ** ** (c) 1995 by Sybase, Inc. All Rights Reserved ** ****************************************************************** ****************************************************************** ** PROGRAM: OSCICS4C ** ** THIS PROGRAM IS A THE OPEN SERVER VERSION OF RSP4C. ** It will receive one of 2 Keywords @ERRORMSG or @WARNMSG and ** Other Keywords. Will reply with the keywords and data. ** If @ERRORMSG AND/OR @WARNMSG are 'Y' that type of message ** will be returned... ** exec SY4C @WARNMSG=Y,@ERRORMSG=Y......... ****************************************************************** ENVIRONMENT DIVISION. DATA DIVISION. WORKING-STORAGE SECTION. ****************************************************************** * COPY IN THE OS SERVER LIBRARYS ****************************************************************** COPY SYGWCOB. ****************************************************************** *OPEN SERVER WORK VARIBLES FOR OS CALL TO USE ... ****************************************************************** 01 WS-GWL-WORK-VARIBLES. 05 GWL-PROC POINTER. 05 GWL-INIT-HANDLE POINTER. 05 GWL-RC PIC S9(9) COMP. 05 GWL-INFPRM-ID PIC S9(9) COMP. 05 GWL-INFPRM-TYPE PIC S9(9) COMP. 05 GWL-INFPRM-DATA-L PIC S9(9) COMP. 05 GWL-INFPRM-MAX-DATA-L PIC S9(9) COMP. 05 GWL-INFPRM-STATUS PIC S9(9) COMP. 05 GWL-INFPRM-NAME PIC X(30). 05 GWL-INFPRM-NAME-L PIC S9(9) COMP. 05 GWL-INFPRM-USER-DATA PIC S9(9) COMP. 05 GWL-INFUDT-USER-TYPE PIC S9(9) COMP. 05 GWL-STATUS-NR PIC S9(9) COMP. 05 GWL-STATUS-DONE PIC S9(9) COMP. 05 GWL-STATUS-COUNT PIC S9(9) COMP. 05 GWL-STATUS-COMM PIC S9(9) COMP. 05 GWL-COMM-STATE PIC S9(9) COMP. 05 GWL-STATUS-RETURN-CODE PIC S9(9) COMP. 05 GWL-STATUS-SUBCODE PIC S9(9) COMP. 05 GWL-NUMPRM-PARMS PIC S9(9) COMP. 05 GWL-RCVPRM-DATA-L PIC S9(9) COMP. 05 GWL-SETPRM-ID PIC S9(9) COMP. 05 GWL-SETPRM-TYPE PIC S9(9) COMP. 05 GWL-SETPRM-DATA-L PIC S9(9) COMP. 05 GWL-SETPRM-USER-DATA PIC S9(9) COMP. 05 GWL-CONVRT-SCALE PIC S9(9) COMP VALUE 2. 05 GWL-SETBCD-SCALE PIC S9(9) COMP VALUE 0. 05 GWL-INFBCD-LENGTH PIC S9(9) COMP. 05 GWL-INFBCD-SCALE PIC S9(9) COMP. 05 GWL-RETURN-ROWS PIC S9(9) COMP VALUE +0. 05 SNA-CONN-NAME PIC X(8) VALUE SPACES. 05 SNA-SUBC PIC S9(9) COMP. 05 WRK-DONE-STATUS PIC S9(9) COMP. 05 GWL-ACTUAL-LEN PIC S9(9) COMP. 05 GWL-TRAN-LEN PIC S9(9) COMP. 05 GWL-MSG-LEN PIC S9(9) COMP. 05 WS-NUMPRM-PARMS PIC S9(9) COMP. 05 GWL-REQUEST-TYP PIC S9(9) COMP. 05 GWL-RPC-NAME PIC X(30) VALUE SPACES. 05 GWL-COMM-STATE PIC S9(9) COMP. 05 I PIC S9(9) COMP. 05 WS-ERROR-MSG PIC S9(9) COMP VALUE ZERO. 05 WS-ERROR-SEV PIC S9(9) COMP VALUE ZERO. 01 DESCRIPTION-FIELDS. 05 COLUMN-NUMBER PIC S9(09) COMP VALUE +0. 05 HOST-TYPE PIC S9(09) COMP VALUE +0. 05 HOST-LEN PIC S9(09) COMP VALUE +0. 05 COLUMN-LEN PIC S9(09) COMP VALUE +0. 05 COLUMN-NAME-LEN PIC S9(09) COMP VALUE +0. 05 WS-ZERO PIC S9(09) COMP VALUE +0. 01 WS-MSG-WORK-VARS. 05 MSG-NR PIC S9(9) COMP VALUE +9999. 01 WS-INPUT-LEN PIC S9(9) COMP VALUE +55. 01 WS-INPUT-DATA PIC X(55) VALUE SPACES. 01 WS-LENGTH PIC S9(9) COMP VALUE ZERO. 01 WS-WARNMSG PIC X(8) VALUE '@WARNMSG'. 01 WS-WARNMSG-ID PIC S9(9) COMP VALUE ZERO. 01 WS-WARNMSG-88 PIC X(1) VALUE 'N'. 88 WARNING-MSG VALUE 'Y'. 01 WS-ERRORMSG PIC X(9) VALUE '@ERRORMSG'. 01 WS-ERRORMSG-ID PIC S9(9) COMP VALUE ZERO. 01 WS-ERRORMSG-88 PIC X(1) VALUE 'N'. 88 ERROR-MSG VALUE 'Y'. 01 WS-OUTPUT-DATA PIC X(55) VALUE SPACES. 01 WS-OUTPUT-COL-NAME PIC X(13) VALUE 'OUTPUT_COLUMN'. 01 WS-QUEUE-NAME. 05 WS-TRANID PIC X(4) VALUE 'SY3C'. 05 WS-TRMID PIC X(4) VALUE SPACES. 01 CICSRC PIC S9(8) COMP. 01 CICSRC-DIS PIC S9(8). ****************************************************************** * MESSAGES * ****************************************************************** 01 WS-MSG. 05 FILLER PIC X(17) VALUE 'ERROR IN OS CALL '. 05 WS-MSG-FUNC PIC X(10). 05 FILLER PIC X(04) VALUE 'RC='. 05 WS-MSG-RC PIC S9(9). 05 FILLER PIC X(18) VALUE ' SUBCODE ERROR = '. 05 MSG-SUBC PIC 9(9) VALUE 0. 05 WS-MSG-TEXT PIC X(50) VALUE SPACES. 01 WS-HOLD-MSG PIC X(107) VALUE SPACES. 01 WS-WARN-MSG PIC X(107) VALUE 'THIS IS A WARNING MESSAGE........'. 01 WS-ERR-MSG PIC X(107) VALUE 'THIS IS A ERROR MESSAGE........'. 01 WORK-SRVIN-INFO. 05 WK-INFO-TBL-ID PIC S9(8) COMP. 05 WK-INFO-TBL-NAME PIC X(30). 05 WK-INFO-TBL-VALUE PIC X(10). LINKAGE SECTION. ************************************************************** * THE LINKAGE SECTION DEFINES MASKS FOR DATA AREAS THAT ARE * PASSED BETWEEN THIS PROGRAM. ************************************************************** 01 DFHCOMMAREA PIC X(1). PROCEDURE DIVISION. 000-MAIN-PROCESSING. PERFORM 100-INITIALIZE THRU 100-EXIT. PERFORM 200-PROCESS-INPUT THRU 200-EXIT. PERFORM 300-PROCESS-OUTPUT THRU 300-EXIT. PERFORM 900-ALL-DONE THRU 900-EXIT. GOBACK. 000-EXIT. EXIT. 100-INITIALIZE. ****************************************************** * INTIALIZED THE TDS CONNECTION AND CONFIRM THAT IS * WAS AN RPC CALL, ........ ****************************************************** *==> INITIAL QUEUE NAME <===* MOVE EIBTRMID TO WS-TRMID. *==> ESTABLISH GATEWAY ENVIRONMENT <===* CALL 'TDINIT' USING DFHEIBLK, GWL-RC, GWL-INIT-HANDLE. IF GWL-RC NOT = TDS-OK THEN PERFORM 910-ERR-PROCESS THRU 910-EXIT END-IF. *==> ACCEPT CLIENT REQUEST <===* CALL 'TDACCEPT' USING GWL-PROC, GWL-RC, GWL-INIT-HANDLE, SNA-CONN-NAME, SNA-SUBC. IF GWL-RC NOT = TDS-OK THEN PERFORM 910-ERR-PROCESS THRU 910-EXIT END-IF. *==> TO MAKE SURE WE WERE STARTED BY RPC REQUEST... <===* CALL 'TDINFRPC' USING GWL-PROC, GWL-RC, GWL-REQUEST-TYP, GWL-RPC-NAME, GWL-COMM-STATE. IF GWL-RC NOT = TDS-OK OR GWL-REQUEST-TYP NOT = TDS-RPC-EVENT THEN MOVE GWL-RC TO WS-MSG-RC MOVE 'TDINFRPC' TO WS-MSG-FUNC PERFORM 920-SEND-MESSAGE THRU 920-EXIT PERFORM 910-ERR-PROCESS THRU 910-EXIT END-IF. 100-EXIT. EXIT. 200-PROCESS-INPUT. **************************************************************** * RECEIVE THE INPUT PARAMETER INTO HOST VARIBLE, SEND ROW DATA * * BACK DOWN TO CLIENT * **************************************************************** *---> Find out how many parms are being passed <---* CALL 'TDNUMPRM' USING GWL-PROC, GWL-NUMPRM-PARMS. *---> NO PARMS, pump back a message <---* IF GWL-NUMPRM-PARMS < +1 THEN MOVE 'At least one parm is needed' TO WS-MSG-TEXT MOVE GWL-RC TO WS-MSG-RC MOVE 'TDNUMPRM' TO WS-MSG-FUNC MOVE WS-MSG TO WS-HOLD-MSG MOVE TDS-ERROR-MSG TO WS-ERROR-MSG MOVE TDS-ERROR-SEV TO WS-ERROR-SEV PERFORM 920-SEND-MESSAGE THRU 920-EXIT PERFORM 910-ERR-PROCESS THRU 910-EXIT END-IF. *---> TEST TO SEE IF THE KEYWORDS "WARNMSG" AND <---* *---> OR ERRORMSG WHERE SENT.... <---* MOVE LENGTH OF WS-WARNMSG TO WS-LENGTH. CALL 'TDLOCPRM' USING GWL-PROC, WS-WARNMSG-ID, WS-WARNMSG, WS-LENGTH. MOVE LENGTH OF WS-ERRORMSG TO WS-LENGTH. CALL 'TDLOCPRM' USING GWL-PROC, WS-ERRORMSG-ID, WS-ERRORMSG, WS-LENGTH. *---> SAVE THE NUMBER OF PARMS FOR THE LOOP <---* MOVE GWL-NUMPRM-PARMS TO WS-NUMPRM-PARMS. *---> LOOP THRU THE PARMS AND WRITE TO TEMP STORAGE <----* PERFORM VARYING GWL-NUMPRM-PARMS FROM 1 BY 1 UNTIL GWL-NUMPRM-PARMS > WS-NUMPRM-PARMS PERFORM 210-GET-PARM THRU 210-EXIT PERFORM 220-WRITE-TS THRU 220-EXIT END-PERFORM. 200-EXIT. EXIT. 210-GET-PARM. **************************************************************** * *---> Get that parm into into the host varible <---* * **************************************************************** CALL 'TDRCVPRM' USING GWL-PROC, GWL-RC, GWL-NUMPRM-PARMS, WS-INPUT-DATA, TDSCHAR, WS-INPUT-LEN, GWL-ACTUAL-LEN IF GWL-RC NOT = TDS-OK THEN MOVE GWL-RC TO WS-MSG-RC MOVE 'TDRCVPRM' TO WS-MSG-FUNC MOVE WS-MSG TO WS-HOLD-MSG MOVE TDS-ERROR-MSG TO WS-ERROR-MSG MOVE TDS-ERROR-SEV TO WS-ERROR-SEV PERFORM 920-SEND-MESSAGE THRU 920-EXIT PERFORM 910-ERR-PROCESS THRU 910-EXIT END-IF. 210-EXIT. EXIT. 220-WRITE-TS. **************************************************************** * *---> WRITE PARMS TO TEMP STORAGE, LATER RETURN PARMS <---* * * *---> BACK DOWN TO CLIENT AS OUTPUT <---* * **************************************************************** EXEC CICS WRITEQ TS QUEUE(WS-QUEUE-NAME) FROM (WS-INPUT-DATA) LENGTH(LENGTH OF WS-INPUT-DATA) RESP (CICSRC) END-EXEC. IF CICSRC NOT = DFHRESP(NORMAL) MOVE CICSRC TO CICSRC-DIS MOVE CICSRC-DIS TO WS-MSG-RC MOVE 'WRITEQ' TO WS-MSG-FUNC MOVE WS-MSG TO WS-HOLD-MSG MOVE TDS-ERROR-MSG TO WS-ERROR-MSG MOVE TDS-ERROR-SEV TO WS-ERROR-SEV PERFORM 920-SEND-MESSAGE THRU 920-EXIT PERFORM 910-ERR-PROCESS THRU 910-EXIT END-IF. 220-EXIT. EXIT. 300-PROCESS-OUTPUT. **************************************************************** * READ TEMP STORAGE QUEUE AND SEND ROWS TO CLIENT * **************************************************************** PERFORM 310-DEFINE-OUTPUT THRU 310-EXIT. PERFORM VARYING I FROM 1 BY 1 UNTIL I > WS-NUMPRM-PARMS PERFORM 320-READQ-TS THRU 320-EXIT PERFORM 330-SEND-ROW THRU 330-EXIT END-PERFORM. *---> PROCESS WARNMSG AND/OR ERRORMSG AFTER SENDING ROWS. <---* IF WARNING-MSG THEN MOVE TDS-INFO-MSG TO WS-ERROR-MSG MOVE TDS-INFO-SEV TO WS-ERROR-SEV MOVE WS-WARN-MSG TO WS-HOLD-MSG PERFORM 920-SEND-MESSAGE THRU 920-EXIT END-IF. IF ERROR-MSG THEN MOVE TDS-ERROR-MSG TO WS-ERROR-MSG MOVE TDS-ERROR-SEV TO WS-ERROR-SEV MOVE WS-ERR-MSG TO WS-HOLD-MSG PERFORM 920-SEND-MESSAGE THRU 920-EXIT END-IF. 300-EXIT. EXIT. 310-DEFINE-OUTPUT. **************************************************************** * DEFINE THE OUTPUT COLUM AS CHAR OF 55 BYTES * **************************************************************** MOVE +1 TO COLUMN-NUMBER. MOVE LENGTH OF WS-OUTPUT-DATA TO HOST-LEN COLUMN-LEN. MOVE LENGTH OF WS-OUTPUT-COL-NAME TO COLUMN-NAME-LEN. CALL 'TDESCRIB' USING GWL-PROC, GWL-RC, COLUMN-NUMBER, TDSCHAR, HOST-LEN, WS-OUTPUT-DATA, TDS-ZERO, TDS-FALSE, TDSCHAR, COLUMN-LEN, WS-OUTPUT-COL-NAME, COLUMN-NAME-LEN. IF GWL-RC NOT = TDS-OK THEN MOVE GWL-RC TO WS-MSG-RC MOVE 'TDESCRIB' TO WS-MSG-FUNC MOVE WS-MSG TO WS-HOLD-MSG MOVE TDS-ERROR-MSG TO WS-ERROR-MSG MOVE TDS-ERROR-SEV TO WS-ERROR-SEV PERFORM 920-SEND-MESSAGE THRU 920-EXIT PERFORM 910-ERR-PROCESS THRU 910-EXIT END-IF. 310-EXIT. EXIT. 320-READQ-TS. **************************************************************** * READ THE INPUT TEMP STORAGE QUEUE **************************************************************** EXEC CICS READQ TS QUEUE(WS-QUEUE-NAME) INTO (WS-OUTPUT-DATA) LENGTH(LENGTH OF WS-OUTPUT-DATA) NEXT RESP (CICSRC) END-EXEC. IF CICSRC NOT = DFHRESP(NORMAL) MOVE CICSRC TO CICSRC-DIS MOVE CICSRC-DIS TO WS-MSG-RC MOVE 'READQ' TO WS-MSG-FUNC MOVE WS-MSG TO WS-HOLD-MSG MOVE TDS-ERROR-MSG TO WS-ERROR-MSG MOVE TDS-ERROR-SEV TO WS-ERROR-SEV PERFORM 920-SEND-MESSAGE THRU 920-EXIT PERFORM 910-ERR-PROCESS THRU 910-EXIT END-IF. *---> PROCESS WARNMSG AND/OR ERRORMSG PARMS IF YES... <---* IF WS-WARNMSG-ID = I AND WS-OUTPUT-DATA = 'Y' MOVE 'Y' TO WS-WARNMSG-88. IF WS-ERRORMSG-ID = I AND WS-OUTPUT-DATA = 'Y' MOVE 'Y' TO WS-ERRORMSG-88. 320-EXIT. EXIT. 330-SEND-ROW. **************************************************************** * SEND ROW OF DATA TO CLIENT.... ***************************************************************** CALL 'TDSNDROW' USING GWL-PROC, GWL-RC IF GWL-RC NOT = TDS-OK THEN MOVE GWL-RC TO WS-MSG-RC MOVE 'TDSNDROW' TO WS-MSG-FUNC MOVE WS-MSG TO WS-HOLD-MSG MOVE TDS-ERROR-MSG TO WS-ERROR-MSG MOVE TDS-ERROR-SEV TO WS-ERROR-SEV PERFORM 920-SEND-MESSAGE THRU 920-EXIT PERFORM 910-ERR-PROCESS THRU 910-EXIT END-IF. 330-EXIT. EXIT. EJECT 900-ALL-DONE. ****************************************************************** * CLOSE CONNECTION TO CLIENT AND RETURN TO CICS... * ****************************************************************** CALL 'TDSNDDON' USING GWL-PROC, GWL-RC, WRK-DONE-STATUS, GWL-RETURN-ROWS, TDS-ZERO, TDS-ENDRPC. IF GWL-RC NOT = TDS-OK THEN PERFORM 980-CICS-DUMP THRU 980-EXIT PERFORM 990-CICS-RETURN THRU 990-EXIT END-IF. CALL 'TDFREE' USING GWL-PROC, GWL-RC. EXEC CICS DELETEQ TS QUEUE(WS-QUEUE-NAME) RESP (CICSRC) END-EXEC. IF CICSRC NOT = DFHRESP(NORMAL) MOVE CICSRC TO CICSRC-DIS MOVE CICSRC-DIS TO WS-MSG-RC MOVE 'DELETEQ' TO WS-MSG-FUNC MOVE WS-MSG TO WS-HOLD-MSG MOVE TDS-ERROR-MSG TO WS-ERROR-MSG MOVE TDS-ERROR-SEV TO WS-ERROR-SEV PERFORM 920-SEND-MESSAGE THRU 920-EXIT PERFORM 910-ERR-PROCESS THRU 910-EXIT END-IF. PERFORM 990-CICS-RETURN THRU 990-EXIT. 900-EXIT. EXIT. 910-ERR-PROCESS. ****************************************************************** * PERFORM ALL-DONE IN A ERROR STATE * ****************************************************************** MOVE ZERO TO GWL-RETURN-ROWS. MOVE TDS-DONE-ERROR TO WRK-DONE-STATUS. PERFORM 900-ALL-DONE THRU 900-EXIT. 910-EXIT. EXIT. 920-SEND-MESSAGE. ****************************************************************** * SEND ERROR MESSAGE DOWN TO CLIENT * ****************************************************************** CALL 'TDSTATUS' USING GWL-PROC, GWL-RC, GWL-STATUS-NR, GWL-STATUS-DONE, GWL-STATUS-COUNT, GWL-STATUS-COMM, GWL-STATUS-RETURN-CODE, GWL-STATUS-SUBCODE. *==> ENSURE THAT WE ARE IN THE CORRECT STATE TO SEND A MESSAGE <=* IF GWL-RC NOT = TDS-OK THEN PERFORM 980-CICS-DUMP THRU 980-EXIT PERFORM 990-CICS-RETURN THRU 990-EXIT END-IF. IF GWL-STATUS-COMM = TDS-RECEIVE THEN CALL 'TDCANCEL' USING GWL-PROC, GWL-RC. MOVE LENGTH OF EIBTRNID TO GWL-TRAN-LEN. MOVE LENGTH OF WS-HOLD-MSG TO GWL-MSG-LEN. CALL 'TDSNDMSG' USING GWL-PROC, GWL-RC, WS-ERROR-MSG, MSG-NR, WS-ERROR-SEV, TDS-ZERO, TDS-ZERO, EIBTRNID, GWL-TRAN-LEN, WS-HOLD-MSG, GWL-MSG-LEN. 920-EXIT. EXIT. 980-CICS-DUMP. ****************************************************************** * CAUSE A CICS TRANSACTION DUMP USUALLY BECAUSE SOMETHING IS BAD * ****************************************************************** EXEC CICS DUMP DUMPCODE('SY3C') NOHANDLE END-EXEC. 980-EXIT. EXIT. 990-CICS-RETURN. ****************************************************************** * RETURN TO CICS... * ****************************************************************** EXEC CICS RETURN END-EXEC. 990-EXIT. EXIT. ¤ Dauer der Verarbeitung: 0.109 Sekunden (vorverarbeitet) ¤ |
Laden
Fehler beim Verzeichnis:
in der Quellcodebibliothek suchenDie farbliche Syntaxdarstellung ist noch experimentell.Bot Zugriff |
