home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / comanche.exe / lib / tclX8.0.5 / tcl.tlib < prev    next >
Text File  |  1999-02-24  |  48KB  |  1,769 lines
  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 code 0
  12.     set result {}
  13.     set searchId [array startsearch enumArray]
  14.     while {[array anymore enumArray $searchId]} {
  15.     set enumVar [array nextelement enumArray $searchId]
  16.         set code [catch {uplevel 1 $codeFragment} result]
  17.         if {$code != 0 && $code != 4} break
  18.     }
  19.     array donesearch enumArray $searchId
  20.  
  21.     if {$code == 0 || $code == 3 || $code == 4} {
  22.         return $result
  23.     }
  24.     if {$code == 1} {
  25.         global errorCode errorInfo
  26.         return -code $code -errorcode $errorCode -errorinfo $errorInfo $result
  27.     }
  28.     return -code $code $result
  29. }
  30.  
  31.  
  32.  
  33. #@package: TclX-GenCompat assign_fields cexpand
  34.  
  35. proc assign_fields {list args} {
  36.     puts stderr {**** Your program is using an obsolete TclX proc, "assign_fields".}
  37.     puts stderr {**** Please use the command "lassign". Compatibility support will}
  38.     puts stderr {**** be removed in the next release.}
  39.  
  40.     proc assign_fields {list args} {
  41.         if [lempty $args] {
  42.             return
  43.         }
  44.         return [uplevel lassign [list $list] $args]
  45.     }
  46.     return [uplevel assign_fields [list $list] $args]
  47. }
  48.  
  49. proc cexpand str {subst -nocommands -novariables $str}
  50.  
  51. #@package: TclX-ServerCompat server_open server_connect server_send \
  52.                              server_info server_cntl
  53.  
  54.  
  55. proc server_open args {
  56.     set cmd server_connect
  57.  
  58.     set buffered 1
  59.     while {[string match -* [lindex $args 0]]} {
  60.         set opt [lvarpop args]
  61.         if [cequal $opt -buf] {
  62.             set buffered 1
  63.         } elseif  [cequal $opt -nobuf] {
  64.             set buffered 0
  65.         }
  66.         lappend cmd $opt
  67.     }
  68.     set handle [uplevel [concat $cmd $args]]
  69.     if $buffered {
  70.         lappend handle [dup $handle]
  71.     }
  72.     return $handle
  73. }
  74.  
  75.  
  76. proc server_connect args {
  77.     set cmd socket
  78.  
  79.     set buffered 1
  80.     set twoids 0
  81.     while {[string match -* [lindex $args 0]]} {
  82.         switch -- [set opt [lvarpop args]] {
  83.             -buf {
  84.                 set buffered 1
  85.             }
  86.             -nobuf {
  87.                 set buffered 0
  88.             }
  89.             -myip {
  90.                 lappend cmd -myaddr [lvarpop args]
  91.             }
  92.             -myport {
  93.                 lappend cmd -myport [lvarpop args]
  94.             }
  95.             -twoids {
  96.                 set twoids 1
  97.             }
  98.             default {
  99.                 error "unknown option \"$opt\""
  100.             }
  101.         }
  102.     }
  103.     set handle [uplevel [concat $cmd $args]]
  104.     if !$buffered {
  105.         fconfigure $handle -buffering none 
  106.     }
  107.     if $twoids {
  108.         lappend handle [dup $handle]
  109.     }
  110.     return $handle
  111. }
  112.  
  113. proc server_send args {
  114.     set cmd puts
  115.  
  116.     while {[string match -* [lindex $args 0]]} {
  117.         switch -- [set opt [lvarpop args]] {
  118.             {-dontroute} {
  119.                 error "server_send if obsolete, -dontroute is not supported by the compatibility proc"
  120.             }
  121.             {-outofband} {
  122.                 error "server_send if obsolete, -outofband is not supported by the compatibility proc"
  123.             }
  124.         }
  125.         lappend cmd $opt
  126.     }
  127.     uplevel [concat $cmd $args]
  128.     flush [lindex $args 0]
  129. }
  130.  
  131. proc server_info args {
  132.     eval [concat host_info $args]
  133. }
  134.  
  135. proc server_cntl args {
  136.     eval [concat fcntl $args]
  137. }
  138.  
  139. #@package: TclX-ClockCompat fmtclock convertclock getclock
  140.  
  141.  
  142. proc fmtclock {clockval {format {}} {zone {}}} {
  143.     lappend cmd clock format $clockval
  144.     if ![lempty $format] {
  145.         lappend cmd -format $format
  146.     }
  147.     if ![lempty $zone] {
  148.         lappend cmd -gmt 1
  149.     }
  150.     return [eval $cmd]
  151. }
  152.  
  153.  
  154. proc convertclock {dateString {zone {}} {baseClock {}}} {
  155.     lappend cmd clock scan $dateString
  156.     if ![lempty $zone] {
  157.         lappend cmd -gmt 1
  158.     }
  159.     if ![lempty $baseClock] {
  160.         lappend cmd -base $baseClock
  161.     }
  162.     return [eval $cmd]
  163. }
  164.  
  165.  
  166. proc getclock {} {
  167.     return [clock seconds]
  168. }
  169.  
  170. #@package: TclX-FileCompat mkdir rmdir unlink frename
  171.  
  172.  
  173. proc mkdir args {
  174.     set path 0
  175.     if {[llength $args] > 1} {
  176.         lvarpop args
  177.         set path 1
  178.     }
  179.     foreach dir [lindex $args 0] {
  180.         if {((!$path) && [file isdirectory $dir]) || \
  181.                 ([file exists $dir] && ![file isdirectory $dir])} {
  182.             error "creating directory \"$dir\" failed: file already exists" \
  183.                     {} {POSIX EEXIST {file already exists}}
  184.         }
  185.         file mkdir $dir
  186.     }
  187.     return
  188. }
  189.  
  190.  
  191. proc rmdir args {
  192.     set nocomplain 0
  193.     if {[llength $args] > 1} {
  194.         lvarpop args
  195.         set nocomplain 1
  196.         global errorInfo errorCode
  197.         set saveErrorInfo $errorInfo
  198.         set saveErrorCode $errorCode
  199.     }
  200.     foreach dir [lindex $args 0] {
  201.         if $nocomplain {
  202.             catch {file delete $dir}
  203.         } else {
  204.             if ![file exists $dir] {
  205.                 error "can't remove \"$dir\": no such file or directory" {} \
  206.                         {POSIX ENOENT {no such file or directory}}
  207.             }
  208.             if ![cequal [file type $dir] directory] {
  209.                 error "$dir: not a directory" {} \
  210.                         {POSIX ENOTDIR {not a directory}}
  211.             }
  212.             file delete $dir
  213.         }
  214.     }
  215.     if $nocomplain {
  216.         set errorInfo $saveErrorInfo 
  217.         set errorCode $saveErrorCode
  218.     }
  219.     return
  220. }
  221.  
  222.  
  223. proc unlink args {
  224.     set nocomplain 0
  225.     if {[llength $args] > 1} {
  226.         lvarpop args
  227.         set nocomplain 1
  228.         global errorInfo errorCode
  229.         set saveErrorInfo $errorInfo
  230.         set saveErrorCode $errorCode
  231.     }
  232.     foreach file [lindex $args 0] {
  233.         if {[file exists $file] && [cequal [file type $file] directory]} {
  234.             if !$nocomplain {
  235.                 error "$file: not owner" {} {POSIX EPERM {not owner}}
  236.             }
  237.         } elseif $nocomplain {
  238.             catch {file delete $file}
  239.         } else {
  240.             if {!([file exists $file] || \
  241.                     ([catch {file readlink $file}] == 0))} {
  242.                 error "can't remove \"$file\": no such file or directory" {} \
  243.                         {POSIX ENOENT {no such file or directory}}
  244.             }
  245.             file delete $file
  246.         }
  247.     }
  248.     if $nocomplain {
  249.         set errorInfo $saveErrorInfo 
  250.         set errorCode $saveErrorCode
  251.     }
  252.     return
  253. }
  254.  
  255.  
  256. proc frename {old new} {
  257.     if {[file isdirectory $new] && ![lempty [readdir $new]]} {
  258.         error "rename \"foo\" to \"baz\" failed: directory not empty" {} \
  259.                 POSIX ENOTEMPTY {directory not empty}
  260.     }
  261.     file rename -force $old $new
  262. }
  263.  
  264.  
  265. #@package: TclX-CopyFileCompat copyfile
  266.  
  267.  
  268.  
  269. proc copyfile args {
  270.     global errorInfo errorCode
  271.  
  272.     set copyMode NORMAL
  273.     set translate 0
  274.     while {[string match -* [lindex $args 0]]} {
  275.         set opt [lvarpop args]
  276.         switch -exact -- $opt {
  277.             -bytes {
  278.                 set copyMode BYTES
  279.                 if {[llength $args] == 0} {
  280.                     error "argument required for -bytes option"
  281.                 }
  282.                 set totalBytesToRead [lvarpop args]
  283.             }
  284.             -maxbytes {
  285.                 set copyMode MAX_BYTES
  286.                 if {[llength $args] == 0} {
  287.                     error "argument required for -maxbytes option"
  288.                 }
  289.                 set totalBytesToRead [lvarpop args]
  290.             }
  291.             -translate {
  292.                 set translate 1
  293.             }
  294.             default {
  295.                 error "invalid argument \"$opt\", expected \"-bytes\",\
  296.                         \"-maxbytes\", or \"-translate\""
  297.             }
  298.         }
  299.     }
  300.     if {[llength $args] != 2} {
  301.         error "wrong # args: copyfile ?-bytes num|-maxbytes num? ?-translate?\
  302.                 fromFileId toFileId"
  303.     }
  304.     lassign $args fromFileId toFileId
  305.  
  306.     if !$translate {
  307.         set fromOptions [list \
  308.                 [fconfigure $fromFileId -translation] \
  309.                 [fconfigure $fromFileId -eofchar]]
  310.         set toOptions [list \
  311.                 [fconfigure $toFileId -translation] \
  312.                 [fconfigure $toFileId -eofchar]]
  313.  
  314.         fconfigure $fromFileId -translation binary
  315.         fconfigure $fromFileId -eofchar {}
  316.         fconfigure $toFileId -translation binary
  317.         fconfigure $toFileId -eofchar {}
  318.     }
  319.  
  320.     set cmd [list fcopy $fromFileId $toFileId]
  321.     if ![cequal $copyMode NORMAL] {
  322.         lappend cmd -size $totalBytesToRead
  323.     }
  324.     
  325.     set stat [catch {eval $cmd} totalBytesRead]
  326.     if $stat {
  327.         set saveErrorResult $totalBytesRead
  328.         set saveErrorInfo $errorInfo
  329.         set saveErrorCode $errorCode
  330.     }
  331.  
  332.     if !$translate {
  333.         # Try to restore state, even if we have an error.
  334.         if [catch {
  335.             fconfigure $fromFileId -translation [lindex $fromOptions 0]
  336.             fconfigure $fromFileId -eofchar [lindex $fromOptions 1]
  337.             fconfigure $toFileId -translation [lindex $toOptions 0]
  338.             fconfigure $toFileId -eofchar [lindex $toOptions 1]
  339.         } errorResult] {
  340.             # If fcopy did not get an error, we process this one
  341.             if !$stat {
  342.                 set stat 1
  343.                 set saveErrorResult $errorResult
  344.                 set saveErrorInfo $errorInfo
  345.                 set saveErrorCode $errorCode
  346.             }
  347.         }
  348.     }
  349.  
  350.     if $stat {
  351.         error $saveErrorResult $saveErrorInfo $saveErrorCode
  352.     }
  353.  
  354.     if {[cequal $copyMode BYTES] && ($totalBytesToRead > 0) && \
  355.             ($totalBytesRead != $totalBytesToRead)} {
  356.         error "premature EOF, $totalBytesToRead bytes expected,\
  357.                 $totalBytesRead bytes actually read"
  358.     }
  359.     return $totalBytesRead
  360. }
  361.  
  362. #@package: TclX-convertlib convert_lib
  363.  
  364. namespace eval TclX {
  365.  
  366.     #--------------------------------------------------------------------------
  367.     # ParseTclIndex
  368.     # Parse a tclIndex file, returning an array of file names with the list of
  369.     # procedures in each package. This is done by sourcing the file and then
  370.     # going through the local auto_index array that was created. Issues
  371.     # warnings for lines that can't be converted. 
  372.     # Returns 1 if all lines are converted, 0 if some failed.
  373.  
  374.     proc ParseTclIndex {tclIndex fileTblVar ignore} {
  375.         upvar $fileTblVar fileTbl
  376.         set allOK 1
  377.  
  378.         # Open and validate the file.
  379.  
  380.         set tclIndexFH [open $tclIndex r]
  381.         try_eval {
  382.             set hdr [gets $tclIndexFH]
  383.             if {!([cequal $hdr {# Tcl autoload index file, version 2.0}] ||
  384.                 [cequal $hdr == {# Tcl autoload index file, version 2.0 for [incr Tcl]}])} {
  385.                     error "can only convert version 2.0 Tcl auto-load files"
  386.                 }
  387.             set dir [file dirname $tclIndex]  ;# Expected by the script.
  388.             eval [read $tclIndexFH]
  389.         }  {} {
  390.             close $tclIndexFH
  391.         }
  392.         foreach procName [array names auto_index] {
  393.             if ![string match "source *" $auto_index($procName)] {
  394.                 puts stderr "WARNING: Can't convert load command for\
  395.                         \"$procName\": $auto_index($procName)"
  396.                 set allOK 0
  397.                 continue
  398.             }
  399.             set filePath [lindex $auto_index($procName) 1]
  400.             set fileName [file tail $filePath] 
  401.             if {[lsearch $ignore $fileName] >= 0} continue
  402.             
  403.             lappend fileTbl($filePath) $procName
  404.         }
  405.         if ![info exists fileTbl] {
  406.             error "no entries could be converted in $tclIndex"
  407.         }
  408.         return $allOK
  409.     }
  410. } ;# namespace TclX
  411.  
  412.  
  413. proc convert_lib {tclIndex packageLib {ignore {}}} {
  414.     if {[file tail $tclIndex] != "tclIndex"} {
  415.         error "Tail file name must be `tclIndex': $tclIndex"}
  416.     if ![file readable $tclIndex] {
  417.         error "File not readable: $tclIndex"
  418.     }
  419.  
  420.     # Parse the file.
  421.  
  422.     set allOK [TclX::ParseTclIndex $tclIndex fileTbl $ignore]
  423.  
  424.     # Generate the .tlib package names with contain the directory and
  425.     # file name, less any extensions.
  426.  
  427.     if {[file extension $packageLib] != ".tlib"} {
  428.         append packageLib ".tlib"
  429.     }
  430.     set libFH [open $packageLib w]
  431.  
  432.     foreach srcFile [array names fileTbl] {
  433.         set pkgName [file tail [file dirname $srcFile]]/[file tail [file root $srcFile]]
  434.         set srcFH [open $srcFile r]
  435.         puts $libFH "#@package: $pkgName $fileTbl($srcFile)\n"
  436.         copyfile $srcFH $libFH
  437.         close $srcFH
  438.     }
  439.     close $libFH
  440.     buildpackageindex $packageLib
  441.     if !$allOK {
  442.         error "*** Not all entries converted, but library generated"
  443.     }
  444. }
  445.  
  446.  
  447.  
  448. #@package: TclX-developer_utils saveprocs edprocs
  449.  
  450. proc saveprocs {fileName args} {
  451.     set fp [open $fileName w]
  452.     try_eval {
  453.         puts $fp "# tcl procs saved on [fmtclock [getclock]]\n"
  454.         puts $fp [eval "showproc $args"]
  455.     } {} {
  456.         close $fp
  457.     }
  458. }
  459.  
  460. proc edprocs {args} {
  461.     global env
  462.  
  463.     set tmpFilename /tmp/tcldev.[id process]
  464.  
  465.     set fp [open $tmpFilename w]
  466.     try_eval {
  467.         puts $fp "\n# TEMP EDIT BUFFER -- YOUR CHANGES ARE FOR THIS SESSION ONLY\n"
  468.         puts $fp [eval "showproc $args"]
  469.     } {} {
  470.         close $fp
  471.     }
  472.  
  473.     if [info exists env(EDITOR)] {
  474.         set editor $env(EDITOR)
  475.     } else {
  476.     set editor vi
  477.     }
  478.  
  479.     set startMtime [file mtime $tmpFilename]
  480.     system "$editor $tmpFilename"
  481.  
  482.     if {[file mtime $tmpFilename] != $startMtime} {
  483.     source $tmpFilename
  484.     echo "Procedures were reloaded."
  485.     } else {
  486.     echo "No changes were made."
  487.     }
  488.     unlink $tmpFilename
  489.     return
  490. }
  491.  
  492.  
  493.  
  494. #@package: TclX-events mainloop
  495.  
  496. proc mainloop {} {
  497.     global tcl_interactive
  498.  
  499.     if {[info exists tcl_interactive] && $tcl_interactive} {
  500.         commandloop -async -interactive on -endcommand exit
  501.     }
  502.     set loopVar 0
  503.     catch {vwait loopVar}
  504.     exit
  505. }
  506.  
  507.  
  508.  
  509. #@package: TclX-forfile for_file
  510.  
  511. proc for_file {var filename cmd} {
  512.     upvar $var line
  513.     set fp [open $filename r]
  514.     try_eval {
  515.         set code 0
  516.         set result {}
  517.         while {[gets $fp line] >= 0} {
  518.             set code [catch {uplevel 1 $cmd} result]
  519.             if {$code != 0 && $code != 4} break
  520.         }
  521.     } {} {
  522.         close $fp
  523.     }
  524.  
  525.     if {$code == 0 || $code == 3 || $code == 4} {
  526.         return $result
  527.     }
  528.     if {$code == 1} {
  529.         global errorCode errorInfo
  530.         return -code $code -errorcode $errorCode -errorinfo $errorInfo $result
  531.     }
  532.     return -code $code $result
  533. }
  534.  
  535.  
  536.  
  537. #@package: TclX-globrecur recursive_glob
  538.  
  539. proc recursive_glob {dirlist globlist} {
  540.     set result {}
  541.     set recurse {}
  542.     foreach dir $dirlist {
  543.         if ![file isdirectory $dir] {
  544.             error "\"$dir\" is not a directory"
  545.         }
  546.         foreach pattern $globlist {
  547.             set result [concat $result \
  548.                     [glob -nocomplain -- [file join $dir $pattern]]]
  549.         }
  550.         foreach file [readdir $dir] {
  551.             set file [file join $dir $file]
  552.             if [file isdirectory $file] {
  553.                 set fileTail [file tail $file]
  554.                 if {!([cequal $fileTail .] || [cequal $fileTail ..])} {
  555.                     lappend recurse $file
  556.                 }
  557.             }
  558.         }
  559.     }
  560.     if ![lempty $recurse] {
  561.         set result [concat $result [recursive_glob $recurse $globlist]]
  562.     }
  563.     return $result
  564. }
  565.  
  566. #@package: TclX-forrecur for_recursive_glob
  567.  
  568. proc for_recursive_glob {var dirlist globlist cmd {depth 1}} {
  569.     upvar $depth $var myVar
  570.     set recurse {}
  571.     foreach dir $dirlist {
  572.         if ![file isdirectory $dir] {
  573.             error "\"$dir\" is not a directory"
  574.         }
  575.         set code 0
  576.         set result {}
  577.         foreach pattern $globlist {
  578.             foreach file [glob -nocomplain -- [file join $dir $pattern]] {
  579.                 set myVar $file
  580.                 set code [catch {uplevel $depth $cmd} result]
  581.                 if {$code != 0 && $code != 4} break
  582.             }
  583.             if {$code != 0 && $code != 4} break
  584.         }
  585.         if {$code != 0 && $code != 4} {
  586.             if {$code == 3} {
  587.                 return $result
  588.             }
  589.             if {$code == 1} {
  590.                 global errorCode errorInfo
  591.                 return -code $code -errorcode $errorCode \
  592.                         -errorinfo $errorInfo $result
  593.             }
  594.             return -code $code $result
  595.         }
  596.  
  597.         foreach file [readdir $dir] {
  598.             set file [file join $dir $file]
  599.             if [file isdirectory $file] {
  600.                 set fileTail [file tail $file]
  601.                 if {!([cequal $fileTail .] || [cequal $fileTail ..])} {
  602.                     lappend recurse $file
  603.                 }
  604.             }
  605.         }
  606.     }
  607.     if ![lempty $recurse] {
  608.         return [for_recursive_glob $var $recurse $globlist $cmd \
  609.                     [expr $depth + 1]]
  610.     }
  611.     return {}
  612. }
  613.  
  614.  
  615.  
  616. #@package: TclX-help help helpcd helppwd apropos
  617.  
  618. namespace eval TclXHelp {
  619.  
  620.     # Determine the path separator.
  621.     switch $::tcl_platform(platform) {
  622.         unix {
  623.             variable pathSep /
  624.         }
  625.         windows {
  626.             variable pathSep \\
  627.         }
  628.         macintosh {
  629.             variable pathSep :
  630.         }
  631.         default {
  632.             error "unknown platform \"$::tcl_platform(platform)\""
  633.         }
  634.     }
  635.  
  636.     variable curSubject $pathSep
  637.  
  638.     #----------------------------------------------------------------------
  639.     # Return a list of help root directories.
  640.  
  641.     proc RootDirs {} {
  642.         global auto_path
  643.         set roots {}
  644.         foreach dir $auto_path {
  645.             set fname [file join $dir help]
  646.             if {[file isdirectory $fname]} {
  647.                 lappend roots $fname
  648.             }
  649.         }
  650.         return $roots
  651.     }
  652.  
  653.     #--------------------------------------------------------------------------
  654.     # Take a path name which might have "." and ".." elements and flatten them
  655.     # out.  Also removes trailing and adjacent "/", unless its the only
  656.     # character.
  657.  
  658.     proc NormalizePath helpFile {
  659.         variable pathSep
  660.         set newPath {}
  661.         foreach element [file split $helpFile] {
  662.             if {[cequal $element  .] || [lempty $element]} continue
  663.  
  664.             if {[cequal $element ..]} {
  665.                 if {[llength [file join $newPath]] == 0} {
  666.                     error "Help: name goes above subject directory root" {} \
  667.                         [list TCLXHELP NAMEABOVEROOT $helpFile]
  668.                 }
  669.                 lvarpop newPath [expr {[llength $newPath]-1}]
  670.             } else {
  671.                 lappend newPath $element
  672.             }
  673.             
  674.         }
  675.         set newPath [eval file join $newPath]
  676.  
  677.         # Take care of the case where we started with something line "/" or "/."
  678.         if {[lempty $newPath] && [cequal [file pathtype $helpFile] absolute]} {
  679.             set newPath $pathSep
  680.         }
  681.  
  682.         return $newPath
  683.     }
  684.  
  685.     #--------------------------------------------------------------------------
  686.     # Given a helpFile relative to the virtual help root, convert it to a list
  687.     # of real file paths.  A list is returned because the path could be "/",
  688.     # returning a list of all roots. The list is returned in the same order of
  689.     # the auto_path variable. If path does not start with a "/", it is take as
  690.     # relative to the current help subject.  Note: The root directory part of
  691.     # the name is not flattened.  This lets other commands pick out the part
  692.     # relative to the one of the root directories.
  693.  
  694.     proc ConvertHelpFile helpFile {
  695.         variable curSubject
  696.         variable pathSep
  697.  
  698.         if {![cequal [file pathtype $helpFile] absolute]} {
  699.             if {[cequal $curSubject $pathSep]} {
  700.                 set helpFile [file join $pathSep $helpFile]
  701.             } else {
  702.                 set helpFile [file join $curSubject $helpFile]
  703.             }
  704.         }
  705.         set helpFile [NormalizePath $helpFile]
  706.  
  707.         # If the virtual root is specified, return a list of directories.
  708.  
  709.         if {[cequal $helpFile $pathSep]} {
  710.             return [RootDirs]
  711.         }
  712.  
  713.         # Make help file name into a relative path for joining with real
  714.         # root.
  715.         set helpFile [eval file join [lrange [file split $helpFile] 1 end]]
  716.  
  717.         # Search for the first match.
  718.         foreach dir [RootDirs] {
  719.             set fname [file join $dir $helpFile]
  720.             if {[file readable $fname]} {
  721.                 return [list $fname]
  722.             }
  723.         }
  724.  
  725.     # Not found, try to find a file matching only the file tail,
  726.     # for example if --> <helpDir>/tcl/control/if.
  727.  
  728.     set fileTail [file tail $helpFile]
  729.         foreach dir [RootDirs] {
  730.         set fileName [recursive_glob $dir $fileTail]
  731.         if {![lempty $fileName]} {
  732.                 return [list $fileName]
  733.         }
  734.     }
  735.  
  736.         error "\"$helpFile\" does not exist" {} \
  737.             [list TCLXHELP NOEXIST $helpFile]
  738.     }
  739.  
  740.     #--------------------------------------------------------------------------
  741.     # Return the virtual root relative name of the file given its absolute
  742.     # path.  The root part of the path should not have been normalized, as we
  743.     # would not be able to match it.
  744.  
  745.     proc RelativePath helpFile {
  746.         variable pathSep
  747.         foreach dir [RootDirs] {
  748.             if {[cequal [csubstr $helpFile 0 [clength $dir]] $dir]} {
  749.                 set name [csubstr $helpFile [clength $dir] end]
  750.                 if {[lempty $name]} {
  751.                     set name $pathSep
  752.                 }
  753.                 return $name
  754.             }
  755.         }
  756.         if {![info exists found]} {
  757.             error "problem translating \"$helpFile\"" {} [list TCLXHELP INTERROR]
  758.         }
  759.     }
  760.  
  761.     #--------------------------------------------------------------------------
  762.     # Given a list of path names to subjects generated by ConvertHelpFile, return
  763.     # the contents of the subjects.  Two lists are returned, subjects under
  764.     # that subject and a list of pages under the subject.  Both lists are
  765.     # returned sorted.  This merges all the roots into a virtual root.
  766.     # helpFile is the string that was passed to ConvertHelpFile and is used for
  767.     # error reporting.  *.brk files are not returned.
  768.  
  769.     proc ListSubject {helpFile pathList subjectsVar pagesVar} {
  770.         upvar $subjectsVar subjects $pagesVar pages
  771.         variable pathSep
  772.  
  773.         set subjects {}
  774.         set pages {}
  775.         set foundDir 0
  776.         foreach dir $pathList {
  777.             if {![file isdirectory $dir]} continue
  778.             if {[cequal [file tail $dir] CVS]} continue
  779.             set foundDir 1
  780.             foreach file [glob -nocomplain [file join $dir *]] {
  781.                 if {[lsearch {.brf .orig .diff .rej} [file extension $file]] \
  782.                         >= 0} continue
  783.                 if {[file isdirectory $file]} {
  784.                     lappend subjects [file tail $file]$pathSep
  785.                 } else {
  786.                     lappend pages [file tail $file]
  787.                 }
  788.             }
  789.         }
  790.         if {!$foundDir} {
  791.             if {[cequal $helpFile $pathSep]} {
  792.                 global auto_path
  793.                 error "no \"help\" directories found on auto_path ($auto_path)" {} \
  794.                     [list TCLXHELP NOHELPDIRS]
  795.             } else {
  796.                 error "\"$helpFile\" is not a subject" {} \
  797.                     [list TCLXHELP NOTSUBJECT $helpFile]
  798.             }
  799.         }
  800.         set subjects [lsort $subjects]
  801.         set pages [lsort $pages]
  802.         return {}
  803.     }
  804.  
  805.     #--------------------------------------------------------------------------
  806.     # Display a line of output, pausing waiting for input before displaying if
  807.     # the screen size has been reached.  Return 1 if output is to continue,
  808.     # return 0 if no more should be outputed, indicated by input other than
  809.     # return.
  810.  
  811.     proc Display line {
  812.         variable lineCnt
  813.         if {$lineCnt >= 23} {
  814.             set lineCnt 0
  815.             puts -nonewline stdout ":"
  816.             flush stdout
  817.             gets stdin response
  818.             if {![lempty $response]} {
  819.                 return 0}
  820.         }
  821.         puts stdout $line
  822.         incr lineCnt
  823.     }
  824.  
  825.     #--------------------------------------------------------------------------
  826.     # Display a help page (file).
  827.  
  828.     proc DisplayPage filePath {
  829.  
  830.         set inFH [open $filePath r]
  831.         try_eval {
  832.             while {[gets $inFH fileBuf] >= 0} {
  833.                 if {![Display $fileBuf]} {
  834.                     break
  835.                 }
  836.             }
  837.         } {} {
  838.             close $inFH
  839.         }
  840.     }
  841.  
  842.     #--------------------------------------------------------------------------
  843.     # Display a list of file names in a column format. This use columns of 14 
  844.     # characters 3 blanks.
  845.  
  846.     proc DisplayColumns {nameList} {
  847.         set count 0
  848.         set outLine ""
  849.         foreach name $nameList {
  850.             if {$count == 0} {
  851.                 append outLine "   "}
  852.             append outLine $name
  853.             if {[incr count] < 4} {
  854.                 set padLen [expr {17-[clength $name]}]
  855.                 if {$padLen < 3} {
  856.                    set padLen 3}
  857.                 append outLine [replicate " " $padLen]
  858.             } else {
  859.                if {![Display $outLine]} {
  860.                    return}
  861.                set outLine ""
  862.                set count 0
  863.             }
  864.         }
  865.         if {$count != 0} {
  866.             Display [string trimright $outLine]}
  867.         return
  868.     }
  869.  
  870.  
  871.     #--------------------------------------------------------------------------
  872.     # Display help on help, the first occurance of a help page called "help" in
  873.     # the help root.
  874.  
  875.     proc HelpOnHelp {} {
  876.         variable pathSep
  877.         set helpPage [lindex [ConvertHelpFile ${pathSep}help] 0]
  878.         if {[lempty $helpPage]} {
  879.             error "No help page on help found" {} \
  880.                 [list TCLXHELP NOHELPPAGE]
  881.         }
  882.         DisplayPage $helpPage
  883.     }
  884.  
  885. };# namespace TclXHelp
  886.  
  887.  
  888.  
  889. proc help {{what {}}} {
  890.     variable ::TclXHelp::lineCnt 0
  891.  
  892.     # Special case "help help", so we can get it at any level.
  893.  
  894.     if {($what == "help") || ($what == "?")} {
  895.         TclXHelp::HelpOnHelp
  896.         return
  897.     }
  898.  
  899.     set pathList [TclXHelp::ConvertHelpFile $what]
  900.     if {[file isfile [lindex $pathList 0]]} {
  901.         TclXHelp::DisplayPage [lindex $pathList 0]
  902.         return
  903.     }
  904.  
  905.     TclXHelp::ListSubject $what $pathList subjects pages
  906.     set relativeDir [TclXHelp::RelativePath [lindex $pathList 0]]
  907.  
  908.     if {[llength $subjects] != 0} {
  909.         TclXHelp::Display "\nSubjects available in $relativeDir:"
  910.         TclXHelp::DisplayColumns $subjects
  911.     }
  912.     if {[llength $pages] != 0} {
  913.         TclXHelp::Display "\nHelp pages available in $relativeDir:"
  914.         TclXHelp::DisplayColumns $pages
  915.     }
  916. }
  917.  
  918.  
  919.  
  920. proc helpcd {{dir {}}} {
  921.     variable ::TclXHelp::curSubject
  922.     if {[lempty $dir]} {
  923.         set dir $TclXHelp::pathSep
  924.     }
  925.  
  926.     set helpFile [lindex [TclXHelp::ConvertHelpFile $dir] 0]
  927.  
  928.     if {![file isdirectory $helpFile]} {
  929.         error "\"$dir\" is not a subject" \
  930.             [list TCLXHELP NOTSUBJECT $dir]
  931.     }
  932.  
  933.     set ::TclXHelp::curSubject [TclXHelp::RelativePath $helpFile]
  934.     return
  935. }
  936.  
  937.  
  938. proc helppwd {} {
  939.     variable ::TclXHelp::curSubject
  940.     echo "Current help subject: $::TclXHelp::curSubject"
  941. }
  942.  
  943.  
  944. proc apropos {regexp} {
  945.     variable ::TclXHelp::lineCnt 0
  946.     variable ::TclXHelp::curSubject
  947.  
  948.     set ch [scancontext create]
  949.     scanmatch -nocase $ch $regexp {
  950.         set path [lindex $matchInfo(line) 0]
  951.         set desc [lrange $matchInfo(line) 1 end]
  952.         if {![TclXHelp::Display [format "%s - %s" $path $desc]]} {
  953.             set stop 1
  954.             return}
  955.     }
  956.     set stop 0
  957.     foreach dir [TclXHelp::RootDirs] {
  958.         foreach brief [glob -nocomplain [file join $dir *.brf]] {
  959.             set briefFH [open $brief]
  960.             try_eval {
  961.                 scanfile $ch $briefFH
  962.             } {} {
  963.                 close $briefFH
  964.             }
  965.             if {$stop} break
  966.         }
  967.         if {$stop} break
  968.     }
  969.     scancontext delete $ch
  970. }
  971.  
  972. #@package: TclX-profrep profrep
  973.  
  974. namespace eval TclXProfRep {
  975.  
  976.     # Convert the profile array from entries that have only the time spent in
  977.     # the proc to the time spend in the proc and all it calls.
  978.     proc sum {inDataVar outDataVar} {
  979.         upvar 1 $inDataVar inData $outDataVar outData
  980.  
  981.         foreach inStack [array names inData] {
  982.             for {set idx 0} {![lempty [set part [lrange $inStack $idx end]]]} \
  983.                     {incr idx} {
  984.                 if ![info exists outData($part)] {
  985.                     set outData($part) {0 0 0}
  986.                 }
  987.                 lassign $outData($part) count real cpu
  988.                 if {$idx == 0} {
  989.                     incr count [lindex $inData($inStack) 0]
  990.                 }
  991.                 incr real [lindex $inData($inStack) 1]
  992.                 incr cpu [lindex $inData($inStack) 2]
  993.                 set outData($part) [list $count $real $cpu]
  994.             }
  995.         }
  996.     }
  997.  
  998.     # Do sort comparison.  May only be called by sort, as it address its
  999.     # local variables.
  1000.     proc sortcmp {key1 key2} {
  1001.         upvar profData profData keyIndex keyIndex
  1002.  
  1003.         set val1 [lindex $profData($key1) $keyIndex]
  1004.         set val2 [lindex $profData($key2) $keyIndex]
  1005.  
  1006.         if {$val1 < $val2} {
  1007.             return -1
  1008.         }
  1009.         if {$val1 > $val2} {
  1010.             return 1
  1011.         }
  1012.         return 0
  1013.     }
  1014.  
  1015.     # Generate a list, sorted in descending order by the specified key, contain
  1016.     # the indices into the summarized data.
  1017.     proc sort {profDataVar sortKey} {
  1018.         upvar $profDataVar profData
  1019.  
  1020.         case $sortKey {
  1021.             {calls} {set keyIndex 0}
  1022.             {real}  {set keyIndex 1}
  1023.             {cpu}   {set keyIndex 2}
  1024.             default {
  1025.                 error "Expected a sort type of: `calls', `cpu' or ` real'"
  1026.             }
  1027.         }
  1028.  
  1029.         return [lsort -integer -decreasing -command sortcmp \
  1030.                 [array names profData]]
  1031.     }
  1032.  
  1033.     # Print the sorted report
  1034.     proc print {profDataVar sortedProcList outFile userTitle} {
  1035.         upvar $profDataVar profData
  1036.  
  1037.         set maxNameLen 0
  1038.         foreach procStack [array names profData] {
  1039.             foreach procName $procStack {
  1040.                 set maxNameLen [max $maxNameLen [clength $procName]]
  1041.             }
  1042.         }
  1043.  
  1044.         if {$outFile == ""} {
  1045.             set outFH stdout
  1046.         } else {
  1047.             set outFH [open $outFile w]
  1048.         }
  1049.  
  1050.         # Output a header.
  1051.  
  1052.         set stackTitle "Procedure Call Stack"
  1053.         set maxNameLen [max [expr $maxNameLen+6] [expr [clength $stackTitle]+4]]
  1054.         set hdr [format "%-${maxNameLen}s %10s %10s %10s" $stackTitle \
  1055.                         "Calls" "Real Time" "CPU Time"]
  1056.         if {$userTitle != ""} {
  1057.             puts $outFH [replicate - [clength $hdr]]
  1058.             puts $outFH $userTitle
  1059.         }
  1060.         puts $outFH [replicate - [clength $hdr]]
  1061.         puts $outFH $hdr
  1062.         puts $outFH [replicate - [clength $hdr]]
  1063.  
  1064.         # Output the data in sorted order.  Trim leading ::.
  1065.  
  1066.         foreach procStack $sortedProcList {
  1067.             set data $profData($procStack)
  1068.             set cmd [lvarpop procStack]
  1069.             regsub {^::} $cmd {} cmd
  1070.             puts $outFH [format "%-${maxNameLen}s %10d %10d %10d" \
  1071.                                 $cmd [lindex $data 0] [lindex $data 1] \
  1072.                                 [lindex $data 2]]
  1073.             foreach procName $procStack {
  1074.                 if {$procName == "<global>"} break
  1075.                 regsub {^::} $procName {} procName
  1076.                 puts $outFH "    $procName"
  1077.             }
  1078.         }
  1079.         if {$outFile != ""} {
  1080.             close $outFH
  1081.         }
  1082.     }
  1083.  
  1084. } ;# TclXProfRep
  1085.  
  1086.  
  1087. proc profrep {profDataVar sortKey {outFile {}} {userTitle {}}} {
  1088.     upvar $profDataVar profData
  1089.  
  1090.     TclXProfRep::sum profData sumProfData
  1091.     set sortedProcList [TclXProfRep::sort sumProfData $sortKey]
  1092.     TclXProfRep::print sumProfData $sortedProcList $outFile $userTitle
  1093. }
  1094.  
  1095.  
  1096.  
  1097. #@package: TclX-directory_stack pushd popd dirs
  1098.  
  1099. global TCLXENV(dirPushList)
  1100.  
  1101. set TCLXENV(dirPushList) ""
  1102.  
  1103. proc pushd {{new ""}} {
  1104.     global TCLXENV
  1105.  
  1106.     set current [pwd]
  1107.     if {[clength $new] > 0} {
  1108.         set dirs [glob -nocomplain $new]
  1109.         set count [llength $dirs]
  1110.         if {$count == 0} {
  1111.             error "no such directory: $new"
  1112.         } elseif {$count != 1} {
  1113.             error "ambiguous directory: $new: [join $directories ", "]"
  1114.         }
  1115.         cd [lindex $dirs 0]
  1116.         lvarpush TCLXENV(dirPushList) $current
  1117.     } else {
  1118.         if [lempty $TCLXENV(dirPushList)] {
  1119.             error "directory stack empty"
  1120.         }
  1121.         cd [lindex $TCLXENV(dirPushList) 0]
  1122.         lvarpop TCLXENV(dirPushList)
  1123.         lvarpush TCLXENV(dirPushList) $current
  1124.     }
  1125.     return [pwd]
  1126. }
  1127.  
  1128. proc popd {} {
  1129.     global TCLXENV
  1130.  
  1131.     if [lempty $TCLXENV(dirPushList)] {
  1132.         error "directory stack empty"
  1133.     }
  1134.     cd [lvarpop TCLXENV(dirPushList)]
  1135.     return [pwd]
  1136. }
  1137.  
  1138. proc dirs {} { 
  1139.     global TCLXENV
  1140.     return [concat [list [pwd]] $TCLXENV(dirPushList)]
  1141. }
  1142.  
  1143.  
  1144.  
  1145. #@package: TclX-set_functions union intersect intersect3 lrmdups
  1146.  
  1147. proc union {lista listb} {
  1148.     return [lrmdups [concat $lista $listb]]
  1149. }
  1150.  
  1151. proc lrmdups list {
  1152.     if [lempty $list] {
  1153.         return {}
  1154.     }
  1155.     set list [lsort $list]
  1156.     set last [lvarpop list]
  1157.     lappend result $last
  1158.     foreach element $list {
  1159.     if ![cequal $last $element] {
  1160.         lappend result $element
  1161.         set last $element
  1162.     }
  1163.     }
  1164.     return $result
  1165. }
  1166.  
  1167.  
  1168. proc intersect3 {list1 list2} {
  1169.     set la1(0) {} ; unset la1(0)
  1170.     set lai(0) {} ; unset lai(0)
  1171.     set la2(0) {} ; unset la2(0)
  1172.     foreach v $list1 {
  1173.         set la1($v) {}
  1174.     }
  1175.     foreach v $list2 {
  1176.         set la2($v) {}
  1177.     }
  1178.     foreach elem [concat $list1 $list2] {
  1179.         if {[info exists la1($elem)] && [info exists la2($elem)]} {
  1180.             unset la1($elem)
  1181.             unset la2($elem)
  1182.             set lai($elem) {}
  1183.         }
  1184.     }
  1185.     list [lsort [array names la1]] [lsort [array names lai]] \
  1186.          [lsort [array names la2]]
  1187. }
  1188.  
  1189. proc intersect {list1 list2} {
  1190.     set intersectList ""
  1191.  
  1192.     set list1 [lsort $list1]
  1193.     set list2 [lsort $list2]
  1194.  
  1195.     while {1} {
  1196.         if {[lempty $list1] || [lempty $list2]} break
  1197.  
  1198.         set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
  1199.  
  1200.         if {$compareResult < 0} {
  1201.             lvarpop list1
  1202.             continue
  1203.         }
  1204.  
  1205.         if {$compareResult > 0} {
  1206.             lvarpop list2
  1207.             continue
  1208.         }
  1209.  
  1210.         lappend intersectList [lvarpop list1]
  1211.         lvarpop list2
  1212.     }
  1213.     return $intersectList
  1214. }
  1215.  
  1216.  
  1217.  
  1218.  
  1219.  
  1220. #@package: TclX-showproc showproc
  1221.  
  1222. proc showproc args {
  1223.     if [lempty $args] {
  1224.         set args [info procs]
  1225.     }
  1226.     set out {}
  1227.  
  1228.     foreach procname $args {
  1229.         if [lempty [info procs $procname]] {
  1230.             auto_load $procname
  1231.         }
  1232.         set arglist [info args $procname]
  1233.         set nargs {}
  1234.         while {[llength $arglist] > 0} {
  1235.             set varg [lvarpop arglist 0]
  1236.             if [info default $procname $varg defarg] {
  1237.                 lappend nargs [list $varg $defarg]
  1238.             } else {
  1239.                 lappend nargs $varg
  1240.             }
  1241.         }
  1242.         append out "proc $procname [list $nargs] \{[info body $procname]\}\n"
  1243.     }
  1244.     return $out
  1245. }
  1246.  
  1247.  
  1248.  
  1249. #@package: TclX-stringfile_functions read_file write_file
  1250.  
  1251. proc read_file {fileName args} {
  1252.     if {$fileName == "-nonewline"} {
  1253.         set flag $fileName
  1254.         set fileName [lvarpop args]
  1255.     } else {
  1256.         set flag {}
  1257.     }
  1258.     set fp [open $fileName]
  1259.     try_eval {
  1260.         set result [eval read $flag $fp $args]
  1261.     } {} {
  1262.         close $fp
  1263.     }
  1264.     return $result
  1265. } 
  1266.  
  1267. proc write_file {fileName args} {
  1268.     set fp [open $fileName w]
  1269.     try_eval {
  1270.         foreach string $args {
  1271.             puts $fp $string
  1272.         }
  1273.     } {} {
  1274.         close $fp
  1275.     }
  1276. }
  1277.  
  1278.  
  1279.  
  1280.  
  1281. #@package: TclX-libraries searchpath auto_load_file
  1282.  
  1283. proc searchpath {pathlist file} {
  1284.     foreach dir $pathlist {
  1285.         if {$dir == ""} {set dir .}
  1286.         if {[catch {file exists $dir/$file} result] == 0 && $result}  {
  1287.             return $dir/$file
  1288.         }
  1289.     }
  1290.     return {}
  1291. }
  1292.  
  1293. proc auto_load_file {name} {
  1294.     global auto_path errorCode
  1295.     if {[string first / $name] >= 0} {
  1296.         return  [uplevel 1 source $name]
  1297.     }
  1298.     set where [searchpath $auto_path $name]
  1299.     if [lempty $where] {
  1300.         error "couldn't find $name in any directory in auto_path"
  1301.     }
  1302.     uplevel 1 source $where
  1303. }
  1304.  
  1305. #@package: TclX-lib-list auto_packages auto_commands
  1306.  
  1307.  
  1308. proc auto_packages {{option {}}} {
  1309.     global auto_pkg_index
  1310.  
  1311.     auto_load  ;# Make sure all indexes are loaded.
  1312.     if ![info exists auto_pkg_index] {
  1313.         return {}
  1314.     }
  1315.     
  1316.     set packList [array names auto_pkg_index] 
  1317.     if [lempty $option] {
  1318.         return $packList
  1319.     }
  1320.  
  1321.     if {$option != "-files"} {
  1322.         error "Unknow option \"$option\", expected \"-files\""
  1323.     }
  1324.     set locList {}
  1325.     foreach pack $packList {
  1326.         lappend locList [list $pack [lindex $auto_pkg_index($pack) 0]]
  1327.     }
  1328.     return $locList
  1329. }
  1330.  
  1331.  
  1332. proc auto_commands {{option {}}} {
  1333.     global auto_index
  1334.  
  1335.     auto_load  ;# Make sure all indexes are loaded.
  1336.     if ![info exists auto_index] {
  1337.         return {}
  1338.     }
  1339.     
  1340.     set cmdList [array names auto_index] 
  1341.     if [lempty $option] {
  1342.         return $cmdList
  1343.     }
  1344.  
  1345.     if {$option != "-loaders"} {
  1346.         error "Unknow option \"$option\", expected \"-loaders\""
  1347.     }
  1348.     set loadList {}
  1349.     foreach cmd $cmdList {
  1350.         lappend loadList [list $cmd $auto_index($cmd)]
  1351.     }
  1352.     return $loadList
  1353. }
  1354.  
  1355.  
  1356.  
  1357.  
  1358. #@package: TclX-fmath acos asin atan ceil cos cosh exp fabs floor log log10 \
  1359.            sin sinh sqrt tan tanh fmod pow atan2 abs double int round
  1360.  
  1361. proc acos  x {uplevel [list expr acos($x)]}
  1362. proc asin  x {uplevel [list expr asin($x)]}
  1363. proc atan  x {uplevel [list expr atan($x)]}
  1364. proc ceil  x {uplevel [list expr ceil($x)]}
  1365. proc cos   x {uplevel [list expr cos($x)]}
  1366. proc cosh  x {uplevel [list expr cosh($x)]}
  1367. proc exp   x {uplevel [list expr exp($x)]}
  1368. proc fabs  x {uplevel [list expr abs($x)]}
  1369. proc floor x {uplevel [list expr floor($x)]}
  1370. proc log   x {uplevel [list expr log($x)]}
  1371. proc log10 x {uplevel [list expr log10($x)]}
  1372. proc sin   x {uplevel [list expr sin($x)]}
  1373. proc sinh  x {uplevel [list expr sinh($x)]}
  1374. proc sqrt  x {uplevel [list expr sqrt($x)]}
  1375. proc tan   x {uplevel [list expr tan($x)]}
  1376. proc tanh  x {uplevel [list expr tanh($x)]}
  1377.  
  1378. proc fmod {x n} {uplevel [list expr fmod($x,$n)]}
  1379. proc pow {x n} {uplevel [list expr pow($x,$n)]}
  1380.  
  1381.  
  1382. proc atan2  x {uplevel [list expr atan2($x)]}
  1383. proc abs    x {uplevel [list expr abs($x)]}
  1384. proc double x {uplevel [list expr double($x)]}
  1385. proc int    x {uplevel [list expr int($x)]}
  1386. proc round  x {uplevel [list expr round($x)]}
  1387.  
  1388.  
  1389.  
  1390.  
  1391. #@package: TclX-buildhelp buildhelp
  1392.  
  1393. proc TruncFileName {pathName} {
  1394.     global truncFileNames
  1395.  
  1396.     if {!$truncFileNames} {
  1397.         return $pathName}
  1398.     set fileName [file tail $pathName]
  1399.     if {"[crange $fileName 0 3]" == "Tcl_"} {
  1400.         set fileName [crange $fileName 4 end]}
  1401.     set fileName [crange $fileName 0 13]
  1402.     return "[file dirname $pathName]/$fileName"
  1403. }
  1404.  
  1405.  
  1406. proc EnsureDirs {filePath} {
  1407.     set dirPath [file dirname $filePath]
  1408.     if [file exists $dirPath] return
  1409.     foreach dir [split $dirPath /] {
  1410.         lappend dirList $dir
  1411.         set partPath [join $dirList /]
  1412.         if [file exists $partPath] continue
  1413.  
  1414.         mkdir $partPath
  1415.         chmod u=rwx,go=rx $partPath
  1416.     }
  1417. }
  1418.  
  1419.  
  1420. proc CreateFilterNroffManPageContext {} {
  1421.     global filterNroffManPageContext
  1422.  
  1423.     set filterNroffManPageContext [scancontext create]
  1424.  
  1425.     # On finding a page header, drop the previous line (which is
  1426.     # the page footer). Also deleting the blank lines followin
  1427.     # the last line on the previous page.
  1428.  
  1429.     scanmatch $filterNroffManPageContext {@@@BUILDHELP@@@} {
  1430.         catch {unset prev2Blanks}
  1431.         catch {unset prev1Line}
  1432.         catch {unset prev1Blanks}
  1433.         set nukeBlanks {}
  1434.     }
  1435.  
  1436.     # Save blank lines
  1437.  
  1438.     scanmatch $filterNroffManPageContext {$^} {
  1439.         if ![info exists nukeBlanks] {
  1440.             append prev1Blanks \n
  1441.         }
  1442.     }
  1443.  
  1444.     # Non-blank line, save it.  Output the 2nd previous line if necessary.
  1445.  
  1446.     scanmatch $filterNroffManPageContext {
  1447.         catch {unset nukeBlanks}
  1448.         if [info exists prev2Line] {
  1449.             puts $outFH $prev2Line
  1450.             unset prev2Line
  1451.         }
  1452.         if [info exists prev2Blanks] {
  1453.             puts $outFH $prev2Blanks nonewline
  1454.             unset prev2Blanks
  1455.         }
  1456.         if [info exists prev1Line] {
  1457.             set prev2Line $prev1Line
  1458.         }
  1459.         set prev1Line $matchInfo(line)
  1460.         if [info exists prev1Blanks] {
  1461.             set prev2Blanks $prev1Blanks
  1462.             unset prev1Blanks
  1463.         }
  1464.     }
  1465. }
  1466.  
  1467.  
  1468. proc FilterNroffManPage {inFH outFH} {
  1469.     global filterNroffManPageContext
  1470.  
  1471.     if ![info exists filterNroffManPageContext] {
  1472.         CreateFilterNroffManPageContext
  1473.     }
  1474.  
  1475.     scanfile $filterNroffManPageContext $inFH
  1476.  
  1477.     if [info exists prev2Line] {
  1478.         puts $outFH $prev2Line
  1479.     }
  1480. }
  1481.  
  1482.  
  1483. proc CreateExtractNroffHeaderContext {} {
  1484.     global extractNroffHeaderContext
  1485.  
  1486.     set extractNroffHeaderContext [scancontext create]
  1487.  
  1488.     scanmatch $extractNroffHeaderContext {'\\"@endheader[     ]*$} {
  1489.         break
  1490.     }
  1491.     scanmatch $extractNroffHeaderContext {'\\"@:} {
  1492.         append nroffHeader "[crange $matchInfo(line) 5 end]\n"
  1493.     }
  1494.     scanmatch $extractNroffHeaderContext {
  1495.         append nroffHeader "$matchInfo(line)\n"
  1496.     }
  1497. }
  1498.  
  1499.  
  1500. proc ExtractNroffHeader {manPageFH} {
  1501.     global extractNroffHeaderContext nroffHeader
  1502.  
  1503.     if ![info exists extractNroffHeaderContext] {
  1504.         CreateExtractNroffHeaderContext
  1505.     }
  1506.     scanfile $extractNroffHeaderContext $manPageFH
  1507. }
  1508.  
  1509.  
  1510.  
  1511. proc CreateExtractNroffHelpContext {} {
  1512.     global extractNroffHelpContext
  1513.  
  1514.     set extractNroffHelpContext [scancontext create]
  1515.  
  1516.     scanmatch $extractNroffHelpContext {^'\\"@endhelp[     ]*$} {
  1517.         break
  1518.     }
  1519.  
  1520.     scanmatch $extractNroffHelpContext {^'\\"@brief:} {
  1521.         if $foundBrief {
  1522.             error {Duplicate "@brief:" entry}
  1523.         }
  1524.         set foundBrief 1
  1525.         puts $briefHelpFH "$helpName\t[csubstr $matchInfo(line) 11 end]"
  1526.         continue
  1527.     }
  1528.  
  1529.     scanmatch $extractNroffHelpContext {^'\\"@:} {
  1530.         puts $nroffFH  [csubstr $matchInfo(line) 5 end]
  1531.         continue
  1532.     }
  1533.     scanmatch $extractNroffHelpContext {^'\\"@help:} {
  1534.         error {"@help" found within another help section"}
  1535.     }
  1536.     scanmatch $extractNroffHelpContext {
  1537.         puts $nroffFH $matchInfo(line)
  1538.     }
  1539. }
  1540.  
  1541.  
  1542. proc ExtractNroffHelp {manPageFH manLine} {
  1543.     global helpDir nroffHeader briefHelpFH colArgs
  1544.     global extractNroffHelpContext
  1545.  
  1546.     if ![info exists extractNroffHelpContext] {
  1547.         CreateExtractNroffHelpContext
  1548.     }
  1549.  
  1550.     set helpName [string trim [csubstr $manLine 9 end]]
  1551.     set helpFile [TruncFileName "$helpDir/$helpName"]
  1552.     if [file exists $helpFile] {
  1553.         error "Help file already exists: $helpFile"
  1554.     }
  1555.     EnsureDirs $helpFile
  1556.  
  1557.     set tmpFile "[file dirname $helpFile]/tmp.[id process]"
  1558.  
  1559.     echo "    creating help file $helpName"
  1560.  
  1561.     set nroffFH [open "| nroff -man | col $colArgs > $tmpFile" w]
  1562.  
  1563.     puts $nroffFH {.TH @@@BUILDHELP@@@ 1}
  1564.  
  1565.     set foundBrief 0
  1566.     scanfile $extractNroffHelpContext $manPageFH
  1567.  
  1568.     # Close returns an error on if anything comes back on stderr, even if
  1569.     # its a warning.  Output errors and continue.
  1570.  
  1571.     set stat [catch {
  1572.         close $nroffFH
  1573.     } msg]
  1574.     if $stat {
  1575.         puts stderr "nroff: $msg"
  1576.     }
  1577.  
  1578.     set tmpFH [open $tmpFile r]
  1579.     set helpFH [open $helpFile w]
  1580.  
  1581.     FilterNroffManPage $tmpFH $helpFH
  1582.  
  1583.     close $tmpFH
  1584.     close $helpFH
  1585.  
  1586.     unlink $tmpFile
  1587.     chmod a-w,a+r $helpFile
  1588. }
  1589.  
  1590.  
  1591. proc CreateExtractScriptHelpContext {} {
  1592.     global extractScriptHelpContext
  1593.  
  1594.     set extractScriptHelpContext [scancontext create]
  1595.  
  1596.     scanmatch $extractScriptHelpContext {^#@endhelp[     ]*$} {
  1597.         break
  1598.     }
  1599.  
  1600.     scanmatch $extractScriptHelpContext {^#@brief:} {
  1601.         if $foundBrief {
  1602.             error {Duplicate "@brief" entry}
  1603.         }
  1604.         set foundBrief 1
  1605.         puts $briefHelpFH "$helpName\t[csubstr $matchInfo(line) 9 end]"
  1606.         continue
  1607.     }
  1608.  
  1609.     scanmatch $extractScriptHelpContext {^#@help:} {
  1610.         error {"@help" found within another help section"}
  1611.     }
  1612.  
  1613.     scanmatch $extractScriptHelpContext {^#$} {
  1614.         puts $helpFH ""
  1615.     }
  1616.  
  1617.     scanmatch $extractScriptHelpContext {
  1618.         if {[clength $matchInfo(line)] > 1} {
  1619.             puts $helpFH " [csubstr $matchInfo(line) 1 end]"
  1620.         } else {
  1621.             puts $helpFH $matchInfo(line)
  1622.         }
  1623.     }
  1624. }
  1625.  
  1626.  
  1627. proc ExtractScriptHelp {scriptPageFH scriptLine} {
  1628.     global helpDir briefHelpFH
  1629.     global extractScriptHelpContext
  1630.  
  1631.     if ![info exists extractScriptHelpContext] {
  1632.         CreateExtractScriptHelpContext
  1633.     }
  1634.  
  1635.     set helpName [string trim [csubstr $scriptLine 7 end]]
  1636.     set helpFile "$helpDir/$helpName"
  1637.     if {[file exists $helpFile]} {
  1638.         error "Help file already exists: $helpFile"
  1639.     }
  1640.     EnsureDirs $helpFile
  1641.  
  1642.     echo "    creating help file $helpName"
  1643.  
  1644.     set helpFH [open $helpFile w]
  1645.  
  1646.     set foundBrief 0
  1647.     scanfile $extractScriptHelpContext $scriptPageFH
  1648.  
  1649.     close $helpFH
  1650.     chmod a-w,a+r $helpFile
  1651. }
  1652.  
  1653.  
  1654. proc ProcessNroffFile {pathName} {
  1655.    global nroffScanCT scriptScanCT nroffHeader
  1656.  
  1657.    set fileName [file tail $pathName]
  1658.  
  1659.    set nroffHeader {}
  1660.    set manPageFH [open $pathName r]
  1661.    set matchInfo(fileName) [file tail $pathName]
  1662.  
  1663.    echo "    scanning $pathName"
  1664.  
  1665.    scanfile $nroffScanCT $manPageFH
  1666.  
  1667.    close $manPageFH
  1668. }
  1669.  
  1670.  
  1671. proc ProcessTclScript {pathName} {
  1672.    global scriptScanCT nroffHeader
  1673.  
  1674.    set scriptFH [open "$pathName" r]
  1675.    set matchInfo(fileName) [file tail $pathName]
  1676.  
  1677.    echo "    scanning $pathName"
  1678.    scanfile $scriptScanCT $scriptFH
  1679.  
  1680.    close $scriptFH
  1681. }
  1682.  
  1683.  
  1684. proc buildhelp {helpDirPath briefFile sourceFiles} {
  1685.     global helpDir truncFileNames nroffScanCT
  1686.     global scriptScanCT briefHelpFH colArgs
  1687.  
  1688.     echo ""
  1689.     echo "Begin building help tree"
  1690.  
  1691.     # Determine version of col command to use (no -x on BSD)
  1692.     if {[system {col -bx </dev/null >/dev/null 2>&1}] != 0} {
  1693.         set colArgs {-b}
  1694.     } else {
  1695.         set colArgs {-bx}
  1696.     }
  1697.     set helpDir $helpDirPath
  1698.     if {![file exists $helpDir]} {
  1699.         mkdir $helpDir
  1700.     }
  1701.  
  1702.     if {![file isdirectory $helpDir]} {
  1703.         error [concat "$helpDir is not a directory or does not exist. "  
  1704.                       "This should be the help root directory"]
  1705.     }
  1706.         
  1707.     set status [catch {set tmpFH [open $helpDir/AVeryVeryBigFileName w]}]
  1708.     if {$status != 0} {
  1709.         set truncFileNames 1
  1710.     } else {
  1711.         close $tmpFH
  1712.         unlink $helpDir/AVeryVeryBigFileName
  1713.         set truncFileNames 0
  1714.     }
  1715.  
  1716.     set nroffScanCT [scancontext create]
  1717.  
  1718.     scanmatch $nroffScanCT {'\\"@help:} {
  1719.         ExtractNroffHelp $matchInfo(handle) $matchInfo(line)
  1720.         continue
  1721.     }
  1722.  
  1723.     scanmatch $nroffScanCT {^'\\"@header} {
  1724.         ExtractNroffHeader $matchInfo(handle)
  1725.         continue
  1726.     }
  1727.     scanmatch $nroffScanCT {^'\\"@endhelp} {
  1728.         error [concat {@endhelp" without corresponding "@help:"} \
  1729.                  ", offset = $matchInfo(offset)"]
  1730.     }
  1731.     scanmatch $nroffScanCT {^'\\"@brief} {
  1732.         error [concat {"@brief" without corresponding "@help:"} \
  1733.                  ", offset = $matchInfo(offset)"]
  1734.     }
  1735.  
  1736.     set scriptScanCT [scancontext create]
  1737.     scanmatch $scriptScanCT {^#@help:} {
  1738.         ExtractScriptHelp $matchInfo(handle) $matchInfo(line)
  1739.     }
  1740.  
  1741.     if {[file extension $briefFile] != ".brf"} {
  1742.         error "Brief file \"$briefFile\" must have an extension \".brf\""
  1743.     }
  1744.     if [file exists $helpDir/$briefFile] {
  1745.         error "Brief file \"$helpDir/$briefFile\" already exists"
  1746.     }
  1747.     set briefHelpFH [open "|sort > $helpDir/$briefFile" w]
  1748.  
  1749.     foreach manFile [glob $sourceFiles] {
  1750.         set ext [file extension $manFile]
  1751.         if {$ext == ".tcl" || $ext == ".tlib"} {
  1752.             set status [catch {ProcessTclScript $manFile} msg]
  1753.         } else {
  1754.             set status [catch {ProcessNroffFile $manFile} msg]
  1755.         }
  1756.         if {$status != 0} {
  1757.             global errorInfo errorCode
  1758.             error "Error extracting help from: $manFile" $errorInfo $errorCode
  1759.         }
  1760.     }
  1761.  
  1762.     close $briefHelpFH
  1763.     chmod a-w,a+r $helpDir/$briefFile
  1764.     echo "Completed extraction of help files"
  1765. }
  1766.  
  1767.  
  1768.  
  1769.