You are here: DBG/400>DBG400 Web>SourceCodeList>RpgleSource>RpgleDBG102R4 (26 May 2005, MartinRowe)EditAttach
**********************************************************************************************
* 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
**********************************************************************************************
Edit | Attach | Print version | History: r1 | Backlinks | View wiki text | Edit wiki text | More topic actions
Topic revision: r1 - 26 May 2005 - 19:20:04 - MartinRowe
Site Map
DBG400
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