git.zerfleddert.de Git - micropolis/blob - src/tcl/library/init.tcl

   1 # init.tcl --
   2 #
   3 # Default system startup file for Tcl-based applications.  Defines
   4 # "unknown" procedure and auto-load facilities.
   5 #
   6 # $Header: /user6/ouster/tcl/scripts/RCS/init.tcl,v 1.7 92/07/25 16:29:36 ouster Exp $ SPRITE (Berkeley)
   7 #
   8 # Copyright 1991-1992 Regents of the University of California
   9 # Permission to use, copy, modify, and distribute this
  10 # software and its documentation for any purpose and without
  11 # fee is hereby granted, provided that this copyright
  12 # notice appears in all copies.  The University of California
  13 # makes no representations about the suitability of this
  14 # software for any purpose.  It is provided "as is" without
  15 # express or implied warranty.
  16 #
  17
  18 # unknown:
  19 # Invoked when a Tcl command is invoked that doesn't exist in the
  20 # interpreter:
  21 #
  22 #       1. See if the autoload facility can locate the command in a
  23 #          Tcl script file.  If so, load it and execute it.
  24 #       2. See if the command exists as an executable UNIX program.
  25 #          If so, "exec" the command.
  26 #       3. See if the command is a valid abbreviation for another command.
  27 #          if so, invoke the command.  However, only permit abbreviations
  28 #          at top-level.
  29
  30 proc unknown args {
  31     global auto_noexec auto_noload env unknown_active
  32
  33     if [info exists unknown_active] {
  34         unset unknown_active
  35         error "unexpected recursion in \"unknown\" command"
  36     }
  37     set unknown_active 1
  38     set name [lindex $args 0]
  39     if ![info exists auto_noload] {
  40         if [auto_load $name] {
  41             unset unknown_active
  42             return [uplevel $args]
  43         }
  44     }
  45     if ![info exists auto_noexec] {
  46         if [auto_execok $name] {
  47             unset unknown_active
  48             return [uplevel exec $args]
  49         }
  50     }
  51     if {([info level] == 1) && ([info script] == "")} {
  52         set cmds [info commands $name*]
  53         if {[llength $cmds] == 1} {
  54             unset unknown_active
  55             return [uplevel [lreplace $args 0 0 $cmds]]
  56         }
  57         if {[llength $cmds] != 0} {
  58             unset unknown_active
  59             if {$name == ""} {
  60                 error "empty command name \"\""
  61             } else {
  62                 error "ambiguous command name \"$name\": [lsort $cmds]"
  63             }
  64         }
  65     }
  66     unset unknown_active
  67     error "invalid command name \"$name\""
  68 }
  69
  70 # auto_load:
  71 # Checks a collection of library directories to see if a procedure
  72 # is defined in one of them.  If so, it sources the appropriate
  73 # library file to create the procedure.  Returns 1 if it successfully
  74 # loaded the procedure, 0 otherwise.
  75
  76 proc auto_load cmd {
  77     global auto_index auto_oldpath auto_path env
  78
  79     if [info exists auto_index($cmd)] {
  80         uplevel #0 source $auto_index($cmd)
  81         return 1
  82     }
  83     if [catch {set path $auto_path}] {
  84         if [catch {set path $env(TCLLIBPATH)}] {
  85             if [catch {set path [info library]}] {
  86                 return 0
  87             }
  88         }
  89     }
  90     if [info exists auto_oldpath] {
  91         if {$auto_oldpath == $path} {
  92             return 0
  93         }
  94     }
  95     set auto_oldpath $path
  96     catch {unset auto_index}
  97     foreach dir $path {
  98         set f ""
  99         catch {
 100             set f [open $dir/tclindex]
 101             if {[gets $f] != "# Tcl autoload index file: each line identifies a Tcl"} {
 102                 puts stdout "Bad id line in file $dir/tclindex"
 103                 error done
 104             }
 105             while {[gets $f line] >= 0} {
 106                 if {([string index $line 0] == "#") || ([llength $line] != 2)} {
 107                     continue
 108                 }
 109                 set name [lindex $line 0]
 110                 if {![info exists auto_index($name)]} {
 111                     set auto_index($name) $dir/[lindex $line 1]
 112                 }
 113             }
 114         }
 115         if {$f != ""} {
 116             close $f
 117         }
 118     }
 119     if [info exists auto_index($cmd)] {
 120         uplevel #0 source $auto_index($cmd)
 121         return 1
 122     }
 123     return 0
 124 }
 125
 126 # auto_execok:
 127 # Returns 1 if there's an executable in the current path for the
 128 # given name, 0 otherwise.  Builds an associative array auto_execs
 129 # that caches information about previous checks, for speed.
 130
 131 proc auto_execok name {
 132     global auto_execs env
 133
 134     if [info exists auto_execs($name)] {
 135         return $auto_execs($name)
 136     }
 137     set auto_execs($name) 0
 138     foreach dir [split $env(PATH) :] {
 139         if {[file executable $dir/$name] && ![file isdirectory $dir/$name]} {
 140             set auto_execs($name) 1
 141             return 1
 142         }
 143     }
 144     return 0
 145 }
 146
 147 # auto_reset:
 148 # Destroy all cached information for auto-loading and auto-execution,
 149 # so that the information gets recomputed the next time it's needed.
 150
 151 proc auto_reset {} {
 152     global auto_execs auto_index
 153     unset auto_execs auto_index
 154 }