// Evaluate an SQL expression; return the result as a message // Copyright (C) Dennis Lovelady, 2010 // Released to the public domain 2010-May-25 // This is a quick and dirty program to simply accept an expression // to be evaluated by SQL, and return the result as a message to // the calling program. It's more or less a proof of concept // to allow quick access to the result of some SQL question, or // to play what-if games with SQL functions. // Due to the nature of the very long varying-length expression // parameter, this program is intended to be used as a CPP. The // command defition should look like this: // CMD PROMPT('Evaluate SQL expression') // PARM KWD(RSLTTYPE) TYPE(*NAME) RSTD(*YES) + // DFT(*DEC) SPCVAL((*DEC DECIMAL) (*STRING + // STRING) (*FLOAT FLOAT) (*INT INTEGER)) + // EXPR(*YES) PROMPT('Type of result') // PARM KWD(EXPR) TYPE(*CHAR) LEN(16384) MIN(1) + // EXPR(*YES) VARY(*YES *INT2) + // PROMPT('SQL expression') H OPTION(*NOSHOWCPY:*NOEXPDDS:*NODEBUGIO:*SRCSTMT) H DATFMT(*ISO) TIMFMT(*ISO) DFTACTGRP(*NO) H CVTOPT(*VARCHAR:*NODATETIME) H THREAD(*SERIALIZE) D sqlEval PR ExtPgm('SQLEVAL') D resultType 10 Const D parmExpr 16384 Const Varying D sqlEval PI D resultType 10 Const D parmExpr 16384 Const Varying D CheckSQL PR N D EOF_IS_OK N Value Options(*NoPass) D parmWarnOnly N Value Options(*NoPass) D parmLocation 32 Value Varying D Options(*NoPass) D parmStmt 16384 Varying Options(*NoPass) D Value D SendEscape PR ExtProc('sendEscape') D MSGID Const Like(QUSEC.messageID) D MSGDTA Const Like(QUSEC.messageData) D StackCount 5I 0 Value Options(*NoPass) D sndPgmMsg PR 4 ExtProc('sndPgmMsg') D parmMsgID 7 Value D parmMsg 4096 Value Options(*NoPass) Varying D parmMsgType 10 Value Options(*NoPass) D parmMsgFile 20 Value Options(*NoPass) D parmToPgmQ 10 Value Options(*NoPass) D toPgmqCounter 10I 0 Value Options(*NoPass) D SQL_EOF C 100 D SQL_EOF_IS_OK C *On D SQL_EOF_NOT_OK C *Off D SQL_WARN_ONLY C *On D SQL_ABORT C *Off D QUSEC DS Inz Qualified D QUSBPRV 10I 0 Inz(%Size(QUSEC)) D QUSBAVL 10I 0 D QUSEI 7 D 1 D QUSED01 4096 D bytesProvided 10I 0 Overlay(QUSEC: 1) D bytesAvailable... D 10I 0 Overlay(QUSEC: 5) D messageID 7 Overlay(QUSEC: 9) D messageData 4096 Overlay(QUSEC: 17) D floatResult S 8F D intResult S 10I 0 D decResult S 31P 9 D stringResult S 16384 Varying D expression S Like(parmExpr) /Free expression = 'Values(' + parmExpr + ') INTO ?' ; Exec SQL Prepare dynamic from :expression ; Select ; When resultType = 'FLOAT' ; Exec SQL Execute dynamic Using :floatResult ; checkSQL(SQL_EOF_IS_OK: SQL_ABORT : 'Evaluating FLOAT expression' : expression ) ; stringResult = %Char(floatResult) ; When resultType = 'INTEGER' ; Exec SQL Execute dynamic Using :intResult ; checkSQL(SQL_EOF_IS_OK: SQL_ABORT : 'Evaluating INTEGER expression' : expression ) ; stringResult = %Char(intResult) ; When resultType = 'DECIMAL' ; Exec SQL Execute dynamic Using :decResult ; checkSQL(SQL_EOF_IS_OK: SQL_ABORT : 'Evaluating DECIMAL expression' : expression ) ; stringResult = %Char(decResult) ; When resultType = 'STRING' ; Exec SQL Execute dynamic Using :stringResult ; checkSQL(SQL_EOF_IS_OK: SQL_ABORT : 'Evaluating STRING expression' : expression ) ; Other ; sendEscape('CPF9898': 'Unknown output format') ; EndSL ; sndPgmMsg('CPI8859' : 'Result is ' + stringResult : '*INFO': *Blanks: '*CTLBDY': 1 ) ; *INLR = *On ; Return ; /End-free P CheckSQL B ********************************************************************* * Determine the Success/Failure of an SQL operation by checking * * SQLCODE and SQLSTATE. * * --- * * Return *ON for success; *OFF for failure * * --- * * Send a message to the program message queue if a failure occurs. * ********************************************************************* D CheckSQL PI N D EOF_IS_OK N Value Options(*NoPass) D parmWarnOnly N Value Options(*NoPass) D parmLocation 32 Value Varying D Options(*NoPass) D parmStmt 16384 Varying Value D Options(*NoPass) D workLogStmt S like(parmStmt) D workLogStm2 S like(parmStmt) D WarningOnly S N Inz(SQL_ABORT) D StmtLocation S 32 Varying D Inz('Unspecified location') D SQLerrID S 7 D SuccessFlag S N D IgnoreEOF S N Inz(*On) /Free If %Parms > 0 ; IgnoreEOF = EOF_IS_OK ; If %Parms > 1 ; WarningOnly = parmWarnOnly ; If %Parms > 2 ; StmtLocation = parmLocation ; EndIF ; EndIF ; EndIF ; SQLErrID = *Blanks ; SuccessFlag = *On ; Select ; When SQLCOD = -842 and SQLSTT = '08002' ; // Already connected SuccessFlag = *On ; SQLerrID = 'SQL9999' ; When SQLCOD = 100 and IgnoreEOF ; SuccessFlag = *On ; When SQLSTT <> *Zero ; SuccessFlag = *Off ; SQLerrID = 'SQL9999' ; When SQLCOD <> *Zero ; SuccessFlag = *Off ; SQLerrID = 'SQL9999' ; When SQLCOD = *Zero ; SuccessFlag = *On ; Other ; SuccessFlag = *On ; EndSL ; If SQLCOD = *Zero or (SQLCOD = 100 and IgnoreEOF) ; // Couldn't think of another way to word it with readability Else ; EvalR SQLerrID = %EditC(%Abs(SQLCOD): 'X') ; If %Subst(SQLerrID: 3: 1) = '0' ; %Subst(SQLerrID: 1: 3) = 'SQL' ; Else ; %Subst(SQLerrID: 1: 2) = 'SQ' ; EndIF ; sndPgmMsg(SQLerrID: SQLERM: '*COMP') ; EndIF ; If Not SuccessFlag ; If %Parms >= 4 and parmStmt <> *Blank ; workLogStmt = 'Failing stmt: ' + parmStmt ; DoW %Len(workLogStmt) > *Zero ; If %Len(workLogStmt) > 480 ; workLogStm2 = %Subst(workLogStmt: 1: 480) ; workLogStmt = %Subst(workLogStmt: 481) ; Else ; workLogStm2 = workLogStmt ; workLogStmt = '' ; EndIF ; sndPgmMsg('CPF9897' : workLogStm2 : '*INFO') ; EndDO ; EndIF ; If WarningOnly ; sndPgmMsg('CPI8859' : 'Error occurred at ' + StmtLocation: '*COMP') ; Else ; SendEscape('CPF9898' : 'Abort due to SQL error at ' + StmtLocation ) ; EndIF ; EndIF ; Return SuccessFlag ; /End-free P CheckSQL E P SendEscape B Export // *************************************************************** // SendEscape will send an escape message to this program's caller // Since this will cause execution of this program to fail, you // should PERFORM BASIC CLEANUP BEFORE CALLING THIS ROUTINE. // *************************************************************** D SendEscape PI D MSGID Const Like(QUSEC.messageID) D MSGDTA Const Like(QUSEC.messageData) D StackCount 5I 0 Value Options(*NoPass) D SndStkCount S 5I 0 Inz(-1) /Free sndPgmMsg(MSGID: MSGDTA: '*ESCAPE') ; *INLR = *On ; // Really, this is documentary.. . Return ; // But no harm done /End-free P SendEscape E P sndPgmMsg B Export //****************************************** //* Send an impromptu message to a pgmq //****************************************** D sndPgmMsg PI 4 D parmMsgID 7 Value D parmMsg 4096 Value Options(*NoPass) Varying D parmMsgType 10 Value Options(*NoPass) D parmMsgFile 20 Value Options(*NoPass) D parmToPgmQ 10 Value Options(*NoPass) D toPgmqCounter 10I 0 Value Options(*NoPass) //****************************************** //* Local variables. D myUSEC DS LikeDS(QUSEC) D msgf DS 21 D MsgFile 10 Inz('QCPFMSG') D MsgFLib 10 Inz('*LIBL') D msgType S Like(parmMsgType) Inz('*INFO') D toPgmQ S Like(parmToPgmQ) Inz('*') D msgid S 7 Inz('CPF9897') D msgData S 4096 Varying D nDataLen S 10I 0 Inz(0) D nRelInv S 10I 0 Inz(1) D nIncInv S 10I 0 Inz(1) D RtnMsgKey S 4 DQMHSNDPM_API PR ExtPgm('QMHSNDPM') D MessageID 7 const D MessageFile 20 const D MessageData 65535 const Options(*varsize) D LengthMsgDta 10I 0 const D MessageType 10 const D CallStackEnt 10 const Options(*varsize) D CallStkEntCtr 10I 0 const D MessageKey 4 D ErrorStruct LikeDS(QUSEC) Options(*varsize) /Free Clear myUSEC ; myUSEC.bytesProvided = %Size(myUSEC) ; if %addr(parmMsgType) <> *Null and parmMsgType = '*ESCAPE' ; toPgmQ = '*PRVPGM' ; endIF ; If %Parms >= 1 and parmMsgID > *Blanks ; msgID = parmMsgID ; endif ; // %Parms >= 1 If %Parms >= 2 ; msgData = %TrimR(parmMsg) ; endif ; // %Parms >= 2 If %Parms >= 3 ; msgType = parmMsgType ; If %subst(msgType:1:1)<>'*' ; msgType = '*' + %Trim(msgType) ; endif ; // %subst(msgType:1:1)<>'*' if msgType = '*ESCAPE' ; toPgmQ = '*PRVPGM' ; endIF ; endif ; // %Parms >= 2 If %Parms >= 4 and parmMsgFile <> *Blanks ; msgF = parmMsgFile ; if MsgFLib = *Blanks ; MsgFLib = '*LIBL' ; EndIF ; endif ; // %Parms >= 4 If %Parms >= 5 and parmToPgmQ <> *BLANKS ; toPgmQ = parmToPgmQ ; endif ; // %Parms >= 5 If msgType = '*STATUS' ; // Status messages always go ToPgmQ(*EXT) toPgmQ = '*EXT' ; endif ; // msgType = '*STATUS' If msgType = '*' ; msgType = '*INFO' ; endif ; // msgType = '*' nDataLen = %len(msgData) ; // Length of the message to be sent. If msgType = '*INFO' ; toPgmQ = '*CTLBDY' ; EndIF ; Select ; When toPgmQ = ' ' or toPgmQ = '*SAME' or toPgmQ = '*' ; toPgmQ = '*' ; nRelInv = *Zero ; nIncInv = 1 ; When toPgmQ = '*PRVPROC' or toPgmQ='*PRV' ; toPgmQ = '*' ; nRelInv = 1 ; nIncInv = 1 ; When toPgmQ = '*PRVPGM' ; toPgmQ = '*CTLBDY' ; nRelInv = *Zero ; nIncInv = 1 ; When toPgmQ = '*CTLBDY' ; toPgmQ = '*CTLBDY' ; nRelInv = *Zero ; nIncInv = *Zero ; When toPgmQ = '*EXT' ; nRelInv = *Zero ; Other ; nRelInv = *Zero ; nIncInv = *Zero ; endsl ; If %Parms >= 6 ; nRelInv = toPgmqCounter ; nIncInv = *Zero ; EndIF ; If msgFile = 'QCPFMSG' and %Subst(msgid: 1: 2) = 'SQ' ; msgFile = 'QSQLMSG' ; EndIF ; //* Since we're a relative invocation, and we are //* one-level deep, we need to bump up the relative //* invocation by the calculated increment. nRelInv += nIncInv ; QMHSNDPM_API(msgid : msgf : msgData : nDataLen : msgType : toPgmQ : nRelInv : rtnMsgKey : myUSEC ) ; return rtnMsgKey ; /End-free P sndPgmMsg E