**********************************************************************************************
      * 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
Topic revision: r1 - 26 May 2005 - 19:26:15 - 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