# Tcl script based on procedures from genStubs.tcl to parse the
# Tcl9 tcl.decls file.
# It spits out the names of all functions, which have Tcl_Size as
# return value or parameter.
# This list can then be used by Tcl script FindTclSizeFuncs.tcl
# to find all files in a source code directory using one of these functions.

set inFile "tcl.decls"
if { $argc >= 1 } {
    set inFile [lindex $argv 0]
}
if { ! [file exists $inFile] } {
    puts ""
    puts "Error: File $inFile does not exist."
    puts ""
    puts "Usage: $argv0 ?tcl.decls file?"
    puts ""
    exit 1
}

proc unknown { args } {
    #puts "Ignoring $args"
}

proc parseArg {arg} {
    if {![regexp {^(.+[ ][*]*)([^][ *]+)(\[\])?$} $arg all type name array]} {
        if {$arg eq "void"} {
            return $arg
        } else {
            return
        }
    }
    set result [list [string trim $type] $name]
    if {$array ne ""} {
        lappend result $array
    }
    return $result
}

proc parseDecl {decl} {
    if {![regexp {^(.*)\((.*)\)$} $decl all prefix args]} {
        set prefix $decl
        set args {}
    }
    set prefix [string trim $prefix]
    if {![regexp {^(.+[ ][*]*)([^ *]+)$} $prefix all rtype fname]} {
        puts stderr "Bad return type: $decl"
        return
    }
    set rtype [string trim $rtype]
    if {$args eq ""} {
        return [list $rtype $fname {}]
    }
    foreach arg [split $args ,] {
        lappend argList [string trim $arg]
    }
    if {![string compare [lindex $argList end] "..."]} {
        set args TCL_VARARGS
        foreach arg [lrange $argList 0 end-1] {
            set argInfo [parseArg $arg]
            if {[llength $argInfo] == 2 || [llength $argInfo] == 3} {
                lappend args $argInfo
            } else {
                puts stderr "Bad argument: '$arg' in '$decl'"
                return
            }
        }
    } else {
        set args {}
        foreach arg $argList {
            set argInfo [parseArg $arg]
            if {![string compare $argInfo "void"]} {
                lappend args "void"
                break
            } elseif {[llength $argInfo] == 2 || [llength $argInfo] == 3} {
                lappend args $argInfo
            } else {
                puts stderr "Bad argument: '$arg' in '$decl'"
                return
            }
        }
    }
    return [list $rtype $fname $args]
}

proc interface { name } {
    global gCurName

    set gCurName $name
}

proc declare { args } {
    global gExportIndex
    global gCurName
    global gFuncInParam
    global gFuncOutParam
    global gFuncReturn

    if {[llength $args] == 2} {
        lassign $args index declString
        set platformList generic
    } elseif {[llength $args] == 3} {
        lassign $args index platformList declString
    } else {
        puts stderr "wrong # args: declare $args"
        return
    }

    regsub -all "\[ \t\n\]+" [string trim $declString] " " declString
    set declList [parseDecl $declString]
    # puts $declList
    if { [string first "Tcl_Size" [lindex $declList 0]] >= 0 } {
        lappend gFuncReturn [lindex $declList 1]
    }
    foreach param [lindex $declList 2] {
        lassign $param type name
        if { [string first "Tcl_Size" $type] >= 0 } {
            if { [string first "*" $type] >= 0 } {
                lappend gFuncOutParam [lindex $declList 1]
            } else {
                lappend gFuncInParam [lindex $declList 1]
            }
        }
    }
    return
}

proc export { args } {
    global gExportIndex

    declare $gExportIndex {*}$args
    incr gExportIndex
}

set gExportIndex  1000
set gFuncInParam  [list]
set gFuncOutParam [list]
set gFuncReturn   [list]

source $inFile

puts "# Functions with Tcl_Size IN parameters"
foreach func [lsort -dictionary $gFuncInParam] {
    puts "TclSizeInParam $func"
}

puts ""
puts "# Functions with Tcl_Size OUT parameters"
foreach func [lsort -dictionary $gFuncOutParam] {
    puts "TclSizeOutParam $func"
}

puts ""
puts "# Functions with Tcl_Size return values"
foreach func [lsort -dictionary $gFuncReturn] {
    puts "TclSizeReturn $func"
}

exit 0

# Functions with Tcl_Size IN parameters
TclSizeParam Tcl_AppendFormatToObj
TclSizeParam Tcl_AppendLimitedToObj
...
# Functions with Tcl_Size OUT parameters
TclSizeOutParam Tcl_DictObjSize
TclSizeOutParam Tcl_ExternalToUtfDStringEx
...
# Functions with Tcl_Size return values
TclSizeReturn Tcl_Char16Len
TclSizeReturn Tcl_ConvertCountedElement

# Tcl script to read the list of Tcl9 C functions, which have Tcl_Size as
# return value or parameter and find all files in a source code directory
# using one of these functions.

# Change these options manually.
set showFileDetail 1
set showFuncList   1

set showReturnParams 1
set showInParams     1
set showOutParams    1

set filePattern "*.c *.h  *.cxx *.hxx  *.cpp *.hpp  *.i *.swg "
# set filePattern "*"

# These options can be changed via command line.
set inDir  [pwd]
set inFile "TclSizeFuncList"

if { $argc >= 1 } {
    set inDir [lindex $argv 0]
}
if { $argc >= 2 } {
    set inFile [lindex $argv 1]
}
if { ! [file exists $inFile] || ! [file isdirectory $inDir] } {
    puts ""
    if { ! [file exists $inFile] } {
        puts "Error: File $inFile does not exist."
    }
    if { ! [file isdirectory $inDir] } {
        puts "Error: Directory $inDir does not exist."
    }
    puts ""
    puts "Usage: $argv0 ?TclSizeListFile? ?Directory?"
    puts ""
    exit 1
}

proc IsBinaryString { test } {
    set binaryRegExp {[\x00-\x08\x0b\x0e-\x1f]}
    if { [ regexp -- $binaryRegExp $test ] } {
        return true
    }
    return false
}

proc GetDirList {dirName {showDirs 1} {showFiles 1} {dirPattern *} {filePattern *}} {
    set curDir [pwd]
    set catchVal [catch {cd $dirName}]
    if { $catchVal } {
        return [list]
    }

    set absDirList  [list]
    set relFileList [list]

    if { $showDirs } {
        set relDirList [glob -nocomplain -types d -- {*}$dirPattern]
        foreach dir $relDirList {
            if { [string index $dir 0] eq "~" } {
                set dir [format "./%s" $dir]
            }
            set absName [file join $dirName $dir]
            lappend absDirList $absName
        }
    }
    if { $showFiles } {
        set relFileList [glob -nocomplain -types f -- {*}$filePattern]
    }
    cd $curDir

    return [list $absDirList $relFileList]
}

proc CheckMatchList { searchString matchList } {
    set matchCmd "string match"
    foreach matchString $matchList {
        if { [eval $matchCmd {$matchString $searchString}] } {
            return true
        }
    }
    return false
}

proc FindRecursive { srcDir pattern } {
    global gFuncList
    global gFoundFiles

    set retVal [catch { cd $srcDir } ]
    if { $retVal } {
        puts stderr "Could not read directory \"$srcDir\""
        return
    }
    set dirCont [GetDirList $srcDir]
    set dirList  [lindex $dirCont 0]
    set fileList [lindex $dirCont 1]
    foreach dir $dirList {
        set dirName [file tail $dir]
        set subSrcDir  [file join $srcDir  $dirName]
        FindRecursive $subSrcDir $pattern
    }
    foreach fileName $fileList {
        if { [string first "~" $fileName] == 0 } {
            # File starts with tilde.
            set fileName [format "./%s" $fileName]
        }
        set fileAbs [file join $srcDir $fileName]
        if { [CheckMatchList [file tail $fileAbs] $pattern] } {
            # puts "Checking $fileAbs"
            set catchVal [catch { open $fileAbs r } fp]
            if { $catchVal } {
                error "Could not read file \"$fileAbs\"."
            }
            fconfigure $fp -translation binary
            set srcCont [read $fp]
            close $fp

            if { [IsBinaryString $srcCont] } {
                # puts "Ignoring binary file $fileAbs"
                continue
            }

            set funcFoundList [list]
            foreach funcName $gFuncList {
                set ind [string first "$funcName" $srcCont]
                if { $ind > 0 } {
                    lappend funcFoundList $funcName
                }
            }
            if { [llength $funcFoundList] > 0 } {
                set gFoundFiles($fileAbs) $funcFoundList
            }
        }
    }
}

proc CollectFuncNames { funcName } {
    global gFuncList

    lappend gFuncList $funcName
}

proc TclSizeInParam { funcName } {
    if { $::showInParams } {
        CollectFuncNames $funcName
    }
}

proc TclSizeOutParam { funcName } {
    if { $::showOutParams } {
        CollectFuncNames $funcName
    }
}

proc TclSizeReturn { funcName } {
    if { $::showReturnParams } {
        CollectFuncNames $funcName
    }
}

set gFuncList [list]

source $inFile
FindRecursive [file normalize $inDir] $filePattern

set funcList [list]
foreach fileName [array names gFoundFiles] {
    puts $fileName
    foreach funcName [lsort -unique -dictionary $gFoundFiles($fileName)] {
        lappend funcList $funcName
        if { $showFileDetail } {
            puts "  $funcName"
        }
    }
}

if { $showFuncList && [llength $funcList] > 0 } {
    puts ""
    foreach funcName [lsort -unique -dictionary $funcList] {
        puts $funcName
    }
}

exit 0

> tclsh FindTclSizeFuncs.tcl ..\Tcl9-TclSize-Pkgs\tcltls-1.7.23

D:/Exchange/Tcl9/Tcl9-TclSize-Pkgs/tcltls-1.7.23/tclOpts.h
  Tcl_GetByteArrayFromObj
  Tcl_GetStringFromObj
D:/Exchange/Tcl9/Tcl9-TclSize-Pkgs/tcltls-1.7.23/tls.c
  Tcl_EvalEx
  Tcl_GetStringFromObj
  Tcl_ListObjGetElements
  Tcl_NewListObj
  Tcl_NewStringObj
  Tcl_WrongNumArgs
D:/Exchange/Tcl9/Tcl9-TclSize-Pkgs/tcltls-1.7.23/tlsX509.c
  Tcl_NewListObj
  Tcl_NewStringObj
D:/Exchange/Tcl9/Tcl9-TclSize-Pkgs/tcltls-1.7.23/tlsBIO.c
  Tcl_Read
  Tcl_ReadRaw
  Tcl_Write
  Tcl_WriteRaw

Tcl_EvalEx
Tcl_GetByteArrayFromObj
Tcl_GetStringFromObj
Tcl_ListObjGetElements
Tcl_NewListObj
Tcl_NewStringObj
Tcl_Read
Tcl_ReadRaw
Tcl_Write
Tcl_WriteRaw
Tcl_WrongNumArgs