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