ClEXCSQL < DBG400

<verbatim>
/* ************************************************************************** */
/* EXCSQL: Execute SQL request                                                */
/* Copyright (C) 2001, 2008  Martin Rowe  <martin@dbg400.net>                 */
/*                                                                            */
/* This program is free software; you can redistribute it and/or modify       */
/* it under the terms of the GNU General Public License as published by       */
/* the Free Software Foundation; either version 2 of the License, or          */
/* (at your option) any later version.                                        */
/*                                                                            */
/* This program is distributed in the hope that it will be useful,            */
/* but WITHOUT ANY WARRANTY; without even the implied warranty of             */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              */
/* GNU General Public License for more details.                               */
/*                                                                            */
/* You should have received a copy of the GNU General Public License          */
/* along with this program; if not, write to the Free Software                */
/* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307   USA */
/* ************************************************************************** */
PGM PARM(&REQUEST &OUTPUT &QUALSRTSEQ &PRTF &OUTFILE &OUTMBR)
  DCL        VAR(&POS1) TYPE(*DEC) LEN(3 0)
  DCL        VAR(&POS2) TYPE(*DEC) LEN(3 0)
  DCL        VAR(&COUNT) TYPE(*DEC) LEN(3 0)
  DCL        VAR(&REQUEST) TYPE(*CHAR) LEN(825)
  DCL        VAR(&RTNLIB) TYPE(*CHAR) LEN(10)
  DCL        VAR(&FILEATR) TYPE(*CHAR) LEN(3)
  DCL        VAR(&OUTPUT) TYPE(*CHAR) LEN(1)
  DCL        VAR(&QUALSRTSEQ) TYPE(*CHAR) LEN(20)
  DCL        VAR(&SRTSEQ) TYPE(*CHAR) LEN(10)
  DCL        VAR(&SRTSEQLIB) TYPE(*CHAR) LEN(10)
  DCL        VAR(&JOBSRTSEQ) TYPE(*CHAR) LEN(10)
  DCL        VAR(&JOBSRTSEQL) TYPE(*CHAR) LEN(10)
  DCL        VAR(&PRTF) TYPE(*CHAR) LEN(20)
  DCL        VAR(&PRTFNAME) TYPE(*CHAR) LEN(10)
  DCL        VAR(&PRTFLIB) TYPE(*CHAR) LEN(10)
  DCL        VAR(&OUTFILE) TYPE(*CHAR) LEN(20)
  DCL        VAR(&OUTFILENAM) TYPE(*CHAR) LEN(10)
  DCL        VAR(&OUTFILELIB) TYPE(*CHAR) LEN(10)
  DCL        VAR(&OUTMBR) TYPE(*CHAR) LEN(20)
  DCL        VAR(&OUTMBRNAME) TYPE(*CHAR) LEN(10)
  DCL        VAR(&OUTMBROPT) TYPE(*CHAR) LEN(8)
  DCL        VAR(&ORGFILENAM) TYPE(*CHAR) LEN(10)
  DCL        VAR(&ORGFILELIB) TYPE(*CHAR) LEN(10)
  DCL        VAR(&ORGMBROPT) TYPE(*CHAR) LEN(8)
  DCL        VAR(&SQL1) TYPE(*CHAR) LEN(55)
  DCL        VAR(&SQL2) TYPE(*CHAR) LEN(55)
  DCL        VAR(&SQL3) TYPE(*CHAR) LEN(55)
  DCL        VAR(&SQL4) TYPE(*CHAR) LEN(55)
  DCL        VAR(&SQL5) TYPE(*CHAR) LEN(55)
  DCL        VAR(&SQL6) TYPE(*CHAR) LEN(55)
  DCL        VAR(&SQL7) TYPE(*CHAR) LEN(55)
  DCL        VAR(&SQL8) TYPE(*CHAR) LEN(55)
  DCL        VAR(&SQL9) TYPE(*CHAR) LEN(55)
  DCL        VAR(&SQLA) TYPE(*CHAR) LEN(55)
  DCL        VAR(&SQLB) TYPE(*CHAR) LEN(55)
  DCL        VAR(&SQLC) TYPE(*CHAR) LEN(55)
  DCL        VAR(&SQLD) TYPE(*CHAR) LEN(55)
  DCL        VAR(&SQLE) TYPE(*CHAR) LEN(55)
  DCL        VAR(&SQLF) TYPE(*CHAR) LEN(55)
/* ************************************************************************** */
/*  GLOBAL MESSAGE MONITOR                                                    */
/* ************************************************************************** */
  MONMSG     MSGID(CPF0000 RPG0000 QRG0000 RSF0000 +
               MCH0000) EXEC(GOTO CMDLBL(##ERROR))
  GOTO       CMDLBL(##NOERROR)
##ERROR:
  SNDPGMMSG  MSGID(CPF9899) MSGF(QCPFMSG) MSGTYPE(*ESCAPE)
##NOERROR:
/* ************************************************************************** */
/*  START OF MAINLINE CODE                                                    */
/* ************************************************************************** */
  CHGVAR     VAR(&SRTSEQ) VALUE(%SST(&QUALSRTSEQ 1 10))
  CHGVAR     VAR(&SRTSEQLIB) VALUE(%SST(&QUALSRTSEQ 11 10))
  CHGVAR     VAR(&PRTFNAME) VALUE(%SST(&PRTF 1 10))
  CHGVAR     VAR(&PRTFLIB) VALUE(%SST(&PRTF 11 10))
  CHGVAR     VAR(&OUTFILENAM) VALUE(%SST(&OUTFILE 1 10))
  CHGVAR     VAR(&OUTFILELIB) VALUE(%SST(&OUTFILE 11 10))
  CHGVAR     VAR(&OUTMBRNAME) VALUE(%SST(&OUTMBR 3 10))
  CHGVAR     VAR(&OUTMBROPT) VALUE(%SST(&OUTMBR 13 8))
  CHGVAR     VAR(&ORGFILENAM) VALUE(%SST(&OUTFILE 1 10))
  CHGVAR     VAR(&ORGFILELIB) VALUE(%SST(&OUTFILE 11 10))
  CHGVAR     VAR(&ORGMBROPT) VALUE(%SST(&OUTMBR 13 8))
/* If a different sort sequence specified, switch to it now */
  IF         COND(&SRTSEQ *NE '*SAME') THEN(DO)
/* Get current sort sequence, so it can be restored afterwards (if needed) */
    RTVJOBA    SRTSEQ(&JOBSRTSEQ) SRTSEQLIB(&JOBSRTSEQL)
    IF         COND(&SRTSEQLIB *NE '          ') THEN(DO)
      CHGJOB     SRTSEQ(&SRTSEQLIB/&SRTSEQ)
      MONMSG     MSGID(CPF1651) EXEC(GOTO CMDLBL(ERRORS2))
    ENDDO
    ELSE       CMD(DO)
      CHGJOB     SRTSEQ(&SRTSEQ)
      MONMSG     MSGID(CPF1651) EXEC(GOTO CMDLBL(ERRORS2))
    ENDDO
  ENDDO
  CHGVAR     VAR(&POS1) VALUE(1)
  CHGVAR     VAR(&COUNT) VALUE(1)
TOPOFLOOP:
/* Drop out of loop once the full SQL string has been processed */
/* Break up the SQL request into 55 character long chunks */
  IF         COND(&COUNT *EQ 1) THEN(CHGVAR +
               VAR(&SQL1) VALUE(%SST(&REQUEST &POS1 55)))
  IF         COND(&COUNT *GT 1) THEN(DO)
/* QMQRY variables truncate trailing blanks, so any found should be part of */
/* the start of the next variable. */
    CHGVAR     VAR(&POS2) VALUE(&POS1 - 1)
TOPTRAIL:
    IF         COND(%SST(&REQUEST &POS2 1) *EQ ' ') THEN(DO)
      CHGVAR     VAR(&POS1) VALUE(&POS2)
      CHGVAR     VAR(&POS2) VALUE(&POS2 - 1)
      IF         COND(&POS2 *GT 1) THEN(GOTO CMDLBL(TOPTRAIL))
    ENDDO
    IF         COND(&COUNT *EQ 2) THEN(CHGVAR VAR(&SQL2) +
                 VALUE(%SST(&REQUEST &POS1 55)))
    IF         COND(&COUNT *EQ 3) THEN(CHGVAR VAR(&SQL3) +
                 VALUE(%SST(&REQUEST &POS1 55)))
    IF         COND(&COUNT *EQ 4) THEN(CHGVAR VAR(&SQL4) +
                 VALUE(%SST(&REQUEST &POS1 55)))
    IF         COND(&COUNT *EQ 5) THEN(CHGVAR VAR(&SQL5) +
                 VALUE(%SST(&REQUEST &POS1 55)))
    IF         COND(&COUNT *EQ 6) THEN(CHGVAR VAR(&SQL6) +
                 VALUE(%SST(&REQUEST &POS1 55)))
    IF         COND(&COUNT *EQ 7) THEN(CHGVAR VAR(&SQL7) +
                 VALUE(%SST(&REQUEST &POS1 55)))
    IF         COND(&COUNT *EQ 8) THEN(CHGVAR VAR(&SQL8) +
                 VALUE(%SST(&REQUEST &POS1 55)))
    IF         COND(&COUNT *EQ 9) THEN(CHGVAR VAR(&SQL9) +
                 VALUE(%SST(&REQUEST &POS1 55)))
    IF         COND(&COUNT *EQ 10) THEN(CHGVAR VAR(&SQLA) +
                 VALUE(%SST(&REQUEST &POS1 55)))
    IF         COND(&COUNT *EQ 11) THEN(CHGVAR VAR(&SQLB) +
                 VALUE(%SST(&REQUEST &POS1 55)))
    IF         COND(&COUNT *EQ 12) THEN(CHGVAR VAR(&SQLC) +
                 VALUE(%SST(&REQUEST &POS1 55)))
    IF         COND(&COUNT *EQ 13) THEN(CHGVAR VAR(&SQLD) +
                 VALUE(%SST(&REQUEST &POS1 55)))
    IF         COND(&COUNT *EQ 14) THEN(CHGVAR VAR(&SQLE) +
                 VALUE(%SST(&REQUEST &POS1 55)))
    IF         COND(&COUNT *EQ 15) THEN(CHGVAR VAR(&SQLF) +
                 VALUE(%SST(&REQUEST &POS1 55)))
  ENDDO
/* If more for next string */
  IF         COND(&COUNT *LT 15) THEN(DO)
    CHGVAR     VAR(&POS1) VALUE(&POS1 + 55)
    CHGVAR     VAR(&COUNT) VALUE(&COUNT + 1)
    GOTO       CMDLBL(TOPOFLOOP)
  ENDDO
/* Execute the request */
/* Echo output to display */
  IF         COND(&OUTPUT *EQ '1') THEN(DO)
    STRQMQRY   QMQRY(EXCSQL) OUTPUT(*) ALWQRYDFN(*YES) +
                 SETVAR((SQL1 &SQL1) (SQL2 &SQL2) (SQL3 +
                 &SQL3) (SQL4 &SQL4) (SQL5 &SQL5) (SQL6 +
                 &SQL6) (SQL7 &SQL7) (SQL8 &SQL8) (SQL9 +
                 &SQL9) (SQLA &SQLA) (SQLB &SQLB) (SQLC +
                 &SQLC) (SQLD &SQLD) (SQLE &SQLE) (SQLF +
                 &SQLF))
    MONMSG     MSGID(QWM2701) EXEC(GOTO CMDLBL(ERRORS1))
  ENDDO
/* Echo output to print */
  IF         COND(&OUTPUT *EQ '2') THEN(DO)
/* Substitute default printfile if required */
    IF         COND(&PRTFNAME *EQ '*EXCSQL') THEN(CHGVAR +
                 VAR(&PRTFNAME) VALUE('EXCSQL'))
/* Substitute default *LIBL if required */
    IF         COND(&PRTFLIB *EQ ' ') THEN(CHGVAR +
                 VAR(&PRTFLIB) VALUE('*LIBL'))
/* Use chosen report for output */
    OVRPRTF    FILE(QPQXPRTF) TOFILE(&PRTFLIB/&PRTFNAME)
    STRQMQRY   QMQRY(EXCSQL) OUTPUT(*PRINT) ALWQRYDFN(*YES) +
                 SETVAR((SQL1 &SQL1) (SQL2 &SQL2) (SQL3 +
                 &SQL3) (SQL4 &SQL4) (SQL5 &SQL5) (SQL6 +
                 &SQL6) (SQL7 &SQL7) (SQL8 &SQL8) (SQL9 +
                 &SQL9) (SQLA &SQLA) (SQLB &SQLB) (SQLC +
                 &SQLC) (SQLD &SQLD) (SQLE &SQLE) (SQLF +
                 &SQLF))
    MONMSG     MSGID(QWM2701) EXEC(GOTO CMDLBL(ERRORS1))
  ENDDO
/* Echo output to database file */
  IF         COND(&OUTPUT *EQ '3') THEN(DO)
/* If *UPDADD requested, then divert *outfile data to temporary file first, */
/* then copy it to requested file - STRQMQRY doesn't support the *UPDADD */
/* option that CPYF does */
    IF         COND(&OUTMBROPT *EQ '*UPDADD') THEN(DO)
      RTVMBRD    FILE(&OUTFILELIB/&OUTFILENAM) +
                          RTNLIB(&RTNLIB) FILEATR(&FILEATR)
      IF         COND(&FILEATR *EQ '*PF') THEN(DO)
        DLTF       FILE(QTEMP/EXCSQLTEMP)
        MONMSG     MSGID(CPF2105)
        CRTDUPOBJ  OBJ(&OUTFILENAM) FROMLIB(&RTNLIB) +
                     OBJTYPE(*FILE) TOLIB(QTEMP) +
                     NEWOBJ(EXCSQLTEMP)
        CHGVAR     VAR(&OUTFILENAM) VALUE('EXCSQLTEMP')
        CHGVAR     VAR(&OUTFILELIB) VALUE('QTEMP')
        CHGVAR     VAR(&OUTMBROPT) VALUE('*ADD')
      ENDDO
    ENDDO
    STRQMQRY   QMQRY(EXCSQL) OUTPUT(*OUTFILE) +
                 OUTFILE(&OUTFILELIB/&OUTFILENAM) +
                 OUTMBR(&OUTMBRNAME &OUTMBROPT) +
                 ALWQRYDFN(*YES) SETVAR((SQL1 &SQL1) (SQL2 +
                 &SQL2) (SQL3 &SQL3) (SQL4 &SQL4) (SQL5 +
                 &SQL5) (SQL6 &SQL6) (SQL7 &SQL7) (SQL8 +
                 &SQL8) (SQL9 &SQL9) (SQLA &SQLA) (SQLB +
                 &SQLB) (SQLC &SQLC) (SQLD &SQLD) (SQLE +
                 &SQLE) (SQLF &SQLF))
    MONMSG     MSGID(QWM2701) EXEC(GOTO CMDLBL(ERRORS1))
    IF         COND(&ORGMBROPT *EQ '*UPDADD') THEN(DO)
      CPYF       FROMFILE(QTEMP/EXCSQLTEMP) +
                   TOFILE(&ORGFILELIB/&ORGFILENAM) +
                   FROMMBR(&OUTMBRNAME) TOMBR(&OUTMBRNAME) +
                   MBROPT(*UPDADD) FROMRCD(1) FMTOPT(*MAP +
                   *DROP) ERRLVL(*NOMAX)
    MONMSG     MSGID(CPF0000) EXEC(GOTO CMDLBL(ERRORS1))
    ENDDO
  ENDDO
  GOTO       CMDLBL(ENDPGM)
ERRORS1:
/* If the job's sort sequence was changed, switch back to the original values */
  IF         COND(&JOBSRTSEQ *NE '          ') THEN(DO)
    IF         COND(&JOBSRTSEQL *NE '          ') THEN(DO)
      CHGJOB     SRTSEQ(&JOBSRTSEQL/&JOBSRTSEQ)
    ENDDO
    ELSE       CMD(DO)
      CHGJOB     SRTSEQ(&JOBSRTSEQ)
    ENDDO
  ENDDO
  SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('EXCSQL +
               encountered one or more problems in the +
               SQL - review joblog.') MSGTYPE(*ESCAPE)
ERRORS2:
  SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('EXCSQL +
               could not switch to the requested sort +
               sequence. Review joblog.') MSGTYPE(*ESCAPE)
ENDPGM:
/* If the job's sort sequence was changed, switch back to the original values */
  IF         COND(&JOBSRTSEQ *NE '          ') THEN(DO)
    IF         COND(&JOBSRTSEQL *NE '          ') THEN(DO)
      CHGJOB     SRTSEQ(&JOBSRTSEQL/&JOBSRTSEQ)
    ENDDO
    ELSE       CMD(DO)
      CHGJOB     SRTSEQ(&JOBSRTSEQ)
    ENDDO
  ENDDO
  DLTOVR     FILE(QPQXPRTF)
  MONMSG     MSGID(CPF9841)
  RETURN
ENDPGM
</verbatim>
 
-- Main.MartinRowe - 23 Sep 2008
This topic: DBG400 > SourceCodeList > ClSource > ClEXCSQL
Topic revision: r2 - 23 Sep 2008 - 11:07:42 - MartinRowe
Copyright © by the contributing authors. All material on this collaboration platform is the property of the contributing authors.
Ideas, requests, problems regarding DBG/400? Send feedback