home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / lib / tclX8.3 / tcl.tlib < prev    next >
Encoding:
Text File  |  2001-10-22  |  71.0 KB  |  2,245 lines
  1. #
  2. # arrayprocs.tcl --
  3. #
  4. # Extended Tcl array procedures.
  5. # 
  6. #------------------------------------------------------------------------------
  7. # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
  8. #
  9. # Permission to use, copy, modify, and distribute this software and its
  10. # documentation for any purpose and without fee is hereby granted, provided
  11. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  12. # Mark Diekhans make no representations about the suitability of this
  13. # software for any purpose.  It is provided "as is" without express or
  14. # implied warranty.
  15. #------------------------------------------------------------------------------
  16. # $Id: arrayprocs.tcl,v 8.3 1999/03/31 06:37:47 markd Exp $
  17. #------------------------------------------------------------------------------
  18. #
  19.  
  20. #@package: TclX-ArrayProcedures for_array_keys
  21.  
  22. proc for_array_keys {varName arrayName codeFragment} {
  23.     upvar $varName enumVar $arrayName enumArray
  24.  
  25.     if ![info exists enumArray] {
  26.     error "\"$arrayName\" isn't an array"
  27.     }
  28.  
  29.     set code 0
  30.     set result {}
  31.     set searchId [array startsearch enumArray]
  32.     while {[array anymore enumArray $searchId]} {
  33.     set enumVar [array nextelement enumArray $searchId]
  34.         set code [catch {uplevel 1 $codeFragment} result]
  35.         if {$code != 0 && $code != 4} break
  36.     }
  37.     array donesearch enumArray $searchId
  38.  
  39.     if {$code == 0 || $code == 3 || $code == 4} {
  40.         return $result
  41.     }
  42.     if {$code == 1} {
  43.         global errorCode errorInfo
  44.         return -code $code -errorcode $errorCode -errorinfo $errorInfo $result
  45.     }
  46.     return -code $code $result
  47. }
  48.  
  49.  
  50. #
  51. # compat --
  52. #
  53. # This file provides commands compatible with older versions of Extended Tcl.
  54. # 
  55. #------------------------------------------------------------------------------
  56. # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
  57. #
  58. # Permission to use, copy, modify, and distribute this software and its
  59. # documentation for any purpose and without fee is hereby granted, provided
  60. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  61. # Mark Diekhans make no representations about the suitability of this
  62. # software for any purpose.  It is provided "as is" without express or
  63. # implied warranty.
  64. #------------------------------------------------------------------------------
  65. # $Id: compat.tcl,v 8.6 1999/03/31 06:37:47 markd Exp $
  66. #------------------------------------------------------------------------------
  67. #
  68.  
  69. #@package: TclX-GenCompat assign_fields cexpand
  70.  
  71. proc assign_fields {list args} {
  72.     puts stderr {**** Your program is using an obsolete TclX proc, "assign_fields".}
  73.     puts stderr {**** Please use the command "lassign". Compatibility support will}
  74.     puts stderr {**** be removed in the next release.}
  75.  
  76.     proc assign_fields {list args} {
  77.         if [lempty $args] {
  78.             return
  79.         }
  80.         return [uplevel lassign [list $list] $args]
  81.     }
  82.     return [uplevel assign_fields [list $list] $args]
  83. }
  84.  
  85. # Added TclX 7.4a
  86. proc cexpand str {subst -nocommands -novariables $str}
  87.  
  88. #@package: TclX-ServerCompat server_open server_connect server_send \
  89.                              server_info server_cntl
  90.  
  91. # Added TclX 7.4a
  92.  
  93. proc server_open args {
  94.     set cmd server_connect
  95.  
  96.     set buffered 1
  97.     while {[string match -* [lindex $args 0]]} {
  98.         set opt [lvarpop args]
  99.         if [cequal $opt -buf] {
  100.             set buffered 1
  101.         } elseif  [cequal $opt -nobuf] {
  102.             set buffered 0
  103.         }
  104.         lappend cmd $opt
  105.     }
  106.     set handle [uplevel [concat $cmd $args]]
  107.     if $buffered {
  108.         lappend handle [dup $handle]
  109.     }
  110.     return $handle
  111. }
  112.  
  113. # Added TclX 7.5a
  114.  
  115. proc server_connect args {
  116.     set cmd socket
  117.  
  118.     set buffered 1
  119.     set twoids 0
  120.     while {[string match -* [lindex $args 0]]} {
  121.         switch -- [set opt [lvarpop args]] {
  122.             -buf {
  123.                 set buffered 1
  124.             }
  125.             -nobuf {
  126.                 set buffered 0
  127.             }
  128.             -myip {
  129.                 lappend cmd -myaddr [lvarpop args]
  130.             }
  131.             -myport {
  132.                 lappend cmd -myport [lvarpop args]
  133.             }
  134.             -twoids {
  135.                 set twoids 1
  136.             }
  137.             default {
  138.                 error "unknown option \"$opt\""
  139.             }
  140.         }
  141.     }
  142.     set handle [uplevel [concat $cmd $args]]
  143.     if !$buffered {
  144.         fconfigure $handle -buffering none 
  145.     }
  146.     if $twoids {
  147.         lappend handle [dup $handle]
  148.     }
  149.     return $handle
  150. }
  151.  
  152. proc server_send args {
  153.     set cmd puts
  154.  
  155.     while {[string match -* [lindex $args 0]]} {
  156.         switch -- [set opt [lvarpop args]] {
  157.             {-dontroute} {
  158.                 error "server_send if obsolete, -dontroute is not supported by the compatibility proc"
  159.             }
  160.             {-outofband} {
  161.                 error "server_send if obsolete, -outofband is not supported by the compatibility proc"
  162.             }
  163.         }
  164.         lappend cmd $opt
  165.     }
  166.     uplevel [concat $cmd $args]
  167.     flush [lindex $args 0]
  168. }
  169.  
  170. proc server_info args {
  171.     eval [concat host_info $args]
  172. }
  173.  
  174. proc server_cntl args {
  175.     eval [concat fcntl $args]
  176. }
  177.  
  178. #@package: TclX-ClockCompat fmtclock convertclock getclock
  179.  
  180. # Added TclX 7.5a
  181.  
  182. proc fmtclock {clockval {format {}} {zone {}}} {
  183.     lappend cmd clock format $clockval
  184.     if ![lempty $format] {
  185.         lappend cmd -format $format
  186.     }
  187.     if ![lempty $zone] {
  188.         lappend cmd -gmt 1
  189.     }
  190.     return [eval $cmd]
  191. }
  192.  
  193. # Added TclX 7.5a
  194.  
  195. proc convertclock {dateString {zone {}} {baseClock {}}} {
  196.     lappend cmd clock scan $dateString
  197.     if ![lempty $zone] {
  198.         lappend cmd -gmt 1
  199.     }
  200.     if ![lempty $baseClock] {
  201.         lappend cmd -base $baseClock
  202.     }
  203.     return [eval $cmd]
  204. }
  205.  
  206. # Added TclX 7.5a
  207.  
  208. proc getclock {} {
  209.     return [clock seconds]
  210. }
  211.  
  212. #@package: TclX-FileCompat mkdir rmdir unlink frename
  213.  
  214. # Added TclX 7.6.0
  215.  
  216. proc mkdir args {
  217.     set path 0
  218.     if {[llength $args] > 1} {
  219.         lvarpop args
  220.         set path 1
  221.     }
  222.     foreach dir [lindex $args 0] {
  223.         if {((!$path) && [file isdirectory $dir]) || \
  224.                 ([file exists $dir] && ![file isdirectory $dir])} {
  225.             error "creating directory \"$dir\" failed: file already exists" \
  226.                     {} {POSIX EEXIST {file already exists}}
  227.         }
  228.         file mkdir $dir
  229.     }
  230.     return
  231. }
  232.  
  233. # Added TclX 7.6.0
  234.  
  235. proc rmdir args {
  236.     set nocomplain 0
  237.     if {[llength $args] > 1} {
  238.         lvarpop args
  239.         set nocomplain 1
  240.         global errorInfo errorCode
  241.         set saveErrorInfo $errorInfo
  242.         set saveErrorCode $errorCode
  243.     }
  244.     foreach dir [lindex $args 0] {
  245.         if $nocomplain {
  246.             catch {file delete $dir}
  247.         } else {
  248.             if ![file exists $dir] {
  249.                 error "can't remove \"$dir\": no such file or directory" {} \
  250.                         {POSIX ENOENT {no such file or directory}}
  251.             }
  252.             if ![cequal [file type $dir] directory] {
  253.                 error "$dir: not a directory" {} \
  254.                         {POSIX ENOTDIR {not a directory}}
  255.             }
  256.             file delete $dir
  257.         }
  258.     }
  259.     if $nocomplain {
  260.         set errorInfo $saveErrorInfo 
  261.         set errorCode $saveErrorCode
  262.     }
  263.     return
  264. }
  265.  
  266. # Added TclX 7.6.0
  267.  
  268. proc unlink args {
  269.     set nocomplain 0
  270.     if {[llength $args] > 1} {
  271.         lvarpop args
  272.         set nocomplain 1
  273.         global errorInfo errorCode
  274.         set saveErrorInfo $errorInfo
  275.         set saveErrorCode $errorCode
  276.     }
  277.     foreach file [lindex $args 0] {
  278.         if {[file exists $file] && [cequal [file type $file] directory]} {
  279.             if !$nocomplain {
  280.                 error "$file: not owner" {} {POSIX EPERM {not owner}}
  281.             }
  282.         } elseif $nocomplain {
  283.             catch {file delete $file}
  284.         } else {
  285.             if {!([file exists $file] || \
  286.                     ([catch {file readlink $file}] == 0))} {
  287.                 error "can't remove \"$file\": no such file or directory" {} \
  288.                         {POSIX ENOENT {no such file or directory}}
  289.             }
  290.             file delete $file
  291.         }
  292.     }
  293.     if $nocomplain {
  294.         set errorInfo $saveErrorInfo 
  295.         set errorCode $saveErrorCode
  296.     }
  297.     return
  298. }
  299.  
  300. # Added TclX 7.6.0
  301.  
  302. proc frename {old new} {
  303.     if {[file isdirectory $new] && ![lempty [readdir $new]]} {
  304.         error "rename \"foo\" to \"baz\" failed: directory not empty" {} \
  305.                 POSIX ENOTEMPTY {directory not empty}
  306.     }
  307.     file rename -force $old $new
  308. }
  309.  
  310.  
  311. #@package: TclX-CopyFileCompat copyfile
  312.  
  313. # Added TclX 8.0.0
  314.  
  315. # copyfile ?-bytes num | \-maxbytes num? ?\-translate? fromFileId toFileId
  316.  
  317. proc copyfile args {
  318.     global errorInfo errorCode
  319.  
  320.     set copyMode NORMAL
  321.     set translate 0
  322.     while {[string match -* [lindex $args 0]]} {
  323.         set opt [lvarpop args]
  324.         switch -exact -- $opt {
  325.             -bytes {
  326.                 set copyMode BYTES
  327.                 if {[llength $args] == 0} {
  328.                     error "argument required for -bytes option"
  329.                 }
  330.                 set totalBytesToRead [lvarpop args]
  331.             }
  332.             -maxbytes {
  333.                 set copyMode MAX_BYTES
  334.                 if {[llength $args] == 0} {
  335.                     error "argument required for -maxbytes option"
  336.                 }
  337.                 set totalBytesToRead [lvarpop args]
  338.             }
  339.             -translate {
  340.                 set translate 1
  341.             }
  342.             default {
  343.                 error "invalid argument \"$opt\", expected \"-bytes\",\
  344.                         \"-maxbytes\", or \"-translate\""
  345.             }
  346.         }
  347.     }
  348.     if {[llength $args] != 2} {
  349.         error "wrong # args: copyfile ?-bytes num|-maxbytes num? ?-translate?\
  350.                 fromFileId toFileId"
  351.     }
  352.     lassign $args fromFileId toFileId
  353.  
  354.     if !$translate {
  355.         set fromOptions [list \
  356.                 [fconfigure $fromFileId -translation] \
  357.                 [fconfigure $fromFileId -eofchar]]
  358.         set toOptions [list \
  359.                 [fconfigure $toFileId -translation] \
  360.                 [fconfigure $toFileId -eofchar]]
  361.  
  362.         fconfigure $fromFileId -translation binary
  363.         fconfigure $fromFileId -eofchar {}
  364.         fconfigure $toFileId -translation binary
  365.         fconfigure $toFileId -eofchar {}
  366.     }
  367.  
  368.     set cmd [list fcopy $fromFileId $toFileId]
  369.     if ![cequal $copyMode NORMAL] {
  370.         lappend cmd -size $totalBytesToRead
  371.     }
  372.     
  373.     set stat [catch {eval $cmd} totalBytesRead]
  374.     if $stat {
  375.         set saveErrorResult $totalBytesRead
  376.         set saveErrorInfo $errorInfo
  377.         set saveErrorCode $errorCode
  378.     }
  379.  
  380.     if !$translate {
  381.         # Try to restore state, even if we have an error.
  382.         if [catch {
  383.             fconfigure $fromFileId -translation [lindex $fromOptions 0]
  384.             fconfigure $fromFileId -eofchar [lindex $fromOptions 1]
  385.             fconfigure $toFileId -translation [lindex $toOptions 0]
  386.             fconfigure $toFileId -eofchar [lindex $toOptions 1]
  387.         } errorResult] {
  388.             # If fcopy did not get an error, we process this one
  389.             if !$stat {
  390.                 set stat 1
  391.                 set saveErrorResult $errorResult
  392.                 set saveErrorInfo $errorInfo
  393.                 set saveErrorCode $errorCode
  394.             }
  395.         }
  396.     }
  397.  
  398.     if $stat {
  399.         error $saveErrorResult $saveErrorInfo $saveErrorCode
  400.     }
  401.  
  402.     if {[cequal $copyMode BYTES] && ($totalBytesToRead > 0) && \
  403.             ($totalBytesRead != $totalBytesToRead)} {
  404.         error "premature EOF, $totalBytesToRead bytes expected,\
  405.                 $totalBytesRead bytes actually read"
  406.     }
  407.     return $totalBytesRead
  408. }
  409. #
  410. # convlib.tcl --
  411. #
  412. #     Convert Ousterhout style tclIndex files and associated libraries to a
  413. # package library.
  414. # 
  415. #------------------------------------------------------------------------------
  416. # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
  417. #
  418. # Permission to use, copy, modify, and distribute this software and its
  419. # documentation for any purpose and without fee is hereby granted, provided
  420. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  421. # Mark Diekhans make no representations about the suitability of this
  422. # software for any purpose.  It is provided "as is" without express or
  423. # implied warranty.
  424. #------------------------------------------------------------------------------
  425. # $Id: convlib.tcl,v 8.7 1999/03/31 06:37:47 markd Exp $
  426. #------------------------------------------------------------------------------
  427. #
  428.  
  429. #@package: TclX-convertlib convert_lib
  430.  
  431. namespace eval TclX {
  432.  
  433.     #--------------------------------------------------------------------------
  434.     # ParseTclIndex
  435.     # Parse a tclIndex file, returning an array of file names with the list of
  436.     # procedures in each package. This is done by sourcing the file and then
  437.     # going through the local auto_index array that was created. Issues
  438.     # warnings for lines that can't be converted. 
  439.     #
  440.     # Returns 1 if all lines are converted, 0 if some failed.
  441.     #
  442.  
  443.     proc ParseTclIndex {tclIndex fileTblVar ignore} {
  444.         upvar $fileTblVar fileTbl
  445.         set allOK 1
  446.  
  447.         # Open and validate the file.
  448.  
  449.         set tclIndexFH [open $tclIndex r]
  450.         try_eval {
  451.             set hdr [gets $tclIndexFH]
  452.             if {!([cequal $hdr {# Tcl autoload index file, version 2.0}] ||
  453.                 [cequal $hdr == {# Tcl autoload index file, version 2.0 for [incr Tcl]}])} {
  454.                     error "can only convert version 2.0 Tcl auto-load files"
  455.                 }
  456.             set dir [file dirname $tclIndex]  ;# Expected by the script.
  457.             eval [read $tclIndexFH]
  458.         }  {} {
  459.             close $tclIndexFH
  460.         }
  461.         foreach procName [array names auto_index] {
  462.             if ![string match "source *" $auto_index($procName)] {
  463.                 puts stderr "WARNING: Can't convert load command for\
  464.                         \"$procName\": $auto_index($procName)"
  465.                 set allOK 0
  466.                 continue
  467.             }
  468.             set filePath [lindex $auto_index($procName) 1]
  469.             set fileName [file tail $filePath] 
  470.             if {[lsearch $ignore $fileName] >= 0} continue
  471.             
  472.             lappend fileTbl($filePath) $procName
  473.         }
  474.         if ![info exists fileTbl] {
  475.             error "no entries could be converted in $tclIndex"
  476.         }
  477.         return $allOK
  478.     }
  479. } ;# namespace TclX
  480.  
  481. #--------------------------------------------------------------------------
  482. # convert_lib:
  483. # Convert a tclIndex library to a .tlib. ignore any files in the ignore
  484. # list
  485.  
  486. proc convert_lib {tclIndex packageLib {ignore {}}} {
  487.     if {[file tail $tclIndex] != "tclIndex"} {
  488.         error "Tail file name must be `tclIndex': $tclIndex"}
  489.     if ![file readable $tclIndex] {
  490.         error "File not readable: $tclIndex"
  491.     }
  492.  
  493.     # Parse the file.
  494.  
  495.     set allOK [TclX::ParseTclIndex $tclIndex fileTbl $ignore]
  496.  
  497.     # Generate the .tlib package names with contain the directory and
  498.     # file name, less any extensions.
  499.  
  500.     if {[file extension $packageLib] != ".tlib"} {
  501.         append packageLib ".tlib"
  502.     }
  503.     set libFH [open $packageLib w]
  504.  
  505.     foreach srcFile [array names fileTbl] {
  506.         set pkgName [file tail [file dirname $srcFile]]/[file tail [file root $srcFile]]
  507.         set srcFH [open $srcFile r]
  508.         puts $libFH "#@package: $pkgName $fileTbl($srcFile)\n"
  509.         copyfile $srcFH $libFH
  510.         close $srcFH
  511.     }
  512.     close $libFH
  513.     buildpackageindex $packageLib
  514.     if !$allOK {
  515.         error "*** Not all entries converted, but library generated"
  516.     }
  517. }
  518.  
  519.  
  520. #
  521. # edprocs.tcl --
  522. #
  523. # Tools for Tcl developers. Procedures to save procs to a file and to edit
  524. # a proc in memory.
  525. #------------------------------------------------------------------------------
  526. # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
  527. #
  528. # Permission to use, copy, modify, and distribute this software and its
  529. # documentation for any purpose and without fee is hereby granted, provided
  530. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  531. # Mark Diekhans make no representations about the suitability of this
  532. # software for any purpose.  It is provided "as is" without express or
  533. # implied warranty.
  534. #------------------------------------------------------------------------------
  535. # $Id: edprocs.tcl,v 8.4 1999/03/31 06:37:47 markd Exp $
  536. #------------------------------------------------------------------------------
  537. #
  538.  
  539. #@package: TclX-developer_utils saveprocs edprocs
  540.  
  541. proc saveprocs {fileName args} {
  542.     set fp [open $fileName w]
  543.     try_eval {
  544.         puts $fp "# tcl procs saved on [fmtclock [getclock]]\n"
  545.         puts $fp [eval "showproc $args"]
  546.     } {} {
  547.         close $fp
  548.     }
  549. }
  550.  
  551. proc edprocs {args} {
  552.     global env
  553.  
  554.     set tmpFilename /tmp/tcldev.[id process]
  555.  
  556.     set fp [open $tmpFilename w]
  557.     try_eval {
  558.         puts $fp "\n# TEMP EDIT BUFFER -- YOUR CHANGES ARE FOR THIS SESSION ONLY\n"
  559.         puts $fp [eval "showproc $args"]
  560.     } {} {
  561.         close $fp
  562.     }
  563.  
  564.     if [info exists env(EDITOR)] {
  565.         set editor $env(EDITOR)
  566.     } else {
  567.     set editor vi
  568.     }
  569.  
  570.     set startMtime [file mtime $tmpFilename]
  571.     system "$editor $tmpFilename"
  572.  
  573.     if {[file mtime $tmpFilename] != $startMtime} {
  574.     source $tmpFilename
  575.     echo "Procedures were reloaded."
  576.     } else {
  577.     echo "No changes were made."
  578.     }
  579.     unlink $tmpFilename
  580.     return
  581. }
  582.  
  583.  
  584. #
  585. # eventloop.tcl --
  586. #
  587. # Eventloop procedure.
  588. #------------------------------------------------------------------------------
  589. # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
  590. #
  591. # Permission to use, copy, modify, and distribute this software and its
  592. # documentation for any purpose and without fee is hereby granted, provided
  593. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  594. # Mark Diekhans make no representations about the suitability of this
  595. # software for any purpose.  It is provided "as is" without express or
  596. # implied warranty.
  597. #------------------------------------------------------------------------------
  598. # $Id: events.tcl,v 8.3 1999/03/31 06:37:47 markd Exp $
  599. #------------------------------------------------------------------------------
  600. #
  601.  
  602. #@package: TclX-events mainloop
  603.  
  604. proc mainloop {} {
  605.     global tcl_interactive
  606.  
  607.     if {[info exists tcl_interactive] && $tcl_interactive} {
  608.         commandloop -async -interactive on -endcommand exit
  609.     }
  610.     set loopVar 0
  611.     catch {vwait loopVar}
  612.     exit
  613. }
  614.  
  615.  
  616. #
  617. # forfile.tcl --
  618. #
  619. # Proc to execute code on every line of a file.
  620. #------------------------------------------------------------------------------
  621. # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
  622. #
  623. # Permission to use, copy, modify, and distribute this software and its
  624. # documentation for any purpose and without fee is hereby granted, provided
  625. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  626. # Mark Diekhans make no representations about the suitability of this
  627. # software for any purpose.  It is provided "as is" without express or
  628. # implied warranty.
  629. #------------------------------------------------------------------------------
  630. # $Id: forfile.tcl,v 8.5 1999/03/31 06:37:48 markd Exp $
  631. #------------------------------------------------------------------------------
  632. #
  633.  
  634. #@package: TclX-forfile for_file
  635.  
  636. proc for_file {var filename cmd} {
  637.     upvar 1 $var line
  638.     set fp [open $filename r]
  639.     try_eval {
  640.         set code 0
  641.         set result {}
  642.         while {[gets $fp line] >= 0} {
  643.             set code [catch {uplevel 1 $cmd} result]
  644.             if {$code != 0 && $code != 4} break
  645.         }
  646.     } {} {
  647.         close $fp
  648.     }
  649.  
  650.     if {$code == 0 || $code == 3 || $code == 4} {
  651.         return $result
  652.     }
  653.     if {$code == 1} {
  654.         global errorCode errorInfo
  655.         return -code $code -errorcode $errorCode -errorinfo $errorInfo $result
  656.     }
  657.     return -code $code $result
  658. }
  659.  
  660.  
  661. #
  662. # globrecur.tcl --
  663. #
  664. #  Build or process a directory list recursively.
  665. #------------------------------------------------------------------------------
  666. # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
  667. #
  668. # Permission to use, copy, modify, and distribute this software and its
  669. # documentation for any purpose and without fee is hereby granted, provided
  670. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  671. # Mark Diekhans make no representations about the suitability of this
  672. # software for any purpose.  It is provided "as is" without express or
  673. # implied warranty.
  674. #------------------------------------------------------------------------------
  675. # $Id: globrecur.tcl,v 8.3 1999/03/31 06:37:48 markd Exp $
  676. #------------------------------------------------------------------------------
  677. #
  678.  
  679. #@package: TclX-globrecur recursive_glob
  680.  
  681. proc recursive_glob {dirlist globlist} {
  682.     set result {}
  683.     set recurse {}
  684.     foreach dir $dirlist {
  685.         if ![file isdirectory $dir] {
  686.             error "\"$dir\" is not a directory"
  687.         }
  688.         foreach pattern $globlist {
  689.             set result [concat $result \
  690.                     [glob -nocomplain -- [file join $dir $pattern]]]
  691.         }
  692.         foreach file [readdir $dir] {
  693.             set file [file join $dir $file]
  694.             if [file isdirectory $file] {
  695.                 set fileTail [file tail $file]
  696.                 if {!([cequal $fileTail .] || [cequal $fileTail ..])} {
  697.                     lappend recurse $file
  698.                 }
  699.             }
  700.         }
  701.     }
  702.     if ![lempty $recurse] {
  703.         set result [concat $result [recursive_glob $recurse $globlist]]
  704.     }
  705.     return $result
  706. }
  707.  
  708. #@package: TclX-forrecur for_recursive_glob
  709.  
  710. proc for_recursive_glob {var dirlist globlist cmd {depth 1}} {
  711.     upvar $depth $var myVar
  712.     set recurse {}
  713.     foreach dir $dirlist {
  714.         if ![file isdirectory $dir] {
  715.             error "\"$dir\" is not a directory"
  716.         }
  717.         set code 0
  718.         set result {}
  719.         foreach pattern $globlist {
  720.             foreach file [glob -nocomplain -- [file join $dir $pattern]] {
  721.                 set myVar $file
  722.                 set code [catch {uplevel $depth $cmd} result]
  723.                 if {$code != 0 && $code != 4} break
  724.             }
  725.             if {$code != 0 && $code != 4} break
  726.         }
  727.         if {$code != 0 && $code != 4} {
  728.             if {$code == 3} {
  729.                 return $result
  730.             }
  731.             if {$code == 1} {
  732.                 global errorCode errorInfo
  733.                 return -code $code -errorcode $errorCode \
  734.                         -errorinfo $errorInfo $result
  735.             }
  736.             return -code $code $result
  737.         }
  738.  
  739.         foreach file [readdir $dir] {
  740.             set file [file join $dir $file]
  741.             if [file isdirectory $file] {
  742.                 set fileTail [file tail $file]
  743.                 if {!([cequal $fileTail .] || [cequal $fileTail ..])} {
  744.                     lappend recurse $file
  745.                 }
  746.             }
  747.         }
  748.     }
  749.     if ![lempty $recurse] {
  750.         return [for_recursive_glob $var $recurse $globlist $cmd \
  751.                     [expr $depth + 1]]
  752.     }
  753.     return {}
  754. }
  755.  
  756.  
  757. #
  758. # help.tcl --
  759. #
  760. # Tcl help command. (see TclX manual)
  761. # 
  762. #------------------------------------------------------------------------------
  763. # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
  764. #
  765. # Permission to use, copy, modify, and distribute this software and its
  766. # documentation for any purpose and without fee is hereby granted, provided
  767. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  768. # Mark Diekhans make no representations about the suitability of this
  769. # software for any purpose.  It is provided "as is" without express or
  770. # implied warranty.
  771. #------------------------------------------------------------------------------
  772. # The help facility is based on a hierarchical tree of subjects (directories)
  773. # and help pages (files).  There is a virtual root to this tree. The root
  774. # being the merger of all "help" directories found along the $auto_path
  775. # variable.
  776. #------------------------------------------------------------------------------
  777. # $Id: help.tcl,v 8.9 1999/03/31 06:37:48 markd Exp $
  778. #------------------------------------------------------------------------------
  779. #
  780. # FIX: Convert this to use namespaces.
  781.  
  782. #@package: TclX-help help helpcd helppwd apropos
  783.  
  784. namespace eval TclXHelp {
  785.  
  786.     variable curSubject "/"
  787.  
  788.     #----------------------------------------------------------------------
  789.     # Return a list of help root directories.
  790.  
  791.     proc RootDirs {} {
  792.         global auto_path
  793.         set roots {}
  794.         foreach dir $auto_path {
  795.             if [file isdirectory $dir/help] {
  796.                 lappend roots $dir/help
  797.             }
  798.         }
  799.         return $roots
  800.     }
  801.  
  802.     #--------------------------------------------------------------------------
  803.     # Take a path name which might have "." and ".." elements and flatten them
  804.     # out.  Also removes trailing and adjacent "/", unless its the only
  805.     # character.
  806.  
  807.     proc FlattenPath pathName {
  808.         set newPath {}
  809.         foreach element [split $pathName /] {
  810.             if {"$element" == "." || [lempty $element]} continue
  811.  
  812.             if {"$element" == ".."} {
  813.                 if {[llength [join $newPath /]] == 0} {
  814.                     error "Help: name goes above subject directory root" {} \
  815.                         [list TCLXHELP NAMEABOVEROOT $pathName]
  816.                 }
  817.                 lvarpop newPath [expr [llength $newPath]-1]
  818.                 continue
  819.             }
  820.             lappend newPath $element
  821.         }
  822.         set newPath [join $newPath /]
  823.  
  824.         # Take care of the case where we started with something line "/" or "/."
  825.  
  826.         if {("$newPath" == "") && [string match "/*" $pathName]} {
  827.             set newPath "/"
  828.         }
  829.  
  830.         return $newPath
  831.     }
  832.  
  833.     #--------------------------------------------------------------------------
  834.     # Given a pathName relative to the virtual help root, convert it to a list
  835.     # of real file paths.  A list is returned because the path could be "/",
  836.     # returning a list of all roots. The list is returned in the same order of
  837.     # the auto_path variable. If path does not start with a "/", it is take as
  838.     # relative to the current help subject.  Note: The root directory part of
  839.     # the name is not flattened.  This lets other commands pick out the part
  840.     # relative to the one of the root directories.
  841.  
  842.     proc ConvertPath pathName {
  843.         variable curSubject
  844.  
  845.         if {![string match "/*" $pathName]} {
  846.             if [cequal $curSubject "/"] {
  847.                 set pathName "/$pathName"
  848.             } else {
  849.                 set pathName "$curSubject/$pathName"
  850.             }
  851.         }
  852.         set pathName [FlattenPath $pathName]
  853.  
  854.         # If the virtual root is specified, return a list of directories.
  855.  
  856.         if {$pathName == "/"} {
  857.             return [RootDirs]
  858.         }
  859.  
  860.         # Not the virtual root find the first match.
  861.  
  862.         foreach dir [RootDirs] {
  863.             if [file readable $dir/$pathName] {
  864.                 return [list $dir/$pathName]
  865.             }
  866.         }
  867.  
  868.     # Not found, try to find a file matching only the file tail,
  869.     # for example if --> <helpDir>/tcl/control/if.
  870.  
  871.     set fileTail [file tail $pathName]
  872.         foreach dir [RootDirs] {
  873.         set fileName [exec find $dir -name $fileTail | head -1]
  874.         if {$fileName != {}} {
  875.                 return [list $fileName]
  876.         }
  877.     }
  878.  
  879.         error "\"$pathName\" does not exist" {} \
  880.             [list TCLXHELP NOEXIST $pathName]
  881.     }
  882.  
  883.     #--------------------------------------------------------------------------
  884.     # Return the virtual root relative name of the file given its absolute
  885.     # path.  The root part of the path should not have been flattened, as we
  886.     # would not be able to match it.
  887.  
  888.     proc RelativePath pathName {
  889.         foreach dir [RootDirs] {
  890.             if {[csubstr $pathName 0 [clength $dir]] == $dir} {
  891.                 set name [csubstr $pathName [clength $dir] end]
  892.                 if {$name == ""} {set name /}
  893.                 return $name
  894.             }
  895.         }
  896.         if ![info exists found] {
  897.             error "problem translating \"$pathName\"" {} [list TCLXHELP INTERROR]
  898.         }
  899.     }
  900.  
  901.     #--------------------------------------------------------------------------
  902.     # Given a list of path names to subjects generated by ConvertPath, return
  903.     # the contents of the subjects.  Two lists are returned, subjects under
  904.     # that subject and a list of pages under the subject.  Both lists are
  905.     # returned sorted.  This merges all the roots into a virtual root.
  906.     # pathName is the string that was passed to ConvertPath and is used for
  907.     # error reporting.  *.brk files are not returned.
  908.  
  909.     proc ListSubject {pathName pathList subjectsVar pagesVar} {
  910.         upvar $subjectsVar subjects $pagesVar pages
  911.  
  912.         set subjects {}
  913.         set pages {}
  914.         set foundDir 0
  915.         foreach dir $pathList {
  916.             if ![file isdirectory $dir] continue
  917.             if [cequal [file tail $dir] CVS] continue
  918.             set foundDir 1
  919.             foreach file [glob -nocomplain $dir/*] {
  920.                 if {[lsearch {.brf .orig .diff .rej} [file extension $file]] \
  921.                         >= 0} continue
  922.                 if [file isdirectory $file] {
  923.                     lappend subjects [file tail $file]/
  924.                 } else {
  925.                     lappend pages [file tail $file]
  926.                 }
  927.             }
  928.         }
  929.         if !$foundDir {
  930.             if [cequal $pathName /] {
  931.                 global auto_path
  932.                 error "no \"help\" directories found on auto_path ($auto_path)" {} \
  933.                     [list TCLXHELP NOHELPDIRS]
  934.             } else {
  935.                 error "\"$pathName\" is not a subject" {} \
  936.                     [list TCLXHELP NOTSUBJECT $pathName]
  937.             }
  938.         }
  939.         set subjects [lsort $subjects]
  940.         set pages [lsort $pages]
  941.         return {}
  942.     }
  943.  
  944.     #--------------------------------------------------------------------------
  945.     # Display a line of output, pausing waiting for input before displaying if
  946.     # the screen size has been reached.  Return 1 if output is to continue,
  947.     # return 0 if no more should be outputed, indicated by input other than
  948.     # return.
  949.     #
  950.  
  951.     proc Display line {
  952.         variable lineCnt
  953.         if {$lineCnt >= 23} {
  954.             set lineCnt 0
  955.             puts -nonewline stdout ":"
  956.             flush stdout
  957.             gets stdin response
  958.             if {![lempty $response]} {
  959.                 return 0}
  960.         }
  961.         puts stdout $line
  962.         incr lineCnt
  963.     }
  964.  
  965.     #--------------------------------------------------------------------------
  966.     # Display a help page (file).
  967.  
  968.     proc DisplayPage filePath {
  969.  
  970.         set inFH [open $filePath r]
  971.         try_eval {
  972.             while {[gets $inFH fileBuf] >= 0} {
  973.                 if {![Display $fileBuf]} {
  974.                     break
  975.                 }
  976.             }
  977.         } {} {
  978.             close $inFH
  979.         }
  980.     }
  981.  
  982.     #--------------------------------------------------------------------------
  983.     # Display a list of file names in a column format. This use columns of 14 
  984.     # characters 3 blanks.
  985.  
  986.     proc DisplayColumns {nameList} {
  987.         set count 0
  988.         set outLine ""
  989.         foreach name $nameList {
  990.             if {$count == 0} {
  991.                 append outLine "   "}
  992.             append outLine $name
  993.             if {[incr count] < 4} {
  994.                 set padLen [expr 17-[clength $name]]
  995.                 if {$padLen < 3} {
  996.                    set padLen 3}
  997.                 append outLine [replicate " " $padLen]
  998.             } else {
  999.                if {![Display $outLine]} {
  1000.                    return}
  1001.                set outLine ""
  1002.                set count 0
  1003.             }
  1004.         }
  1005.         if {$count != 0} {
  1006.             Display [string trimright $outLine]}
  1007.         return
  1008.     }
  1009.  
  1010.  
  1011.     #--------------------------------------------------------------------------
  1012.     # Display help on help, the first occurance of a help page called "help" in
  1013.     # the help root.
  1014.  
  1015.     proc HelpOnHelp {} {
  1016.         set helpPage [lindex [ConvertPath /help] 0]
  1017.         if [lempty $helpPage] {
  1018.             error "No help page on help found" {} \
  1019.                 [list TCLXHELP NOHELPPAGE]
  1020.         }
  1021.         DisplayPage $helpPage
  1022.     }
  1023.  
  1024. };# namespace TclXHelp
  1025.  
  1026.  
  1027. #------------------------------------------------------------------------------
  1028. # Help command.
  1029.  
  1030. proc help {{what {}}} {
  1031.     variable ::TclXHelp::lineCnt 0
  1032.  
  1033.     # Special case "help help", so we can get it at any level.
  1034.  
  1035.     if {($what == "help") || ($what == "?")} {
  1036.         TclXHelp::HelpOnHelp
  1037.         return
  1038.     }
  1039.  
  1040.     set pathList [TclXHelp::ConvertPath $what]
  1041.     if [file isfile [lindex $pathList 0]] {
  1042.         TclXHelp::DisplayPage [lindex $pathList 0]
  1043.         return
  1044.     }
  1045.  
  1046.     TclXHelp::ListSubject $what $pathList subjects pages
  1047.     set relativeDir [TclXHelp::RelativePath [lindex $pathList 0]]
  1048.  
  1049.     if {[llength $subjects] != 0} {
  1050.         TclXHelp::Display "\nSubjects available in $relativeDir:"
  1051.         TclXHelp::DisplayColumns $subjects
  1052.     }
  1053.     if {[llength $pages] != 0} {
  1054.         TclXHelp::Display "\nHelp pages available in $relativeDir:"
  1055.         TclXHelp::DisplayColumns $pages
  1056.     }
  1057. }
  1058.  
  1059.  
  1060. #------------------------------------------------------------------------------
  1061. # helpcd command.  The name of the new current directory is assembled from the
  1062. # current directory and the argument.
  1063.  
  1064. proc helpcd {{dir /}} {
  1065.     variable ::TclXHelp::curSubject
  1066.  
  1067.     set pathName [lindex [TclXHelp::ConvertPath $dir] 0]
  1068.  
  1069.     if {![file isdirectory $pathName]} {
  1070.         error "\"$dir\" is not a subject" \
  1071.             [list TCLXHELP NOTSUBJECT $dir]
  1072.     }
  1073.  
  1074.     set ::TclXHelp::curSubject [TclXHelp::RelativePath $pathName]
  1075.     return
  1076. }
  1077.  
  1078. #------------------------------------------------------------------------------
  1079. # Helpcd main.
  1080.  
  1081. proc helppwd {} {
  1082.     variable ::TclXHelp::curSubject
  1083.     echo "Current help subject: $::TclXHelp::curSubject"
  1084. }
  1085.  
  1086. #------------------------------------------------------------------------------
  1087. # apropos command.  This search the 
  1088.  
  1089. proc apropos {regexp} {
  1090.     variable ::TclXHelp::lineCnt 0
  1091.     variable ::TclXHelp::curSubject
  1092.  
  1093.     set ch [scancontext create]
  1094.     scanmatch -nocase $ch $regexp {
  1095.         set path [lindex $matchInfo(line) 0]
  1096.         set desc [lrange $matchInfo(line) 1 end]
  1097.         if {![TclXHelp::Display [format "%s - %s" $path $desc]]} {
  1098.             set stop 1
  1099.             return}
  1100.     }
  1101.     set stop 0
  1102.     foreach dir [TclXHelp::RootDirs] {
  1103.         foreach brief [glob -nocomplain $dir/*.brf] {
  1104.             set briefFH [open $brief]
  1105.             try_eval {
  1106.                 scanfile $ch $briefFH
  1107.             } {} {
  1108.                 close $briefFH
  1109.             }
  1110.             if $stop break
  1111.         }
  1112.         if $stop break
  1113.     }
  1114.     scancontext delete $ch
  1115. }
  1116. #
  1117. # profrep  --
  1118. #
  1119. # Generate Tcl profiling reports.
  1120. #------------------------------------------------------------------------------
  1121. # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
  1122. #
  1123. # Permission to use, copy, modify, and distribute this software and its
  1124. # documentation for any purpose and without fee is hereby granted, provided
  1125. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  1126. # Mark Diekhans make no representations about the suitability of this
  1127. # software for any purpose.  It is provided "as is" without express or
  1128. # implied warranty.
  1129. #------------------------------------------------------------------------------
  1130. # $Id: profrep.tcl,v 8.5 1999/03/31 06:37:48 markd Exp $
  1131. #------------------------------------------------------------------------------
  1132. #
  1133.  
  1134. #@package: TclX-profrep profrep
  1135.  
  1136. namespace eval TclXProfRep {
  1137.  
  1138.     #
  1139.     # Convert the profile array from entries that have only the time spent in
  1140.     # the proc to the time spend in the proc and all it calls.
  1141.     #
  1142.     proc sum {inDataVar outDataVar} {
  1143.         upvar 1 $inDataVar inData $outDataVar outData
  1144.  
  1145.         foreach inStack [array names inData] {
  1146.             for {set idx 0} {![lempty [set part [lrange $inStack $idx end]]]} \
  1147.                     {incr idx} {
  1148.                 if ![info exists outData($part)] {
  1149.                     set outData($part) {0 0 0}
  1150.                 }
  1151.                 lassign $outData($part) count real cpu
  1152.                 if {$idx == 0} {
  1153.                     incr count [lindex $inData($inStack) 0]
  1154.                 }
  1155.                 incr real [lindex $inData($inStack) 1]
  1156.                 incr cpu [lindex $inData($inStack) 2]
  1157.                 set outData($part) [list $count $real $cpu]
  1158.             }
  1159.         }
  1160.     }
  1161.  
  1162.     #
  1163.     # Do sort comparison.  May only be called by sort, as it address its
  1164.     # local variables.
  1165.     #
  1166.     proc sortcmp {key1 key2} {
  1167.         upvar profData profData keyIndex keyIndex
  1168.  
  1169.         set val1 [lindex $profData($key1) $keyIndex]
  1170.         set val2 [lindex $profData($key2) $keyIndex]
  1171.  
  1172.         if {$val1 < $val2} {
  1173.             return -1
  1174.         }
  1175.         if {$val1 > $val2} {
  1176.             return 1
  1177.         }
  1178.         return 0
  1179.     }
  1180.  
  1181.     #
  1182.     # Generate a list, sorted in descending order by the specified key, contain
  1183.     # the indices into the summarized data.
  1184.     #
  1185.     proc sort {profDataVar sortKey} {
  1186.         upvar $profDataVar profData
  1187.  
  1188.         case $sortKey {
  1189.             {calls} {set keyIndex 0}
  1190.             {real}  {set keyIndex 1}
  1191.             {cpu}   {set keyIndex 2}
  1192.             default {
  1193.                 error "Expected a sort type of: `calls', `cpu' or ` real'"
  1194.             }
  1195.         }
  1196.  
  1197.         return [lsort -integer -decreasing -command sortcmp \
  1198.                 [array names profData]]
  1199.     }
  1200.  
  1201.     #
  1202.     # Print the sorted report
  1203.     #
  1204.     proc print {profDataVar sortedProcList outFile userTitle} {
  1205.         upvar $profDataVar profData
  1206.  
  1207.         set maxNameLen 0
  1208.         foreach procStack [array names profData] {
  1209.             foreach procName $procStack {
  1210.                 set maxNameLen [max $maxNameLen [clength $procName]]
  1211.             }
  1212.         }
  1213.  
  1214.         if {$outFile == ""} {
  1215.             set outFH stdout
  1216.         } else {
  1217.             set outFH [open $outFile w]
  1218.         }
  1219.  
  1220.         # Output a header.
  1221.  
  1222.         set stackTitle "Procedure Call Stack"
  1223.         set maxNameLen [max [expr $maxNameLen+6] [expr [clength $stackTitle]+4]]
  1224.         set hdr [format "%-${maxNameLen}s %10s %10s %10s" $stackTitle \
  1225.                         "Calls" "Real Time" "CPU Time"]
  1226.         if {$userTitle != ""} {
  1227.             puts $outFH [replicate - [clength $hdr]]
  1228.             puts $outFH $userTitle
  1229.         }
  1230.         puts $outFH [replicate - [clength $hdr]]
  1231.         puts $outFH $hdr
  1232.         puts $outFH [replicate - [clength $hdr]]
  1233.  
  1234.         # Output the data in sorted order.  Trim leading ::.
  1235.  
  1236.         foreach procStack $sortedProcList {
  1237.             set data $profData($procStack)
  1238.             set cmd [lvarpop procStack]
  1239.             regsub {^::} $cmd {} cmd
  1240.             puts $outFH [format "%-${maxNameLen}s %10d %10d %10d" \
  1241.                                 $cmd [lindex $data 0] [lindex $data 1] \
  1242.                                 [lindex $data 2]]
  1243.             foreach procName $procStack {
  1244.                 if {$procName == "<global>"} break
  1245.                 regsub {^::} $procName {} procName
  1246.                 puts $outFH "    $procName"
  1247.             }
  1248.         }
  1249.         if {$outFile != ""} {
  1250.             close $outFH
  1251.         }
  1252.     }
  1253.  
  1254. } ;# TclXProfRep
  1255.  
  1256. #------------------------------------------------------------------------------
  1257. # Generate a report from data collect from the profile command.
  1258. #   o profDataVar (I) - The name of the array containing the data from profile.
  1259. #   o sortKey (I) - Value to sort by. One of "calls", "cpu" or "real".
  1260. #   o outFile (I) - Name of file to write the report to.  If omitted, stdout
  1261. #     is assumed.
  1262. #   o userTitle (I) - Title line to add to output.
  1263.  
  1264. proc profrep {profDataVar sortKey {outFile {}} {userTitle {}}} {
  1265.     upvar $profDataVar profData
  1266.  
  1267.     TclXProfRep::sum profData sumProfData
  1268.     set sortedProcList [TclXProfRep::sort sumProfData $sortKey]
  1269.     TclXProfRep::print sumProfData $sortedProcList $outFile $userTitle
  1270. }
  1271.  
  1272.  
  1273. #
  1274. # pushd.tcl --
  1275. #
  1276. # C-shell style directory stack procs.
  1277. #
  1278. #------------------------------------------------------------------------------
  1279. # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
  1280. #
  1281. # Permission to use, copy, modify, and distribute this software and its
  1282. # documentation for any purpose and without fee is hereby granted, provided
  1283. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  1284. # Mark Diekhans make no representations about the suitability of this
  1285. # software for any purpose.  It is provided "as is" without express or
  1286. # implied warranty.
  1287. #------------------------------------------------------------------------------
  1288. # $Id: pushd.tcl,v 8.3 1999/03/31 06:37:48 markd Exp $
  1289. #------------------------------------------------------------------------------
  1290. #
  1291.  
  1292. #@package: TclX-directory_stack pushd popd dirs
  1293.  
  1294. global TCLXENV(dirPushList)
  1295.  
  1296. set TCLXENV(dirPushList) ""
  1297.  
  1298. proc pushd {{new ""}} {
  1299.     global TCLXENV
  1300.  
  1301.     set current [pwd]
  1302.     if {[clength $new] > 0} {
  1303.         set dirs [glob -nocomplain $new]
  1304.         set count [llength $dirs]
  1305.         if {$count == 0} {
  1306.             error "no such directory: $new"
  1307.         } elseif {$count != 1} {
  1308.             error "ambiguous directory: $new: [join $directories ", "]"
  1309.         }
  1310.         cd [lindex $dirs 0]
  1311.         lvarpush TCLXENV(dirPushList) $current
  1312.     } else {
  1313.         if [lempty $TCLXENV(dirPushList)] {
  1314.             error "directory stack empty"
  1315.         }
  1316.         cd [lindex $TCLXENV(dirPushList) 0]
  1317.         lvarpop TCLXENV(dirPushList)
  1318.         lvarpush TCLXENV(dirPushList) $current
  1319.     }
  1320.     return [pwd]
  1321. }
  1322.  
  1323. proc popd {} {
  1324.     global TCLXENV
  1325.  
  1326.     if [lempty $TCLXENV(dirPushList)] {
  1327.         error "directory stack empty"
  1328.     }
  1329.     cd [lvarpop TCLXENV(dirPushList)]
  1330.     return [pwd]
  1331. }
  1332.  
  1333. proc dirs {} { 
  1334.     global TCLXENV
  1335.     return [concat [list [pwd]] $TCLXENV(dirPushList)]
  1336. }
  1337.  
  1338.  
  1339. #
  1340. # setfuncs --
  1341. #
  1342. # Perform set functions on lists.  Also has a procedure for removing duplicate
  1343. # list entries.
  1344. #------------------------------------------------------------------------------
  1345. # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
  1346. #
  1347. # Permission to use, copy, modify, and distribute this software and its
  1348. # documentation for any purpose and without fee is hereby granted, provided
  1349. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  1350. # Mark Diekhans make no representations about the suitability of this
  1351. # software for any purpose.  It is provided "as is" without express or
  1352. # implied warranty.
  1353. #------------------------------------------------------------------------------
  1354. # $Id: setfuncs.tcl,v 8.4 1999/03/31 06:37:48 markd Exp $
  1355. #------------------------------------------------------------------------------
  1356. #
  1357.  
  1358. #@package: TclX-set_functions union intersect intersect3 lrmdups
  1359.  
  1360. #
  1361. # return the logical union of two lists, removing any duplicates
  1362. #
  1363. proc union {lista listb} {
  1364.     return [lrmdups [concat $lista $listb]]
  1365. }
  1366.  
  1367. #
  1368. # sort a list, returning the sorted version minus any duplicates
  1369. #
  1370. proc lrmdups list {
  1371.     if [lempty $list] {
  1372.         return {}
  1373.     }
  1374.     set list [lsort $list]
  1375.     set last [lvarpop list]
  1376.     lappend result $last
  1377.     foreach element $list {
  1378.     if ![cequal $last $element] {
  1379.         lappend result $element
  1380.         set last $element
  1381.     }
  1382.     }
  1383.     return $result
  1384. }
  1385.  
  1386. #
  1387. # intersect3 - perform the intersecting of two lists, returning a list
  1388. # containing three lists.  The first list is everything in the first
  1389. # list that wasn't in the second, the second list contains the intersection
  1390. # of the two lists, the third list contains everything in the second list
  1391. # that wasn't in the first.
  1392. #
  1393.  
  1394. proc intersect3 {list1 list2} {
  1395.     set la1(0) {} ; unset la1(0)
  1396.     set lai(0) {} ; unset lai(0)
  1397.     set la2(0) {} ; unset la2(0)
  1398.     foreach v $list1 {
  1399.         set la1($v) {}
  1400.     }
  1401.     foreach v $list2 {
  1402.         set la2($v) {}
  1403.     }
  1404.     foreach elem [concat $list1 $list2] {
  1405.         if {[info exists la1($elem)] && [info exists la2($elem)]} {
  1406.             unset la1($elem)
  1407.             unset la2($elem)
  1408.             set lai($elem) {}
  1409.         }
  1410.     }
  1411.     list [lsort [array names la1]] [lsort [array names lai]] \
  1412.          [lsort [array names la2]]
  1413. }
  1414.  
  1415. #
  1416. # intersect - perform an intersection of two lists, returning a list
  1417. # containing every element that was present in both lists
  1418. #
  1419. proc intersect {list1 list2} {
  1420.     set intersectList ""
  1421.  
  1422.     set list1 [lsort $list1]
  1423.     set list2 [lsort $list2]
  1424.  
  1425.     while {1} {
  1426.         if {[lempty $list1] || [lempty $list2]} break
  1427.  
  1428.         set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
  1429.  
  1430.         if {$compareResult < 0} {
  1431.             lvarpop list1
  1432.             continue
  1433.         }
  1434.  
  1435.         if {$compareResult > 0} {
  1436.             lvarpop list2
  1437.             continue
  1438.         }
  1439.  
  1440.         lappend intersectList [lvarpop list1]
  1441.         lvarpop list2
  1442.     }
  1443.     return $intersectList
  1444. }
  1445.  
  1446.  
  1447.  
  1448.  
  1449. #
  1450. # showproc.tcl --
  1451. #
  1452. # Display procedure headers and bodies.
  1453. #------------------------------------------------------------------------------
  1454. # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
  1455. #
  1456. # Permission to use, copy, modify, and distribute this software and its
  1457. # documentation for any purpose and without fee is hereby granted, provided
  1458. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  1459. # Mark Diekhans make no representations about the suitability of this
  1460. # software for any purpose.  It is provided "as is" without express or
  1461. # implied warranty.
  1462. #------------------------------------------------------------------------------
  1463. # $Id: showproc.tcl,v 8.3 1999/03/31 06:37:48 markd Exp $
  1464. #------------------------------------------------------------------------------
  1465. #
  1466.  
  1467. #@package: TclX-showproc showproc
  1468.  
  1469. proc showproc args {
  1470.     if [lempty $args] {
  1471.         set args [info procs]
  1472.     }
  1473.     set out {}
  1474.  
  1475.     foreach procname $args {
  1476.         if [lempty [info procs $procname]] {
  1477.             auto_load $procname
  1478.         }
  1479.         set arglist [info args $procname]
  1480.         set nargs {}
  1481.         while {[llength $arglist] > 0} {
  1482.             set varg [lvarpop arglist 0]
  1483.             if [info default $procname $varg defarg] {
  1484.                 lappend nargs [list $varg $defarg]
  1485.             } else {
  1486.                 lappend nargs $varg
  1487.             }
  1488.         }
  1489.         append out "proc $procname [list $nargs] \{[info body $procname]\}\n"
  1490.     }
  1491.     return $out
  1492. }
  1493.  
  1494.  
  1495. #
  1496. # string_file --
  1497. #
  1498. # Functions to read and write strings from a file that has not been opened.
  1499. #------------------------------------------------------------------------------
  1500. # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
  1501. #
  1502. # Permission to use, copy, modify, and distribute this software and its
  1503. # documentation for any purpose and without fee is hereby granted, provided
  1504. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  1505. # Mark Diekhans make no representations about the suitability of this
  1506. # software for any purpose.  It is provided "as is" without express or
  1507. # implied warranty.
  1508. #------------------------------------------------------------------------------
  1509. # $Id: stringfile.tcl,v 8.4 1999/03/31 06:37:48 markd Exp $
  1510. #------------------------------------------------------------------------------
  1511. #
  1512.  
  1513. #@package: TclX-stringfile_functions read_file write_file
  1514.  
  1515. proc read_file {fileName args} {
  1516.     if {$fileName == "-nonewline"} {
  1517.         set flag $fileName
  1518.         set fileName [lvarpop args]
  1519.     } else {
  1520.         set flag {}
  1521.     }
  1522.     set fp [open $fileName]
  1523.     try_eval {
  1524.         set result [eval read $flag $fp $args]
  1525.     } {} {
  1526.         close $fp
  1527.     }
  1528.     return $result
  1529. } 
  1530.  
  1531. proc write_file {fileName args} {
  1532.     set fp [open $fileName w]
  1533.     try_eval {
  1534.         foreach string $args {
  1535.             puts $fp $string
  1536.         }
  1537.     } {} {
  1538.         close $fp
  1539.     }
  1540. }
  1541.  
  1542.  
  1543.  
  1544. #
  1545. # tcllib.tcl --
  1546. #
  1547. # Various command dealing with tlib package libraries.
  1548. #------------------------------------------------------------------------------
  1549. # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
  1550. #
  1551. # Permission to use, copy, modify, and distribute this software and its
  1552. # documentation for any purpose and without fee is hereby granted, provided
  1553. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  1554. # Mark Diekhans make no representations about the suitability of this
  1555. # software for any purpose.  It is provided "as is" without express or
  1556. # implied warranty.
  1557. #------------------------------------------------------------------------------
  1558. # Copyright (c) 1991-1994 The Regents of the University of California.
  1559. # All rights reserved.
  1560. #
  1561. # Permission is hereby granted, without written agreement and without
  1562. # license or royalty fees, to use, copy, modify, and distribute this
  1563. # software and its documentation for any purpose, provided that the
  1564. # above copyright notice and the following two paragraphs appear in
  1565. # all copies of this software.
  1566. #
  1567. # IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  1568. # DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  1569. # OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  1570. # CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  1571. #
  1572. # THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  1573. # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  1574. # AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  1575. # ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  1576. # PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  1577. #------------------------------------------------------------------------------
  1578. # $Id: tcllib.tcl,v 8.3 1999/03/31 06:37:48 markd Exp $
  1579. #------------------------------------------------------------------------------
  1580. #
  1581.  
  1582. #@package: TclX-libraries searchpath auto_load_file
  1583.  
  1584. #------------------------------------------------------------------------------
  1585. # searchpath:
  1586. # Search a path list for a file. (catch is for bad ~user)
  1587. #
  1588. proc searchpath {pathlist file} {
  1589.     foreach dir $pathlist {
  1590.         if {$dir == ""} {set dir .}
  1591.         if {[catch {file exists $dir/$file} result] == 0 && $result}  {
  1592.             return $dir/$file
  1593.         }
  1594.     }
  1595.     return {}
  1596. }
  1597.  
  1598. #------------------------------------------------------------------------------
  1599. # auto_load_file:
  1600. # Search auto_path for a file and source it.
  1601. #
  1602. proc auto_load_file {name} {
  1603.     global auto_path errorCode
  1604.     if {[string first / $name] >= 0} {
  1605.         return  [uplevel 1 source $name]
  1606.     }
  1607.     set where [searchpath $auto_path $name]
  1608.     if [lempty $where] {
  1609.         error "couldn't find $name in any directory in auto_path"
  1610.     }
  1611.     uplevel 1 source $where
  1612. }
  1613.  
  1614. #@package: TclX-lib-list auto_packages auto_commands
  1615.  
  1616. #------------------------------------------------------------------------------
  1617. # auto_packages:
  1618. # List all of the loadable packages.  If -files is specified, the file paths
  1619. # of the packages is also returned.
  1620.  
  1621. proc auto_packages {{option {}}} {
  1622.     global auto_pkg_index
  1623.  
  1624.     auto_load  ;# Make sure all indexes are loaded.
  1625.     if ![info exists auto_pkg_index] {
  1626.         return {}
  1627.     }
  1628.     
  1629.     set packList [array names auto_pkg_index] 
  1630.     if [lempty $option] {
  1631.         return $packList
  1632.     }
  1633.  
  1634.     if {$option != "-files"} {
  1635.         error "Unknow option \"$option\", expected \"-files\""
  1636.     }
  1637.     set locList {}
  1638.     foreach pack $packList {
  1639.         lappend locList [list $pack [lindex $auto_pkg_index($pack) 0]]
  1640.     }
  1641.     return $locList
  1642. }
  1643.  
  1644. #------------------------------------------------------------------------------
  1645. # auto_commands:
  1646. # List all of the loadable commands.  If -loaders is specified, the commands
  1647. # that will be involked to load the commands is also returned.
  1648.  
  1649. proc auto_commands {{option {}}} {
  1650.     global auto_index
  1651.  
  1652.     auto_load  ;# Make sure all indexes are loaded.
  1653.     if ![info exists auto_index] {
  1654.         return {}
  1655.     }
  1656.     
  1657.     set cmdList [array names auto_index] 
  1658.     if [lempty $option] {
  1659.         return $cmdList
  1660.     }
  1661.  
  1662.     if {$option != "-loaders"} {
  1663.         error "Unknow option \"$option\", expected \"-loaders\""
  1664.     }
  1665.     set loadList {}
  1666.     foreach cmd $cmdList {
  1667.         lappend loadList [list $cmd $auto_index($cmd)]
  1668.     }
  1669.     return $loadList
  1670. }
  1671.  
  1672.  
  1673.  
  1674. #
  1675. # fmath.tcl --
  1676. #
  1677. #   Contains a package of procs that interface to the Tcl expr command built-in
  1678. # functions.  These procs provide compatibility with older versions of TclX and
  1679. # are also generally useful.
  1680. #------------------------------------------------------------------------------
  1681. # Copyright 1993-1999 Karl Lehenbauer and Mark Diekhans.
  1682. #
  1683. # Permission to use, copy, modify, and distribute this software and its
  1684. # documentation for any purpose and without fee is hereby granted, provided
  1685. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  1686. # Mark Diekhans make no representations about the suitability of this
  1687. # software for any purpose.  It is provided "as is" without express or
  1688. # implied warranty.
  1689. #------------------------------------------------------------------------------
  1690. # $Id: fmath.tcl,v 8.3 1999/03/31 06:37:47 markd Exp $
  1691. #------------------------------------------------------------------------------
  1692.  
  1693. #@package: TclX-fmath acos asin atan ceil cos cosh exp fabs floor log log10 \
  1694.            sin sinh sqrt tan tanh fmod pow atan2 abs double int round
  1695.  
  1696. proc acos  x {uplevel [list expr acos($x)]}
  1697. proc asin  x {uplevel [list expr asin($x)]}
  1698. proc atan  x {uplevel [list expr atan($x)]}
  1699. proc ceil  x {uplevel [list expr ceil($x)]}
  1700. proc cos   x {uplevel [list expr cos($x)]}
  1701. proc cosh  x {uplevel [list expr cosh($x)]}
  1702. proc exp   x {uplevel [list expr exp($x)]}
  1703. proc fabs  x {uplevel [list expr abs($x)]}
  1704. proc floor x {uplevel [list expr floor($x)]}
  1705. proc log   x {uplevel [list expr log($x)]}
  1706. proc log10 x {uplevel [list expr log10($x)]}
  1707. proc sin   x {uplevel [list expr sin($x)]}
  1708. proc sinh  x {uplevel [list expr sinh($x)]}
  1709. proc sqrt  x {uplevel [list expr sqrt($x)]}
  1710. proc tan   x {uplevel [list expr tan($x)]}
  1711. proc tanh  x {uplevel [list expr tanh($x)]}
  1712.  
  1713. proc fmod {x n} {uplevel [list expr fmod($x,$n)]}
  1714. proc pow {x n} {uplevel [list expr pow($x,$n)]}
  1715.  
  1716. # New functions that TclX did not provide in eariler versions.
  1717.  
  1718. proc atan2  x {uplevel [list expr atan2($x)]}
  1719. proc abs    x {uplevel [list expr abs($x)]}
  1720. proc double x {uplevel [list expr double($x)]}
  1721. proc int    x {uplevel [list expr int($x)]}
  1722. proc round  x {uplevel [list expr round($x)]}
  1723.  
  1724.  
  1725.  
  1726. #
  1727. # buildhelp.tcl --
  1728. #
  1729. # Program to extract help files from TCL manual pages or TCL script files.
  1730. # The help directories are built as a hierarchical tree of subjects and help
  1731. # files.  
  1732. # 
  1733. #------------------------------------------------------------------------------
  1734. # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
  1735. #
  1736. # Permission to use, copy, modify, and distribute this software and its
  1737. # documentation for any purpose and without fee is hereby granted, provided
  1738. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  1739. # Mark Diekhans make no representations about the suitability of this
  1740. # software for any purpose.  It is provided "as is" without express or
  1741. # implied warranty.
  1742. #------------------------------------------------------------------------------
  1743. # $Id: buildhelp.tcl,v 8.3 1999/03/31 06:37:47 markd Exp $
  1744. #------------------------------------------------------------------------------
  1745. #
  1746. # For nroff man pages, the areas of text to extract are delimited with:
  1747. #
  1748. #     '\"@help: subjectdir/helpfile
  1749. #     '\"@endhelp
  1750. #
  1751. # start in column one. The text between these markers is extracted and stored
  1752. # in help/subjectdir/help.  The file must not exists, this is done to enforced 
  1753. # cleaning out the directories before help file generation is started, thus
  1754. # removing any stale files.  The extracted text is run through:
  1755. #
  1756. #     nroff -man|col -xb   {col -b on BSD derived systems}
  1757. #
  1758. # If there is other text to include in the helpfile, but not in the manual 
  1759. # page, the text, along with nroff formatting commands, may be included using:
  1760. #
  1761. #     '\"@:Other text to include in the help page.
  1762. #
  1763. # A entry in the brief file, used by apropos my be included by:
  1764. #
  1765. #     '\"@brief: Short, one line description
  1766. #
  1767. # These brief request must occur with in the bounds of a help section.
  1768. #
  1769. # If some header text, such as nroff macros, need to be preappended to the
  1770. # text streem before it is run through nroff, then that text can be bracketed
  1771. # with:
  1772. #
  1773. #     '\"@header
  1774. #     '\"@endheader
  1775. #
  1776. # If multiple header blocks are encountered, they will all be preappended.
  1777. #
  1778. # For TCL script files, which are indentified because they end in ".tcl",
  1779. # the text to be extracted is delimited by:
  1780. #
  1781. #    #@help: subjectdir/helpfile
  1782. #    #@endhelp
  1783. #
  1784. # And brief lines are in the form:
  1785. #
  1786. #     #@brief: Short, one line description
  1787. #
  1788. # The only processing done on text extracted from .tcl files it to replace
  1789. # the # in column one with a space.
  1790. #
  1791. #
  1792. #-----------------------------------------------------------------------------
  1793. # 
  1794. # To generate help:
  1795. #
  1796. #   buildhelp helpDir brief.brf filelist
  1797. #
  1798. # o helpDir is the help tree root directory.  helpDir should  exists, but any
  1799. #   subdirectories that don't exists will be created.  helpDir should be
  1800. #   cleaned up before the start of manual page generation, as this program
  1801. #   will not overwrite existing files.
  1802. # o brief.brf  is the name of the brief file to create form the @brief entries.
  1803. #   It must have an extension of ".brf".  It will be created in helpDir.
  1804. # o filelist are the nroff manual pages, or .tcl, .tlib files to extract
  1805. #   the help files from. If the suffix is not .tcl or .tlib, a nroff manual
  1806. #   page is assumed.
  1807. #
  1808. #-----------------------------------------------------------------------------
  1809.  
  1810. #@package: TclX-buildhelp buildhelp
  1811.  
  1812. #-----------------------------------------------------------------------------
  1813. # Truncate a file name of a help file if the system does not support long
  1814. # file names.  If the name starts with `Tcl_', then this prefix is removed.
  1815. # If the name is then over 14 characters, it is truncated to 14 charactes
  1816. #  
  1817. proc TruncFileName {pathName} {
  1818.     global truncFileNames
  1819.  
  1820.     if {!$truncFileNames} {
  1821.         return $pathName}
  1822.     set fileName [file tail $pathName]
  1823.     if {"[crange $fileName 0 3]" == "Tcl_"} {
  1824.         set fileName [crange $fileName 4 end]}
  1825.     set fileName [crange $fileName 0 13]
  1826.     return "[file dirname $pathName]/$fileName"
  1827. }
  1828.  
  1829. #-----------------------------------------------------------------------------
  1830. # Proc to ensure that all directories for the specified file path exists,
  1831. # and if they don't create them.  Don't use -path so we can set the
  1832. # permissions.
  1833.  
  1834. proc EnsureDirs {filePath} {
  1835.     set dirPath [file dirname $filePath]
  1836.     if [file exists $dirPath] return
  1837.     foreach dir [split $dirPath /] {
  1838.         lappend dirList $dir
  1839.         set partPath [join $dirList /]
  1840.         if [file exists $partPath] continue
  1841.  
  1842.         mkdir $partPath
  1843.         chmod u=rwx,go=rx $partPath
  1844.     }
  1845. }
  1846.  
  1847. #-----------------------------------------------------------------------------
  1848. # Proc to set up scan context for use by FilterNroffManPage.
  1849. # This keeps the a two line cache of the previous two lines encountered
  1850. # and the blank lines that followed them.
  1851. #
  1852.  
  1853. proc CreateFilterNroffManPageContext {} {
  1854.     global filterNroffManPageContext
  1855.  
  1856.     set filterNroffManPageContext [scancontext create]
  1857.  
  1858.     # On finding a page header, drop the previous line (which is
  1859.     # the page footer). Also deleting the blank lines followin
  1860.     # the last line on the previous page.
  1861.  
  1862.     scanmatch $filterNroffManPageContext {@@@BUILDHELP@@@} {
  1863.         catch {unset prev2Blanks}
  1864.         catch {unset prev1Line}
  1865.         catch {unset prev1Blanks}
  1866.         set nukeBlanks {}
  1867.     }
  1868.  
  1869.     # Save blank lines
  1870.  
  1871.     scanmatch $filterNroffManPageContext {$^} {
  1872.         if ![info exists nukeBlanks] {
  1873.             append prev1Blanks \n
  1874.         }
  1875.     }
  1876.  
  1877.     # Non-blank line, save it.  Output the 2nd previous line if necessary.
  1878.  
  1879.     scanmatch $filterNroffManPageContext {
  1880.         catch {unset nukeBlanks}
  1881.         if [info exists prev2Line] {
  1882.             puts $outFH $prev2Line
  1883.             unset prev2Line
  1884.         }
  1885.         if [info exists prev2Blanks] {
  1886.             puts $outFH $prev2Blanks nonewline
  1887.             unset prev2Blanks
  1888.         }
  1889.         if [info exists prev1Line] {
  1890.             set prev2Line $prev1Line
  1891.         }
  1892.         set prev1Line $matchInfo(line)
  1893.         if [info exists prev1Blanks] {
  1894.             set prev2Blanks $prev1Blanks
  1895.             unset prev1Blanks
  1896.         }
  1897.     }
  1898. }
  1899.  
  1900. #-----------------------------------------------------------------------------
  1901. # Proc to filter a formatted manual page, removing the page headers and
  1902. # footers.  This relies on each manual page having a .TH macro in the form:
  1903. #   .TH @@@BUILDHELP@@@ n
  1904.  
  1905. proc FilterNroffManPage {inFH outFH} {
  1906.     global filterNroffManPageContext
  1907.  
  1908.     if ![info exists filterNroffManPageContext] {
  1909.         CreateFilterNroffManPageContext
  1910.     }
  1911.  
  1912.     scanfile $filterNroffManPageContext $inFH
  1913.  
  1914.     if [info exists prev2Line] {
  1915.         puts $outFH $prev2Line
  1916.     }
  1917. }
  1918.  
  1919. #-----------------------------------------------------------------------------
  1920. # Proc to set up scan context for use by ExtractNroffHeader
  1921. #
  1922.  
  1923. proc CreateExtractNroffHeaderContext {} {
  1924.     global extractNroffHeaderContext
  1925.  
  1926.     set extractNroffHeaderContext [scancontext create]
  1927.  
  1928.     scanmatch $extractNroffHeaderContext {'\\"@endheader[     ]*$} {
  1929.         break
  1930.     }
  1931.     scanmatch $extractNroffHeaderContext {'\\"@:} {
  1932.         append nroffHeader "[crange $matchInfo(line) 5 end]\n"
  1933.     }
  1934.     scanmatch $extractNroffHeaderContext {
  1935.         append nroffHeader "$matchInfo(line)\n"
  1936.     }
  1937. }
  1938.  
  1939. #-----------------------------------------------------------------------------
  1940. # Proc to extract nroff text to use as a header to all pass to nroff when
  1941. # processing a help file.
  1942. #    manPageFH - The file handle of the manual page.
  1943. #
  1944.  
  1945. proc ExtractNroffHeader {manPageFH} {
  1946.     global extractNroffHeaderContext nroffHeader
  1947.  
  1948.     if ![info exists extractNroffHeaderContext] {
  1949.         CreateExtractNroffHeaderContext
  1950.     }
  1951.     scanfile $extractNroffHeaderContext $manPageFH
  1952. }
  1953.  
  1954.  
  1955. #-----------------------------------------------------------------------------
  1956. # Proc to set up scan context for use by ExtractNroffHelp
  1957. #
  1958.  
  1959. proc CreateExtractNroffHelpContext {} {
  1960.     global extractNroffHelpContext
  1961.  
  1962.     set extractNroffHelpContext [scancontext create]
  1963.  
  1964.     scanmatch $extractNroffHelpContext {^'\\"@endhelp[     ]*$} {
  1965.         break
  1966.     }
  1967.  
  1968.     scanmatch $extractNroffHelpContext {^'\\"@brief:} {
  1969.         if $foundBrief {
  1970.             error {Duplicate "@brief:" entry}
  1971.         }
  1972.         set foundBrief 1
  1973.         puts $briefHelpFH "$helpName\t[csubstr $matchInfo(line) 11 end]"
  1974.         continue
  1975.     }
  1976.  
  1977.     scanmatch $extractNroffHelpContext {^'\\"@:} {
  1978.         puts $nroffFH  [csubstr $matchInfo(line) 5 end]
  1979.         continue
  1980.     }
  1981.     scanmatch $extractNroffHelpContext {^'\\"@help:} {
  1982.         error {"@help" found within another help section"}
  1983.     }
  1984.     scanmatch $extractNroffHelpContext {
  1985.         puts $nroffFH $matchInfo(line)
  1986.     }
  1987. }
  1988.  
  1989. #-----------------------------------------------------------------------------
  1990. # Proc to extract a nroff help file when it is located in the text.
  1991. #    manPageFH - The file handle of the manual page.
  1992. #    manLine - The '\"@help: line starting the data to extract.
  1993. #
  1994.  
  1995. proc ExtractNroffHelp {manPageFH manLine} {
  1996.     global helpDir nroffHeader briefHelpFH colArgs
  1997.     global extractNroffHelpContext
  1998.  
  1999.     if ![info exists extractNroffHelpContext] {
  2000.         CreateExtractNroffHelpContext
  2001.     }
  2002.  
  2003.     set helpName [string trim [csubstr $manLine 9 end]]
  2004.     set helpFile [TruncFileName "$helpDir/$helpName"]
  2005.     if [file exists $helpFile] {
  2006.         error "Help file already exists: $helpFile"
  2007.     }
  2008.     EnsureDirs $helpFile
  2009.  
  2010.     set tmpFile "[file dirname $helpFile]/tmp.[id process]"
  2011.  
  2012.     echo "    creating help file $helpName"
  2013.  
  2014.     set nroffFH [open "| nroff -man | col $colArgs > $tmpFile" w]
  2015.  
  2016.     puts $nroffFH {.TH @@@BUILDHELP@@@ 1}
  2017.  
  2018.     set foundBrief 0
  2019.     scanfile $extractNroffHelpContext $manPageFH
  2020.  
  2021.     # Close returns an error on if anything comes back on stderr, even if
  2022.     # its a warning.  Output errors and continue.
  2023.  
  2024.     set stat [catch {
  2025.         close $nroffFH
  2026.     } msg]
  2027.     if $stat {
  2028.         puts stderr "nroff: $msg"
  2029.     }
  2030.  
  2031.     set tmpFH [open $tmpFile r]
  2032.     set helpFH [open $helpFile w]
  2033.  
  2034.     FilterNroffManPage $tmpFH $helpFH
  2035.  
  2036.     close $tmpFH
  2037.     close $helpFH
  2038.  
  2039.     unlink $tmpFile
  2040.     chmod a-w,a+r $helpFile
  2041. }
  2042.  
  2043. #-----------------------------------------------------------------------------
  2044. # Proc to set up scan context for use by ExtractScriptHelp
  2045. #
  2046.  
  2047. proc CreateExtractScriptHelpContext {} {
  2048.     global extractScriptHelpContext
  2049.  
  2050.     set extractScriptHelpContext [scancontext create]
  2051.  
  2052.     scanmatch $extractScriptHelpContext {^#@endhelp[     ]*$} {
  2053.         break
  2054.     }
  2055.  
  2056.     scanmatch $extractScriptHelpContext {^#@brief:} {
  2057.         if $foundBrief {
  2058.             error {Duplicate "@brief" entry}
  2059.         }
  2060.         set foundBrief 1
  2061.         puts $briefHelpFH "$helpName\t[csubstr $matchInfo(line) 9 end]"
  2062.         continue
  2063.     }
  2064.  
  2065.     scanmatch $extractScriptHelpContext {^#@help:} {
  2066.         error {"@help" found within another help section"}
  2067.     }
  2068.  
  2069.     scanmatch $extractScriptHelpContext {^#$} {
  2070.         puts $helpFH ""
  2071.     }
  2072.  
  2073.     scanmatch $extractScriptHelpContext {
  2074.         if {[clength $matchInfo(line)] > 1} {
  2075.             puts $helpFH " [csubstr $matchInfo(line) 1 end]"
  2076.         } else {
  2077.             puts $helpFH $matchInfo(line)
  2078.         }
  2079.     }
  2080. }
  2081.  
  2082. #-----------------------------------------------------------------------------
  2083. # Proc to extract a tcl script help file when it is located in the text.
  2084. #    ScriptPageFH - The file handle of the .tcl file.
  2085. #    ScriptLine - The #@help: line starting the data to extract.
  2086. #
  2087.  
  2088. proc ExtractScriptHelp {scriptPageFH scriptLine} {
  2089.     global helpDir briefHelpFH
  2090.     global extractScriptHelpContext
  2091.  
  2092.     if ![info exists extractScriptHelpContext] {
  2093.         CreateExtractScriptHelpContext
  2094.     }
  2095.  
  2096.     set helpName [string trim [csubstr $scriptLine 7 end]]
  2097.     set helpFile "$helpDir/$helpName"
  2098.     if {[file exists $helpFile]} {
  2099.         error "Help file already exists: $helpFile"
  2100.     }
  2101.     EnsureDirs $helpFile
  2102.  
  2103.     echo "    creating help file $helpName"
  2104.  
  2105.     set helpFH [open $helpFile w]
  2106.  
  2107.     set foundBrief 0
  2108.     scanfile $extractScriptHelpContext $scriptPageFH
  2109.  
  2110.     close $helpFH
  2111.     chmod a-w,a+r $helpFile
  2112. }
  2113.  
  2114. #-----------------------------------------------------------------------------
  2115. # Proc to scan a nroff manual file looking for the start of a help text
  2116. # sections and extracting those sections.
  2117. #    pathName - Full path name of file to extract documentation from.
  2118. #
  2119.  
  2120. proc ProcessNroffFile {pathName} {
  2121.    global nroffScanCT scriptScanCT nroffHeader
  2122.  
  2123.    set fileName [file tail $pathName]
  2124.  
  2125.    set nroffHeader {}
  2126.    set manPageFH [open $pathName r]
  2127.    set matchInfo(fileName) [file tail $pathName]
  2128.  
  2129.    echo "    scanning $pathName"
  2130.  
  2131.    scanfile $nroffScanCT $manPageFH
  2132.  
  2133.    close $manPageFH
  2134. }
  2135.  
  2136. #-----------------------------------------------------------------------------
  2137. # Proc to scan a Tcl script file looking for the start of a
  2138. # help text sections and extracting those sections.
  2139. #    pathName - Full path name of file to extract documentation from.
  2140. #
  2141.  
  2142. proc ProcessTclScript {pathName} {
  2143.    global scriptScanCT nroffHeader
  2144.  
  2145.    set scriptFH [open "$pathName" r]
  2146.    set matchInfo(fileName) [file tail $pathName]
  2147.  
  2148.    echo "    scanning $pathName"
  2149.    scanfile $scriptScanCT $scriptFH
  2150.  
  2151.    close $scriptFH
  2152. }
  2153.  
  2154. #-----------------------------------------------------------------------------
  2155. # build: main procedure.  Generates help from specified files.
  2156. #    helpDirPath - Directory were the help files go.
  2157. #    briefFile - The name of the brief file to create.
  2158. #    sourceFiles - List of files to extract help files from.
  2159.  
  2160. proc buildhelp {helpDirPath briefFile sourceFiles} {
  2161.     global helpDir truncFileNames nroffScanCT
  2162.     global scriptScanCT briefHelpFH colArgs
  2163.  
  2164.     echo ""
  2165.     echo "Begin building help tree"
  2166.  
  2167.     # Determine version of col command to use (no -x on BSD)
  2168.     if {[system {col -bx </dev/null >/dev/null 2>&1}] != 0} {
  2169.         set colArgs {-b}
  2170.     } else {
  2171.         set colArgs {-bx}
  2172.     }
  2173.     set helpDir $helpDirPath
  2174.     if {![file exists $helpDir]} {
  2175.         mkdir $helpDir
  2176.     }
  2177.  
  2178.     if {![file isdirectory $helpDir]} {
  2179.         error [concat "$helpDir is not a directory or does not exist. "  
  2180.                       "This should be the help root directory"]
  2181.     }
  2182.         
  2183.     set status [catch {set tmpFH [open $helpDir/AVeryVeryBigFileName w]}]
  2184.     if {$status != 0} {
  2185.         set truncFileNames 1
  2186.     } else {
  2187.         close $tmpFH
  2188.         unlink $helpDir/AVeryVeryBigFileName
  2189.         set truncFileNames 0
  2190.     }
  2191.  
  2192.     set nroffScanCT [scancontext create]
  2193.  
  2194.     scanmatch $nroffScanCT {'\\"@help:} {
  2195.         ExtractNroffHelp $matchInfo(handle) $matchInfo(line)
  2196.         continue
  2197.     }
  2198.  
  2199.     scanmatch $nroffScanCT {^'\\"@header} {
  2200.         ExtractNroffHeader $matchInfo(handle)
  2201.         continue
  2202.     }
  2203.     scanmatch $nroffScanCT {^'\\"@endhelp} {
  2204.         error [concat {@endhelp" without corresponding "@help:"} \
  2205.                  ", offset = $matchInfo(offset)"]
  2206.     }
  2207.     scanmatch $nroffScanCT {^'\\"@brief} {
  2208.         error [concat {"@brief" without corresponding "@help:"} \
  2209.                  ", offset = $matchInfo(offset)"]
  2210.     }
  2211.  
  2212.     set scriptScanCT [scancontext create]
  2213.     scanmatch $scriptScanCT {^#@help:} {
  2214.         ExtractScriptHelp $matchInfo(handle) $matchInfo(line)
  2215.     }
  2216.  
  2217.     if {[file extension $briefFile] != ".brf"} {
  2218.         error "Brief file \"$briefFile\" must have an extension \".brf\""
  2219.     }
  2220.     if [file exists $helpDir/$briefFile] {
  2221.         error "Brief file \"$helpDir/$briefFile\" already exists"
  2222.     }
  2223.     set briefHelpFH [open "|sort > $helpDir/$briefFile" w]
  2224.  
  2225.     foreach manFile [glob $sourceFiles] {
  2226.         set ext [file extension $manFile]
  2227.         if {$ext == ".tcl" || $ext == ".tlib"} {
  2228.             set status [catch {ProcessTclScript $manFile} msg]
  2229.         } else {
  2230.             set status [catch {ProcessNroffFile $manFile} msg]
  2231.         }
  2232.         if {$status != 0} {
  2233.             global errorInfo errorCode
  2234.             error "Error extracting help from: $manFile" $errorInfo $errorCode
  2235.         }
  2236.     }
  2237.  
  2238.     close $briefHelpFH
  2239.     chmod a-w,a+r $helpDir/$briefFile
  2240.     echo "Completed extraction of help files"
  2241. }
  2242.  
  2243.  
  2244.  
  2245.