| #!/bin/sh |
| ## Begin dltk.tcl \ |
| exec tclsh "$0" ${1+"$@"} |
| |
| # We are not using namespace for this package so that it should |
| # work with tcl versions older than 8.0 (not tested yet). |
| |
| # This script relies on few proc renames, so instruct the tclchecker |
| # to ignore proc renames. |
| #checker -scope global exclude warnRedefine |
| |
| proc hasCommand cmdName { |
| return [expr [llength [info commands $cmdName]] > 0]; |
| } |
| |
| ## Begin renaming of core tcl cmds |
| rename package package-org |
| proc package {subcmd args} { |
| global pkg_stack pkg_reqs_tmp path_tmp |
| |
| switch -exact -- $subcmd { |
| "require" { |
| set exact 0 |
| set name [lindex $args 0] |
| set vers [lrange $args 1 end] |
| if {[string equal $name "-exact"]} { |
| set exact 1 |
| set name [lindex $args 1] |
| set vers [lrange $args 2 end] |
| } |
| # Track package require dependencies but |
| # skip if pkg name is null |
| set pname [lindex $pkg_stack 0] |
| if {![string equal $pname ""]} { |
| lappend pkg_reqs_tmp($pname) [list $name $vers $exact] |
| } |
| set pkg_stack [linsert $pkg_stack 0 $name] |
| set retCode [catch {uplevel 1 "::package-org $subcmd $args"} vers] |
| set pkg_stack [lrange $pkg_stack 1 end] |
| if {$retCode} { |
| # Unsuccessful pkg load |
| add-pkg-srcs-info $name "" |
| } else { |
| # Successful pkg load |
| add-pkg-srcs-info $name $vers |
| } |
| return -code $retCode $vers |
| } |
| "ifneeded" { |
| set name [lindex $args 0] |
| set vers [lindex $args 1] |
| #set body [lindex $args 2] |
| upvar 1 use_path lcl_use_path |
| upvar 1 dir lcl_dir |
| set path $path_tmp |
| if {[info exists lcl_use_path]} { |
| set path [lindex $lcl_use_path end] |
| set path [get-canonical-path $path] |
| set path_tmp $path |
| } |
| set d "" |
| if {[info exists lcl_dir]} { |
| set d $lcl_dir |
| } |
| add-pkg-info $name $vers $path $d |
| return [uplevel 1 "::package-org $subcmd $args"] |
| } |
| default {} |
| } |
| |
| return [uplevel 1 "::package-org $subcmd $args"] |
| } ;# End of proc package |
| |
| rename source source-org |
| proc source {args} { |
| global pkg_srcs_tmp pkg_stack |
| global file_srcs_tmp |
| global auto_index |
| |
| log::debug "source $args" |
| # Ignore "-rsrc*" option when its optional filename |
| # which should be present as 3rd argument is not specified |
| if {[llength $args] != "2"} { |
| # If the file is already sourced, don't source it again |
| set fname [get-canonical-path [lindex $args end]] |
| if {[info exists file_srcs_tmp($fname)]} { |
| return |
| } |
| set file_srcs_tmp($fname) 1 |
| log::debug "source file: $fname" |
| |
| # Skip pkgIndex.tcl or tclIndex file or if pkg name is null |
| set pname [lindex $pkg_stack 0] |
| set ftail [file tail $fname] |
| if {![string equal $pname ""] && [file exists $fname] && |
| ![string equal $ftail "pkgIndex.tcl"] && |
| ![string equal $ftail "tclIndex"]} { |
| lappend pkg_srcs_tmp($pname) $fname |
| } ;# End of if stmt |
| } ;# End of if stmt |
| |
| return [uplevel 1 "::source-org $args"] |
| } ;# End of proc source |
| |
| if [hasCommand load] { |
| rename load load-org |
| } |
| proc load {args} { |
| global pkg_load_tmp pkg_stack |
| global file_load_tmp |
| |
| log::debug "load $args" |
| # If the file is already loaded, don't load it again |
| set fname [get-canonical-path [lindex $args 0]] |
| if {[info exists file_load_tmp($fname)]} { |
| return |
| } |
| set file_load_tmp($fname) 1 |
| log::debug "load file: $fname" |
| |
| # Skip if pkg name is null |
| set pname [lindex $pkg_stack 0] |
| if {![string equal $pname ""] && [file exists $fname]} { |
| lappend pkg_load_tmp($pname) $fname |
| } |
| |
| return [uplevel 1 "::load-org $args"] |
| } ;# End of proc load |
| |
| # Some pkgs rename exit proc when it is loaded or they may explicitly |
| # terminate this script by explicitly calling exit. We prevent this |
| # by renaming exit cmd as per below. |
| rename exit exit-org |
| proc exit args {} |
| ## End renaming of core tcl cmds |
| |
| ## Log routines: can be easily replaced with tcllib's logger pkg |
| ## |
| namespace eval ::log { |
| variable level warn |
| } |
| proc ::log::noop {args} {} |
| proc ::log::print {lvl msg} { |
| # Print log level and msg |
| puts stdout "$lvl - $msg" |
| } ;# End of proc ::log::print |
| |
| proc ::log::levellist {} { |
| return [list error warn notice info debug] |
| } ;# End of proc ::log::levellist |
| proc ::log::getlevel {} { |
| variable level |
| return $level |
| } ;# End of proc ::log::getlevel |
| |
| proc ::log::setlevel {lvl} { |
| variable level |
| |
| # Validate specified level |
| if {[lsearch [log::levellist] $lvl] == "-1"} { |
| log::warn "Invalid log level: $lvl ... ignoring" |
| return |
| } ;# End of switch stmt |
| |
| set log_alias ::log::print |
| foreach elm [log::levellist] { |
| interp alias {} ::log::$elm {} $log_alias [string toupper $elm] |
| if {[string equal $lvl $elm]} { |
| set log_alias ::log::noop |
| } ;# End of if stmt |
| } ;# End of foreach loop |
| |
| return $lvl |
| } ;# End of proc ::log::setlevel |
| |
| ## Local procs below |
| ## |
| proc get-canonical-path {path} { |
| global tcl_version |
| |
| set retVal $path |
| # [file normalize] cmd was introduced in tcl8.4 version |
| if {$tcl_version >= 8.4} { |
| set retVal [file normalize $path] |
| } elseif {[string equal [file pathtype $path] "relative"]} { |
| set retVal [file join [pwd] $path] |
| } ;# End of if stmt |
| |
| return $retVal |
| } ;# End of proc get-canonical-path |
| |
| proc trace-auto_index {var idx op} { |
| global auto_index |
| |
| # Return immediately if it is not a write operation on |
| # auto_index array element |
| if {![string equal $var "auto_index"] || ![string equal $op "w"]} { |
| return |
| } ;# End of if stmt |
| |
| # If the auto_index element is updated by tclIndex file |
| # of a package, the corresponding file should be sourced |
| if {[info exists auto_index($idx)]} { |
| catch {uplevel #0 $auto_index($idx)} err |
| } ;# End of if stmt |
| |
| return |
| } ;# End of proc trace-auto_index |
| |
| proc process-pkg-info {find_level find_pkgs} { |
| global auto_index |
| |
| # Do not go any further it find level is negative |
| if {$find_level < 0} { |
| return |
| } ;# End of if stmt |
| |
| # Set a variable trace on auto_index so that it also |
| # finds auto-loaded tcl soruce files for a pkg |
| trace variable ::auto_index w trace-auto_index |
| |
| # Also source files in existing auto_index array to |
| # avoid mixup of existing entries with new pkg |
| foreach {elm cmd} [array get auto_index] { |
| catch {uplevel #0 $cmd} err |
| } ;# End of foreach {elm cmd} loop |
| |
| # load all specified pkgs |
| set pkgs $find_pkgs |
| if {[string equal $pkgs ""]} { |
| set pkgs [package names] |
| } ;# End of if stmt |
| foreach name $pkgs { |
| log::notice "%DLTK-PROCESS-PKG% $name" |
| if {![get-pkg-info exists $name]} { |
| # This package does not exist, so skip |
| continue |
| } ;# End of if stmt |
| |
| # Load the package |
| if {$find_level && ![catch {package require $name} vers]} { |
| # If the package was loaded successfully, do nothing |
| # since its info will be added by package require |
| } else { |
| # If the package could not be loaded, register all |
| # known versions of the pkg |
| foreach nvers [get-pkg-info vers $name] { |
| add-pkg-srcs-info $name $nvers |
| } ;# End of foreach loop |
| } ;# End of if catch stmt |
| } ;# End of foreach name loop |
| |
| return |
| } ;# End of proc process-pkg-info |
| |
| proc add-pkg-srcs-info {name vers} { |
| global pkg_path_names |
| global pkg_dir_names |
| global pkg_reqs pkg_srcs pkg_load |
| global pkg_reqs_tmp pkg_srcs_tmp pkg_load_tmp |
| global pkg_names_tmp |
| |
| set type [get-pkg-info type $name $vers] |
| if {[string equal $type ""]} { |
| # If the package is not known to the interpreter, |
| # its shouldn't be recorded, so return immediately. |
| return |
| } ;# End of if stmt |
| |
| set elm [list $name $vers] |
| set path [get-pkg-info path $name $vers] |
| set dir [get-pkg-info dir $name $vers] |
| # Skip if pkg name has been previously recorded |
| if {[info exists pkg_names_tmp($elm)]} { |
| return |
| } ;# End of if stmt |
| set pkg_names_tmp($elm) $vers |
| |
| # Store the files sourced and its package require |
| # dependencies in a global variable. |
| set pkg_srcs($elm) [list] |
| set pkg_load($elm) [list] |
| set pkg_reqs($elm) [list] |
| if {[info exists pkg_srcs_tmp($name)]} { |
| set pkg_srcs($elm) $pkg_srcs_tmp($name) |
| unset pkg_srcs_tmp($name) |
| } ;# End of if stmt |
| if {[info exists pkg_load_tmp($name)]} { |
| set pkg_load($elm) $pkg_load_tmp($name) |
| unset pkg_load_tmp($name) |
| } ;# End of if stmt |
| if {[info exists pkg_reqs_tmp($name)]} { |
| set pkg_reqs($elm) $pkg_reqs_tmp($name) |
| unset pkg_reqs_tmp($name) |
| } ;# End of if stmt |
| lappend pkg_path_names($path) $elm |
| lappend pkg_dir_names($dir) $elm |
| log::debug "PKG-PATH $elm $path" |
| |
| return |
| } ;# End of proc add-pkg-srcs-info |
| |
| proc add-pkg-info {name vers path {dir ""}} { |
| global pkg_names_vers |
| global pkg_names_path |
| global pkg_names_dir |
| |
| # Don't go any further if: |
| # 1. the specified pkg vers has been recorded previously, or |
| # 2. the vers is null and any pkg vers has been previously recorded |
| set elm [list $name $vers] |
| if {[info exists pkg_names_path($elm)] || |
| ([string equal $vers ""] && [info exists pkg_names_vers($name)])} { |
| return |
| } ;# End of if stmt |
| |
| if {![info exists pkg_names_vers($name)]} { |
| set pkg_names_vers($name) [list] |
| } ;# End of if stmt |
| if {![string equal $vers ""]} { |
| lappend pkg_names_vers($name) $vers |
| } ;# End of if stmt |
| |
| # Save path and dir for pkg version. |
| set pkg_names_path($elm) $path |
| set pkg_names_dir($elm) $dir |
| |
| log::debug "PATH-PKG $name $vers $path $dir" |
| return |
| } ;# End of proc add-pkg-info |
| |
| proc get-pkg-info {what name {vers ""}} { |
| global pkg_names_vers |
| global pkg_names_path |
| global pkg_names_dir |
| |
| # Parse $what |
| set retVal {} |
| set elm [list $name $vers] |
| switch -exact -- $what { |
| "path" { |
| if {[info exists pkg_names_path($elm)]} { |
| set retVal $pkg_names_path($elm) |
| } ;# End of if stmt |
| } |
| "dir" { |
| if {[info exists pkg_names_dir($elm)]} { |
| set retVal $pkg_names_dir($elm) |
| } ;# End of if stmt |
| } |
| "type" { |
| if {[info exists pkg_names_path($elm)]} { |
| set retVal [get-path-info type $pkg_names_path($elm)] |
| } ;# End of if stmt |
| } |
| "vers" { |
| # Returns list of known pkg versions |
| if {[info exists pkg_names_vers($name)]} { |
| set retVal $pkg_names_vers($name) |
| } ;# End of if stmt |
| } |
| "exists" { |
| # Returns 1 if the pkg version is known |
| # otherwise it returns 0 |
| set retVal 0 |
| if {[info exists pkg_names_vers($name)]} { |
| if {[string equal $vers ""] || |
| [lsearch $pkg_names_vers($name) $vers] != "-1"} { |
| set retVal 1 |
| } ;# End of if stmt |
| } ;# End of if stmt |
| } |
| default { |
| # should never reach here |
| return |
| } |
| } ;# End of switch stmt |
| |
| return $retVal |
| } ;# End of proc get-pkg-info |
| |
| proc get-path-info {what {path ""}} { |
| global pkg_path_names |
| global pkg_path_type |
| |
| # Parse $what |
| set retVal {} |
| switch -exact -- $what { |
| "list" { |
| set retVal [array names pkg_path_names] |
| } |
| "type" { |
| # Returns type for the given path |
| if {[info exists pkg_path_type($path)]} { |
| set retVal $pkg_path_type($path) |
| } ;# End of if stmt |
| } |
| "pkgs" { |
| # Returns list of known pkgs for the given path |
| if {[info exists pkg_path_names($path)]} { |
| set retVal $pkg_path_names($path) |
| } ;# End of if stmt |
| } |
| default { |
| # should never reach here |
| return |
| } |
| } ;# End of switch stmt |
| |
| return $retVal |
| } ;# End of proc get-path-info |
| |
| proc process-pkg-paths {find_paths builtin_pkgs} { |
| global env auto_path |
| global pkg_path_type |
| global pkg_path_names |
| |
| # Initialize builtin pkgs |
| set pkg_path_names() [list] |
| set pkg_path_type() builtin |
| foreach name $builtin_pkgs { |
| if {![catch {package provide $name} vers]} { |
| add-pkg-info $name $vers "" |
| } ;# End of if stmt |
| } ;# End of foreach pkt |
| |
| # First save paths found in auto_path variable |
| # and set the flag to 0 |
| set paths $find_paths |
| if {[string equal $paths ""]} { |
| set paths $auto_path |
| } ;# End of if stmt |
| foreach path $paths { |
| set path [get-canonical-path $path] |
| set pkg_path_names($path) [list] |
| set pkg_path_type($path) "auto_path" |
| } ;# End of foreach elm loop |
| |
| # Next look for paths found in TCLLIBPATH variable |
| # and set the flag to 1 |
| if {[info exists env(TCLLIBPATH)]} { |
| foreach path $::env(TCLLIBPATH) { |
| set path [get-canonical-path $path] |
| set pkg_path_names($path) [list] |
| set pkg_path_type($path) "tcllibpath" |
| } ;# End of foreach elm loop |
| } ;# End of if TCLLIBPATH exists sttm |
| |
| return |
| } ;# End of proc process-pkg-paths |
| |
| proc print-pkg-info {output} { |
| global pkg_srcs pkg_load pkg_reqs |
| |
| set tabspc " " |
| set path_count 0 |
| set pkgs_count 0 |
| set reqs_count 0 |
| set srcs_count 0 |
| set load_count 0 |
| |
| set dltk_size 0 |
| set path_data {} |
| foreach path [lsort [get-path-info list]] { |
| # Indentation |
| set indent "$tabspc" |
| incr path_count |
| |
| set path_size 0 |
| set pkg_data {} |
| log::info "path: $path" |
| |
| foreach elm [lsort [get-path-info pkgs $path]] { |
| # Double indentation |
| set indent "$tabspc$tabspc" |
| incr pkgs_count |
| set pkg_size 0 |
| set data {} |
| |
| set name [lindex $elm 0] |
| set vers [lindex $elm 1] |
| set srcs $pkg_srcs($elm) |
| set load $pkg_load($elm) |
| set reqs $pkg_reqs($elm) |
| log::info " pkg: $name $vers" |
| |
| foreach r $reqs { |
| incr reqs_count |
| set rname [lindex $r 0] |
| set rvers [lindex $r 1] |
| set rexact [lindex $r 2] |
| set rattr name=\"$rname\" |
| if {![string equal $rvers ""]} { |
| append rattr " " version=\"$rvers\" |
| } ;# End of if stmt |
| if {$rexact} { |
| append rattr " " exact=\"1\" |
| } ;# End of if stmt |
| log::info " require: $rname $rvers" |
| append data $indent $tabspc "<require $rattr/>" \n |
| } ;# End of foreach rname loop |
| |
| foreach sname $srcs { |
| incr srcs_count |
| set sattr name=\"$sname\" |
| if {[file exists $sname]} { |
| set ssize [file size $sname] |
| if {$ssize} { |
| append sattr " " size=\"$ssize\" |
| incr pkg_size $ssize |
| } ;# End of if stmt |
| } else { |
| log::warn "Source file not found: $sname" |
| } ;# End of ifelse stmt |
| log::info " source: $sname" |
| append data $indent $tabspc "<source $sattr/>" \n |
| } ;# End of foreach sname loop |
| |
| foreach lname $load { |
| incr load_count |
| set lattr name=\"$lname\" |
| if {[file exists $lname]} { |
| set lsize [file size $lname] |
| if {$lsize} { |
| append lattr " " size=\"$lsize\" |
| incr pkg_size $lsize |
| } ;# End of if stmt |
| } else { |
| log::warn "Load file not found: $lname" |
| } ;# End of ifelse stmt |
| log::info " load: $lname" |
| append data $indent $tabspc "<load $lattr/>" \n |
| } ;# End of foreach lname loop |
| |
| # Create the pkg xml structure |
| set pattr name=\"$name\" |
| if {![string equal $vers ""]} { |
| append pattr " " version=\"$vers\" |
| } ;# End of if stmt |
| # Disable printing of directory name for the pkg for now |
| # set pkg_dir [get-pkg-info dir $name $vers] |
| # if {![string equal $pkg_dir ""]} { |
| # append pattr " " dir=\"$pkg_dir\" |
| # } ;# End of if stmt |
| if {$pkg_size} { |
| append pattr " " size=\"$pkg_size\" |
| } ;# End of if stmt |
| append pkg_data $indent "<package $pattr>" \n |
| append pkg_data $data |
| append pkg_data $indent "</package>" \n |
| incr path_size $pkg_size |
| } ;# End of foreach loop |
| |
| # Create the path xml structure |
| set indent "$tabspc" |
| set type [get-path-info type $path] |
| set pattr "name=\"$path\" type=\"$type\"" |
| if {$path_size} { |
| append pattr " " size=\"$path_size\" |
| } |
| append path_data $indent "<path $pattr>" \n |
| append path_data $pkg_data |
| append path_data $indent "</path>" \n |
| incr dltk_size $path_size |
| } ;# End of foreach loop |
| |
| # Create the dltk xml structure |
| set dltk_data {} |
| append dltk_data "<DLTK size=\"$dltk_size\">" \n |
| append dltk_data $path_data |
| append dltk_data </DLTK> |
| |
| # Print dltk data to stdout or output file |
| set fname [get-canonical-path $output] |
| if {[string equal $fname ""]} { |
| puts stdout $dltk_data |
| } else { |
| # Ensure that parent dir exists |
| set fdir [file dirname $fname] |
| file mkdir $fdir |
| set fh [open $fname w] |
| puts $fh $dltk_data |
| close $fh |
| } ;# End of if else stmt |
| |
| log::notice "Output file: $fname" |
| log::notice "Number of pkg paths found: $path_count" |
| log::notice "Number of pkgs found: $pkgs_count" |
| log::notice "Number of files sourced: $srcs_count" |
| log::notice "Number of libs loaded: $load_count" |
| log::notice "Number of pkg dependencies: $reqs_count" |
| |
| return |
| } ;# End of proc print-pkg-info |
| |
| proc help {{usermsg ""}} { |
| set msg $usermsg |
| append msg { |
| USAGE: dltk.tcl [subcmd] [options] ?-output <file>? |
| |
| This script scans all the directories relevant to the tcl |
| interpreter and returns an xml structure consisting of library |
| paths, various packages available for loading alongwith its |
| corresponding version number, package dependencies and files |
| sourced or loaded by the package. The -output option can be |
| specified to save the xml structure to a file, otherwise it |
| print it to stdout. |
| |
| |
| > dltk.tcl get-paths ?-paths "<p1> .."? ?-output <file>? \ |
| ?-loglevel error|warn|notice|info|debug? |
| Print all paths known to tcl interpeter including $auto_path |
| and TCLLIBPATH values. Optionally restrict the paths printed |
| using -paths option. |
| |
| > dltk.tcl get-pkgs ?-paths "<p1> .."? ?-pkgs "<pkg1> .."? ?-output <file>? \ |
| ?-fpkgs <file-with-list>? \ |
| ?-loglevel error|warn|notice|info|debug? |
| Print pkg paths and associated package names. Specify -paths and/or |
| -pkgs option to display limited number of paths and pkgs. |
| |
| > dltk.tcl get-srcs ?-paths "<p1> .."? ?-pkgs "<pkg1> .."? ?-output <file>? \ |
| ?-fpkgs <file-with-list>? \ |
| ?-loglevel error|warn|notice|info|debug? |
| Print pkg paths, pkg names/versions and corresponding library |
| source files. Limit output to specified packages or paths using |
| -pkgs or -paths option. |
| |
| > dltk.tcl |
| > dltk.tcl help |
| Print this help msg |
| } |
| |
| puts stderr $msg |
| |
| return |
| } ;# End of proc help |
| |
| proc main {argv} { |
| global auto_path |
| global pkg_stack path_tmp |
| set pkg_stack {} ;# initialize to null |
| set path_tmp {} ;# initialize to null |
| |
| set subcmd [lindex $argv 0] |
| |
| # We could use tcl's time cmd below but we don't need |
| # microsecond resolution |
| set start_time [clock seconds] |
| |
| # Initialize log level |
| ::log::setlevel notice |
| |
| set find_level 1 |
| switch -exact -- $subcmd { |
| "get-paths" { |
| set find_level -1 |
| } |
| "get-pkgs" { |
| set find_level 0 |
| } |
| "get-srcs" { |
| set find_level 1 |
| } |
| "help" - |
| default { |
| # Print help msg and quit |
| help |
| return |
| } |
| } ;# End of switch stmt |
| |
| # Parse the options |
| set argc [llength $argv] |
| set idx 1 |
| set paths [list] |
| set pkgs [list] |
| set output [list] |
| while {$idx < $argc} { |
| set opt [lindex $argv $idx] |
| incr idx |
| switch -exact -- $opt { |
| "-path" - |
| "-paths" { |
| set paths [lindex $argv $idx] |
| } |
| "-pkg" - |
| "-pkgs" { |
| set pkgs [lindex $argv $idx] |
| } |
| "-fpkgs" { |
| set fname [lindex $argv $idx] |
| set fp [open "$fname" r] |
| set pkgs [read $fp] |
| puts "Loaded: $pkgs" |
| close $fp |
| } |
| "-output" { |
| set output [get-canonical-path [lindex $argv $idx]] |
| } |
| "-loglevel" { |
| ::log::setlevel [lindex $argv $idx] |
| } |
| default { |
| # Invalid option, print error |
| help "Invalid option: $opt\n\n" |
| return |
| } |
| } ;# End of switch stmt |
| incr idx |
| } ;# End of while loop |
| |
| # First try to get list of builtin pkgs known to interpreter |
| # Then try to load an unknown pkg, so that it discovers all packages |
| set builtin_pkgs [package names] |
| catch {::package-org require unknown-random-[clock seconds]} |
| log::notice "%DLTK-NUM-PATHS% [llength $auto_path]" |
| log::notice "%DLTK-NUM-PKGS% [llength [package names]]" |
| |
| # Process pkg paths in auto_path and TCLLIBPATH |
| process-pkg-paths $paths $builtin_pkgs |
| |
| # Process pkg ifneeded bodies by invoking [pkg req] |
| process-pkg-info $find_level $pkgs |
| |
| # Print pkg root folders |
| print-pkg-info $output |
| |
| set stop_time [clock seconds] |
| |
| log::notice "Run time = [expr {$stop_time-$start_time}] secs" |
| |
| return |
| } ;# End of proc main |
| main $argv |
| |
| puts stdout "DLTK-TCL-HELPER-9E7A168E-5EEF-4a46-A86D-0C82E90686E4-END-OF-STREAM" |
| # Exit needs to be called explicitly because some package may endup |
| # invoking Tk pkg which in turn may create a GUI window and wait forever. |
| ::exit-org |
| |
| ## End dltk.tcl |
