RSP8C is an example of an RSP written to handle variable text sent to it from the client application. The code in this sample RSP follows.
IDENTIFICATION DIVISION. PROGRAM-ID. RSP8C ****************************************************************** * RSP8C - DOCTORED STORED PROCEDURE * * * * THIS SAMPLE STORED PROCEDURE WAS WRITTEN TO USE A VARIABLE * * TEXT PARAMETER OF UP TO 10,000 BYTES AND ECHOES IT BACK THRU * * A STANDARD OUTPUT PIPE IN 50 BYTE INCREMENTS. * * * * USE PROCEDURE WITH DATA RSP8C 'THIS IS A VERY BIG PARAMETER' * * * * THE VARIABLE TEXT DOESN'T HAVE TO BE DELIMITED WITH QUOTES OR * * DOUBLE QUOTES. * ******************************************************************
ENVIRONMENT DIVISION. DATA DIVISION. WORKING-STORAGE SECTION.
******************************************************************
* POINTERS TO INPUT AND OUTPUT RECORD AREA. *
******************************************************************
01 WS-SAMPLE-POINTER.
10 WS-OUTPUT-POINTER USAGE IS POINTER.
******************************************************************
* SWITCHES FOR RECORD PROCESSING CONTROL. *
******************************************************************
01 WS-SWITCHES.
10 WS-ERROR-HAPPENED-SW PIC X(01) VALUE 'N'.
88 ERROR-HAPPENED VALUE 'Y'.
88 NO-ERROR-YET VALUE 'N'.
10 WS-OUTPUT-DONE-SW PIC X(01) VALUE 'N'.
88 OUTPUT-DONE VALUE 'Y'.
88 MORE-OUTPUT VALUE 'N'.
* THIS SWITCH IS USED FOR TESTING IF RPC CALL
77 RSPRPC-SWITCH PIC S9(4) COMP VALUE 0.
88 RPC-CALL VALUE 0.
01 COMMAREA-POINTER USAGE IS POINTER.
******************************************************************
* A NUMBER FOR INCREMENTING. *
******************************************************************
01 WS-VARIABLES.
05 WS-INCRINUM PIC 99 VALUE ZEROES.
05 VTABLE-CTR PIC S9(8) COMP VALUE 0.
05 WS-LEN-HOLD PIC 9(4) VALUE ZEROES.
01 MESSAGES.
05 ERROR1-MSG.
07 ERROR1-TEXT1 PIC X(19) VALUE
'ERROR WITH CALL TO '.
07 ERROR1-CALL PIC X(10) VALUE SPACES.
07 ERROR1-TEXT2 PIC X(14) VALUE
' - SPRC CODE: '.
07 ERROR1-SPRC PIC X(03) VALUE SPACES.
******************************************************************
* OUTPUT RECORD DESCRIPTION. *
******************************************************************
01 WS-OUTPUT-REC.
10 WS-OUT-MSG-AREA.
15 FILLER PIC X(07) VALUE 'REC#-> '.
15 WS-OUT-MSG-NUM PIC X(02) VALUE SPACES.
15 FILLER PIC X(01) VALUE ':'.
10 WS-OUT-SOME-DATA PIC X(50) VALUE SPACES.
01 WS-OUT-DATA-MSG.
10 FILLER PIC X(55) VALUE
'**--> THE FOLLOWING IS 50 BYTE BLOCKS OF VARIABLE TEXT '.
10 FILLER PIC X(05) VALUE 'RECVD'.
01 V-TABLE-BLOCKS.
10 V-TABLE-BLOCKS-T OCCURS 200 TIMES.
15 V-ROW PIC X(50) VALUE SPACES.
01 WS-VTABLE-REC.
10 WS-VTABLE-AREA.
15 FILLER PIC X(33) VALUE
'THIS IS THE LENGTH IN SPVARLEN : '.
15 WS-VTABLE-NUM PIC X(04) VALUE SPACES.
15 FILLER PIC X(03) VALUE SPACES.
LINKAGE SECTION.
**************************************************************
* THE LINKAGE SECTION DEFINES MASKS FOR DATA AREAS THAT ARE
* PASSED BETWEEN THIS PROGRAM AND MAINFRAMECONNECT.
**************************************************************
******************************************************************
* LINKAGE TO CALLING PROGRAM *
******************************************************************
01 DFHCOMMAREA.
05 NOT-USED PIC X(1).
05 DUMMY-AREA PIC X(1).
******************************************************************
* THIS IS THE ACTUAL SPAREA POINTER AND DEFINITION *
******************************************************************
01 LWKCOMMAREA.
COPY SPAREAC.
******************************************************************
* VARIABLE FOR ALL INCOMING VARIABLE TEXT PARAMETERS *
******************************************************************
01 INPUT-VALUE PIC X(10000).
01 WS-OUTPUT-RECORD.
10 WS-OUTPUT-DATA PIC X(60).
*================================================================* PROCEDURE DIVISION. *================================================================*
000-MAIN-PROCESSING.
PERFORM 100-INITIALIZE THRU 100-EXIT.
IF NO-ERROR-YET
PERFORM 500-PROCESS-I-O THRU 500-EXIT.
PERFORM 900-WRAP-UP THRU 900-EXIT.
EXEC CICS
RETURN
END-EXEC.
GOBACK.
000-EXIT.
EXIT.
100-INITIALIZE.
******************************************************
* IF THIS IS A RPC CALL, CALL RPSETUP TO INITIALIZE SPAREA
* AND OPEN SERVER (TRANSACTION ROUTER SERVICE)
* IF THIS IS A RSP CALL, SPAREA IS PASSED IN THE COMMAREA.
* (DIRECTCONNECT).
* FOR TRACING, MOVE 'Y' TO SPTRCOPT
******************************************************
MOVE EIBCALEN TO RSPRPC-SWITCH.
IF RPC-CALL
EXEC CICS GETMAIN
SET (COMMAREA-POINTER)
FLENGTH (LENGTH OF LWKCOMMAREA)
END-EXEC
SET ADDRESS OF LWKCOMMAREA TO COMMAREA-POINTER
MOVE 'Y' TO SPTRCOPT
CALL 'RPSETUP' USING SPAREA
ELSE
SET ADDRESS OF LWKCOMMAREA TO ADDRESS OF DFHCOMMAREA
MOVE 'Y' TO SPTRCOPT.
MOVE 'OK' TO SPSTATUS.
PERFORM 110-ESTABLISH-INPUT THRU 110-EXIT.
******************************************************************
* ALLOCATE A BLOCK OF STORAGE TO BE USED FOR THE DATA
* SET POINTER VARIABLE TO ADDRESS OF ALLOCATED STORAGE
******************************************************************
EXEC CICS
GETMAIN SET(WS-OUTPUT-POINTER)
LENGTH(60)
END-EXEC.
SET ADDRESS OF WS-OUTPUT-RECORD TO WS-OUTPUT-POINTER.
IF NO-ERROR-YET
PERFORM 120-OPEN-OUTPUT-PIPE THRU 120-EXIT.
100-EXIT.
EXIT.
110-ESTABLISH-INPUT.
IF SPVARLEN < 1
SET ERROR-HAPPENED TO TRUE
MOVE 'NO PARMS' TO ERROR1-CALL
PERFORM 800-ERROR-MESSAGE THRU 800-EXIT
GO TO 110-EXIT
ELSE
MOVE SPVARLEN TO WS-LEN-HOLD
MOVE WS-LEN-HOLD TO WS-VTABLE-NUM
MOVE WS-VTABLE-REC TO SPMSG
MOVE 'OK' TO SPSTATUS
*-------------------------------------------------------*
* MESSAGE WILL WRITE THE 100 BYTE SPMSG TO A MSG BUFFER,*
* WHICH WILL EVENTUALLY BE WRITTEN TO THE CLIENT *
* APPLICATION *
*-------------------------------------------------------*
CALL 'MESSAGE' USING SPAREA.
SET ADDRESS OF INPUT-VALUE TO SPVARTXT.
MOVE INPUT-VALUE (1:SPVARLEN) TO V-TABLE-BLOCKS.
IF V-ROW (1) = SPACES
SET ERROR-HAPPENED TO TRUE
MOVE 'SPACES ' TO ERROR1-CALL
PERFORM 800-ERROR-MESSAGE THRU 800-EXIT.
IF V-ROW (1) = LOW-VALUES
SET ERROR-HAPPENED TO TRUE
MOVE 'LOWVALUE' TO ERROR1-CALL
PERFORM 800-ERROR-MESSAGE THRU 800-EXIT.
110-EXIT.
EXIT.
120-OPEN-OUTPUT-PIPE.
MOVE 'STD' TO SPFORMAT.
MOVE 60 TO SPMAXLEN.
MOVE 'OUTPUT' TO SPMODE.
*-------------------------------------------------------*
* AN OPEN PIPE WILL SET UP THE COLUMN INFORMATION, WHICH*
* WILL EVENTUALLY BE SENT TO THE CLIENT APPLICATION *
*-------------------------------------------------------*
CALL 'OPENPIPE' USING SPAREA.
IF SPRC NOT = '000'
SET ERROR-HAPPENED TO TRUE
MOVE 'OPENPIPE' TO ERROR1-CALL
PERFORM 800-ERROR-MESSAGE THRU 800-EXIT.
120-EXIT.
EXIT.
500-PROCESS-I-O.
IF NO-ERROR-YET
PERFORM 540-PROCESS-DATA-RECS THRU 540-EXIT.
500-EXIT.
EXIT.
540-PROCESS-DATA-RECS.
******************************************************************
* OBTAIN VARIABLE TEXT SENT WITH PROGRAM. *
******************************************************************
MOVE 0 TO WS-INCRINUM.
PERFORM 542-SEND-RECORDS-HEADING THRU 542-EXIT.
IF NO-ERROR-YET
PERFORM 544-READ-WRITE-RECORDS THRU 544-EXIT
UNTIL OUTPUT-DONE OR ERROR-HAPPENED.
540-EXIT.
EXIT.
542-SEND-RECORDS-HEADING.
IF SPSTATUS = 'OK'
MOVE WS-OUT-DATA-MSG TO WS-OUTPUT-RECORD
MOVE 60 TO SPRECLEN
SET SPFROM TO ADDRESS OF WS-OUTPUT-RECORD
*-------------------------------------------------------*
* PUTPIPE SENDS A RESULT ROW TO THE OUTPUT BUFFER, WHICH*
* WHICH WILL EVENTUALLY BE WRITTEN TO THE CLIENT *
* APPLICATION *
*-------------------------------------------------------*
CALL 'PUTPIPE' USING SPAREA
IF SPRC NOT = '000'
SET ERROR-HAPPENED TO TRUE
MOVE 'PUTPIPE ' TO ERROR1-CALL
PERFORM 800-ERROR-MESSAGE THRU 800-EXIT
END-IF
END-IF.
542-EXIT.
EXIT.
544-READ-WRITE-RECORDS.
******************************************************************
* LOOP THROUGH VARIABLE TEXT TABLE AND SEND BACK TO CLIENT IN *
* 50-BYTE CHUNKS UNTIL ALL ARE RETURNED. *
******************************************************************
ADD 1 TO WS-INCRINUM,
VTABLE-CTR.
IF V-ROW (VTABLE-CTR) IS = SPACES
OR V-ROW (VTABLE-CTR) IS = LOW-VALUES
OR VTABLE-CTR > 200
IF VTABLE-CTR = 1
MOVE WS-INCRINUM TO WS-OUT-MSG-NUM
MOVE V-ROW (VTABLE-CTR) TO WS-OUT-SOME-DATA
MOVE WS-OUTPUT-REC TO WS-OUTPUT-RECORD
SET SPFROM TO ADDRESS OF WS-OUTPUT-RECORD
*-------------------------------------------------------*
* PUTPIPE SENDS A RESULT ROW TO THE OUTPUT BUFFER, *
* WHICH WILL EVENTUALLY BE WRITTEN TO THE CLIENT *
* APPLICATION *
*-------------------------------------------------------*
CALL 'PUTPIPE' USING SPAREA
IF SPRC NOT = '000'
SET ERROR-HAPPENED TO TRUE
MOVE 'PUTPIPE ' TO ERROR1-CALL
PERFORM 800-ERROR-MESSAGE THRU 800-EXIT
END-IF
END-IF
SET OUTPUT-DONE TO TRUE
ELSE
MOVE WS-INCRINUM TO WS-OUT-MSG-NUM
MOVE V-ROW (VTABLE-CTR) TO WS-OUT-SOME-DATA
MOVE WS-OUTPUT-REC TO WS-OUTPUT-RECORD
SET SPFROM TO ADDRESS OF WS-OUTPUT-RECORD
*-------------------------------------------------------*
* PUTPIPE SENDS A RESULT ROW TO THE OUTPUT BUFFER, WHICH*
* WILL EVENTUALLY BE SENT DOWN TO THE CLIENT APPLICATION*
*-------------------------------------------------------*
CALL 'PUTPIPE' USING SPAREA
IF SPRC NOT = '000'
SET ERROR-HAPPENED TO TRUE
SET OUTPUT-DONE TO TRUE
MOVE 'PUTPIPE ' TO ERROR1-CALL
PERFORM 800-ERROR-MESSAGE THRU 800-EXIT
END-IF
END-IF.
544-EXIT.
EXIT.
800-ERROR-MESSAGE.
******************************************************************
* SOMETHING FAILED, SO ISSUE AN ERROR MESSAGE AND GET OUT. *
******************************************************************
MOVE SPRC TO ERROR1-SPRC.
MOVE ERROR1-MSG TO SPMSG.
MOVE 'E' TO SPSTATUS.
*-------------------------------------------------------*
* MESSAGE WILL WRITE THE 100 BYTE SPMSG TO A MSG BUFFER,*
* WHICH WILL EVENTUALLY BE WRITTEN TO THE CLIENT *
* APPLICATION *
*-------------------------------------------------------*
CALL 'MESSAGE' USING SPAREA.
IF SPRC NOT = '000'
SET ERROR-HAPPENED TO TRUE.
800-EXIT.
EXIT.
900-WRAP-UP.
******************************************************************
* CLOSE PIPES - ISSUE STATUS. *
******************************************************************
IF NO-ERROR-YET
MOVE 'OUTPUT' TO SPMODE
*-------------------------------------------------------*
*CLOSEPIPE IS LIKE CLOSING A FILE, PLACES AN EOF MARKER*
*-------------------------------------------------------*
CALL 'CLOSPIPE' USING SPAREA
IF SPRC NOT = '000'
SET ERROR-HAPPENED TO TRUE
MOVE 'CLOSPIPE' TO ERROR1-CALL
PERFORM 800-ERROR-MESSAGE THRU 800-EXIT.
IF NO-ERROR-YET
MOVE 'OK' TO SPSTATUS
ELSE
MOVE 'E' TO SPSTATUS
MOVE 'MYERCODE' TO SPCODE
END-IF.
*-----------------------------------------------------------*
* CALLING STATUS WILL FLUSH ANY RESULTS AND/OR *
* MESSAGES FROM THE BUFFERS, TO THE CLIENT APPLICATION *
*-----------------------------------------------------------*
CALL 'STATUS' USING SPAREA.
IF SPRC NOT = '000'
SET ERROR-HAPPENED TO TRUE
MOVE 'STATUS ' TO ERROR1-CALL
PERFORM 800-ERROR-MESSAGE THRU 800-EXIT
END-IF.
********************************************************
* CLOSE OPEN SERVER
* IF THIS IS AN RPC CALL, PERFORM OPEN SERVER CLOSE
********************************************************
IF RPC-CALL
CALL 'RPDONE' USING SPAREA.
900-EXIT.
EXIT.
