| | 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 | } |
projects / micropolis / blame_incremental