![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to init.tcl CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Micropolis - Activity] / micropolis / src / tcl / library|
Return to init.tcl CVS log | Up to [Micropolis - Activity] / micropolis / src / tcl / library |
1.1 root 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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.