This program accepts all valid Dynamic SQL requests except SELECT commands. DELETE requests must have a WHERE clause, or they will be rejected. Upon successful completion, this program sends a confirmation message to the client; otherwise, it sends an error message.
*@(#) syccsal2.cobol 1.1 3/17/98 */
IDENTIFICATION DIVISION.
PROGRAM-ID. SYCCSAL2.
****** SYCCSAL2 - LANGUAGE REQUEST APPLICATION - COBOL2 - CICS **
*
* TRANID: SYL2
* PROGRAM: SYCCSAL2
* PLAN NAME: SYL2PLAN
* FILES: n/a
* TABLES: adhoc
*
* This program is executed via a client language request
* from sample dblib program 'SYL2', or by SYBASE's ISQL if
* installed. The client program must login to a transaction
* group with SYL2 as the language handler.
*
* The purpose of the program is primarily to demonstrate Server
* Library calls, especially those which would be used in a
* server application designed to handle language requests.
*
* Server Library calls:
* TDACCEPT accept request from client
* TDFREE free TDPROC structure
* TDINFLOG return trace settings
* TDINFPGM return program information
* TDINIT establish environment
* TDRCVSQL receive language text
* TDRESULT describe next communication
* TDSETSPT set specific tracing
* TDSNDDON send results-completion to client
* TDSNDMSG send message to client
* TDSQLLEN get length of incoming text
* TDSTATUS get status information
*
*
* The program accepts all valid SQL requests other than
* 'SELECT'. A 'DELETE' must have a WHERE clause, or it is
* rejected.
*
* A confirmation message is sent to the client if all is
* well, otherwise an error message is sent.
*
* CHANGE ACTIVITY:
* 4/90 - Created, MPM
* 10/93 - Some restructuring, TC
*
*---------------------------------------------------------------*
ENVIRONMENT DIVISION.
DATA DIVISION.
******************************************************************
WORKING-STORAGE SECTION.
******************************************************************
*-----------------------------------------------------------------
* DB2 SQLCA
*-----------------------------------------------------------------
EXEC SQL INCLUDE SQLCA END-EXEC.
*-----------------------------------------------------------------
* DB2 MINIMUM SQLDA FOR COBOL II
*-----------------------------------------------------------------
01 SQLDA.
02 SQLDAID PIC X(8) VALUE 'SQLDA'.
02 SQLDABC PIC S9(8) COMP VALUE 60.
02 SQLN PIC S9(4) COMP VALUE 1.
02 SQLD PIC S9(4) COMP VALUE 0.
02 SQLVAR.
03 SQLTYPE PIC S9(4) COMP.
03 SQLLEN PIC S9(4) COMP.
03 SQLDATA POINTER.
03 SQLIND POINTER.
03 SQLNAME.
49 SQLNAMEL PIC S9(4) COMP.
49 SQLNAMEC PIC X(30).
*-----------------------------------------------------------------
* SERVER LIBRARY COBOL COPY BOOK
*-----------------------------------------------------------------
COPY SYGWCOB.
*-----------------------------------------------------------------
* WORK AREAS
*-----------------------------------------------------------------
01 GW-LIB-MISC-FIELDS.
05 GWL-PROC POINTER.
05 GWL-INIT-HANDLE POINTER.
05 GWL-RC PIC S9(9) COMP.
05 GWL-SQLLEN 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-STATUS-RETURN-CODE PIC S9(9) COMP.
05 GWL-STATUS-SUBCODE PIC S9(9) COMP.
05 GWL-INFPGM-TDS-VERSION PIC S9(9) COMP.
05 GWL-INFPGM-LONGVAR PIC S9(9) COMP.
05 GWL-INFPGM-ROW-LIMIT PIC S9(9) COMP.
05 GWL-INFPGM-REMOTE-TRACE PIC S9(9) COMP.
05 GWL-INFPGM-CORRELATOR PIC S9(9) COMP.
05 GWL-INFPGM-DB2GW-OPTION PIC S9(9) COMP.
05 GWL-INFPGM-DB2GW-PID PIC X(8).
05 GWL-INFPGM-TYPE-RPC PIC S9(9) COMP.
05 GWL-INFLOG-GLOBAL PIC S9(9) COMP.
05 GWL-INFLOG-API PIC S9(9) COMP.
05 GWL-INFLOG-TDS-HEADER PIC S9(9) COMP.
05 GWL-INFLOG-TDS-DATA PIC S9(9) COMP.
05 GWL-INFLOG-TRACE-ID PIC S9(9) COMP.
05 GWL-INFLOG-FILENAME PIC X(8).
05 GWL-INFLOG-TOTAL-RECS PIC S9(9) COMP.
05 GWL-SETSPT-TRACE-LEVEL PIC S9(9) COMP VALUE 4.
05 GWL-SETSPT-RPC-NAME PIC X(4) VALUE 'SYL2'.
05 GWL-SETSPT-RPC-NAME-L PIC S9(9) COMP VALUE 4.
01 LANGUAGE-FIELDS.
05 LANG-MAX-L PIC S9(9) COMP.
05 LANG-ACTUAL-L PIC S9(9) COMP.
05 LANG-TEXT-SS PIC S9(4) COMP.
01 LANG-BUFFER.
49 LANG-BUFFER-LL PIC S9(4) COMP.
49 LANG-BUFFER-TEXT PIC X(1024).
01 PARSESQL-BUFFER REDEFINES LANG-BUFFER.
05 PARSESQL-TEXT.
10 PARSESQL-TEXT-LL PIC S9(4) COMP.
10 PARSESQL-TEXT-CHARS OCCURS 1024 TIMES
PIC X.
05 PARSESQL-TEXT-DUMMY-LVL PIC X.
01 SNA-FIELDS.
05 SNA-SUBC PIC S9(9) COMP.
05 SNA-CONNECTION-NAME PIC X(8) VALUE SPACES.
01 PARSE-FIELDS.
05 PARSE-PTR PIC S9(4) COMP VALUE 0.
05 PARSE-TOKEN PIC X(18) VALUE SPACES.
05 PARSE-FROM PIC X(04).
05 PARSE-TABLE PIC X(46).
05 PARSE-CORRELATION PIC X(18) VALUE SPACES.
05 PARSE-WHERE PIC X(05) VALUE SPACES.
01 WORK-FIELDS.
05 WRK-DONE-STATUS PIC S9(9) COMP.
01 MESSAGE-FIELDS.
05 MSG-TYPE PIC S9(9) COMP.
05 MSG-SEVERITY PIC S9(9) COMP.
05 MSG-SEVERITY-OK PIC S9(9) COMP VALUE 9.
05 MSG-SEVERITY-ERROR PIC S9(9) COMP VALUE 11.
05 MSG-NR PIC S9(9) COMP.
05 MSG-NR-OK PIC S9(9) COMP VALUE 1.
05 MSG-NR-ERROR PIC S9(9) COMP VALUE 2.
05 MSG-RPC PIC X(4) VALUE 'SYL2'.
05 MSG-RPC-L PIC S9(9) COMP.
05 MSG-TEXT PIC X(50).
05 MSG-TEXT-L PIC S9(9) COMP.
05 MSG-SQL-ERROR.
10 MSG-SQL-ERROR-T PIC X(31)
VALUE 'Invalid sql request, sqlcode = '.
10 MSG-SQL-ERROR-C PIC -9(3) DISPLAY.
05 MSG-SELECT PIC X(24)
VALUE 'SQL select not supported'.
05 MSG-NOT-LANG PIC X(35)
VALUE 'SYL2 not begun via language request'.
05 MSG-BAD-LEN PIC X(31)
VALUE 'Request has too many characters'.
05 MSG-NO-WHERE PIC X(26)
VALUE 'Delete has no where clause'.
05 MSG-OK PIC X(22)
VALUE 'Execute was successful'.
05 MSG-NOT-OK.
10 FILLER PIC X(26)
VALUE 'Execute failed, sqlcode = '.
10 MSG-NOT-OK-C PIC -9(3) DISPLAY.
10 FILLER PIC X(18)
VALUE ', ROLLBACK issued.'.
01 CICS-FIELDS.
05 CICS-RESPONSE PIC S9(9) COMP.
01 SWITCHES.
05 TRACING-SET-SW PIC S9(9) COMP VALUE 0.
88 TRACING-RESET VALUE 0.
88 TRACING-SET VALUE 1.
05 SEND-DONE-SW PIC X VALUE 'Y'.
88 SEND-DONE-ERROR VALUE 'N'.
88 SEND-DONE-OK VALUE 'Y'.
*-----------------------------------------------------------------
* DECLARE STATEMENT AND CURSOR
*-----------------------------------------------------------------
EXEC SQL DECLARE S1 STATEMENT END-EXEC.
EXEC SQL DECLARE C1 CURSOR FOR S1 END-EXEC.
******************************************************************
PROCEDURE DIVISION.
******************************************************************
* Reset db2 error handlers
EXEC SQL WHENEVER SQLWARNING CONTINUE END-EXEC.
EXEC SQL WHENEVER SQLERROR CONTINUE END-EXEC.
EXEC SQL WHENEVER NOT FOUND CONTINUE END-EXEC.
* Establish gateway environment
CALL 'TDINIT' USING DFHEIBLK, GWL-RC, GWL-INIT-HANDLE.
* Turn on local tracing if not on globally or locally
CALL 'TDINFLOG' USING GWL-INIT-HANDLE, GWL-RC,
GWL-INFLOG-GLOBAL,
GWL-INFLOG-API,
GWL-INFLOG-TDS-HEADER,
GWL-INFLOG-TDS-DATA,
GWL-INFLOG-TRACE-ID,
GWL-INFLOG-FILENAME,
GWL-INFLOG-TOTAL-RECS.
IF GWL-INFLOG-GLOBAL NOT = TDS-TRACE-ALL-RPCS
AND GWL-INFLOG-GLOBAL NOT = TDS-TRACE-SPECIFIC-RPCS THEN
MOVE 1 TO TRACING-SET-SW
PERFORM LOCAL-TRACING
END-IF.
* Accept client request
CALL 'TDACCEPT' USING GWL-PROC, GWL-RC, GWL-INIT-HANDLE,
SNA-CONNECTION-NAME,
SNA-SUBC.
* Ensure kicked off via language request
* (this could be handled more reasonably by TDRESULT)
CALL 'TDINFPGM' USING GWL-PROC, GWL-RC,
GWL-INFPGM-TDS-VERSION,
GWL-INFPGM-LONGVAR,
GWL-INFPGM-ROW-LIMIT,
GWL-INFPGM-REMOTE-TRACE,
GWL-INFPGM-CORRELATOR,
GWL-INFPGM-DB2GW-OPTION,
GWL-INFPGM-DB2GW-PID,
GWL-INFPGM-TYPE-RPC.
IF GWL-INFPGM-TYPE-RPC NOT = TDS-START-SQL
MOVE MSG-NOT-LANG TO MSG-TEXT
MOVE LENGTH OF MSG-NOT-LANG TO MSG-TEXT-L
PERFORM SEND-ERROR-MESSAGE
GO TO END-PROGRAM
END-IF.
* Prepare for receive
CALL 'TDRESULT' USING GWL-PROC, GWL-RC.
* Get lenth of language text, ensure not too big for us
* (this could be handled without TDSQLLEN by checking
* LANG-ACTUAL-LEN doesn't exceed LANG-MAX-L in TDRCVSQL call)
CALL 'TDSQLLEN' USING GWL-PROC, GWL-SQLLEN.
MOVE LENGTH OF LANG-BUFFER-TEXT TO LANG-MAX-L.
IF GWL-SQLLEN > LANG-MAX-L THEN
MOVE MSG-BAD-LEN TO MSG-TEXT
MOVE LENGTH OF MSG-BAD-LEN TO MSG-TEXT-L
PERFORM SEND-ERROR-MESSAGE
GO TO END-PROGRAM
END-IF.
* Get language text
CALL 'TDRCVSQL' USING GWL-PROC, GWL-RC,
LANG-BUFFER-TEXT,
LANG-MAX-L,
LANG-ACTUAL-L.
MOVE LANG-ACTUAL-L TO LANG-BUFFER-LL.
* Ensure line feeds, low-values, etc. translated to blanks
PERFORM VARYING LANG-TEXT-SS FROM 1 BY 1
UNTIL LANG-TEXT-SS > PARSESQL-TEXT-LL
IF PARSESQL-TEXT-CHARS(LANG-TEXT-SS) < SPACE THEN
MOVE SPACE TO PARSESQL-TEXT-CHARS(LANG-TEXT-SS)
END-IF
* Save position of first non-blank
IF PARSE-PTR = 0 AND
PARSESQL-TEXT-CHARS(LANG-TEXT-SS) > SPACE THEN
MOVE LANG-TEXT-SS TO PARSE-PTR
END-IF
END-PERFORM.
* Let DB2 edit and tell us if SELECT
EXEC SQL PREPARE S1 INTO SQLDA FROM :LANG-BUFFER END-EXEC.
IF SQLD NOT = 0 THEN
MOVE MSG-SELECT TO MSG-TEXT
MOVE LENGTH OF MSG-SELECT TO MSG-TEXT-L
PERFORM SEND-ERROR-MESSAGE
GO TO END-PROGRAM
END-IF.
IF SQLCODE < 0 THEN
MOVE SQLCODE TO MSG-SQL-ERROR-C
MOVE MSG-SQL-ERROR TO MSG-TEXT
MOVE LENGTH OF MSG-SQL-ERROR TO MSG-TEXT-L
PERFORM SEND-ERROR-MESSAGE
GO TO END-PROGRAM
END-IF.
* Parse and handle special case of DELETE without WHERE clause
UNSTRING LANG-BUFFER-TEXT DELIMITED BY ALL ' '
INTO PARSE-TOKEN
PARSE-FROM
PARSE-TABLE
PARSE-CORRELATION
PARSE-WHERE
POINTER PARSE-PTR.
PERFORM XLATE-TOKEN-UPPERCASE.
IF PARSE-TOKEN = 'DELETE' THEN
MOVE PARSE-CORRELATION TO PARSE-TOKEN
PERFORM XLATE-TOKEN-UPPERCASE
MOVE PARSE-TOKEN TO PARSE-CORRELATION
MOVE PARSE-WHERE TO PARSE-TOKEN
PERFORM XLATE-TOKEN-UPPERCASE
IF PARSE-CORRELATION NOT = 'WHERE ' AND
PARSE-TOKEN NOT = 'WHERE ' THEN
MOVE MSG-NO-WHERE TO MSG-TEXT
MOVE LENGTH OF MSG-NO-WHERE TO MSG-TEXT-L
PERFORM SEND-ERROR-MESSAGE
GO TO END-PROGRAM
END-IF
END-IF.
* Execute the SQL statement
EXEC SQL EXECUTE S1 END-EXEC.
IF SQLCODE < 0 THEN
PERFORM CICS-ROLLBACK
MOVE SQLCODE TO MSG-NOT-OK-C
MOVE MSG-NOT-OK TO MSG-TEXT
MOVE LENGTH OF MSG-NOT-OK TO MSG-TEXT-L
PERFORM SEND-ERROR-MESSAGE
GO TO END-PROGRAM
END-IF.
MOVE MSG-OK TO MSG-TEXT.
MOVE LENGTH OF MSG-OK TO MSG-TEXT-L.
PERFORM SEND-CONFIRM-MESSAGE.
GO TO END-PROGRAM.
*-----------------------------------------------------------------
XLATE-TOKEN-UPPERCASE.
*-----------------------------------------------------------------
* All we care about is DELETE and WHERE
INSPECT PARSE-TOKEN REPLACING ALL 'd' BY 'D'
'e' BY 'E'
'h' BY 'H'
'l' BY 'L'
'r' BY 'R'
't' BY 'T'
'w' BY 'W'.
*-----------------------------------------------------------------
SEND-CONFIRM-MESSAGE.
*-----------------------------------------------------------------
MOVE MSG-SEVERITY-OK TO MSG-SEVERITY.
MOVE MSG-NR-OK TO MSG-NR.
MOVE TDS-INFO-MSG TO MSG-TYPE.
PERFORM SEND-MESSAGE.
*-----------------------------------------------------------------
SEND-ERROR-MESSAGE.
*-----------------------------------------------------------------
MOVE 'N' TO SEND-DONE-SW.
MOVE MSG-SEVERITY-ERROR TO MSG-SEVERITY.
MOVE MSG-NR-ERROR TO MSG-NR.
MOVE TDS-ERROR-MSG TO MSG-TYPE.
PERFORM SEND-MESSAGE.
*-----------------------------------------------------------------
SEND-MESSAGE.
*-----------------------------------------------------------------
MOVE LENGTH OF MSG-RPC TO MSG-RPC-L.
* -------------------------------------------------------------
* ensure we're in right state to send a message
* -------------------------------------------------------------
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.
IF (GWL-RC = TDS-OK AND
GWL-STATUS-COMM = TDS-RECEIVE) THEN
CALL 'TDSNDMSG' USING GWL-PROC, GWL-RC,
MSG-TYPE, MSG-NR,
MSG-SEVERITY,
TDS-ZERO,
TDS-ZERO,
MSG-RPC, MSG-RPC-L,
MSG-TEXT, MSG-TEXT-L
END-IF.
*-----------------------------------------------------------------
LOCAL-TRACING.
*-----------------------------------------------------------------
CALL 'TDSETSPT' USING GWL-INIT-HANDLE, GWL-RC,
TRACING-SET-SW,
GWL-SETSPT-TRACE-LEVEL,
GWL-SETSPT-RPC-NAME,
GWL-SETSPT-RPC-NAME-L.
*-----------------------------------------------------------------
CICS-ROLLBACK.
*-----------------------------------------------------------------
EXEC CICS SYNCPOINT
ROLLBACK
RESP(CICS-RESPONSE)
END-EXEC.
*-----------------------------------------------------------------
END-PROGRAM.
*-----------------------------------------------------------------
IF TRACING-SET
MOVE 0 TO TRACING-SET-SW
PERFORM LOCAL-TRACING
END-IF.
IF SEND-DONE-OK
MOVE TDS-DONE-COUNT TO WRK-DONE-STATUS
ELSE
MOVE TDS-DONE-ERROR TO WRK-DONE-STATUS
MOVE ZERO TO SQLERRD(3)
END-IF.
CALL 'TDSNDDON' USING GWL-PROC, GWL-RC,
WRK-DONE-STATUS,
SQLERRD(3),
TDS-ZERO,
TDS-ENDRPC.
CALL 'TDFREE' USING GWL-PROC, GWL-RC.
EXEC CICS RETURN END-EXEC.
