&ANALYZE-SUSPEND _VERSION-NUMBER AB_v10r12 &ANALYZE-RESUME &ANALYZE-SUSPEND _UIB-CODE-BLOCK _CUSTOM _DEFINITIONS Procedure /*------------------------------------------------------------------------ File : Purpose : Syntax : Description : Author(s) : Created : Notes : ----------------------------------------------------------------------*/ /* This .W file was created with the Progress AppBuilder. */ /*----------------------------------------------------------------------*/ /*------------------------------------------------------------------------------------------------ Copyright 2015 The Mad DBA 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 3 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. ---------------------------------------------------------------------------------------------------*/ /* *************************** Definitions ************************** */ /*--- Temp table definitions ---*/ DEFINE TEMP-TABLE ttBlock NO-UNDO FIELD AreaName AS CHARACTER FIELD BlockNumber AS DECIMAL FIELD RecordCount AS INTEGER FIELD TableList AS CHARACTER FIELD BlockMap AS CHARACTER INDEX IdxMain IS UNIQUE AreaName BlockNumber. DEFINE TEMP-TABLE ttTableBlock NO-UNDO FIELD TableName AS CHARACTER FIELD BlockNumber AS DECIMAL FIELD RecordCount AS DECIMAL INDEX IdxMain IS UNIQUE TableName BlockNumber INDEX IdxBlock BlockNumber RecordCount INDEX IdxTable TableName RecordCount. DEFINE TEMP-TABLE ttArea NO-UNDO FIELD AreaNumber AS INTEGER FIELD AreaName AS CHARACTER FIELD AreaVersion AS INTEGER FIELD AreaRPB AS INTEGER FIELD AreaBlockSize AS INTEGER FIELD AreaBufferPool AS INTEGER INDEX IdxMain IS UNIQUE AreaNumber. DEFINE TEMP-TABLE ttTable NO-UNDO FIELD TableNumber AS INTEGER FIELD TableName AS CHARACTER FIELD AreaNumber AS INTEGER FIELD RecordCount AS INTEGER FIELD BufferPool AS INTEGER FIELD DistinctBlocks AS INTEGER FIELD BestBlocks AS INTEGER FIELD FragRatio AS DECIMAL FIELD FileRecid AS RECID FIELD IsUsed AS LOGICAL INDEX IdxMain IS UNIQUE TableNumber INDEX IdxTable IS UNIQUE TableName INDEX IdxUsed IsUsed TableName INDEX IdxArea AreaNumber TableName INDEX IdxZUsed AreaNumber IsUsed. DEFINE TEMP-TABLE ttRecid NO-UNDO FIELD rRecid AS RECID FIELD iSlot AS INTEGER INDEX IdxMain IS UNIQUE rRecid. /*--- Define Buffers ---*/ DEFINE BUFFER bfTable FOR ttTable. DEFINE BUFFER bfTableBlock FOR ttTableBlock. DEFINE BUFFER bfBlock FOR ttBlock. /*--- Define Variables ---*/ DEFINE VARIABLE cField AS CHARACTER NO-UNDO. DEFINE VARIABLE iBlocks AS INTEGER NO-UNDO. DEFINE VARIABLE iRecords AS INTEGER NO-UNDO. DEFINE VARIABLE iDBBlock AS INTEGER NO-UNDO. DEFINE VARIABLE iTemp AS INTEGER NO-UNDO. /*--- Define Streams ---*/ DEFINE STREAM stFile. /*--- Define Parameters ----*/ DEFINE INPUT PARAMETER ipFileName AS CHARACTER NO-UNDO. DEFINE INPUT PARAMETER ipAreaList AS CHARACTER NO-UNDO. DEFINE INPUT PARAMETER ipTableList AS CHARACTER NO-UNDO. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ANALYZE-SUSPEND _UIB-PREPROCESSOR-BLOCK /* ******************** Preprocessor Definitions ******************** */ &Scoped-define PROCEDURE-TYPE Procedure &Scoped-define DB-AWARE no /* _UIB-PREPROCESSOR-BLOCK-END */ &ANALYZE-RESUME /* ************************ Function Prototypes ********************** */ &IF DEFINED(EXCLUDE-fn_Ceil) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD fn_Ceil Procedure FUNCTION fn_Ceil RETURNS INTEGER PRIVATE ( INPUT ip_Decimal AS DECIMAL ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-fn_FieldList) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD fn_FieldList Procedure FUNCTION fn_FieldList RETURNS CHARACTER PRIVATE ( ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-fn_GetBlocks) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD fn_GetBlocks Procedure FUNCTION fn_GetBlocks RETURNS LOGICAL PRIVATE ( INPUT ip_TableName AS CHARACTER) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-fn_Header) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD fn_Header Procedure FUNCTION fn_Header RETURNS LOGICAL PRIVATE ( INPUT ip_Text AS CHARACTER, INPUT ip_Header AS INTEGER, INPUT ip_ID AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-fn_HTMLHeader) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD fn_HTMLHeader Procedure FUNCTION fn_HTMLHeader RETURNS LOGICAL PRIVATE ( /* parameter-definitions */ ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-fn_OtherTables) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD fn_OtherTables Procedure FUNCTION fn_OtherTables RETURNS CHARACTER PRIVATE ( /* parameter-definitions */ ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-fn_Query) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD fn_Query Procedure FUNCTION fn_Query RETURNS LOGICAL PRIVATE ( INPUT ip_TableName AS CHARACTER, INPUT ip_Where AS CHARACTER, INPUT ip_Sort AS CHARACTER, INPUT ip_First AS LOGICAL, INPUT ip_Handler AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-fn_RecidCheck) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD fn_RecidCheck Procedure FUNCTION fn_RecidCheck RETURNS LOGICAL PRIVATE ( INPUT ip_TableName AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF /* *********************** Procedure Settings ************************ */ &ANALYZE-SUSPEND _PROCEDURE-SETTINGS /* Settings for THIS-PROCEDURE Type: Procedure Allow: Frames: 0 Add Fields to: Neither Other Settings: CODE-ONLY */ &ANALYZE-RESUME _END-PROCEDURE-SETTINGS /* ************************* Create Window ************************** */ &ANALYZE-SUSPEND _CREATE-WINDOW /* DESIGN Window definition (used by the UIB) CREATE WINDOW Procedure ASSIGN HEIGHT = 15 WIDTH = 60. /* END WINDOW DEFINITION */ */ &ANALYZE-RESUME &ANALYZE-SUSPEND _UIB-CODE-BLOCK _CUSTOM _MAIN-BLOCK Procedure /* *************************** Main Block *************************** */ /*--- Get the area information ---*/ fn_Query ("_Area", " WHERE _Area._Area-Version = 1 AND CAN-DO('" + ipAreaList + "',_Area._Area-Name)", "", FALSE, "ip_ProcessArea"). /*--- Get the basic table information --*/ fn_Query ("_File", " FIELDS(_File._File-Number _File._File-Name) WHERE _File._Tbl-Type = 'T' ", "", FALSE, "ip_ProcessTable"). /*--- Get the table storage area information ---*/ fn_Query ("_StorageObject", "WHERE _storageobject._object-type = 1", "", FALSE, "ip_ProcessTableObject"). /*--- Clean up orphaned tables ---*/ FOR EACH ttTable WHERE ttTable.AreaNumber = 0: DELETE ttTable. END. /*--- Clean up areas where we don't have tables to track ---*/ FOR EACH ttArea: FIND FIRST ttTable WHERE ttTable.AreaNumber = ttArea.AreaNumber AND CAN-DO(ipTableList,ttTable.TableName) NO-ERROR. IF AVAILABLE ttTable THEN NEXT. FOR EACH ttTable WHERE ttTable.AreaNumber = ttArea.AreaNumber: DELETE ttTable. END. DELETE ttArea. END. /*--- EACH ttArea ---*/ /*--- Which tables do we look at directly? ----*/ FOR EACH ttArea, EACH ttTable OF ttArea: IF NOT CAN-DO(ipTableList,ttTable.TableName) THEN NEXT. /*--- Read all of the records ---*/ fn_GetBlocks(ttTable.TableName). END. /*-- EACH Type 1 Area/Table ---*/ /*--- parse blocks for other tables not specified ---*/ FOR EACH ttArea: /*--- does this area have untracked tables? --=*/ FIND FIRST ttTable WHERE ttTable.AreaNumber = ttArea.AreaNumber AND ttTable.IsUsed = FALSE NO-ERROR. IF NOT AVAILABLE ttTable THEN NEXT. /*--- Do we have unfilled blocks? ---*/ FOR EACH ttBlock WHERE ttBlock.AreaName = ttArea.AreaName AND ttBlock.RecordCount < ttArea.AreaRPB: /*-- which recids do we not have records for? --*/ EMPTY TEMP-TABLE ttRecid. DO iTemp = 1 TO ttArea.AreaRPB: IF SUBSTRING(ttBlock.BlockMap,iTemp,1) = "R" THEN NEXT. CREATE ttRecid. ASSIGN ttRecid.rRecid = INTEGER(ttBlock.BlockNumber * ttArea.AreaRPB) + (iTemp - 1) ttRecid.iSlot = iTemp. END. FOR EACH bfTable WHERE bfTable.AreaNumber = ttArea.AreaNumber AND bfTable.IsUsed = FALSE: fn_RecidCheck(bfTable.TableName). FIND FIRST ttRecid NO-ERROR. IF NOT AVAILABLE ttRecid THEN LEAVE. END. /*--- EACH ttTable ---*/ END. /*--- EACH ttBlock ---*/ END. /*--- EACH ttArea ---*/ /*--- Generate the HTML ----*/ RUN ip_GenerateHTML. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME /* ********************** Internal Procedures *********************** */ &IF DEFINED(EXCLUDE-ip_GenerateHTML) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE ip_GenerateHTML Procedure PROCEDURE ip_GenerateHTML PRIVATE : /*------------------------------------------------------------------------------ Purpose: Parameters: Notes: ------------------------------------------------------------------------------*/ OUTPUT STREAM stFile TO VALUE(ipFileName). /*--- Header ---*/ fn_HTMLHeader(). fn_Header("Table Summary",2,"TOP"). PUT STREAM stFile UNFORMATTED "" SKIP "" SKIP "" SKIP "" SKIP "" SKIP "" "" SKIP "" SKIP "" SKIP "" SKIP "" SKIP. FOR EACH ttTable WHERE ttTable.IsUsed = TRUE BY ttTable.FragRatio DESCENDING BY ttTable.TableName: FIND ttArea OF ttTable NO-ERROR. PUT STREAM stFile UNFORMATTED "" SKIP "" SKIP "" SKIP "" SKIP "" SKIP "" SKIP "" SKIP "" SKIP "" SKIP "" SKIP. END. PUT STREAM stFile UNFORMATTED "
Table NameBuffer PoolArea NameArea RPBRecord CountBlocksMinimum Possible BlocksFragmentation Level
" "" ttTable.TableName "" "" IF ttTable.BufferPool = 2 THEN "Alternate" ELSE "Primary" "" ttArea.AreaName "" STRING(ttArea.AreaRPB,">>9") "" STRING(ttTable.RecordCount,">>>,>>>,>>>,>>9") "" STRING(ttTable.DistinctBlocks,">>>,>>>,>>>,>>9") "" STRING(ttTable.BestBlocks,">>>,>>>,>>>,>>9") "" STRING(ttTable.FragRatio,">>>,>>>,>>,>>9.9") "
" SKIP. /*--- Table details ---*/ FOR EACH ttTable WHERE ttTable.IsUsed = TRUE BY ttTable.FragRatio DESCENDING BY ttTable.TableName: FIND ttArea OF ttTable NO-ERROR. fn_Header(ttTable.TableName + " (" + STRING(ttArea.AreaRPB) + " Records Per Block)", 2, "T" + STRING(ttTable.TableNumber)). PUT STREAM stFile UNFORMATTED "" SKIP "" SKIP "" SKIP "" SKIP "" SKIP "" SKIP "" SKIP. FOR EACH ttTableBlock WHERE ttTableBlock.TableName = ttTable.TableName BY ttTableBlock.RecordCount: FIND ttBlock WHERE ttBlock.BlockNumber = ttTableBlock.BlockNumber NO-ERROR. PUT STREAM stFile UNFORMATTED "" "" "" "" "" "" SKIP. END. PUT STREAM stFile UNFORMATTED "
Block NumberRecord Count For This TableOther Tables In This Block(Record Count)Fragments/Empty
" TRIM(STRING(ttTableBlock.BlockNumber,">>>,>>>,>>>,>>9")) "" TRIM(STRING(ttTableBlock.RecordCount,">>>,>>>,>>>,>>9")) "" IF ttBlock.TableList <> ttTable.TableName THEN fn_OtherTables() ELSE "" "" TRIM(STRING(ttArea.AreaRPB - ttBlock.RecordCount,">>>,>>>,>>>,>>9")) "
" SKIP. END. /*--- EACH ttTable ---*/ /*--- Trailer ---*/ PUT STREAM stFile UNFORMATTED "" SKIP "" SKIP "" SKIP. OUTPUT STREAM stFile CLOSE. END PROCEDURE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-ip_ProcessArea) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE ip_ProcessArea Procedure PROCEDURE ip_ProcessArea PRIVATE : /*------------------------------------------------------------------------------ Purpose: Parameters: Notes: ------------------------------------------------------------------------------*/ DEFINE INPUT PARAMETER ip_Handle AS HANDLE NO-UNDO. CREATE ttArea. ASSIGN ttArea.AreaNumber = ip_Handle:BUFFER-FIELD("_Area-Number"):BUFFER-VALUE ttArea.AreaName = ip_Handle:BUFFER-FIELD("_Area-Name"):BUFFER-VALUE ttArea.AreaVersion = (IF ip_Handle:BUFFER-FIELD("_Area-Version"):BUFFER-VALUE = 7 THEN 2 ELSE 1) ttArea.AreaRPB = EXP(2,ip_Handle:BUFFER-FIELD("_Area-RecBits"):BUFFER-VALUE) ttArea.AreaBlockSize = ip_Handle:BUFFER-FIELD("_Area-Blocksize"):BUFFER-VALUE / 1024 ttArea.AreaBufferPool = (GET-BITS(ip_Handle:BUFFER-FIELD("_Area-Attrib"):BUFFER-VALUE,7,1) + 1) NO-ERROR. END PROCEDURE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-ip_ProcessTable) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE ip_ProcessTable Procedure PROCEDURE ip_ProcessTable PRIVATE : /*------------------------------------------------------------------------------ Purpose: Parameters: Notes: ------------------------------------------------------------------------------*/ DEFINE INPUT PARAMETER ip_Handle AS HANDLE NO-UNDO. CREATE ttTable. ASSIGN ttTable.TableNumber = ip_Handle:BUFFER-FIELD("_File-Number"):BUFFER-VALUE ttTable.TableName = ip_Handle:BUFFER-FIELD("_File-Name"):BUFFER-VALUE ttTable.FileRecid = ip_Handle:RECID. END PROCEDURE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-ip_ProcessTableObject) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE ip_ProcessTableObject Procedure PROCEDURE ip_ProcessTableObject PRIVATE : /*------------------------------------------------------------------------------ Purpose: Parameters: Notes: ------------------------------------------------------------------------------*/ DEFINE INPUT PARAMETER ip_Handle AS HANDLE NO-UNDO. FIND ttArea WHERE ttArea.AreaNumber = ip_Handle:BUFFER-FIELD("_Area-Number"):BUFFER-VALUE NO-ERROR. IF NOT AVAILABLE ttArea THEN RETURN. FIND ttTable WHERE ttTable.TableNumber = ip_Handle:BUFFER-FIELD("_Object-Number"):BUFFER-VALUE NO-ERROR. IF NOT AVAILABLE ttTable THEN RETURN. ASSIGN ttTable.AreaNumber = ttArea.AreaNumber ttTable.BufferPool = (IF ttArea.AreaVersion = 1 THEN ttArea.AreaBufferPool ELSE IF ttArea.AreaVersion = 2 AND ttArea.AreaBufferPool = 2 THEN 2 ELSE GET-BITS(ip_Handle:BUFFER-FIELD("_Object-Attrib"):BUFFER-VALUE,7,1) + 1). END PROCEDURE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF /* ************************ Function Implementations ***************** */ &IF DEFINED(EXCLUDE-fn_Ceil) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION fn_Ceil Procedure FUNCTION fn_Ceil RETURNS INTEGER PRIVATE ( INPUT ip_Decimal AS DECIMAL ) : /*------------------------------------------------------------------------------ Purpose: Notes: ------------------------------------------------------------------------------*/ IF TRUNC(ip_Decimal,0) <> ip_Decimal THEN RETURN INTEGER(TRUNC(ip_Decimal,0) + 1). ELSE RETURN INTEGER(ip_Decimal). END FUNCTION. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-fn_FieldList) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION fn_FieldList Procedure FUNCTION fn_FieldList RETURNS CHARACTER PRIVATE ( ) : /*------------------------------------------------------------------------------ Purpose: Notes: ------------------------------------------------------------------------------*/ /*--- Define Variables ---*/ DEFINE VARIABLE hQuery AS HANDLE NO-UNDO. DEFINE VARIABLE hBuffer AS HANDLE NO-UNDO. DEFINE VARIABLE cFieldList AS CHARACTER NO-UNDO. DEFINE VARIABLE cDate AS CHARACTER NO-UNDO. DEFINE VARIABLE cInteger AS CHARACTER NO-UNDO. DEFINE VARIABLE cDecimal AS CHARACTER NO-UNDO. DEFINE VARIABLE cCharacter AS CHARACTER NO-UNDO. CREATE BUFFER hBuffer FOR TABLE "_Field" NO-ERROR. CREATE QUERY hQuery NO-ERROR. hQuery:SET-BUFFERS(hBuffer) NO-ERROR. hQuery:QUERY-PREPARE("FOR EACH _Field FIELDS(_Field._Data-Type _Field._Field-Name) " + "WHERE _Field._File-Recid = " + STRING(ttTable.FileRecid) + " NO-LOCK"). hQuery:QUERY-OPEN() NO-ERROR. $loop$: REPEAT: hQuery:GET-NEXT() NO-ERROR. IF hQuery:QUERY-OFF-END THEN LEAVE $loop$. /*--- Find a nice small field to add to the fields list ---*/ IF hBuffer:BUFFER-FIELD("_Data-Type"):BUFFER-VALUE = "LOGICAL" THEN DO: ASSIGN cFieldList = hBuffer:BUFFER-FIELD("_Field-Name"):BUFFER-VALUE NO-ERROR. LEAVE $loop$. END. /*--- Easiest ---*/ ELSE IF cDate = "" AND hBuffer:BUFFER-FIELD("_Data-Type"):BUFFER-VALUE = "DATE" THEN ASSIGN cDate = hBuffer:BUFFER-FIELD("_Field-Name"):BUFFER-VALUE NO-ERROR. ELSE IF cInteger = "" AND (hBuffer:BUFFER-FIELD("_Data-Type"):BUFFER-VALUE = "INTEGER" OR hBuffer:BUFFER-FIELD("_Data-Type"):BUFFER-VALUE = "INT64") THEN ASSIGN cInteger = hBuffer:BUFFER-FIELD("_Field-Name"):BUFFER-VALUE NO-ERROR. ELSE IF cDecimal = "" AND hBuffer:BUFFER-FIELD("_Data-Type"):BUFFER-VALUE = "DECIMAL" THEN ASSIGN cDecimal = hBuffer:BUFFER-FIELD("_Field-Name"):BUFFER-VALUE NO-ERROR. ELSE IF cCharacter = "" AND hBuffer:BUFFER-FIELD("_Data-Type"):BUFFER-VALUE = "CHARACTER" THEN ASSIGN cCharacter = hBuffer:BUFFER-FIELD("_Field-Name"):BUFFER-VALUE NO-ERROR. END. /*--- $loop$ ---*/ hQuery:QUERY-CLOSE() NO-ERROR. DELETE OBJECT hQuery NO-ERROR. DELETE OBJECT hBuffer NO-ERROR. /*--- Which one? ---*/ IF cFieldList = "" THEN DO: IF cDate <> "" THEN ASSIGN cFieldList = cDate. ELSE IF cInteger <> "" THEN ASSIGN cFieldList = cInteger. ELSE IF cDecimal <> "" THEN ASSIGN cFieldList = cDecimal. ELSE IF cCharacter <> "" THEN ASSIGN cFieldList = cCharacter. END. RETURN cFieldList. END FUNCTION. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-fn_GetBlocks) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION fn_GetBlocks Procedure FUNCTION fn_GetBlocks RETURNS LOGICAL PRIVATE ( INPUT ip_TableName AS CHARACTER): /*--- Define Variables ---*/ DEFINE VARIABLE hQuery AS HANDLE NO-UNDO. DEFINE VARIABLE hBuffer AS HANDLE NO-UNDO. DEFINE VARIABLE cField AS CHARACTER NO-UNDO. DEFINE VARIABLE iSlot AS INTEGER NO-UNDO. ASSIGN iBlocks = 0 iRecords = 0 ttTable.IsUsed = TRUE. ASSIGN cField = fn_FieldList(). CREATE BUFFER hBuffer FOR TABLE ip_TableName NO-ERROR. CREATE QUERY hQuery NO-ERROR. hQuery:SET-BUFFERS(hBuffer) NO-ERROR. hQuery:FORWARD-ONLY = TRUE. hQuery:QUERY-PREPARE("FOR EACH " + ip_TableName + " FIELDS(" + cField + ") NO-LOCK") NO-ERROR. hQuery:QUERY-OPEN() NO-ERROR. $loop$: REPEAT: hQuery:GET-NEXT() NO-ERROR. IF hQuery:QUERY-OFF-END THEN LEAVE $loop$. ASSIGN iDBBlock = hBuffer:RECID iDBBlock = TRUNCATE(iDBBlock / ttArea.AreaRPB,0) iSlot = INTEGER(hBuffer:RECID) - (iDBBlock * ttArea.AreaRPB) + 1 iRecords = iRecords + 1. /*---- Area block tracking ---*/ FIND ttBlock WHERE ttBlock.AreaName = ttArea.AreaName AND ttBlock.BlockNumber = iDBBlock NO-ERROR. IF NOT AVAILABLE ttBlock THEN DO: CREATE ttBlock. ASSIGN ttBlock.AreaName = ttArea.AreaName ttBlock.BlockNumber = iDBBlock ttBlock.BlockMap = FILL("-",ttArea.AreaRPB). END. /*--- Keep track of the tables in this block ---*/ IF NOT CAN-DO(ttBlock.TableList,ttTable.TableName) THEN DO: IF ttBlock.TableList = "" THEN ASSIGN ttBlock.TableList = ttTable.TableName. ELSE ASSIGN ttBlock.TableList = ttBlock.TableList + "," + ttTable.TableName. END. ASSIGN ttBlock.RecordCount = ttBlock.RecordCount + 1 SUBSTRING(ttBlock.BlockMap,iSlot,1) = "R". /*--- Table block tracking ---*/ FIND ttTableBlock WHERE ttTableBlock.TableName = ttTable.TableName AND ttTableBlock.BlockNumber = iDBBlock NO-ERROR. IF NOT AVAILABLE ttTableBlock THEN DO: CREATE ttTableBlock. ASSIGN ttTableBlock.TableName = ttTable.TableName ttTableBlock.BlockNumber = iDBBlock iBlocks = iBlocks + 1. END. ASSIGN ttTableBlock.RecordCount = ttTableBlock.RecordCount + 1. END. /*--- $loop$ ---*/ hQuery:QUERY-CLOSE() NO-ERROR. DELETE OBJECT hQuery NO-ERROR. DELETE OBJECT hBuffer NO-ERROR. ASSIGN ttTable.DistinctBlocks = iBlocks ttTable.RecordCount = iRecords ttTable.BestBlocks = fn_Ceil(ttTable.RecordCount / ttArea.AreaRPB) ttTable.FragRatio = ttTable.DistinctBlocks / ttTable.BestBlocks. RETURN FALSE. /* Function return value. */ END FUNCTION. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-fn_Header) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION fn_Header Procedure FUNCTION fn_Header RETURNS LOGICAL PRIVATE ( INPUT ip_Text AS CHARACTER, INPUT ip_Header AS INTEGER, INPUT ip_ID AS CHARACTER ) : /*------------------------------------------------------------------------------ Purpose: Notes: ------------------------------------------------------------------------------*/ DEFINE VARIABLE cTag AS CHARACTER NO-UNDO. ASSIGN cTag = "h" + STRING(ip_Header). PUT STREAM stFile UNFORMATTED "<" cTag " id=" (IF ip_ID <> "" THEN ip_ID ELSE "TOP") ">" "" ip_Text "". IF ip_ID <> "" AND ip_ID <> "TOP" THEN PUT STREAM stFile UNFORMATTED "" "Back to Summary" SKIP. PUT STREAM stFile UNFORMATTED "" SKIP. RETURN FALSE. /* Function return value. */ END FUNCTION. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-fn_HTMLHeader) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION fn_HTMLHeader Procedure FUNCTION fn_HTMLHeader RETURNS LOGICAL PRIVATE ( /* parameter-definitions */ ) : /*------------------------------------------------------------------------------ Purpose: Notes: ------------------------------------------------------------------------------*/ PUT STREAM stFile UNFORMATTED "" SKIP "" SKIP "" SKIP "OpenEdge Type 1 Area Blocks - The Mad DBA (TheMadDBA.com)" SKIP "" SKIP "" SKIP "" SKIP "
". RETURN FALSE. /* Function return value. */ END FUNCTION. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-fn_OtherTables) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION fn_OtherTables Procedure FUNCTION fn_OtherTables RETURNS CHARACTER PRIVATE ( /* parameter-definitions */ ) : /*------------------------------------------------------------------------------ Purpose: Notes: ------------------------------------------------------------------------------*/ DEFINE VARIABLE cList AS CHARACTER NO-UNDO. FOR EACH bfTableBlock WHERE bfTableBlock.BlockNumber = ttTableBlock.BlockNumber AND bfTableBlock.TableName <> ttTableBlock.TableName BY bfTableBlock.TableName: ASSIGN cList = cList + bfTableBlock.TableName + "(" + STRING(bfTableBlock.RecordCount) + ") ". END. RETURN cList. END FUNCTION. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-fn_Query) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION fn_Query Procedure FUNCTION fn_Query RETURNS LOGICAL PRIVATE ( INPUT ip_TableName AS CHARACTER, INPUT ip_Where AS CHARACTER, INPUT ip_Sort AS CHARACTER, INPUT ip_First AS LOGICAL, INPUT ip_Handler AS CHARACTER ) : /*--- Define Variables ---*/ DEFINE VARIABLE hQuery AS HANDLE NO-UNDO. DEFINE VARIABLE hBuffer AS HANDLE NO-UNDO. DEFINE VARIABLE cQuery AS CHARACTER NO-UNDO. ASSIGN cQuery = "FOR EACH " + ip_TableName + (IF ip_Where = "" THEN "" ELSE " " + ip_Where) + (IF ip_Sort = "" THEN "" ELSE " " + ip_Sort) + " NO-LOCK" NO-ERROR. CREATE BUFFER hBuffer FOR TABLE ip_TableName NO-ERROR. CREATE QUERY hQuery NO-ERROR. hQuery:SET-BUFFERS(hBuffer) NO-ERROR. hQuery:QUERY-PREPARE(cQuery) NO-ERROR. hQuery:QUERY-OPEN() NO-ERROR. $loop$: REPEAT: hQuery:GET-NEXT() NO-ERROR. IF hBuffer:AVAILABLE = FALSE THEN LEAVE. IF hQuery:QUERY-OFF-END THEN LEAVE $loop$. RUN VALUE(ip_Handler) (INPUT hBuffer:HANDLE) NO-ERROR. IF ip_First = TRUE THEN LEAVE $loop$. END. /*--- $loop$ ---*/ hQuery:QUERY-CLOSE() NO-ERROR. DELETE OBJECT hQuery NO-ERROR. DELETE OBJECT hBuffer NO-ERROR. RETURN FALSE. /* Function return value. */ END FUNCTION. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-fn_RecidCheck) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION fn_RecidCheck Procedure FUNCTION fn_RecidCheck RETURNS LOGICAL PRIVATE ( INPUT ip_TableName AS CHARACTER ) : /*------------------------------------------------------------------------------ Purpose: Notes: ------------------------------------------------------------------------------*/ /*--- Define Variables ---*/ DEFINE VARIABLE hQuery AS HANDLE NO-UNDO. DEFINE VARIABLE hBuffer AS HANDLE NO-UNDO. DEFINE VARIABLE hTT AS HANDLE NO-UNDO. DEFINE VARIABLE cField AS CHARACTER NO-UNDO. DEFINE VARIABLE rStart AS RECID NO-UNDO. DEFINE VARIABLE rEnd AS RECID NO-UNDO. ASSIGN cField = fn_FieldList() rStart = INTEGER(ttArea.AreaRPB * ttTableBlock.BlockNumber) rEnd = INTEGER(rStart) + ttArea.AreaRPB - 1. CREATE BUFFER hBuffer FOR TABLE ip_TableName NO-ERROR. CREATE BUFFER hTT FOR TABLE BUFFER ttRecid:HANDLE. CREATE QUERY hQuery NO-ERROR. hQuery:SET-BUFFERS(hTT,hBuffer) NO-ERROR. hQuery:FORWARD-ONLY = TRUE. hQuery:QUERY-PREPARE("FOR EACH ttRecid, EACH " + ip_TableName + " FIELDS(" + cField + ") " + " WHERE RECID(" + ip_TableName + ") = ttRecid.rRecid " + " NO-LOCK") NO-ERROR. hQuery:QUERY-OPEN() NO-ERROR. $loop$: REPEAT: hQuery:GET-NEXT() NO-ERROR. IF hQuery:QUERY-OFF-END THEN LEAVE $loop$. ASSIGN ttBlock.RecordCount = ttBlock.RecordCount + 1 iRecords = iRecords + 1 SUBSTRING(ttBlock.BlockMap, htt:BUFFER-FIELD("iSlot"):BUFFER-VALUE, 1) = "R". /*--- Keep track of the tables in this block ---*/ IF NOT CAN-DO(ttBlock.TableList,ip_TableName) THEN ASSIGN ttBlock.TableList = ttBlock.TableList + "," + ip_TableName. /*--- Table block tracking ---*/ FIND bfTableBlock WHERE bfTableBlock.TableName = ip_TableName AND bfTableBlock.BlockNumber = ttBlock.BlockNumber NO-ERROR. IF NOT AVAILABLE bfTableBlock THEN DO: CREATE bfTableBlock. ASSIGN bfTableBlock.TableName = ip_TableName bfTableBlock.BlockNumber = ttBlock.BlockNumber. END. ASSIGN bfTableBlock.RecordCount = bfTableBlock.RecordCount + 1. hTT:BUFFER-DELETE(). END. /*--- $loop$ ---*/ hQuery:QUERY-CLOSE() NO-ERROR. DELETE OBJECT hQuery NO-ERROR. DELETE OBJECT hBuffer NO-ERROR. DELETE OBJECT hTT NO-ERROR. RETURN FALSE. /* Function return value. */ END FUNCTION. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF