**********************************************************************************************
      * DBG102R4: Execute database generation script
      * Copyright (C) 2000  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
      **********************************************************************************************
     H DATEDIT(*YMD) DEBUG(*YES) OPTION(*NODEBUGIO : *SRCSTMT)
      **********************************************************************************************
      * INDICATOR USAGE:
      **********************************************************************************************
      *     File access inds
      *  80  81  82  83
      *     Error ind (for calls)
      *  90
      **********************************************************************************************
      * FILES:
      **********************************************************************************************
      * Database Generation links
     FDBGDGL00  IF   E           K DISK
      * Database Generation scripts
     FDBGSQLD1  IF   E           K DISK
      **********************************************************************************************
      * ARRAYS:
      **********************************************************************************************
     D P#OutStrings    S            132    DIM(50)
      **********************************************************************************************
      * DATA STRUCTURES:
      **********************************************************************************************
      *  PROGRAM NAME
     D                SDS
     D SDS#PGM                       10
      *
     D                 DS
     D CPYF                         120    INZ('CPYF FROMFILE(          ) -
     D                                     TOFILE(                      ) -
     D                                     MBROPT(*REPLACE) -
     D                                     FROMRCD(1) -
     D                                     FMTOPT(*MAP *DROP) -
     D                                     ERRLVL(*NOMAX)')
     D  FromFile                     10    OVERLAY(CPYF:15)
     D  ToFile                       21    OVERLAY(CPYF:34)
      *
     D                 DS
     D CLRPFM                        40    INZ('CLRPFM FILE(                   -
     D                                       )')
     D  ToFile2                      21    OVERLAY(CLRPFM:13)
      **********************************************************************************************
      * WORK FIELDS:
      **********************************************************************************************
     D CallPgm         S             10
     D K#DglSeq        S                   LIKE(DGLSEQ)
     D NextPgm         S             10
     D P#CallParm      S             10
     D P#CharNbr       S             16
     D P#CmdLength     S             15  5
     D P#CmdString     S            256
     D P#DecNbr        S             15  5
     D P#ErrorID       S              7
     D P#Errors        S              1
     D P#File          S             10
     D P#InString      S            132
     D P#Library       S             10
     D P#MbrOpt        S              8
     D P#MsgData       S            512
     D P#MsgDtaLn      S              5  0
     D P#MsgFile       S             10
     D P#MsgfLib       S             10
     D P#MsgID         S              7
     D P#MsgType       S             10
     D P#NbrRcds       S             10  0
     D P#ObjName       S             10
     D P#ObjType       S             10
     D P#PgmMode       S              4
     D P#PgmNbr        S              2  0
     D P#PgmQueue      S             10
     D P#PgmStack      S              5  0
     D P#Request       S                   LIKE(DGLSQL)
     D P#RqsType       S              7
     D P#RtnCode1      S              1
     D P#Script        S                   LIKE(DFDOCD)
     D P#Source        S                   LIKE(DGLSRC)
     D P#SubPgmMode    S              4
     D P#SubScript     S                   LIKE(DFDOCD)
     D P#Target        S                   LIKE(DGLTGT)
     D P#ToLibNme      S             10
     D P#ToObjNme      S             10
     D P#WordNbr       S              3  0
     D Pos1            S              3  0
     D Sequence        S              2
     D Textline        S                   LIKE(DFTEXT)
      **********************************************************************************************
      * CONSTANTS:
      **********************************************************************************************
     D Lower           C                   CONST('abcdefghijklmnopqrstuvwxyz')
     D Upper           C                   CONST('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
      **********************************************************************************************
      * ENTRY PARAMETERS:
      **********************************************************************************************
     C     *ENTRY        PLIST
     C                   PARM                    P#Script
     C                   PARM                    P#Library
     C                   PARM                    P#PgmMode
     C                   PARM                    P#Errors
     C                   PARM                    P#PgmNbr
      **********************************************************************************************
      * KEY LISTS:
      **********************************************************************************************
     C     LinkKey       KLIST
     C                   KFLD                    P#Target
     C                   KFLD                    P#Source
     C                   KFLD                    K#DglSeq
      **********************************************************************************************
      * MAINLINE:
      **********************************************************************************************
      * Validate the script entries
     C                   EXSR      VALIDATE
      * Now repeat (if no errors) to load the required data
B001 C                   IF        P#Errors = *off
     C                             AND P#PgmMode = '*RUN'
     C                   EXSR      EXECUTE
E001 C                   ENDIF
      *  Time to go...
     C     ENDPGM        TAG
      *    ======        ===
     C                   EVAL      *INLR = *on
     C                   RETURN
      **********************************************************************************************
      * VALIDATE: Validate the script
      **********************************************************************************************
     C     VALIDATE      BEGSR
      * First validate the script
     C     P#Script      CHAIN     DBGSQLD1                           80
      * Error if the script not found (doh)
B001 C                   IF        *IN80
     C                   EVAL      P#MsgID = 'MIT0072'
     C                   EVAL      P#MsgData = P#Script
     C                   EVAL      P#MsgDtaLn = 10
     C                   EVAL      P#PgmStack = 3 + P#PgmNbr
     C                   EVAL      P#Errors = *on
     C                   EVAL      P#MsgType = '*COMP'
     C                   EXSR      SNDMSG
E001 C                   ENDIF
      *
B001 C                   DOW       NOT *IN80
      * Ignore comments (start with a semi-colon) and empty lines
B002 C                   IF        %SUBST(DFTEXT:1:1) <> ';'
     C                             AND DFTEXT <> *blanks
     C     Lower:Upper   XLATE     DFTEXT        Textline
     C                   EVAL      DFTEXT = Textline
      * Parse the line to get the Source (or sub-script), Target & Sequence values
     C                   CALL      'DBG041R4'                           90
     C                   PARM      DFTEXT        P#InString                     Text entry
     C                   PARM      0             P#WordNbr                      Returned entries
     C                   PARM      *blanks       P#OutStrings                   Returned data
      * Determine the type of entry, and process accordingly
B003 C                   SELECT
      * No validation done on special entries at present
S003 C                   WHEN      P#OutStrings(1) = '*CPYF'
S003 C                   WHEN      P#OutStrings(1) = '*CALL'
S003 C                   WHEN      P#OutStrings(1) = '*CMD'
S003 C                   WHEN      P#OutStrings(1) = '*CPYRCDS'
S003 C                   WHEN      P#OutStrings(1) = '*SQLSEL'
S003 C                   WHEN      P#OutStrings(1) = '*SQLUPD'
S003 C                   WHEN      P#OutStrings(1) = '*SQLDLT'
S003 C                   OTHER
     C                   EXSR      CHECKLINK
E003 C                   ENDSL
E002 C                   ENDIF
     C     P#Script      READE     DBGSQLD1                               80
E001 C                   ENDDO
      *
     C                   ENDSR
      **********************************************************************************************
      * CHECKLINK: Check link/script
      **********************************************************************************************
     C     CHECKLINK     BEGSR
      *
     C                   EVAL      P#Target = P#OutStrings(1)
     C                   EVAL      P#Source = P#OutStrings(2)
     C                   EVAL      Sequence = P#OutStrings(3)
     C                   EVAL      P#SubScript = P#OutStrings(1)
      * If this is a script entry
B001 C                   IF        P#Source = '*SCRIPT'
      * Determine name of the next program to be called
     C                   EVAL      P#PgmNbr = P#PgmNbr + 1
     C                   MOVEL     SDS#PGM       NextPgm
     C                   MOVE      P#PgmNbr      NextPgm
      * Copy this program to QTEMP, with the next sequence number
     C                   CALL      'DBG046CL'                           90
     C                   PARM      SDS#PGM       P#ObjName
     C                   PARM      '*PGM'        P#ObjType
     C                   PARM      NextPgm       P#ToObjNme
     C                   PARM      'QTEMP'       P#ToLibNme
     C                   PARM      '0'           P#RtnCode1
      * Call the copy of this program to expand the subscript
     C                   CALL      NextPgm
     C                   PARM                    P#SubScript
     C                   PARM                    P#Library
     C                   PARM                    P#Errors
     C                   PARM                    P#PgmNbr
     C                   PARM      '*CHK'        P#SubPgmMode
      * Reduce program count
     C                   EVAL      P#PgmNbr = P#PgmNbr - 1
      * Otherwise it's a standard DB link record
X001 C                   ELSE
      * Get sequence number in numeric form for key
     C                   MOVE      Sequence      K#DglSeq
     C     LinkKey       CHAIN     DBGDGL00                           81
      * Error if the link statement for these files not found
B002 C                   IF        *IN81
     C                   EVAL      P#MsgID = 'MIT0071'
     C                   EVAL      P#MsgData = P#Target + P#Source + Sequence
     C                   EVAL      P#MsgDtaLn = 23
     C                   EVAL      P#PgmStack = 3 + P#PgmNbr
     C                   EVAL      P#Errors = *on
     C                   EVAL      P#MsgType = '*COMP'
     C                   EXSR      SNDMSG
E002 C                   ENDIF
E001 C                   ENDIF
      *
     C                   ENDSR
      **********************************************************************************************
      * EXECUTE: Execute the script
      **********************************************************************************************
     C     EXECUTE       BEGSR
      *
     C     P#Script      CHAIN     DBGSQLD1                           80
B001 C                   DOW       NOT *IN80
      * Ignore comments (start with a semi-colon) and empty lines
B002 C                   IF        %SUBST(DFTEXT:1:1) <> ';'
     C                             AND DFTEXT <> *blanks
     C     Lower:Upper   XLATE     DFTEXT        Textline
     C                   EVAL      DFTEXT = Textline
     C                   CALL      'DBG041R4'                           90
     C                   PARM      DFTEXT        P#InString                     Text entry
     C                   PARM      0             P#WordNbr                      Returned entries
     C                   PARM      *blanks       P#OutStrings                   Returned data
      * Determine the type of entry, and process accordingly
B003 C                   SELECT
      * CPYF request
S003 C                   WHEN      P#OutStrings(1) = '*CPYF'
     C                   EVAL      FromFile = P#OutStrings(2)
     C                   EVAL      ToFile = %TRIM(P#Library) + '/' + FromFile
     C                   CALL      'QCMDEXC'                            90
     C                   PARM      CPYF          P#CmdString
     C                   PARM      120           P#CmdLength
      * If an error occurs, clear out the target file (in case this was a refresh of the data)
B004 C                   IF        *IN90
     C                   EVAL      ToFile2 = ToFile
     C                   CALL      'QCMDEXC'                            90
     C                   PARM      CLRPFM        P#CmdString
     C                   PARM      40            P#CmdLength
E004 C                   ENDIF
      * CALL request
S003 C                   WHEN      P#OutStrings(1) = '*CALL'
     C                   EVAL      CallPgm = P#OutStrings(2)
     C                   CALL      CallPgm                              90
     C                   PARM      P#Library     P#CallParm
      * CMD request
S003 C                   WHEN      P#OutStrings(1) = '*CMD'
     C                   EVAL      P#CmdString = %SUBST(DFTEXT:6:74)
     C                   CALL      'QCMDEXC'                            90
     C                   PARM                    P#CmdString
     C                   PARM      74            P#CmdLength
      * CPYRCDS request
S003 C                   WHEN      P#OutStrings(1) = '*CPYRCDS'
      * Convert number of rcds required (third 'word' on line) to decimal value for parm use
     C                   EVAL      P#CharNbr = %TRIM(P#OutStrings(3))
     C                   CALL      'DBG043R3'
     C                   PARM                    P#CharNbr
     C                   PARM      0             P#DecNbr
     C                   EVAL      P#File = P#OutStrings(2)
      * Copy required number of records
     C                   CALL      'DBG103CL'
     C                   PARM                    P#File
     C                   PARM                    P#Library
     C                   PARM      P#DecNbr      P#NbrRcds
      * SQL SELECT request
S003 C                   WHEN      P#OutStrings(1) = '*SQLSEL'
      * If the optional replace member data switch is specified, set the RUNSQL MEMBER parm
B004 C                   IF        P#OutStrings(3) = '/R'
     C                   EVAL      P#MbrOpt = '*REPLACE'
X004 C                   ELSE
     C                   EVAL      P#MbrOpt = '*ADD'
E004 C                   ENDIF
     C                   EVAL      P#Target = P#OutStrings(2)
     C                   EVAL      Pos1 = %SCAN( ' WHERE ' : DFTEXT )
     C                   EVAL      P#Request = 'SELECT * FROM ' + P#Target +
     C                             %SUBST( DFTEXT : Pos1 : 79 - Pos1 )
     C                   CALL      'DBG102CL'                           90
     C                   PARM                    P#Library
     C                   PARM                    P#Target
     C                   PARM      ' '           P#Source
     C                   PARM                    P#Request
     C                   PARM                    P#MbrOpt
     C                   PARM      '*SQLSEL'     P#RqsType
      * SQL UPDATE request
S003 C                   WHEN      P#OutStrings(1) = '*SQLUPD'
     C                   EVAL      P#Target = P#OutStrings(2)
     C                   EVAL      Pos1 = %SCAN( ' SET ' : DFTEXT )
     C                   EVAL      P#Request = 'UPDATE ' + P#Target +
     C                             %SUBST( DFTEXT : Pos1 : 79 - Pos1 )
     C                   CALL      'DBG102CL'                           90
     C                   PARM                    P#Library
     C                   PARM                    P#Target
     C                   PARM      ' '           P#Source
     C                   PARM                    P#Request
     C                   PARM      '*REPLACE'    P#MbrOpt
     C                   PARM      '*SQLUPD'     P#RqsType
      * SQL DELETE request
S003 C                   WHEN      P#OutStrings(1) = '*SQLDLT'
     C                   EVAL      P#Target = P#OutStrings(2)
     C                   EVAL      Pos1 = %SCAN( ' WHERE ' : DFTEXT )
     C                   EVAL      P#Request = 'DELETE FROM ' + P#Target +
     C                             %SUBST( DFTEXT : Pos1 : 79 - Pos1 )
     C                   CALL      'DBG102CL'                           90
     C                   PARM                    P#Library
     C                   PARM                    P#Target
     C                   PARM      ' '           P#Source
     C                   PARM                    P#Request
     C                   PARM      '*REPLACE'    P#MbrOpt
     C                   PARM      '*SQLDLT'     P#RqsType
      * Link or script request
S003 C                   OTHER
     C                   EXSR      PROCLINK
E003 C                   ENDSL
E002 C                   ENDIF
     C     P#Script      READE     DBGSQLD1                               80
E001 C                   ENDDO
      *
     C                   ENDSR
      **********************************************************************************************
      * PROCLINK: Process link/script
      **********************************************************************************************
     C     PROCLINK      BEGSR
      *
     C                   EVAL      P#Target = P#OutStrings(1)
     C                   EVAL      P#Source = P#OutStrings(2)
     C                   EVAL      Sequence = P#OutStrings(3)
     C                   EVAL      P#SubScript = P#OutStrings(1)
      * If this is a subscript entry
B001 C                   IF        P#Source = '*SCRIPT'
      * Need to run this program again for the sub script
     C                   EVAL      P#PgmNbr = P#PgmNbr + 1
     C                   MOVEL     SDS#PGM       NextPgm
     C                   MOVE      P#PgmNbr      NextPgm
      * Call the copy of this program to expand the subscript (should exist from check above)
     C                   CALL      NextPgm
     C                   PARM                    P#SubScript
     C                   PARM                    P#Library
     C                   PARM      *on           P#Errors
     C                   PARM                    P#PgmNbr
     C                   PARM      '*RUN'        P#PgmMode
      * Reduce program count
     C                   EVAL      P#PgmNbr = P#PgmNbr - 1
      * Otherwise process the link as normal
X001 C                   ELSE
     C                   MOVE      Sequence      K#DglSeq
     C     LinkKey       CHAIN     DBGDGL00                           81
B002 C                   IF        NOT *IN81
      * If the optional replace member data switch is specified, set the RUNSQL MEMBER parm
B003 C                   IF        P#OutStrings(4) = '/R'
     C                   EVAL      P#MbrOpt = '*REPLACE'
X003 C                   ELSE
     C                   EVAL      P#MbrOpt = '*ADD'
E003 C                   ENDIF
     C                   CALL      'DBG102CL'                           90
     C                   PARM                    P#Library
     C                   PARM                    P#Target
     C                   PARM                    P#Source
     C                   PARM      DGLSQL        P#Request
     C                   PARM                    P#MbrOpt
     C                   PARM      '*LINK  '     P#RqsType
E002 C                   ENDIF
E001 C                   ENDIF
      *
     C                   ENDSR
      **********************************************************************************************
      * SNDMSG: SEND PROGRAM MESSAGE
      **********************************************************************************************
     C     SNDMSG        BEGSR
      *  Use in-house utility (via system API 'QMHSNDPM')
     C                   CALL      'DBG044R3'
     C                   PARM                    P#MsgID
     C                   PARM      'DBGMSGF   '  P#MsgFile
     C                   PARM      '*LIBL     '  P#MsgfLib
     C                   PARM                    P#MsgData
     C                   PARM                    P#MsgDtaLn
     C                   PARM                    P#MsgType
     C                   PARM      SDS#PGM       P#PgmQueue
     C                   PARM                    P#PgmStack
     C                   PARM      '       '     P#ErrorID
      *
     C                   ENDSR
      **********************************************************************************************
Topic revision: r1 - 26 May 2005 - 19:20:04 - MartinRowe
 
This site is powered by FoswikiCopyright © 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