**********************************************************************************************
      * 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
      **********************************************************************************************


This topic: DBG400 > SourceCodeList > RpgleSource > RpgleDBG104R4
Topic revision: r2 - 01 Oct 2014 - 19:37:02 - UnknownUser
 
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