home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-bin / lib / tcl / init.tcl next >
Encoding:
Text File  |  1996-10-12  |  7.7 KB  |  259 lines
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. #
  7. # Copyright (c) 1991-1993 The Regents of the University of California.
  8. # All rights reserved.
  9. #
  10. # Permission is hereby granted, without written agreement and without
  11. # license or royalty fees, to use, copy, modify, and distribute this
  12. # software and its documentation for any purpose, provided that the
  13. # above copyright notice and the following two paragraphs appear in
  14. # all copies of this software.
  15. #
  16. # IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  17. # DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  18. # OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  19. # CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  20. #
  21. # THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  22. # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  23. # AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  24. # ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  25. # PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  26. #
  27.  
  28. set auto_path [info library]
  29.  
  30. # unknown:
  31. # Invoked when a Tcl command is invoked that doesn't exist in the
  32. # interpreter:
  33. #
  34. #    1. See if the autoload facility can locate the command in a
  35. #       Tcl script file.  If so, load it and execute it.
  36. #    2. See if the command exists as an executable UNIX program.
  37. #       If so, "exec" the command.
  38. #    3. If the command was invoked at top-level:
  39. #        (a) see if the command requests csh-like history substitution
  40. #        in one of the common forms !!, !<number>, or ^old^new.  If
  41. #        so, emulate csh's history substitution.
  42. #        (b) see if the command is a unique abbreviation for another
  43. #        command.  If so, invoke the command.
  44.  
  45. proc unknown args {
  46.     global auto_noexec auto_noload env unknown_pending tcl_interactive;
  47.  
  48.     set name [lindex $args 0]
  49.     if ![info exists auto_noload] {
  50.     #
  51.     # Make sure we're not trying to load the same proc twice.
  52.     #
  53.     if [info exists unknown_pending($name)] {
  54.         unset unknown_pending($name)
  55.         if {[array size unknown_pending] == 0} {
  56.         unset unknown_pending
  57.         }
  58.         return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  59.     }
  60.     set unknown_pending($name) pending;
  61.     set ret [catch {auto_load $name} msg]
  62.     unset unknown_pending($name);
  63.     if {$ret != 0} {
  64.         return -code $ret "error while autoloading \"$name\": $msg"
  65.     }
  66.     if ![array size unknown_pending] {
  67.         unset unknown_pending
  68.     }
  69.     if $msg {
  70.         return [uplevel $args]
  71.     }
  72.     }
  73.     if {([info level] == 1) && ([info script] == "") && $tcl_interactive} {
  74.     if ![info exists auto_noexec] {
  75.         if [auto_execok $name] {
  76.         return [uplevel exec >&@stdout <@stdin $args]
  77.         }
  78.     }
  79.     if {$name == "!!"} {
  80.         return [uplevel {history redo}]
  81.     }
  82.     if [regexp {^!(.+)$} $name dummy event] {
  83.         return [uplevel [list history redo $event]]
  84.     }
  85.     if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
  86.         return [uplevel [list history substitute $old $new]]
  87.     }
  88.     set cmds [info commands $name*]
  89.     if {[llength $cmds] == 1} {
  90.         return [uplevel [lreplace $args 0 0 $cmds]]
  91.     }
  92.     if {[llength $cmds] != 0} {
  93.         if {$name == ""} {
  94.         return -code error "empty command name \"\""
  95.         } else {
  96.         return -code error \
  97.             "ambiguous command name \"$name\": [lsort $cmds]"
  98.         }
  99.     }
  100.     }
  101.     return -code error "invalid command name \"$name\""
  102. }
  103.  
  104. # auto_load:
  105. # Checks a collection of library directories to see if a procedure
  106. # is defined in one of them.  If so, it sources the appropriate
  107. # library file to create the procedure.  Returns 1 if it successfully
  108. # loaded the procedure, 0 otherwise.
  109.  
  110. proc auto_load cmd {
  111.     global auto_index auto_oldpath auto_path env errorInfo errorCode
  112.  
  113.     if [info exists auto_index($cmd)] {
  114.     uplevel #0 $auto_index($cmd)
  115.     return 1
  116.     }
  117.     if [catch {set path $auto_path}] {
  118.     if [catch {set path $env(TCLLIBPATH)}] {
  119.         if [catch {set path [info library]}] {
  120.         return 0
  121.         }
  122.     }
  123.     }
  124.     if [info exists auto_oldpath] {
  125.     if {$auto_oldpath == $path} {
  126.         return 0
  127.     }
  128.     }
  129.     set auto_oldpath $path
  130.     catch {unset auto_index}
  131.     for {set i [expr [llength $path] - 1]} {$i >= 0} {incr i -1} {
  132.     set dir [lindex $path $i]
  133.     set f ""
  134.     if [catch {set f [open $dir/tclIndex]}] {
  135.         continue
  136.     }
  137.     set error [catch {
  138.         set id [gets $f]
  139.         if {$id == "# Tcl autoload index file, version 2.0"} {
  140.         eval [read $f]
  141.         } elseif {$id == "# Tcl autoload index file: each line identifies a Tcl"} {
  142.         while {[gets $f line] >= 0} {
  143.             if {([string index $line 0] == "#")
  144.                 || ([llength $line] != 2)} {
  145.             continue
  146.             }
  147.             set name [lindex $line 0]
  148.             set auto_index($name) "source $dir/[lindex $line 1]"
  149.         }
  150.         } else {
  151.         error "$dir/tclIndex isn't a proper Tcl index file"
  152.         }
  153.     } msg]
  154.     if {$f != ""} {
  155.         close $f
  156.     }
  157.     if $error {
  158.         error $msg $errorInfo $errorCode
  159.     }
  160.     }
  161.     if [info exists auto_index($cmd)] {
  162.     uplevel #0 $auto_index($cmd)
  163.     if {[info commands $cmd] != ""} {
  164.         return 1
  165.     }
  166.     }
  167.     return 0
  168. }
  169.  
  170. # auto_execok:
  171. # Returns 1 if there's an executable in the current path for the
  172. # given name, 0 otherwise.  Builds an associative array auto_execs
  173. # that caches information about previous checks, for speed.
  174.  
  175. proc auto_execok name {
  176.     global auto_execs env
  177.  
  178.     if [info exists auto_execs($name)] {
  179.     return $auto_execs($name)
  180.     }
  181.     set auto_execs($name) 0
  182.     if {[string first / $name] >= 0} {
  183.     if {[file executable $name] && ![file isdirectory $name]} {
  184.         set auto_execs($name) 1
  185.     }
  186.     return $auto_execs($name)
  187.     }
  188.     foreach dir [split $env(PATH) :] {
  189.     if {[file executable $dir/$name] && ![file isdirectory $dir/$name]} {
  190.         set auto_execs($name) 1
  191.         return 1
  192.     }
  193.     }
  194.     return 0
  195. }
  196.  
  197. # auto_reset:
  198. # Destroy all cached information for auto-loading and auto-execution,
  199. # so that the information gets recomputed the next time it's needed.
  200. # Also delete any procedures that are listed in the auto-load index
  201. # except those related to auto-loading.
  202.  
  203. proc auto_reset {} {
  204.     global auto_execs auto_index auto_oldpath
  205.     foreach p [info procs] {
  206.     if {[info exists auto_index($p)] && ($p != "unknown")
  207.         && ![string match auto_* $p]} {
  208.         rename $p {}
  209.     }
  210.     }
  211.     catch {unset auto_execs}
  212.     catch {unset auto_index}
  213.     catch {unset auto_oldpath}
  214. }
  215.  
  216. # auto_mkindex:
  217. # Regenerate a tclIndex file from Tcl source files.  Takes as argument
  218. # the name of the directory in which the tclIndex file is to be placed,
  219. # floowed by any number of glob patterns to use in that directory to
  220. # locate all of the relevant files.
  221.  
  222. proc auto_mkindex {dir args} {
  223.     global errorCode errorInfo
  224.     set oldDir [pwd]
  225.     cd $dir
  226.     set dir [pwd]
  227.     append index "# Tcl autoload index file, version 2.0\n"
  228.     append index "# This file is generated by the \"auto_mkindex\" command\n"
  229.     append index "# and sourced to set up indexing information for one or\n"
  230.     append index "# more commands.  Typically each line is a command that\n"
  231.     append index "# sets an element in the auto_index array, where the\n"
  232.     append index "# element name is the name of a command and the value is\n"
  233.     append index "# a script that loads the command.\n\n"
  234.     foreach file [eval glob $args] {
  235.     set f ""
  236.     set error [catch {
  237.         set f [open $file]
  238.         while {[gets $f line] >= 0} {
  239.         if [regexp {^proc[     ]+([^     ]*)} $line match procName] {
  240.             append index "set [list auto_index($procName)]"
  241.             append index " \"source \$dir/$file\"\n"
  242.         }
  243.         }
  244.         close $f
  245.     } msg]
  246.     if $error {
  247.         set code $errorCode
  248.         set info $errorInfo
  249.         catch {close $f}
  250.         cd $oldDir
  251.         error $msg $info $code
  252.     }
  253.     }
  254.     set f [open tclIndex w]
  255.     puts $f $index nonewline
  256.     close $f
  257.     cd $oldDir
  258. }
  259.