You are here: DBG/400>DBG400 Web>SourceCodeList>RpgleSource>RpgleDBG108R4 (26 May 2005, MartinRowe)EditAttach
**********************************************************************************************
* DBG108R4: Create Program File Set
* 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)
**********************************************************************************************
* DSPPGMREF outfile
FDBGDPRO0 UF E DISK USROPN InfDS(Inf_DS)
FDBGDPRO2 IF E K DISK USROPN Rename(QWHDRPPR:QWHDRPPR2)
**********************************************************************************************
* Arrays
**********************************************************************************************
D FileList S 10 Dim(2000)
**********************************************************************************************
* DATA STRUCTURES:
**********************************************************************************************
* PROGRAM NAME
D SDS
D SDS_Pgm 10
* Information Data Structure
D Inf_DS DS
D RelRcdNbr 10I 0 Overlay(Inf_DS:397)
*
D DS
D DSPPGMREF 120 Inz('DSPPGMREF PGM( -
D ) OUTPUT(*OUTFILE) OUTFILE(QTEMP-
D /DBGDPRO0) OUTMBR(*FIRST *REPLACE)')
D LibAndPgm 21 Overlay(DSPPGMREF:15)
D OutMbr 8 Overlay(DSPPGMREF:93)
*
D DS
D CHKOBJ 60 Inz('CHKOBJ OBJ(1234567890/123456789-
D 0) OBJTYPE(1234567)')
D CHKOBJObj 21 Overlay(CHKOBJ:12)
D CHKOBJTyp 7 Overlay(CHKOBJ:43)
* Standard error code DS for API error handling
D Error_Code DS
D BytesProvd 10I 0 Inz(16)
D BytesAvail 10I 0 Inz(0)
D Except_ID 7
D Reserved 1
D Exception 256
* QUSRMBRD format MBRD0300 structure
D RcvrVarDS DS
D MbrD0300 3184A
D NbrBasedOn 10I 0 Overlay( MbrD0300 : 157 )
D FirstBased 10A Overlay( MbrD0300 : 385 )
*
D BasedEntryDS DS
D BasedEntry 112A
D BasedOnFile 10A Overlay( BasedEntry : 1 )
**********************************************************************************************
* WORK FIELDS:
**********************************************************************************************
D CmdLength S 15 5
D CmdString S 256
D CurrentEnt S 5P 0
D CurrentEnt2 S 5P 0
D FileMember S 10 Inz('*FIRST')
D Index S 5 0
D K_RelRcdNbr S 9 0
D K_WHPNAM S LIKE(WHPNAM)
D Library S 10
D ListFormat S 8
D NbrOfPgms S 3 0
D Offset S 5 0
D Offset2 S 5 0
D OverrideProc S 1 Inz('0')
D PgmName S 10
D P_AllCalled S 1
D P_AllFiles S 1
D P_ErrorID S 7
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_ObjName S 10
D P_ObjType S 10
D P_PgmEntries S 15 5
D P_PgmList S 401
D P_PgmQueue S 10
D P_PgmStack S 5 0
D P_RtnCode1 S 1
D P_ToLib S 10
D P_ToLibNme S 10
D P_ToObjNme S 10
D QualifyFile S 20
D RcvrVarLen S 10I 0 Inz(3184)
D RefnName S 10
**********************************************************************************************
* ENTRY PARAMETERS:
**********************************************************************************************
C *ENTRY PList
C Parm P_PgmList
C Parm P_PgmEntries
C Parm P_ToLibNme
C Parm P_AllFiles
C Parm P_AllCalled
**********************************************************************************************
* KEY LISTS:
**********************************************************************************************
**********************************************************************************************
* MAINLINE:
**********************************************************************************************
* Load the requested program (or recurse through references for all called pgms if required)
C ExSr LoadAllPgms
* Preprocess list to get all depended on files, and create if necessary
C ExSr CrtDepended
* Finally create all remaining files & data areas
C ExSr CrtRemaining
* Time to go
C Eval *INLR = *On
C Return
**********************************************************************************************
* LoadAllPgms: Load all required program references
**********************************************************************************************
C LoadAllPgms BegSr
*
C Eval Offset = 1
C Eval NbrOfPgms = P_PgmEntries
B001 C Do NbrOfPgms
C Eval PgmName = %SubSt( P_PgmList : Offset : 10 )
C Eval Offset = Offset + 10
C Eval Library = %SubSt( P_PgmList : Offset : 10 )
C Eval Offset = Offset + 10
* Get the program references for the passed in program
C Eval LibAndPgm = %TrimR(Library) + '/' +
C PgmName
C Call 'QCMDEXC' 90
C Parm DSPPGMREF CmdString
C Parm 120 CmdLength
* Add any further program entries
C Eval OutMbr = '*ADD '
E001 C EndDo
*
C Open DBGDPRO0
* If recursion through all called programs is required
B001 C If P_AllCalled = *On
C Call 'DBG046CL' 90
C Parm 'DBGDPRO2' P_ObjName
C Parm '*FILE' P_ObjType
C Parm 'DBGDPRO2' P_ToObjNme
C Parm 'QTEMP' P_ToLib
C Parm '0' P_RtnCode1
C Open DBGDPRO2
* Read through the references for the primary program
C 1 SetLL DBGDPRO0
C Read DBGDPRO0 80
B002 C DoW Not *IN80
* If dealing with a referenced program
B003 C If WHOBJT = 'P'
C And %SubSt(WHFNAM:1:1) <> '&'
C And %SubSt(WHFNAM:1:1) <> '*'
C Eval K_WHPNAM = WHFNAM
* Check if this program has been expanded before
C K_WHPNAM SetLL DBGDPRO2 81
* If not already found in the outfile, then add this program's references
B004 C If Not *IN81
C Eval K_RelRcdNbr = RelRcdNbr
C Close DBGDPRO0
C Close DBGDPRO2
C Eval LibAndPgm = '*LIBL/' + K_WHPNAM
C Call 'QCMDEXC' 90
C Parm DSPPGMREF CmdString
C Parm 120 CmdLength
C Open DBGDPRO0
C Open DBGDPRO2
* Reset file pointer in physical to read the next record
C K_RelRcdNbr SetGT DBGDPRO0
E004 C EndIf
E003 C EndIf
C Read DBGDPRO0 80
E002 C EndDo
E001 C EndIf
*
C EndSr
**********************************************************************************************
* CrtDepended: Create depended on physical files
**********************************************************************************************
C CrtDepended BegSr
* First stage is to identify any physicals that are updated via a logical
C 1 SetLL DBGDPRO0
C Read DBGDPRO0 80
B001 C DoW Not *IN80
* Process this file if required (create all referenced files or updated/output only)
B002 C If P_AllFiles = *On Or WHFUSG <> 1
* Get the physical for this dependant logical (if it is a logical)
* Use format in the key if available
B003 C If WHOBJT = 'F'
C And %SubSt(WHFNAM:1:1) <> '&'
C And %SubSt(WHFNAM:1:1) <> '*'
C Eval RefnName = WHFNAM
C Eval QualifyFile = RefnName + '*LIBL'
* Retrieve member description
C Call 'QUSRMBRD'
C Parm RcvrVarDS
C Parm RcvrVarLen
C Parm 'MBRD0300' ListFormat
C Parm QualifyFile
C Parm FileMember
C Parm OverrideProc
C Parm Error_Code
* Process returned entries if the file is a logical
B004 C If FirstBased <> ' ' And BytesAvail = 0
C Eval CurrentEnt = 1
C Eval Offset = 385
* Loop through the entries held in the receiver variable (process max 25 entries)
B005 C DoW CurrentEnt <= NbrBasedOn
C And CurrentEnt <= 25
C Eval BasedEntry = %SubSt( RcvrVarDS :
C Offset : 112 )
C BasedOnFile LookUp FileList(1) 70
* If any physical is there already, all other required physicals must be created
B006 C If Not *IN70
C Eval CHKOBJObj = %Trim(P_ToLibNme) + '/'
C + BasedOnFile
C Eval CHKOBJTyp = WHOTYP
C Call 'QCMDEXC' 90
C Parm CHKOBJ CmdString
C Parm 60 CmdLength
*
B007 C If *IN90
C Call 'DBG046CL' 90
C Parm BasedOnFile P_ObjName
C Parm WHOTYP P_ObjType
C Parm BasedOnFile P_ToObjNme
C Parm P_ToLibNme
C Parm *Off P_RtnCode1
X007 C Else
C Eval P_RtnCode1 = *Off
E007 C EndIf
* Store this physical file's name for check later
C Eval Index = Index + 1
C Eval FileList(Index) = BasedOnFile
B007 C If P_RtnCode1 = *On
* If unable to create the object, send a message to that effect (if not already sent)
C Eval P_MsgID = 'MIT0065'
C Eval P_MsgData = BasedOnFile + WHOTYP + P_ToLibNme
C Eval P_MsgDtaLn = 30
C Eval P_PgmStack = 2
C Eval P_MsgType = '*COMP'
C ExSr SndMsg
E007 C EndIf
E006 C EndIf
* Check if any other physicals are required for this logical
* Bump up the counter & offset for the next entry
C Eval Offset = Offset + 112
C Eval CurrentEnt = CurrentEnt + 1
E005 C EndDo
E004 C EndIf
* If the Retrieve Member Description API failed, then delete the record that caused it.
B004 C If BytesAvail > 0
C Delete QWHDRPPR
E004 C EndIf
E003 C EndIf
E002 C EndIf
C Read DBGDPRO0 80
E001 C EndDo
* Now go through the file to see if any of the input logicals are based over updated
* physicals, but where some input only physicals have yet to be created
C 1 SetLL DBGDPRO0
C Read DBGDPRO0 80
B001 C DoW Not *IN80
* Get the physical for this input only file, if it is a logical
B002 C If WHOBJT = 'F' And WHFUSG = 1
C And %SubSt(WHFNAM:1:1) <> '&'
C And %SubSt(WHFNAM:1:1) <> '*'
C Eval RefnName = WHFNAM
C Eval QualifyFile = RefnName + '*LIBL'
* Retrieve member description
C Call 'QUSRMBRD'
C Parm RcvrVarDS
C Parm RcvrVarLen
C Parm 'MBRD0300' ListFormat
C Parm QualifyFile
C Parm FileMember
C Parm OverrideProc
C Parm Error_Code
* Process returned entries if the file is a logical
B003 C If FirstBased <> ' ' And BytesAvail = 0
C Eval CurrentEnt = 1
C Eval Offset = 385
* Loop through the entries held in the receiver variable (process max 25 entries)
B004 C DoW CurrentEnt <= NbrBasedOn
C And CurrentEnt <= 25
C Eval BasedEntry = %SubSt( RcvrVarDS :
C Offset : 112 )
C BasedOnFile LookUp FileList(1) 70
* If any physical is there already, all other required physicals must be created
B005 C If *IN70
C Eval CurrentEnt2 = 1
C Eval Offset2 = 385
* Loop through the entries held in the receiver variable (process max 25 entries)
B006 C DoW CurrentEnt2 <= NbrBasedOn
C And CurrentEnt2 <= 25
C Eval BasedEntry = %SubSt( RcvrVarDS :
C Offset2 : 112 )
C BasedOnFile LookUp FileList(1) 70
* If any physical is not already there, it must be created
B007 C If Not *IN70
C Eval CHKOBJObj = %Trim(P_ToLibNme) + '/'
C + BasedOnFile
C Eval CHKOBJTyp = WHOTYP
C Call 'QCMDEXC' 90
C Parm CHKOBJ CmdString
C Parm 60 CmdLength
*
B008 C If *IN90
C Call 'DBG046CL' 90
C Parm BasedOnFile P_ObjName
C Parm WHOTYP P_ObjType
C Parm BasedOnFile P_ToObjNme
C Parm P_ToLibNme
C Parm *Off P_RtnCode1
E008 C EndIf
* Store this physical file's name for check later
C Eval Index = Index + 1
C Eval FileList(Index) = BasedOnFile
* If unable to create the object, send a message to that effect
B008 C If P_RtnCode1 = *On
C Eval P_MsgID = 'MIT0065'
C Eval P_MsgData = BasedOnFile + WHOTYP + P_ToLibNme
C Eval P_MsgDtaLn = 30
C Eval P_PgmStack = 2
C Eval P_MsgType = '*COMP'
C ExSr SndMsg
E008 C EndIf
E007 C EndIf
* Check if any other physicals are required for this logical
* Bump up the counter & offset for the next entry
C Eval Offset2 = Offset2 + 112
C Eval CurrentEnt2 = CurrentEnt2 + 1
E006 C EndDo
* No need to check further
C Leave
E005 C EndIf
* Check if any other physicals are required for this logical
* Bump up the counter & offset for the next entry
C Eval Offset = Offset + 112
C Eval CurrentEnt = CurrentEnt + 1
E004 C EndDo
E003 C EndIf
*
E002 C EndIf
C Read DBGDPRO0 80
E001 C EndDo
*
C EndSr
**********************************************************************************************
* CrtRemaining: Create remaining physicals, logicals & data areas
**********************************************************************************************
C CrtRemaining BegSr
* If successful
C 1 SetLL DBGDPRO0
C Read DBGDPRO0 80
B001 C DoW Not *IN80
* Get the physical for this input only file, if it is a logical
* Use format in the key if available
B002 C If WHOBJT = 'F' And WHFUSG = 1
C And %SubSt(WHFNAM:1:1) <> '&'
C And %SubSt(WHFNAM:1:1) <> '*'
C Eval RefnName = WHFNAM
C Eval QualifyFile = RefnName + '*LIBL'
* Retrieve member description
C Call 'QUSRMBRD'
C Parm RcvrVarDS
C Parm RcvrVarLen
C Parm 'MBRD0300' ListFormat
C Parm QualifyFile
C Parm FileMember
C Parm OverrideProc
C Parm Error_Code
* Process returned entries if the file is a logical
B003 C If FirstBased <> ' ' And BytesAvail = 0
C Eval CurrentEnt = 1
C Eval Offset = 385
* Loop through the entries held in the receiver variable (process max 25 entries)
B004 C DoW CurrentEnt <= NbrBasedOn
C And CurrentEnt <= 25
C Eval BasedEntry = %SubSt( RcvrVarDS :
C Offset : 112 )
C BasedOnFile LookUp FileList(1) 70
* If the physical is there then this file must be created, regardless of usage
B005 C If *IN70
C Eval WHFUSG = 2
E005 C EndIf
* Check if any other physicals are required for this logical
* Bump up the counter & offset for the next entry
C Eval Offset = Offset + 112
C Eval CurrentEnt = CurrentEnt + 1
E004 C EndDo
E003 C EndIf
E002 C EndIf
* Create the referenced physical or logical file or data area if required
B002 C If (P_AllFiles = *On Or WHFUSG <> 1)
C And (WHOBJT = 'F' Or WHOBJT = 'D')
C And %SubSt(WHFNAM:1:1) <> '&'
C And %SubSt(WHFNAM:1:1) <> '*'
C Eval RefnName = WHFNAM
C RefnName LookUp FileList(1) 70
B003 C If Not *IN70
C Eval CHKOBJObj = %Trim(P_ToLibNme) + '/'
C + RefnName
C Eval CHKOBJTyp = WHOTYP
C Call 'QCMDEXC' 90
C Parm CHKOBJ CmdString
C Parm 60 CmdLength
*
B004 C If *IN90
C Call 'DBG046CL' 90
C Parm RefnName P_ObjName
C Parm WHOTYP P_ObjType
C Parm RefnName P_ToObjNme
C Parm P_ToLibNme
C Parm *Off P_RtnCode1
E004 C EndIf
C Eval Index = Index + 1
C Eval FileList(Index) = RefnName
* If unable to create the object, send a message to that effect
B004 C If P_RtnCode1 = *On
C Eval P_MsgID = 'MIT0065'
C Eval P_MsgData = RefnName + WHOTYP + P_ToLibNme
C Eval P_MsgDtaLn = 30
C Eval P_PgmStack = 2
C Eval P_MsgType = '*COMP'
C ExSr SndMsg
E004 C EndIf
E003 C EndIf
E002 C EndIf
C Read DBGDPRO0 80
E001 C EndDo
*
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:26:15 - 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