]> git.zerfleddert.de Git - micropolis/blob - src/tcl/library/init.tcl
7a5c3bc4a8683a203181c912b969ec2bf9d44657
[micropolis] / 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 }
Impressum, Datenschutz