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
Collapse
 
  • Page of 1
  • Filter
  • Time
  • Show
Clear All
new posts
Previous template Next
  • #1

    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).]
    Tags: None
Previous template Next
Working...
X

We process personal data about users of our site, through the use of cookies and other technologies, to deliver our services, and to analyze site activity. For additional details, refer to our Privacy Policy.

By clicking "I AGREE" below, you agree to our Privacy Policy and our personal data processing and cookie practices as described therein. You also acknowledge that this forum may be hosted outside your country and you consent to the collection, storage, and processing of your data in the country where this forum is hosted.

I Agree