cvs.zerfleddert.de Git - micropolis/blob - res/tcl.tlb

   1
   2 #@package: TclX-ArrayProcedures for_array_keys
   3
   4 proc for_array_keys {varName arrayName codeFragment} {
   5     upvar $varName enumVar $arrayName enumArray
   6
   7     if ![info exists enumArray] {
   8         error "\"$arrayName\" isn't an array"
   9     }
  10
  11     set searchId [array startsearch enumArray]
  12     while {[array anymore enumArray $searchId]} {
  13         set enumVar [array nextelement enumArray $searchId]
  14         uplevel $codeFragment
  15     }
  16     array donesearch enumArray $searchId
  17 }
  18
  19 #@package: TclX-assign_fields assign_fields
  20
  21 proc assign_fields {list args} {
  22     foreach varName $args {
  23         set value [lvarpop list]
  24         uplevel "set $varName [list $value]"
  25     }
  26 }
  27
  28 #@package: TclX-developer_utils saveprocs edprocs
  29
  30 proc saveprocs {fileName args} {
  31     set fp [open $fileName w]
  32     puts $fp "# tcl procs saved on [fmtclock [getclock]]\n"
  33     puts $fp [eval "showprocs $args"]
  34     close $fp
  35 }
  36
  37 proc edprocs {args} {
  38     global env
  39
  40     set tmpFilename /tmp/tcldev.[id process]
  41
  42     set fp [open $tmpFilename w]
  43     puts $fp "\n# TEMP EDIT BUFFER -- YOUR CHANGES ARE FOR THIS SESSION ONLY\n"
  44     puts $fp [eval "showprocs $args"]
  45     close $fp
  46
  47     if [info exists env(EDITOR)] {
  48         set editor $env(EDITOR)
  49     } else {
  50         set editor vi
  51     }
  52
  53     set startMtime [file mtime $tmpFilename]
  54     system "$editor $tmpFilename"
  55
  56     if {[file mtime $tmpFilename] != $startMtime} {
  57         source $tmpFilename
  58         echo "Procedures were reloaded."
  59     } else {
  60         echo "No changes were made."
  61     }
  62     unlink $tmpFilename
  63     return
  64 }
  65
  66 #@package: TclX-forfile for_file
  67
  68 proc for_file {var filename code} {
  69     upvar $var line
  70     set fp [open $filename r]
  71     while {[gets $fp line] >= 0} {
  72         uplevel $code
  73     }
  74     close $fp
  75 }
  76
  77
  78 #@package: TclX-forrecur for_recursive_glob
  79
  80 proc for_recursive_glob {var globlist code {depth 1}} {
  81     upvar $depth $var myVar
  82     foreach globpat $globlist {
  83         foreach file [glob -nocomplain $globpat] {
  84             if [file isdirectory $file] {
  85                 for_recursive_glob $var $file/* $code [expr {$depth + 1}]
  86             }
  87             set myVar $file
  88             uplevel $depth $code
  89         }
  90     }
  91 }
  92
  93 #@package: TclX-globrecur recursive_glob
  94
  95 proc recursive_glob {globlist} {
  96     set result ""
  97     foreach pattern $globlist {
  98         foreach file [glob -nocomplain $pattern] {
  99             lappend result $file
 100             if [file isdirectory $file] {
 101                 set result [concat $result [recursive_glob $file/*]]
 102             }
 103         }
 104     }
 105     return $result
 106 }
 107
 108 #@package: TclX-help help helpcd helppwd apropos
 109
 110
 111 proc help:flattenPath {pathName} {
 112     set newPath {}
 113     foreach element [split $pathName /] {
 114         if {"$element" == "."} {
 115            continue
 116         }
 117         if {"$element" == ".."} {
 118             if {[llength [join $newPath /]] == 0} {
 119                 error "Help: name goes above subject directory root"}
 120             lvarpop newPath [expr [llength $newPath]-1]
 121             continue
 122         }
 123         lappend newPath $element
 124     }
 125     set newPath [join $newPath /]
 126
 127
 128     if {("$newPath" == "") && [string match "/*" $pathName]} {
 129         set newPath "/"}
 130
 131     return $newPath
 132 }
 133
 134
 135 proc help:EvalPath {pathName} {
 136     global TCLENV
 137
 138     if {![string match "/*" $pathName]} {
 139         if {"$pathName" == ""} {
 140             return $TCLENV(help:curDir)}
 141         if {"$TCLENV(help:curDir)" == "/"} {
 142             set pathName "/$pathName"
 143         } else {
 144             set pathName "$TCLENV(help:curDir)/$pathName"
 145         }
 146     }
 147     set pathName [help:flattenPath $pathName]
 148     if {[string match "*/" $pathName] && ($pathName != "/")} {
 149         set pathName [csubstr $pathName 0 [expr [length $pathName]-1]]}
 150
 151     return $pathName
 152 }
 153
 154
 155 proc help:Display {line} {
 156     global TCLENV
 157     if {$TCLENV(help:lineCnt) >= 23} {
 158         set TCLENV(help:lineCnt) 0
 159         puts stdout ":" nonewline
 160         flush stdout
 161         gets stdin response
 162         if {![lempty $response]} {
 163             return 0}
 164     }
 165     puts stdout $line
 166     incr TCLENV(help:lineCnt)
 167 }
 168
 169
 170 proc help:DisplayFile {filepath} {
 171
 172     set inFH [open $filepath r]
 173     while {[gets $inFH fileBuf] >= 0} {
 174         if {![help:Display $fileBuf]} {
 175             break}
 176     }
 177     close $inFH
 178
 179 }
 180
 181
 182 proc help:ListDir {dirPath} {
 183     set dirList {}
 184     set fileList {}
 185     if {[catch {set dirFiles [glob $dirPath/*]}] != 0} {
 186         error "No files in subject directory: $dirPath"}
 187     foreach fileName $dirFiles {
 188         if [file isdirectory $fileName] {
 189             lappend dirList "[file tail $fileName]/"
 190         } else {
 191             lappend fileList [file tail $fileName]
 192         }
 193     }
 194    return [list [lsort $dirList] [lsort $fileList]]
 195 }
 196
 197
 198 proc help:DisplayColumns {nameList} {
 199     set count 0
 200     set outLine ""
 201     foreach name $nameList {
 202         if {$count == 0} {
 203             append outLine "   "}
 204         append outLine $name
 205         if {[incr count] < 4} {
 206             set padLen [expr 17-[clength $name]]
 207             if {$padLen < 3} {
 208                set padLen 3}
 209             append outLine [replicate " " $padLen]
 210         } else {
 211            if {![help:Display $outLine]} {
 212                return}
 213            set outLine ""
 214            set count 0
 215         }
 216     }
 217     if {$count != 0} {
 218         help:Display $outLine}
 219     return
 220 }
 221
 222
 223
 224 proc help {{subject {}}} {
 225     global TCLENV
 226
 227     set TCLENV(help:lineCnt) 0
 228
 229
 230     if {($subject == "help") || ($subject == "?")} {
 231         help:DisplayFile "$TCLENV(help:root)/help"
 232         return
 233     }
 234
 235     set request [help:EvalPath $subject]
 236     set requestPath "$TCLENV(help:root)$request"
 237
 238     if {![file exists $requestPath]} {
 239         error "Help:\"$request\" does not exist"}
 240
 241     if [file isdirectory $requestPath] {
 242         set dirList [help:ListDir $requestPath]
 243         set subList  [lindex $dirList 0]
 244         set fileList [lindex $dirList 1]
 245         if {[llength $subList] != 0} {
 246             help:Display "\nSubjects available in $request:"
 247             help:DisplayColumns $subList
 248         }
 249         if {[llength $fileList] != 0} {
 250             help:Display "\nHelp files available in $request:"
 251             help:DisplayColumns $fileList
 252         }
 253     } else {
 254         help:DisplayFile $requestPath
 255     }
 256     return
 257 }
 258
 259
 260
 261 proc helpcd {{dir /}} {
 262     global TCLENV
 263
 264     set request [help:EvalPath $dir]
 265     set requestPath "$TCLENV(help:root)$request"
 266
 267     if {![file exists $requestPath]} {
 268         error "Helpcd: \"$request\" does not exist"}
 269
 270     if {![file isdirectory $requestPath]} {
 271         error "Helpcd: \"$request\" is not a directory"}
 272
 273     set TCLENV(help:curDir) $request
 274     return
 275 }
 276
 277
 278 proc helppwd {} {
 279         global TCLENV
 280         echo "Current help subject directory: $TCLENV(help:curDir)"
 281 }
 282
 283
 284 proc apropos {name} {
 285     global TCLENV
 286
 287     set TCLENV(help:lineCnt) 0
 288
 289     set aproposCT [scancontext create]
 290     scanmatch -nocase $aproposCT $name {
 291         set path [lindex $matchInfo(line) 0]
 292         set desc [lrange $matchInfo(line) 1 end]
 293         if {![help:Display [format "%s - %s" $path $desc]]} {
 294             return}
 295     }
 296     foreach brief [glob -nocomplain $TCLENV(help:root)/*.brf] {
 297         set briefFH [open $brief]
 298         scanfile $aproposCT $briefFH
 299         close $briefFH
 300     }
 301     scancontext delete $aproposCT
 302 }
 303
 304 global TCLENV TCLPATH
 305
 306 set TCLENV(help:root) [searchpath $TCLPATH help]
 307 set TCLENV(help:curDir) "/"
 308 set TCLENV(help:outBuf) {}
 309
 310 #@package: TclX-packages packages autoprocs
 311
 312 proc packages {{option {}}} {
 313     global TCLENV
 314     set packList {}
 315     foreach key [array names TCLENV] {
 316         if {[string match "PKG:*" $key]} {
 317             lappend packList [string range $key 4 end]
 318         }
 319     }
 320     if [lempty $option] {
 321         return $packList
 322     } else {
 323         if {$option != "-location"} {
 324             error "Unknow option \"$option\", expected \"-location\""
 325         }
 326         set locList {}
 327         foreach pack $packList {
 328             set fileId [lindex $TCLENV(PKG:$pack) 0]
 329
 330             lappend locList [list $pack [concat $TCLENV($fileId) \
 331                                              [lrange $TCLENV(PKG:$pack) 1 2]]]
 332         }
 333         return $locList
 334     }
 335 }
 336
 337 proc autoprocs {} {
 338     global TCLENV
 339     set procList {}
 340     foreach key [array names TCLENV] {
 341         if {[string match "PROC:*" $key]} {
 342             lappend procList [string range $key 5 end]
 343         }
 344     }
 345     return $procList
 346 }
 347
 348 #@package: TclX-directory_stack pushd popd dirs
 349
 350 global TCLENV(dirPushList)
 351
 352 set TCLENV(dirPushList) ""
 353
 354 proc pushd {args} {
 355     global TCLENV
 356
 357     if {[llength $args] > 1} {
 358         error "bad # args: pushd [dir_to_cd_to]"
 359     }
 360     set TCLENV(dirPushList) [linsert $TCLENV(dirPushList) 0 [pwd]]
 361
 362     if {[llength $args] != 0} {
 363         cd [glob $args]
 364     }
 365 }
 366
 367 proc popd {} {
 368     global TCLENV
 369
 370     if [llength $TCLENV(dirPushList)] {
 371         cd [lvarpop TCLENV(dirPushList)]
 372         pwd
 373     } else {
 374         error "directory stack empty"
 375     }
 376 }
 377
 378 proc dirs {} {
 379     global TCLENV
 380     echo [pwd] $TCLENV(dirPushList)
 381 }
 382
 383 #@package: TclX-set_functions union intersect intersect3 lrmdups
 384
 385 proc union {lista listb} {
 386     set full_list [lsort [concat $lista $listb]]
 387     set check_element [lindex $full_list 0]
 388     set outlist $check_element
 389     foreach element [lrange $full_list 1 end] {
 390         if {$check_element == $element} continue
 391         lappend outlist $element
 392         set check_element $element
 393     }
 394     return $outlist
 395 }
 396
 397 proc lrmdups {list} {
 398     set list [lsort $list]
 399     set result [lvarpop list]
 400     lappend last $result
 401     foreach element $list {
 402         if {$last != $element} {
 403             lappend result $element
 404             set last $element
 405         }
 406     }
 407     return $result
 408 }
 409
 410
 411 proc intersect3 {list1 list2} {
 412     set list1Result ""
 413     set list2Result ""
 414     set intersectList ""
 415
 416     set list1 [lrmdups $list1]
 417     set list2 [lrmdups $list2]
 418
 419     while {1} {
 420         if [lempty $list1] {
 421             if ![lempty $list2] {
 422                 set list2Result [concat $list2Result $list2]
 423             }
 424             break
 425         }
 426         if [lempty $list2] {
 427             set list1Result [concat $list1Result $list1]
 428             break
 429         }
 430         set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
 431
 432         if {$compareResult < 0} {
 433             lappend list1Result [lvarpop list1]
 434             continue
 435         }
 436         if {$compareResult > 0} {
 437             lappend list2Result [lvarpop list2]
 438             continue
 439         }
 440         lappend intersectList [lvarpop list1]
 441         lvarpop list2
 442     }
 443     return [list $list1Result $intersectList $list2Result]
 444 }
 445
 446 proc intersect {list1 list2} {
 447     set intersectList ""
 448
 449     set list1 [lsort $list1]
 450     set list2 [lsort $list2]
 451
 452     while {1} {
 453         if {[lempty $list1] || [lempty $list2]} break
 454
 455         set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
 456
 457         if {$compareResult < 0} {
 458             lvarpop list1
 459             continue
 460         }
 461
 462         if {$compareResult > 0} {
 463             lvarpop list2
 464             continue
 465         }
 466
 467         lappend intersectList [lvarpop list1]
 468         lvarpop list2
 469     }
 470     return $intersectList
 471 }
 472
 473
 474
 475 #@package: TclX-show_procedures showproc showprocs
 476
 477 proc showproc {procname} {
 478     if [lempty [info procs $procname]] {demand_load $procname}
 479         set arglist [info args $procname]
 480         set nargs {}
 481         while {[llength $arglist] > 0} {
 482             set varg [lvarpop arglist 0]
 483             if [info default $procname $varg defarg] {
 484                 lappend nargs [list $varg $defarg]
 485             } else {
 486                 lappend nargs $varg
 487             }
 488     }
 489     format "proc %s \{%s\} \{%s\}\n" $procname $nargs [info body $procname]
 490 }
 491
 492 proc showprocs {args} {
 493     if [lempty $args] { set args [info procs] }
 494     set out ""
 495
 496     foreach i $args {
 497         foreach j $i { append out [showproc $j] "\n"}
 498     }
 499     return $out
 500 }
 501
 502
 503 #@package: TclX-stringfile_functions read_file write_file
 504
 505 proc read_file {fileName {numBytes {}}} {
 506     set fp [open $fileName]
 507     if {$numBytes != ""} {
 508         set result [read $fp $numBytes]
 509     } else {
 510         set result [read $fp]
 511     }
 512     close $fp
 513     return $result
 514 }
 515
 516 proc write_file {fileName args} {
 517     set fp [open $fileName w]
 518     foreach string $args {
 519         puts $fp $string
 520     }
 521     close $fp
 522 }
 523
 524
 525 #@package: TclX-Compatibility execvp
 526
 527 proc execvp {progname args} {
 528     execl $progname $args
 529 }
 530
 531 #@package: TclX-convertlib convert_lib
 532
 533 proc convert_lib {tclIndex packageLib {ignore {}}} {
 534     if {[file tail $tclIndex] != "tclIndex"} {
 535         error "Tail file name numt be `tclIndex': $tclIndex"}
 536     set srcDir [file dirname $tclIndex]
 537
 538     if {[file extension $packageLib] != ".tlib"} {
 539         append packageLib ".tlib"}
 540
 541
 542     set tclIndexFH [open $tclIndex r]
 543     while {[gets $tclIndexFH line] >= 0} {
 544         if {([cindex $line 0] == "#") || ([llength $line] != 2)} {
 545             continue}
 546         if {[lsearch $ignore [lindex $line 1]] >= 0} {
 547             continue}
 548         lappend entryTable([lindex $line 1]) [lindex $line 0]
 549     }
 550     close $tclIndexFH
 551
 552     set libFH [open $packageLib w]
 553     foreach srcFile [array names entryTable] {
 554         set srcFH [open $srcDir/$srcFile r]
 555         puts $libFH "#@package: $srcFile $entryTable($srcFile)\n"
 556         copyfile $srcFH $libFH
 557         close $srcFH
 558     }
 559     close $libFH
 560     buildpackageindex $packageLib
 561 }
 562
 563 #@package: TclX-profrep profrep
 564
 565 proc profrep:summarize {profDataVar stackDepth sumProfDataVar} {
 566     upvar $profDataVar profData $sumProfDataVar sumProfData
 567
 568     if {(![info exists profData]) || ([catch {array size profData}] != 0)} {
 569         error "`profDataVar' must be the name of an array returned by the `profile off' command"
 570     }
 571     set maxNameLen 0
 572     foreach procStack [array names profData] {
 573         if {[llength $procStack] < $stackDepth} {
 574             set sigProcStack $procStack
 575         } else {
 576             set sigProcStack [lrange $procStack 0 [expr {$stackDepth - 1}]]
 577         }
 578         set maxNameLen [max $maxNameLen [clength $sigProcStack]]
 579         if [info exists sumProfData($sigProcStack)] {
 580             set cur $sumProfData($sigProcStack)
 581             set add $profData($procStack)
 582             set     new [expr [lindex $cur 0]+[lindex $add 0]]
 583             lappend new [expr [lindex $cur 1]+[lindex $add 1]]
 584             lappend new [expr [lindex $cur 2]+[lindex $add 2]]
 585             set $sumProfData($sigProcStack) $new
 586         } else {
 587             set sumProfData($sigProcStack) $profData($procStack)
 588         }
 589     }
 590     return $maxNameLen
 591 }
 592
 593 proc profrep:sort {sumProfDataVar sortKey} {
 594     upvar $sumProfDataVar sumProfData
 595
 596     case $sortKey {
 597         {calls} {set keyIndex 0}
 598         {real}  {set keyIndex 1}
 599         {cpu}   {set keyIndex 2}
 600         default {
 601             error "Expected a sort of: `calls',  `cpu' or ` real'"}
 602     }
 603
 604
 605     foreach procStack [array names sumProfData] {
 606         set key [format "%016d" [lindex $sumProfData($procStack) $keyIndex]]
 607         lappend keyProcList [list $key $procStack]
 608     }
 609     set keyProcList [lsort $keyProcList]
 610
 611
 612     for {set idx [expr [llength $keyProcList]-1]} {$idx >= 0} {incr idx -1} {
 613         lappend sortedProcList [lindex [lindex $keyProcList $idx] 1]
 614     }
 615     return $sortedProcList
 616 }
 617
 618
 619 proc profrep:print {sumProfDataVar sortedProcList maxNameLen outFile
 620                     userTitle} {
 621     upvar $sumProfDataVar sumProfData
 622
 623     if {$outFile == ""} {
 624         set outFH stdout
 625     } else {
 626         set outFH [open $outFile w]
 627     }
 628
 629
 630     set stackTitle "Procedure Call Stack"
 631     set maxNameLen [max $maxNameLen [clength $stackTitle]]
 632     set hdr [format "%-${maxNameLen}s %10s %10s %10s" $stackTitle \
 633                     "Calls" "Real Time" "CPU Time"]
 634     if {$userTitle != ""} {
 635         puts $outFH [replicate - [clength $hdr]]
 636         puts $outFH $userTitle
 637     }
 638     puts $outFH [replicate - [clength $hdr]]
 639     puts $outFH $hdr
 640     puts $outFH [replicate - [clength $hdr]]
 641
 642
 643     foreach procStack $sortedProcList {
 644         set data $sumProfData($procStack)
 645         puts $outFH [format "%-${maxNameLen}s %10d %10d %10d" $procStack \
 646                             [lindex $data 0] [lindex $data 1] [lindex $data 2]]
 647     }
 648     if {$outFile != ""} {
 649         close $outFH
 650     }
 651 }
 652
 653
 654 proc profrep {profDataVar sortKey stackDepth {outFile {}} {userTitle {}}} {
 655     upvar $profDataVar profData
 656
 657     set maxNameLen [profrep:summarize profData $stackDepth sumProfData]
 658     set sortedProcList [profrep:sort sumProfData $sortKey]
 659     profrep:print sumProfData $sortedProcList $maxNameLen $outFile $userTitle
 660
 661 }