You are here: DBG/400>DBG400 Web>SourceCodeList>RpgleSource>RpgleDBG104R4 (01 Oct 2014, UnknownUser)EditAttach
**********************************************************************************************
* DBG104R4: Create DBG script from library's files
* 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)
**********************************************************************************************
* FILES:
**********************************************************************************************
* DSPOBJD *OUTFILE for files in target library
FDBGLIST IF E DISK
* Database Generation links
FDBGDGL00 IF E K DISK
* Database Generation script headers
FDBGSQLH1 UF A E K DISK
* Database Generation script headers
FDBGSQLD1 UF A E K DISK
**********************************************************************************************
* ARRAYS:
**********************************************************************************************
D List S 10 DIM(999)
D Comp S 10 DIM(999)
D UnComp S 10 DIM(999)
**********************************************************************************************
* DATA STRUCTURES:
**********************************************************************************************
* PROGRAM NAME
D SDS
D SDS#PGM 10
D SDS#User 254 263
**********************************************************************************************
* WORK FIELDS:
**********************************************************************************************
D CSlot S 3 0
D CtlSize S 4
D Index S 3 0
D K#LSRC S LIKE(DGLSRC)
D K#LTGT S LIKE(DGLTGT)
D LinkFound S 1
D P#File S 10
D P#DtaSpcSiz S 15 0
D P#NbrCurRcd S 10 0
D P#Primary1 S 10
D P#Primary2 S 10
D P#Primary3 S 10
D P#Return S 7
D P#Script S LIKE(DFDOCD)
D P#ScriptType S 5
D Prevmbfile S LIKE(MBFILE)
D Primary S 10
D Repeat S 1
D Sequence S 2
D TgtData S 1
D USlot S 3 0
D WholeMegs S 4 0
**********************************************************************************************
* CONSTANTS:
**********************************************************************************************
**********************************************************************************************
* ENTRY PARAMETERS:
**********************************************************************************************
C *ENTRY PLIST
C PARM P#Script
C PARM P#ScriptType
C PARM P#Return
C PARM P#Primary1
C PARM P#Primary2
C PARM P#Primary3
**********************************************************************************************
* KEY LISTS:
**********************************************************************************************
C DBGDGL00Key KLIST
C KFLD K#LTGT
C KFLD K#LSRC
**********************************************************************************************
* MAINLINE:
**********************************************************************************************
C P#Script CHAIN DBGSQLH1
* If the script already exists (created by someone else), then quit the program
B001 C IF %FOUND(DBGSQLH1)
C AND DFCUSR <> SDS#User
C EVAL P#Return = '*EXISTS'
* Otherwise, write/update a script header
X001 C ELSE
C EVAL DFDOCD = P#Script
C EVAL DFCDTE = *DATE
C EVAL DFADTE = *DATE
C EVAL DFCUSR = SDS#User
C EVAL DFAUSR = SDS#User
C EVAL DFLOCK = 'F'
C EVAL DFHEAD = 'N'
C EVAL DFDOCH = 'Added via CRTDBGSCP command for ' +
C SDS#User
B002 C IF %FOUND(DBGSQLH1)
C UPDATE DB1DFTH
* If updating a script, clear out the old one first
B003 C DOU NOT %FOUND(DBGSQLD1)
C DFDOCD DELETE DB1DFT0
E003 C ENDDO
X002 C ELSE
C WRITE DB1DFTH
E002 C ENDIF
* Loop through all *OUTFILE, entries, storing the physical file names
C 1 SETLL DBGLIST
C READ DBGLIST
B002 C DOW NOT %EOF(DBGLIST)
B003 C IF MBFILE <> Prevmbfile
C EVAL Prevmbfile = MBFILE
C EVAL Index = Index + 1
C EVAL List(Index) = MBFILE
E003 C ENDIF
C READ DBGLIST
E002 C ENDDO
C EVAL List(Index + 1) = '*END'
* Now loop through each entry to create (if possible) a link for each
B002 C SELECT
* If building data by straight CPYF
S002 C WHEN P#ScriptType = '*CPYF'
C EVAL Prevmbfile = *blanks
C 1 SETLL DBGLIST
C READ DBGLIST
B003 C DOW NOT %EOF(DBGLIST)
B004 C IF MBFILE <> Prevmbfile
C EVAL Prevmbfile = MBFILE
* Indicate if the target file already has data
B005 C IF MBNRCD > 0
C EVAL TgtData = 'Y'
X005 C ELSE
C EVAL TgtData = ' '
E005 C ENDIF
* Get the size of the control file - report anything over 5Mb (might slow things down)
C CALL 'DBG104CL'
C PARM MBFILE P#File
C PARM 0 P#NbrCurRcd
C PARM 0 P#DtaSpcSiz
B005 C IF P#DtaSpcSiz > 5242880
C EVAL WholeMegs = P#DtaSpcSiz / (1024 * 1024)
C EVAL CtlSize = %EDITC(WholeMegs:'4')
X005 C ELSE
C EVAL CtlSize = ' < 5'
E005 C ENDIF
* Process according to script type requested
C EVAL DFTEXT = '*CPYF ' + MBFILE + ' ' +
C TgtData + ' ' + CtlSize + 'Mb ' + MBTXT
C EVAL DFLINE = DFLINE + 10
C WRITE DB1DFT0
E004 C ENDIF
*
C READ DBGLIST
E003 C ENDDO
* If building data using database links
S002 C WHEN P#ScriptType = '*LINK'
* Start with the primary file(s) [that are built by user cmd by modifying the script later]
C EVAL Comp(1) = P#Primary1
C EVAL Comp(2) = P#Primary2
C EVAL Comp(3) = P#Primary3
C EVAL UnComp = List
* Load any primary files into the script first
B003 C DO 3 USlot
B004 C SELECT
S004 C WHEN USlot = 1
C EVAL Primary = P#Primary1
S004 C WHEN USlot = 2
C EVAL Primary = P#Primary2
S004 C WHEN USlot = 3
C EVAL Primary = P#Primary3
E004 C ENDSL
*
B004 C IF Primary <> *blanks
C Primary LOOKUP UnComp(USlot) 70
B005 C IF %EQUAL
C EVAL UnComp(USlot) = ' '
E005 C ENDIF
* Get the number of records in the primary
C CALL 'DBG104CL'
C PARM Primary P#File
C PARM 0 P#NbrCurRcd
C PARM 0 P#DtaSpcSiz
C EVAL DFTEXT = '; Build of ' + %TRIM(Primary) +
C ' required here. Source file has ' +
C %trim(%EDITC(P#NbrCurRcd:'4')) + ' records.'
C EVAL DFLINE = DFLINE + 10
C WRITE DB1DFT0
E004 C ENDIF
E003 C ENDDO
*
C EVAL USlot = 1
C EVAL CSlot = 1
C EVAL Index = 2
B003 C DOU Repeat = *off
C EVAL Repeat = *on
* Bypass entries that have already been completed (hence empty)
B004 C DOW UnComp(USlot) = *blanks
C EVAL USlot = USlot + 1
E004 C ENDDO
* If all uncompleted links have been checked against the current control file, move on.
B004 C IF UnComp(USlot) = '*END'
C EVAL CSlot = CSlot + 1
C EVAL USlot = 1
E004 C ENDIF
* If no more control files available, then quit this section
B004 C IF Comp(CSlot) = *blanks
C EVAL Repeat = *off
C LEAVE
E004 C ENDIF
* Now look through the list of files and try to build links with the master as control
C EVAL K#LTGT = UnComp(USlot)
C EVAL K#LSRC = Comp(CSlot)
* If a match found, write to file, and move onto next uncompleted link
C DBGDGL00Key CHAIN DBGDGL00
B004 C IF %FOUND(DBGDGL00)
C MOVE DGLSEQ Sequence
C EVAL DFTEXT = %TRIM(DGLTGT) + ' ' +
C %TRIM(DGLSRC) + ' ' + %TRIM(Sequence) +
C ' ' + %TRIM(DGLTXT)
C EVAL DFLINE = DFLINE + 10
C WRITE DB1DFT0
C EVAL Comp(Index) = UnComp(USlot)
C EVAL UnComp(USlot) = *blanks
C EVAL Index = Index + 1
E004 C ENDIF
C EVAL USlot = USlot + 1
E003 C ENDDO
* Write *CPYF requests for the remaining uncompleted links
C 1 SETLL DBGLIST
C READ DBGLIST
B003 C DOW NOT %EOF(DBGLIST)
B004 C IF MBFILE <> Prevmbfile
C EVAL Prevmbfile = MBFILE
C MBFILE LOOKUP UnComp(USlot) 70
B005 C IF %FOUND
* Indicate if the target file already has data
B006 C IF MBNRCD > 0
C EVAL TgtData = 'Y'
X006 C ELSE
C EVAL TgtData = ' '
E006 C ENDIF
* Get the size of the control file - report anything over 5Mb (might slow things down)
C CALL 'DBG104CL'
C PARM MBFILE P#File
C PARM 0 P#NbrCurRcd
C PARM 0 P#DtaSpcSiz
B006 C IF P#DtaSpcSiz > 5242880
C EVAL WholeMegs = P#DtaSpcSiz / (1024 * 1024)
C EVAL CtlSize = %EDITC(WholeMegs:'4')
X006 C ELSE
C EVAL CtlSize = ' < 5'
E006 C ENDIF
C EVAL DFTEXT = '*CPYF ' + MBFILE + ' ' +
C TgtData + ' ' + CtlSize + 'Mb ' + MBTXT
C EVAL DFLINE = DFLINE + 10
C WRITE DB1DFT0
E005 C ENDIF
E004 C ENDIF
C READ DBGLIST
E003 C ENDDO
E002 C ENDSL
E001 C ENDIF
* Time to go...
C ENDPGM TAG
* ====== ===
C EVAL *INLR = *on
C RETURN
**********************************************************************************************
Edit | Attach | Print version | History: r2 < r1 | Backlinks | View wiki text | Edit wiki text | More topic actions
Topic revision: r2 - 01 Oct 2014 - 19:37:02 - UnknownUser
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