home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / tcl / tclx7_31.z / tclx7_31 / tcldev / tclX7.3a-p1 / tclsrc / tcllib.tcl < prev    next >
Encoding:
Text File  |  1993-12-17  |  6.7 KB  |  203 lines
  1. #
  2. # tcllib.tcl --
  3. #
  4. # Various command dealing with auto-load libraries.  Some of this code is
  5. # taken directly from the UCB Tcl library/init.tcl file.
  6. #------------------------------------------------------------------------------
  7. # Copyright 1992-1993 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. # Copyright (c) 1991-1993 The Regents of the University of California.
  17. # All rights reserved.
  18. #
  19. # Permission is hereby granted, without written agreement and without
  20. # license or royalty fees, to use, copy, modify, and distribute this
  21. # software and its documentation for any purpose, provided that the
  22. # above copyright notice and the following two paragraphs appear in
  23. # all copies of this software.
  24. #
  25. # IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  26. # DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  27. # OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  28. # CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29. #
  30. # THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  31. # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  32. # AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  33. # ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  34. # PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  35. #------------------------------------------------------------------------------
  36. # $Id: tcllib.tcl,v 3.2 1993/12/16 03:58:30 markd Exp $
  37. #------------------------------------------------------------------------------
  38. #
  39.  
  40. #@package: TclX-libraries searchpath auto_load_file
  41.  
  42. #------------------------------------------------------------------------------
  43. # searchpath:
  44. # Search a path list for a file. (catch is for bad ~user)
  45. #
  46. proc searchpath {pathlist file} {
  47.     foreach dir $pathlist {
  48.         if {$dir == ""} {set dir .}
  49.         if {[catch {file exists $dir/$file} result] == 0 && $result}  {
  50.             return $dir/$file
  51.         }
  52.     }
  53.     return {}
  54. }
  55.  
  56. #------------------------------------------------------------------------------
  57. # auto_load_file:
  58. # Search auto_path for a file and source it.
  59. #
  60. proc auto_load_file {name} {
  61.     global auto_path errorCode
  62.     if {[string first / $name] >= 0} {
  63.         return  [uplevel 1 source $name]
  64.     }
  65.     set where [searchpath $auto_path $name]
  66.     if [lempty $where] {
  67.         error "couldn't find $name in any directory in auto_path"
  68.     }
  69.     uplevel 1 source $where
  70. }
  71.  
  72. #@package: TclX-lib-list auto_packages auto_commands
  73.  
  74. #------------------------------------------------------------------------------
  75. # auto_packages:
  76. # List all of the loadable packages.  If -files is specified, the file paths
  77. # of the packages is also returned.
  78.  
  79. proc auto_packages {{option {}}} {
  80.     global auto_pkg_index
  81.  
  82.     auto_load  ;# Make sure all indexes are loaded.
  83.     if ![info exists auto_pkg_index] {
  84.         return {}
  85.     }
  86.     
  87.     set packList [array names auto_pkg_index] 
  88.     if [lempty $option] {
  89.         return $packList
  90.     }
  91.  
  92.     if {$option != "-files"} {
  93.         error "Unknow option \"$option\", expected \"-files\""
  94.     }
  95.     set locList {}
  96.     foreach pack $packList {
  97.         lappend locList [list $pack [lindex $auto_pkg_index($pack) 0]]
  98.     }
  99.     return $locList
  100. }
  101.  
  102. #------------------------------------------------------------------------------
  103. # auto_commands:
  104. # List all of the loadable commands.  If -loaders is specified, the commands
  105. # that will be involked to load the commands is also returned.
  106.  
  107. proc auto_commands {{option {}}} {
  108.     global auto_index
  109.  
  110.     auto_load  ;# Make sure all indexes are loaded.
  111.     if ![info exists auto_index] {
  112.         return {}
  113.     }
  114.     
  115.     set cmdList [array names auto_index] 
  116.     if [lempty $option] {
  117.         return $cmdList
  118.     }
  119.  
  120.     if {$option != "-loaders"} {
  121.         error "Unknow option \"$option\", expected \"-loaders\""
  122.     }
  123.     set loadList {}
  124.     foreach cmd $cmdList {
  125.         lappend loadList [list $cmd $auto_index($cmd)]
  126.     }
  127.     return $loadList
  128. }
  129.  
  130. #@package: TclX-ucblib auto_reset auto_mkindex
  131.  
  132. #------------------------------------------------------------------------------
  133. # auto_reset:
  134. # Destroy all cached information for auto-loading and auto-execution,
  135. # so that the information gets recomputed the next time it's needed.
  136. # Also delete any procedures that are listed in the auto-load index
  137. # except those related to auto-loading.
  138. # *** MODIFIED FOR TclX ***
  139.  
  140. proc auto_reset {} {
  141.     global auto_execs auto_index auto_oldpath
  142.     foreach p [info procs] {
  143.     if {[info exists auto_index($p)] && ($p != "unknown")
  144.         && ![string match auto_* $p]} {
  145.         rename $p {}
  146.     }
  147.     }
  148.     catch {unset auto_execs}
  149.     catch {unset auto_index}
  150.     catch {unset auto_oldpath}
  151.     # *** TclX ***
  152.     global auto_pkg_index
  153.     catch {unset auto_pkg_index}
  154.     set auto_index(buildpackageindex) {source [info library]/buildidx.tcl}
  155.     return
  156. }
  157.  
  158. #------------------------------------------------------------------------------
  159. # auto_mkindex:
  160. # Regenerate a tclIndex file from Tcl source files.  Takes two arguments:
  161. # the name of the directory in which the tclIndex file is to be placed,
  162. # and a glob pattern to use in that directory to locate all of the relevant
  163. # files.
  164.  
  165. proc auto_mkindex {dir files} {
  166.     global errorCode errorInfo
  167.     set oldDir [pwd]
  168.     cd $dir
  169.     set dir [pwd]
  170.     append index "# Tcl autoload index file, version 2.0\n"
  171.     append index "# This file is generated by the \"auto_mkindex\" command\n"
  172.     append index "# and sourced to set up indexing information for one or\n"
  173.     append index "# more commands.  Typically each line is a command that\n"
  174.     append index "# sets an element in the auto_index array, where the\n"
  175.     append index "# element name is the name of a command and the value is\n"
  176.     append index "# a script that loads the command.\n\n"
  177.     foreach file [glob $files] {
  178.     set f ""
  179.     set error [catch {
  180.         set f [open $file]
  181.         while {[gets $f line] >= 0} {
  182.         if [regexp {^proc[     ]+([^     ]*)} $line match procName] {
  183.             append index "set [list auto_index($procName)]"
  184.             append index " \"source \$dir/$file\"\n"
  185.         }
  186.         }
  187.         close $f
  188.     } msg]
  189.     if $error {
  190.         set code $errorCode
  191.         set info $errorInfo
  192.         catch [close $f]
  193.         cd $oldDir
  194.         error $msg $info $code
  195.     }
  196.     }
  197.     set f [open tclIndex w]
  198.     puts $f $index nonewline
  199.     close $f
  200.     cd $oldDir
  201. }
  202.  
  203.