#@package: TclX-ArrayProcedures for_array_keys proc for_array_keys {varName arrayName codeFragment} { upvar $varName enumVar $arrayName enumArray if ![info exists enumArray] { error "\"$arrayName\" isn't an array" } set searchId [array startsearch enumArray] while {[array anymore enumArray $searchId]} { set enumVar [array nextelement enumArray $searchId] uplevel $codeFragment } array donesearch enumArray $searchId } #@package: TclX-assign_fields assign_fields proc assign_fields {list args} { foreach varName $args { set value [lvarpop list] uplevel "set $varName [list $value]" } } #@package: TclX-developer_utils saveprocs edprocs proc saveprocs {fileName args} { set fp [open $fileName w] puts $fp "# tcl procs saved on [fmtclock [getclock]]\n" puts $fp [eval "showprocs $args"] close $fp } proc edprocs {args} { global env set tmpFilename /tmp/tcldev.[id process] set fp [open $tmpFilename w] puts $fp "\n# TEMP EDIT BUFFER -- YOUR CHANGES ARE FOR THIS SESSION ONLY\n" puts $fp [eval "showprocs $args"] close $fp if [info exists env(EDITOR)] { set editor $env(EDITOR) } else { set editor vi } set startMtime [file mtime $tmpFilename] system "$editor $tmpFilename" if {[file mtime $tmpFilename] != $startMtime} { source $tmpFilename echo "Procedures were reloaded." } else { echo "No changes were made." } unlink $tmpFilename return } #@package: TclX-forfile for_file proc for_file {var filename code} { upvar $var line set fp [open $filename r] while {[gets $fp line] >= 0} { uplevel $code } close $fp } #@package: TclX-forrecur for_recursive_glob proc for_recursive_glob {var globlist code {depth 1}} { upvar $depth $var myVar foreach globpat $globlist { foreach file [glob -nocomplain $globpat] { if [file isdirectory $file] { for_recursive_glob $var $file/* $code [expr {$depth + 1}] } set myVar $file uplevel $depth $code } } } #@package: TclX-globrecur recursive_glob proc recursive_glob {globlist} { set result "" foreach pattern $globlist { foreach file [glob -nocomplain $pattern] { lappend result $file if [file isdirectory $file] { set result [concat $result [recursive_glob $file/*]] } } } return $result } #@package: TclX-help help helpcd helppwd apropos proc help:flattenPath {pathName} { set newPath {} foreach element [split $pathName /] { if {"$element" == "."} { continue } if {"$element" == ".."} { if {[llength [join $newPath /]] == 0} { error "Help: name goes above subject directory root"} lvarpop newPath [expr [llength $newPath]-1] continue } lappend newPath $element } set newPath [join $newPath /] if {("$newPath" == "") && [string match "/*" $pathName]} { set newPath "/"} return $newPath } proc help:EvalPath {pathName} { global TCLENV if {![string match "/*" $pathName]} { if {"$pathName" == ""} { return $TCLENV(help:curDir)} if {"$TCLENV(help:curDir)" == "/"} { set pathName "/$pathName" } else { set pathName "$TCLENV(help:curDir)/$pathName" } } set pathName [help:flattenPath $pathName] if {[string match "*/" $pathName] && ($pathName != "/")} { set pathName [csubstr $pathName 0 [expr [length $pathName]-1]]} return $pathName } proc help:Display {line} { global TCLENV if {$TCLENV(help:lineCnt) >= 23} { set TCLENV(help:lineCnt) 0 puts stdout ":" nonewline flush stdout gets stdin response if {![lempty $response]} { return 0} } puts stdout $line incr TCLENV(help:lineCnt) } proc help:DisplayFile {filepath} { set inFH [open $filepath r] while {[gets $inFH fileBuf] >= 0} { if {![help:Display $fileBuf]} { break} } close $inFH } proc help:ListDir {dirPath} { set dirList {} set fileList {} if {[catch {set dirFiles [glob $dirPath/*]}] != 0} { error "No files in subject directory: $dirPath"} foreach fileName $dirFiles { if [file isdirectory $fileName] { lappend dirList "[file tail $fileName]/" } else { lappend fileList [file tail $fileName] } } return [list [lsort $dirList] [lsort $fileList]] } proc help:DisplayColumns {nameList} { set count 0 set outLine "" foreach name $nameList { if {$count == 0} { append outLine " "} append outLine $name if {[incr count] < 4} { set padLen [expr 17-[clength $name]] if {$padLen < 3} { set padLen 3} append outLine [replicate " " $padLen] } else { if {![help:Display $outLine]} { return} set outLine "" set count 0 } } if {$count != 0} { help:Display $outLine} return } proc help {{subject {}}} { global TCLENV set TCLENV(help:lineCnt) 0 if {($subject == "help") || ($subject == "?")} { help:DisplayFile "$TCLENV(help:root)/help" return } set request [help:EvalPath $subject] set requestPath "$TCLENV(help:root)$request" if {![file exists $requestPath]} { error "Help:\"$request\" does not exist"} if [file isdirectory $requestPath] { set dirList [help:ListDir $requestPath] set subList [lindex $dirList 0] set fileList [lindex $dirList 1] if {[llength $subList] != 0} { help:Display "\nSubjects available in $request:" help:DisplayColumns $subList } if {[llength $fileList] != 0} { help:Display "\nHelp files available in $request:" help:DisplayColumns $fileList } } else { help:DisplayFile $requestPath } return } proc helpcd {{dir /}} { global TCLENV set request [help:EvalPath $dir] set requestPath "$TCLENV(help:root)$request" if {![file exists $requestPath]} { error "Helpcd: \"$request\" does not exist"} if {![file isdirectory $requestPath]} { error "Helpcd: \"$request\" is not a directory"} set TCLENV(help:curDir) $request return } proc helppwd {} { global TCLENV echo "Current help subject directory: $TCLENV(help:curDir)" } proc apropos {name} { global TCLENV set TCLENV(help:lineCnt) 0 set aproposCT [scancontext create] scanmatch -nocase $aproposCT $name { set path [lindex $matchInfo(line) 0] set desc [lrange $matchInfo(line) 1 end] if {![help:Display [format "%s - %s" $path $desc]]} { return} } foreach brief [glob -nocomplain $TCLENV(help:root)/*.brf] { set briefFH [open $brief] scanfile $aproposCT $briefFH close $briefFH } scancontext delete $aproposCT } global TCLENV TCLPATH set TCLENV(help:root) [searchpath $TCLPATH help] set TCLENV(help:curDir) "/" set TCLENV(help:outBuf) {} #@package: TclX-packages packages autoprocs proc packages {{option {}}} { global TCLENV set packList {} foreach key [array names TCLENV] { if {[string match "PKG:*" $key]} { lappend packList [string range $key 4 end] } } if [lempty $option] { return $packList } else { if {$option != "-location"} { error "Unknow option \"$option\", expected \"-location\"" } set locList {} foreach pack $packList { set fileId [lindex $TCLENV(PKG:$pack) 0] lappend locList [list $pack [concat $TCLENV($fileId) \ [lrange $TCLENV(PKG:$pack) 1 2]]] } return $locList } } proc autoprocs {} { global TCLENV set procList {} foreach key [array names TCLENV] { if {[string match "PROC:*" $key]} { lappend procList [string range $key 5 end] } } return $procList } #@package: TclX-directory_stack pushd popd dirs global TCLENV(dirPushList) set TCLENV(dirPushList) "" proc pushd {args} { global TCLENV if {[llength $args] > 1} { error "bad # args: pushd [dir_to_cd_to]" } set TCLENV(dirPushList) [linsert $TCLENV(dirPushList) 0 [pwd]] if {[llength $args] != 0} { cd [glob $args] } } proc popd {} { global TCLENV if [llength $TCLENV(dirPushList)] { cd [lvarpop TCLENV(dirPushList)] pwd } else { error "directory stack empty" } } proc dirs {} { global TCLENV echo [pwd] $TCLENV(dirPushList) } #@package: TclX-set_functions union intersect intersect3 lrmdups proc union {lista listb} { set full_list [lsort [concat $lista $listb]] set check_element [lindex $full_list 0] set outlist $check_element foreach element [lrange $full_list 1 end] { if {$check_element == $element} continue lappend outlist $element set check_element $element } return $outlist } proc lrmdups {list} { set list [lsort $list] set result [lvarpop list] lappend last $result foreach element $list { if {$last != $element} { lappend result $element set last $element } } return $result } proc intersect3 {list1 list2} { set list1Result "" set list2Result "" set intersectList "" set list1 [lrmdups $list1] set list2 [lrmdups $list2] while {1} { if [lempty $list1] { if ![lempty $list2] { set list2Result [concat $list2Result $list2] } break } if [lempty $list2] { set list1Result [concat $list1Result $list1] break } set compareResult [string compare [lindex $list1 0] [lindex $list2 0]] if {$compareResult < 0} { lappend list1Result [lvarpop list1] continue } if {$compareResult > 0} { lappend list2Result [lvarpop list2] continue } lappend intersectList [lvarpop list1] lvarpop list2 } return [list $list1Result $intersectList $list2Result] } proc intersect {list1 list2} { set intersectList "" set list1 [lsort $list1] set list2 [lsort $list2] while {1} { if {[lempty $list1] || [lempty $list2]} break set compareResult [string compare [lindex $list1 0] [lindex $list2 0]] if {$compareResult < 0} { lvarpop list1 continue } if {$compareResult > 0} { lvarpop list2 continue } lappend intersectList [lvarpop list1] lvarpop list2 } return $intersectList } #@package: TclX-show_procedures showproc showprocs proc showproc {procname} { if [lempty [info procs $procname]] {demand_load $procname} set arglist [info args $procname] set nargs {} while {[llength $arglist] > 0} { set varg [lvarpop arglist 0] if [info default $procname $varg defarg] { lappend nargs [list $varg $defarg] } else { lappend nargs $varg } } format "proc %s \{%s\} \{%s\}\n" $procname $nargs [info body $procname] } proc showprocs {args} { if [lempty $args] { set args [info procs] } set out "" foreach i $args { foreach j $i { append out [showproc $j] "\n"} } return $out } #@package: TclX-stringfile_functions read_file write_file proc read_file {fileName {numBytes {}}} { set fp [open $fileName] if {$numBytes != ""} { set result [read $fp $numBytes] } else { set result [read $fp] } close $fp return $result } proc write_file {fileName args} { set fp [open $fileName w] foreach string $args { puts $fp $string } close $fp } #@package: TclX-Compatibility execvp proc execvp {progname args} { execl $progname $args } #@package: TclX-convertlib convert_lib proc convert_lib {tclIndex packageLib {ignore {}}} { if {[file tail $tclIndex] != "tclIndex"} { error "Tail file name numt be `tclIndex': $tclIndex"} set srcDir [file dirname $tclIndex] if {[file extension $packageLib] != ".tlib"} { append packageLib ".tlib"} set tclIndexFH [open $tclIndex r] while {[gets $tclIndexFH line] >= 0} { if {([cindex $line 0] == "#") || ([llength $line] != 2)} { continue} if {[lsearch $ignore [lindex $line 1]] >= 0} { continue} lappend entryTable([lindex $line 1]) [lindex $line 0] } close $tclIndexFH set libFH [open $packageLib w] foreach srcFile [array names entryTable] { set srcFH [open $srcDir/$srcFile r] puts $libFH "#@package: $srcFile $entryTable($srcFile)\n" copyfile $srcFH $libFH close $srcFH } close $libFH buildpackageindex $packageLib } #@package: TclX-profrep profrep proc profrep:summarize {profDataVar stackDepth sumProfDataVar} { upvar $profDataVar profData $sumProfDataVar sumProfData if {(![info exists profData]) || ([catch {array size profData}] != 0)} { error "`profDataVar' must be the name of an array returned by the `profile off' command" } set maxNameLen 0 foreach procStack [array names profData] { if {[llength $procStack] < $stackDepth} { set sigProcStack $procStack } else { set sigProcStack [lrange $procStack 0 [expr {$stackDepth - 1}]] } set maxNameLen [max $maxNameLen [clength $sigProcStack]] if [info exists sumProfData($sigProcStack)] { set cur $sumProfData($sigProcStack) set add $profData($procStack) set new [expr [lindex $cur 0]+[lindex $add 0]] lappend new [expr [lindex $cur 1]+[lindex $add 1]] lappend new [expr [lindex $cur 2]+[lindex $add 2]] set $sumProfData($sigProcStack) $new } else { set sumProfData($sigProcStack) $profData($procStack) } } return $maxNameLen } proc profrep:sort {sumProfDataVar sortKey} { upvar $sumProfDataVar sumProfData case $sortKey { {calls} {set keyIndex 0} {real} {set keyIndex 1} {cpu} {set keyIndex 2} default { error "Expected a sort of: `calls', `cpu' or ` real'"} } foreach procStack [array names sumProfData] { set key [format "%016d" [lindex $sumProfData($procStack) $keyIndex]] lappend keyProcList [list $key $procStack] } set keyProcList [lsort $keyProcList] for {set idx [expr [llength $keyProcList]-1]} {$idx >= 0} {incr idx -1} { lappend sortedProcList [lindex [lindex $keyProcList $idx] 1] } return $sortedProcList } proc profrep:print {sumProfDataVar sortedProcList maxNameLen outFile userTitle} { upvar $sumProfDataVar sumProfData if {$outFile == ""} { set outFH stdout } else { set outFH [open $outFile w] } set stackTitle "Procedure Call Stack" set maxNameLen [max $maxNameLen [clength $stackTitle]] set hdr [format "%-${maxNameLen}s %10s %10s %10s" $stackTitle \ "Calls" "Real Time" "CPU Time"] if {$userTitle != ""} { puts $outFH [replicate - [clength $hdr]] puts $outFH $userTitle } puts $outFH [replicate - [clength $hdr]] puts $outFH $hdr puts $outFH [replicate - [clength $hdr]] foreach procStack $sortedProcList { set data $sumProfData($procStack) puts $outFH [format "%-${maxNameLen}s %10d %10d %10d" $procStack \ [lindex $data 0] [lindex $data 1] [lindex $data 2]] } if {$outFile != ""} { close $outFH } } proc profrep {profDataVar sortKey stackDepth {outFile {}} {userTitle {}}} { upvar $profDataVar profData set maxNameLen [profrep:summarize profData $stackDepth sumProfData] set sortedProcList [profrep:sort sumProfData $sortKey] profrep:print sumProfData $sortedProcList $maxNameLen $outFile $userTitle }