Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Code Mapper

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Code Mapper

    This program, given a source file on the command line (or
    put it into your "Send To" folder) will give the following
    output for each sub/function/macro in your program...
    Code:
    FUNCTION MyExample() EXPORT AS STRING
        REM 'Parameters
            BYVAL psDataDir AS STRING
            BYVAL psAltDeffDir AS STRING
            psaTableFiles() AS STRING
            psExt AS STRING
        REM 'Calls made
            GetAllTableNames
            FileNameFromPath
        REM 'Called from
            DatabaseSearch
    And here is the code...
    Code:
    'CodeMapper.bas
    'Colin Schmidt, syhawk76(at)yahoo.com
    'Written in 2005-11
    'This program will read in a .bas file passed on the command
    'line and will output a .map.inc file by the same name.
    'The reason for the .inc extention is to that you can make use of
    'the line folding feature of the SED editor to navigate the output.
    'You might want to put this under your 'Send To' folder for easy use.
    'Program will read in all include files
    'Output includes the sub/function/macro name and params, then lists
    'in order of reference within the code each sub/function/macro called
    'within that sub/function/macro.
    'In order to leave out all of the API/etc calls, source files
    'that are not found via a direct path or are not in the same
    'folder as primary source file will not be included. If you wish to
    'see the output with API/etc calls then use the full path for the
    'API includes. This program is placed into the public domain; use
    'at your own risk.
    
    #RESOURCE "CodeMapper.pbr"
    
    %True = -1
    %False = 0
    $BadChars = CHR$(0 TO 31) + CHR$(33 TO 47) + CHR$(58 TO 64) + CHR$(91 TO 94) + CHR$(96 TO 255)
    
    FUNCTION PBMAIN
        LOCAL llCount1, llCount2, llCount3 AS LONG
        LOCAL llFound, llNewIncs, llIncCount, llLineCount, llBlockCount, llCallCount AS LONG
        LOCAL lsCommand, lsFolder, lsTest, lsTemp, lsTemp2 AS STRING
        LOCAL lsInput, lsUCase AS STRING
        LOCAL lsErr AS STRING
        LOCAL lsaFileNames(), lsaFiles(), lsaIncs(), lsaLines() AS STRING
        LOCAL lsaBlocks(), lsaNames(), lsaUNames(), lsaParams(), lsaCalls() AS STRING
    
        lsErr = "init error trap"
            ON ERROR GOTO CatchError
    
        lsErr = "init arrays"
            REDIM lsaFileNames(1 TO 1)
            REDIM lsaFiles(1 TO 1)
    
        lsErr = "checking command line"
            lsCommand = TRIM$(COMMAND$, $DQ)
            IF DIR$(lsCommand) = "" THEN
                lsErr = "Please pass the primary source code filename on the command line or use this " + _
                        "program via 'Send To'"
                GOTO CatchError
            END IF
    
        lsErr = "getting primary file and folder from the command line"
            lsaFileNames(1) = UCASE$(PARSE$(lsCommand, "\", -1))
            lsFolder = UCASE$(LEFT$(lsCommand, LEN(lsCommand) - LEN(lsaFileNames(1))))
    
        lsErr = "loading primary source file"
            OPEN lsFolder + lsaFileNames(1) FOR BINARY ACCESS READ LOCK SHARED AS #1
                GET$ #1, LOF(1), lsaFiles(1)
            CLOSE #1
    
        lsErr = "loading all source files"
            DO
                llNewIncs = %False
                FOR llCount1 = 1 TO UBOUND(lsaFileNames())
                    lsTest = UCASE$(lsaFiles(llCount1))
                    llIncCount = TALLY(lsTest, "#INCLUDE " + $DQ)
                    IF llIncCount THEN
                        REDIM lsaIncs(0 TO llIncCount)
                        PARSE lsTest, lsaIncs(), "#INCLUDE " + $DQ
                        FOR llCount2 = 1 TO llIncCount
                            lsTest = EXTRACT$(lsaIncs(llCount2), $DQ)
                            llFound = %False
                            FOR llCount3 = 1 TO UBOUND(lsaFileNames())
                                IF lsTest = lsaFileNames(llCount3) THEN
                                   llFound = %True
                                   EXIT FOR
                               END IF
                            NEXT llCount3
                            IF llFound = %False THEN
                                llNewIncs = %True
                                llCount3 = UBOUND(lsaFileNames()) + 1
                                REDIM PRESERVE lsaFileNames(1 TO llCount3)
                                REDIM PRESERVE lsaFiles(1 TO llCount3)
                                lsaFileNames(llCount3) = lsTest
                                IF INSTR(lsTest, "\") THEN
                                    IF LEN(DIR$(lsTest)) THEN
                                        OPEN lsTest FOR BINARY ACCESS READ LOCK SHARED AS #1
                                            GET$ #1, LOF(1), lsaFiles(llCount3)
                                        CLOSE #1
                                        llNewIncs = %True
                                    END IF
                                ELSE
                                    IF LEN(DIR$(lsFolder + lsTest)) THEN
                                        OPEN lsFolder + lsTest FOR BINARY ACCESS READ LOCK SHARED AS #1
                                            GET$ #1, LOF(1), lsaFiles(llCount3)
                                        CLOSE #1
                                        llNewIncs = %True
                                    END IF
                                END IF
                            END IF
                        NEXT llCount2
                    END IF
                NEXT llCount1
            LOOP WHILE llNewIncs = %True
            lsInput = JOIN$(lsaFiles(), $CRLF)
            ERASE lsaFiles()
    
        lsErr = "cleaning whitespace"
            REPLACE $TAB WITH $SPC IN lsInput
            DO WHILE INSTR(lsInput, $SPC + $SPC)
                REPLACE $SPC + $SPC WITH $SPC IN lsInput
            LOOP
            DO WHILE INSTR(lsInput, $CRLF + $SPC)
                REPLACE $CRLF + $SPC WITH $CRLF IN lsInput
            LOOP
            DO WHILE INSTR(lsInput, $SPC + $CRLF)
                REPLACE $SPC + $CRLF WITH $CRLF IN lsInput
            LOOP
    
        lsErr = "cleaning line continuation and comments"
            llLineCount = PARSECOUNT(lsInput, $CRLF)
            REDIM lsaLines(1 TO llLineCount)
            PARSE lsInput, lsaLines(), $CRLF
            FOR llCount1 = 1 TO llLineCount
                IF INSTR(lsaLines(llCount1), " _") THEN
                    IF RIGHT$(lsaLines(llCount1), 2) <> " _" THEN
                        lsTemp = PARSE$(lsaLines(llCount1), " _", -1)
                        lsaLines(llCount1) = LEFT$(lsaLines(llCount1), LEN(lsaLines(llCount1)) - LEN(lsTemp))
                    END IF
                END IF
                IF TALLY(lsaLines(llCount1), "'") = 1 THEN
                    lsaLines(llCount1) = TRIM$(EXTRACT$(lsaLines(llCount1), "'"))
                ELSE
                    'won't bother to deal with this, would only effect output when
                    'a non-commented-out call included a ' within quotes as a parameter
                    'and was followed by a commented-out call. If that code existed,
                    'this program would return the commented-out call as active.
                END IF
            NEXT llCount
            lsInput = JOIN$(lsaLines(), $CRLF)
            ERASE lsaLines()
            REPLACE " _" + $CRLF WITH ""         IN lsInput
    
        lsErr = "cleaning keywords"
            REPLACE "sub"       WITH "SUB"      IN lsInput
            REPLACE "Sub"       WITH "SUB"      IN lsInput
            REPLACE "callback"  WITH "CALLBACK" IN lsInput
            REPLACE "Callback"  WITH "CALLBACK" IN lsInput
            REPLACE "function"  WITH "FUNCTION" IN lsInput
            REPLACE "Function"  WITH "FUNCTION" IN lsInput
            REPLACE "macro"     WITH "MACRO"    IN lsInput
            REPLACE "Macro"     WITH "MACRO"    IN lsInput
            REPLACE "CALLBACK FUNCTION"    WITH "FUNCTION"                  IN lsInput
            REPLACE $CRLF + "end "         WITH $CRLF + "END "              IN lsInput
            REPLACE $CRLF + "End "         WITH $CRLF + "END "              IN lsInput
            lsUCase = UCASE$(lsInput)
            IF TALLY(lsInput, "SUB")      <> TALLY(lsUCase, "SUB")      _
            OR TALLY(lsInput, "FUNCTION") <> TALLY(lsUCase, "FUNCTION") _
            OR TALLY(lsInput, "MACRO")    <> TALLY(lsUCase, "MACRO")    _
            THEN
                lsErr = lsErr + ": Please use open and save source files in PBEdit to fix keyword case"
                GOTO CatchError:
            END IF
            REPLACE $CRLF + "END SUB"      WITH $CRLF + "SUB ENDBLOCK"      IN lsInput
            REPLACE $CRLF + "END FUNCTION" WITH $CRLF + "FUNCTION ENDBLOCK" IN lsInput
            REPLACE $CRLF + "END MACRO"    WITH $CRLF + "MACRO ENDBLOCK"    IN lsInput
    
        lsErr = "parsing program blocks"
            llBlockCount = PARSECOUNT(lsInput, " ENDBLOCK")
            REDIM lsaBlocks(1 TO llBlockCount)
            REDIM lsaNames (1 TO llBlockCount)
            REDIM lsaUNames(1 TO llBlockCount)
            REDIM lsaParams(1 TO llBlockCount)
            PARSE lsInput, lsaBlocks(), " ENDBLOCK"
            FOR llCount1 = 1 TO llBlockCount
                lsTest = PARSE$(lsaBlocks(llCount1), $CRLF, -1)
                SELECT CASE AS CONST$ lsTest
                    CASE "SUB"
                        lsaBlocks(llCount1) = "SUB "      + REMAIN$(lsaBlocks(llCount1), $CRLF + "SUB ")
                    CASE "FUNCTION"
                        lsaBlocks(llCount1) = "FUNCTION " + REMAIN$(lsaBlocks(llCount1), $CRLF + "FUNCTION ")
                    CASE "MACRO"
                        lsaBlocks(llCount1) = "MACRO "    + REMAIN$(lsaBlocks(llCount1), $CRLF + "MACRO ")
                        DO WHILE TALLY(lsaBlocks(llCount1), $CRLF + "MACRO ")
                            lsaBlocks(llCount1) = "MACRO "    + REMAIN$(lsaBlocks(llCount1), $CRLF + "MACRO ")
                        LOOP
                END SELECT
                lsaNames(llCount1) = PARSE$(lsaBlocks(llCount1), ANY $CRLF + $SPC + "(", 2)
                lsaUNames(llCount1) = UCASE$(lsaNames(llCount1))
                lsaParams(llCount1) = EXTRACT$(lsaBlocks(llCount1), $CRLF)
                lsaBlocks(llCount1) = UCASE$(REMAIN$(lsaBlocks(llCount1), $CRLF))
            NEXT llCount1
            IF lsaNames(llBlockCount) = "" THEN
                DECR llBlockCount
                REDIM PRESERVE lsaBlocks(1 TO llBlockCount)
                REDIM PRESERVE lsaNames (1 TO llBlockCount)
                REDIM PRESERVE lsaUNames(1 TO llBlockCount)
                REDIM PRESERVE lsaParams(1 TO llBlockCount)
            END IF
    
        lsErr = "parsing parameters"
            FOR llCount1 = 1 TO llBlockCount
                IF INSTR(lsaParams(llCount1), "(") THEN
                    lsTemp = REMAIN$(lsaParams(llCount1), "(")
                    lsTemp2 = PARSE$(lsTemp, ")", -1)
                    lsTemp = LEFT$(lsTemp, LEN(lsTemp) - LEN(lsTemp2) - 1)
                    IF LEN(lsTemp) THEN
                        lsaParams(llCount1) = EXTRACT$(lsaParams(llCount1), "(") + "()" + lsTemp2
                        REPLACE ", " WITH "," IN lsTemp
                        REPLACE "," WITH $CRLF + $TAB + $TAB IN lsTemp
                        lsaParams(llCount1) = lsaParams(llCount1) + $CRLF + _
                            $TAB + "REM 'Parameters" + $CRLF + $TAB + $TAB + lsTemp
                    ELSE
                        lsaParams(llCount1) = lsaParams(llCount1) + $CRLF + _
                            $TAB + "REM 'Parameters" + $CRLF + $TAB + $TAB + "'none"
                    END IF
                END IF
            NEXT llCount1
    
        lsErr = "finding calls made within a block"
            FOR llCount1 = 1 TO llBlockCount
                REPLACE "(" WITH $SPC IN lsaBlocks(llCount1)
                REPLACE ")" WITH $SPC IN lsaBlocks(llCount1)
                REPLACE "=" WITH $SPC IN lsaBlocks(llCount1)
                REPLACE "," WITH $SPC IN lsaBlocks(llCount1)
                REPLACE $CRLF WITH $SPC IN lsaBlocks(llCount1)
                lsaBlocks(llCount1) = REMOVE$(lsaBlocks(llCount1), ANY $BadChars)
                llCallCount = PARSECOUNT(lsaBlocks(llCount1), $SPC)
                REDIM lsaCalls(1 TO llCallCount)
                PARSE lsaBlocks(llCount1), lsaCalls(), $SPC
                lsaBlocks(llCount1) = $TAB + "REM 'Calls made"
                FOR llCount2 = 1 TO llCallCount
                    llFound = %False
                    IF lsaCalls(llCount2) = "" THEN ITERATE FOR
                    FOR llCount3 = 1 TO llBlockCount
                        IF lsaCalls(llCount2) = lsaUNames(llCount3) THEN
                            llFound = llCount3
                            EXIT FOR
                        END IF
                    NEXT llCount3
                    IF llFound THEN
                        lsaBlocks(llCount1) = lsaBlocks(llCount1) + $CRLF + $TAB + $TAB + lsaNames(llFound)
                    END IF
                NEXT llCount2
                lsaBlocks(llCount1) = lsaBlocks(llCount1) + $CRLF
            NEXT llCount1
    
        lsErr = "finding calls made to a block"
            REDIM lsaCalls(1 TO llBlockCount)
            FOR llCount1 = 1 TO llBlockCount
                lsaCalls(llCount1) = $TAB + "REM 'Called from"
                FOR llCount2 = 1 TO llBlockCount
                    IF llCount1 = llCount2 THEN ITERATE FOR
                    IF INSTR(lsaBlocks(llCount2), $TAB + lsaNames(llCount1) + $CRLF) THEN
                        lsaCalls(llCount1) = lsaCalls(llCount1) + $CRLF + $TAB + $TAB + lsaNames(llCount2)
                    END IF
                NEXT llCount2
            NEXT llBlockCount
    
        lsErr = "joining results"
            FOR llCount1 = 1 TO llBlockCount
                lsaBlocks(llCount1) = lsaParams(llCount1) + $CRLF + lsaBlocks(llCount1) + lsaCalls(llCount1)
            NEXT llCount1
    
        lsErr = "saving results to " + lsFolder + lsaFileNames(1) + ".map.inc"
            OPEN lsFolder + DIR$(lsFolder + lsaFileNames(1)) + ".map.inc" FOR BINARY ACCESS WRITE LOCK SHARED AS #1
                PUT$ #1, JOIN$(lsaBlocks(), $CRLF + $CRLF) + $CRLF + $CRLF
                SETEOF(1)
            CLOSE #1
    
        MSGBOX "All done", 64, "CodeMapper"
        EXIT FUNCTION
    
        CatchError:
            MSGBOX  "Sorry the folling error took place:" + $CRLF + _
                    IIF$(ERR, ERROR$ + " while ", "") + lsErr, _
                    16, "CodeMapper"
    END FUNCTION

    [This message has been edited by Colin Schmidt (edited November 12, 2005).]
Working...
X