home *** CD-ROM | disk | FTP | other *** search
/ The Best of Windows 95.com 1996 September / WIN95_09962.iso / vrml / cp2b2x.exe / DATA.Z / init.tcl < prev    next >
Text File  |  1996-04-23  |  8KB  |  292 lines
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # @(#) init.tcl 1.41 95/09/22 15:39:05
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # Copyright (c) 1994 Sun Microsystems, Inc.
  10. #
  11. # See the file "license.terms" for information on usage and redistribution
  12. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13. #
  14.  
  15. set auto_path [list [info library]]
  16. if {[info commands exec] == ""} {
  17.     # Some machines, such as the Macintosh, do not have exec 
  18.     set auto_noexec 1
  19. }
  20. set errorCode ""
  21. set errorInfo ""
  22.  
  23. # unknown:
  24. # Invoked when a Tcl command is invoked that doesn't exist in the
  25. # interpreter:
  26. #
  27. #    1. See if the autoload facility can locate the command in a
  28. #       Tcl script file.  If so, load it and execute it.
  29. #    2. If the command was invoked interactively at top-level:
  30. #        (a) see if the command exists as an executable UNIX program.
  31. #        If so, "exec" the command.
  32. #        (b) see if the command requests csh-like history substitution
  33. #        in one of the common forms !!, !<number>, or ^old^new.  If
  34. #        so, emulate csh's history substitution.
  35. #        (c) see if the command is a unique abbreviation for another
  36. #        command.  If so, invoke the command.
  37.  
  38. proc unknown args {
  39.     global auto_noexec auto_noload env unknown_pending tcl_interactive
  40.     global errorCode errorInfo
  41.  
  42.     # Save the values of errorCode and errorInfo variables, since they
  43.     # may get modified if caught errors occur below.  The variables will
  44.     # be restored just before re-executing the missing command.
  45.  
  46.     set savedErrorCode $errorCode
  47.     set savedErrorInfo $errorInfo
  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.         set errorCode $savedErrorCode
  71.         set errorInfo $savedErrorInfo
  72.         set code [catch {uplevel $args} msg]
  73.         if {$code ==  1} {
  74.         #
  75.         # Strip the last five lines off the error stack (they're
  76.         # from the "uplevel" command).
  77.         #
  78.  
  79.         set new [split $errorInfo \n]
  80.         set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
  81.         return -code error -errorcode $errorCode \
  82.             -errorinfo $new $msg
  83.         } else {
  84.         return -code $code $msg
  85.         }
  86.     }
  87.     }
  88.     if {([info level] == 1) && ([info script] == "") \
  89.         && [info exists tcl_interactive] && $tcl_interactive} {
  90.     if ![info exists auto_noexec] {
  91.         if [auto_execok $name] {
  92.         set errorCode $savedErrorCode
  93.         set errorInfo $savedErrorInfo
  94.         return [uplevel exec >&@stdout <@stdin $args]
  95.         }
  96.     }
  97.     set errorCode $savedErrorCode
  98.     set errorInfo $savedErrorInfo
  99.     if {$name == "!!"} {
  100.         return [uplevel {history redo}]
  101.     }
  102.     if [regexp {^!(.+)$} $name dummy event] {
  103.         return [uplevel [list history redo $event]]
  104.     }
  105.     if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
  106.         return [uplevel [list history substitute $old $new]]
  107.     }
  108.     set cmds [info commands $name*]
  109.     if {[llength $cmds] == 1} {
  110.         return [uplevel [lreplace $args 0 0 $cmds]]
  111.     }
  112.     if {[llength $cmds] != 0} {
  113.         if {$name == ""} {
  114.         return -code error "empty command name \"\""
  115.         } else {
  116.         return -code error \
  117.             "ambiguous command name \"$name\": [lsort $cmds]"
  118.         }
  119.     }
  120.     }
  121.     return -code error "invalid command name \"$name\""
  122. }
  123.  
  124. # auto_load:
  125. # Checks a collection of library directories to see if a procedure
  126. # is defined in one of them.  If so, it sources the appropriate
  127. # library file to create the procedure.  Returns 1 if it successfully
  128. # loaded the procedure, 0 otherwise.
  129.  
  130. proc auto_load cmd {
  131.     global auto_index auto_oldpath auto_path env errorInfo errorCode
  132.  
  133.     if [info exists auto_index($cmd)] {
  134.     uplevel #0 $auto_index($cmd)
  135.     return [expr {[info commands $cmd] != ""}]
  136.     }
  137.     if [catch {set path $auto_path}] {
  138.     if [catch {set path $env(TCLLIBPATH)}] {
  139.         if [catch {set path [info library]}] {
  140.         return 0
  141.         }
  142.     }
  143.     }
  144.     if [info exists auto_oldpath] {
  145.     if {$auto_oldpath == $path} {
  146.         return 0
  147.     }
  148.     }
  149.     set auto_oldpath $path
  150.     catch {unset auto_index}
  151.     for {set i [expr [llength $path] - 1]} {$i >= 0} {incr i -1} {
  152.     set dir [lindex $path $i]
  153.     set f ""
  154.     if [catch {set f [open $dir/tclIndex]}] {
  155.         continue
  156.     }
  157.     set error [catch {
  158.         set id [gets $f]
  159.         if {$id == "# Tcl autoload index file, version 2.0"} {
  160.         eval [read $f]
  161.         } elseif {$id == "# Tcl autoload index file: each line identifies a Tcl"} {
  162.         while {[gets $f line] >= 0} {
  163.             if {([string index $line 0] == "#")
  164.                 || ([llength $line] != 2)} {
  165.             continue
  166.             }
  167.             set name [lindex $line 0]
  168.             set auto_index($name) "source $dir/[lindex $line 1]"
  169.         }
  170.         } else {
  171.         error "$dir/tclIndex isn't a proper Tcl index file"
  172.         }
  173.     } msg]
  174.     if {$f != ""} {
  175.         close $f
  176.     }
  177.     if $error {
  178.         error $msg $errorInfo $errorCode
  179.     }
  180.     }
  181.     if [info exists auto_index($cmd)] {
  182.     uplevel #0 $auto_index($cmd)
  183.     if {[info commands $cmd] != ""} {
  184.         return 1
  185.     }
  186.     }
  187.     return 0
  188. }
  189.  
  190. # auto_execok:
  191. # Returns 1 if there's an executable in the current path for the
  192. # given name, 0 otherwise.  Builds an associative array auto_execs
  193. # that caches information about previous checks, for speed.
  194.  
  195. proc auto_execok name {
  196.     global auto_execs env
  197.  
  198.     if [info exists auto_execs($name)] {
  199.     return $auto_execs($name)
  200.     }
  201.     set auto_execs($name) 0
  202.     if {[string first / $name] >= 0} {
  203.     if {[file executable $name] && ![file isdirectory $name]} {
  204.         set auto_execs($name) 1
  205.     }
  206.     return $auto_execs($name)
  207.     }
  208.     foreach dir [split $env(PATH) :] {
  209.     if {$dir == ""} {
  210.         set dir .
  211.     }
  212.     if {[file executable $dir/$name] && ![file isdirectory $dir/$name]} {
  213.         set auto_execs($name) 1
  214.         return 1
  215.     }
  216.     }
  217.     return 0
  218. }
  219.  
  220. # auto_reset:
  221. # Destroy all cached information for auto-loading and auto-execution,
  222. # so that the information gets recomputed the next time it's needed.
  223. # Also delete any procedures that are listed in the auto-load index
  224. # except those related to auto-loading.
  225.  
  226. proc auto_reset {} {
  227.     global auto_execs auto_index auto_oldpath
  228.     foreach p [info procs] {
  229.     if {[info exists auto_index($p)] && ($p != "unknown")
  230.         && ![string match auto_* $p]} {
  231.         rename $p {}
  232.     }
  233.     }
  234.     catch {unset auto_execs}
  235.     catch {unset auto_index}
  236.     catch {unset auto_oldpath}
  237. }
  238.  
  239. # auto_mkindex:
  240. # Regenerate a tclIndex file from Tcl source files.  Takes as argument
  241. # the name of the directory in which the tclIndex file is to be placed,
  242. # floowed by any number of glob patterns to use in that directory to
  243. # locate all of the relevant files.
  244.  
  245. proc auto_mkindex {dir args} {
  246.     global errorCode errorInfo
  247.     set oldDir [pwd]
  248.     cd $dir
  249.     set dir [pwd]
  250.     append index "# Tcl autoload index file, version 2.0\n"
  251.     append index "# This file is generated by the \"auto_mkindex\" command\n"
  252.     append index "# and sourced to set up indexing information for one or\n"
  253.     append index "# more commands.  Typically each line is a command that\n"
  254.     append index "# sets an element in the auto_index array, where the\n"
  255.     append index "# element name is the name of a command and the value is\n"
  256.     append index "# a script that loads the command.\n\n"
  257.     foreach file [eval glob $args] {
  258.     set f ""
  259.     set error [catch {
  260.         set f [open $file]
  261.         while {[gets $f line] >= 0} {
  262.         if [regexp {^proc[     ]+([^     ]*)} $line match procName] {
  263.             append index "set [list auto_index($procName)]"
  264.             append index " \"source {\$dir/$file}\"\n"
  265.         }
  266.         }
  267.         close $f
  268.     } msg]
  269.     if $error {
  270.         set code $errorCode
  271.         set info $errorInfo
  272.         catch {close $f}
  273.         cd $oldDir
  274.         error $msg $info $code
  275.     }
  276.     }
  277.     set f ""
  278.     set error [catch {
  279.     set f [open tclIndex w]
  280.     puts $f $index nonewline
  281.     close $f
  282.     cd $oldDir
  283.     } msg]
  284.     if $error {
  285.     set code $errorCode
  286.     set info $errorInfo
  287.     catch {close $f}
  288.     cd $oldDir
  289.     error $msg $info $code
  290.     }
  291. }
  292.