Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # init.tcl -- |
2 | # | |
3 | # Default system startup file for Tcl-based applications. Defines | |
4 | # "unknown" procedure and auto-load facilities. | |
5 | # | |
6 | # RCS: @(#) $Id: init.tcl,v 1.55.2.5 2005/04/28 05:34:40 dgp Exp $ | |
7 | # | |
8 | # Copyright (c) 1991-1993 The Regents of the University of California. | |
9 | # Copyright (c) 1994-1996 Sun Microsystems, Inc. | |
10 | # Copyright (c) 1998-1999 Scriptics Corporation. | |
11 | # | |
12 | # See the file "license.terms" for information on usage and redistribution | |
13 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | |
14 | # | |
15 | ||
16 | if {[info commands package] == ""} { | |
17 | error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" | |
18 | } | |
19 | package require -exact Tcl 8.4 | |
20 | ||
21 | # Compute the auto path to use in this interpreter. | |
22 | # The values on the path come from several locations: | |
23 | # | |
24 | # The environment variable TCLLIBPATH | |
25 | # | |
26 | # tcl_library, which is the directory containing this init.tcl script. | |
27 | # tclInitScript.h searches around for the directory containing this | |
28 | # init.tcl and defines tcl_library to that location before sourcing it. | |
29 | # | |
30 | # The parent directory of tcl_library. Adding the parent | |
31 | # means that packages in peer directories will be found automatically. | |
32 | # | |
33 | # Also add the directory ../lib relative to the directory where the | |
34 | # executable is located. This is meant to find binary packages for the | |
35 | # same architecture as the current executable. | |
36 | # | |
37 | # tcl_pkgPath, which is set by the platform-specific initialization routines | |
38 | # On UNIX it is compiled in | |
39 | # On Windows, it is not used | |
40 | # On Macintosh it is "Tool Command Language" in the Extensions folder | |
41 | ||
42 | if {![info exists auto_path]} { | |
43 | if {[info exists env(TCLLIBPATH)]} { | |
44 | set auto_path $env(TCLLIBPATH) | |
45 | } else { | |
46 | set auto_path "" | |
47 | } | |
48 | } | |
49 | namespace eval tcl { | |
50 | variable Dir | |
51 | if {[info library] != ""} { | |
52 | foreach Dir [list [info library] [file dirname [info library]]] { | |
53 | if {[lsearch -exact $::auto_path $Dir] < 0} { | |
54 | lappend ::auto_path $Dir | |
55 | } | |
56 | } | |
57 | } | |
58 | set Dir [file join [file dirname [file dirname \ | |
59 | [info nameofexecutable]]] lib] | |
60 | if {[lsearch -exact $::auto_path $Dir] < 0} { | |
61 | lappend ::auto_path $Dir | |
62 | } | |
63 | if {[info exists ::tcl_pkgPath]} { | |
64 | foreach Dir $::tcl_pkgPath { | |
65 | if {[lsearch -exact $::auto_path $Dir] < 0} { | |
66 | lappend ::auto_path $Dir | |
67 | } | |
68 | } | |
69 | } | |
70 | } | |
71 | ||
72 | # Windows specific end of initialization | |
73 | ||
74 | if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} { | |
75 | namespace eval tcl { | |
76 | proc EnvTraceProc {lo n1 n2 op} { | |
77 | set x $::env($n2) | |
78 | set ::env($lo) $x | |
79 | set ::env([string toupper $lo]) $x | |
80 | } | |
81 | proc InitWinEnv {} { | |
82 | global env tcl_platform | |
83 | foreach p [array names env] { | |
84 | set u [string toupper $p] | |
85 | if {![string equal $u $p]} { | |
86 | switch -- $u { | |
87 | COMSPEC - | |
88 | PATH { | |
89 | if {![info exists env($u)]} { | |
90 | set env($u) $env($p) | |
91 | } | |
92 | trace variable env($p) w \ | |
93 | [namespace code [list EnvTraceProc $p]] | |
94 | trace variable env($u) w \ | |
95 | [namespace code [list EnvTraceProc $p]] | |
96 | } | |
97 | } | |
98 | } | |
99 | } | |
100 | if {![info exists env(COMSPEC)]} { | |
101 | if {[string equal $tcl_platform(os) "Windows NT"]} { | |
102 | set env(COMSPEC) cmd.exe | |
103 | } else { | |
104 | set env(COMSPEC) command.com | |
105 | } | |
106 | } | |
107 | } | |
108 | InitWinEnv | |
109 | } | |
110 | } | |
111 | ||
112 | # Setup the unknown package handler | |
113 | ||
114 | package unknown tclPkgUnknown | |
115 | ||
116 | if {![interp issafe]} { | |
117 | # setup platform specific unknown package handlers | |
118 | if {[string equal $::tcl_platform(platform) "unix"] && \ | |
119 | [string equal $::tcl_platform(os) "Darwin"]} { | |
120 | package unknown [list tcl::MacOSXPkgUnknown [package unknown]] | |
121 | } | |
122 | if {[string equal $::tcl_platform(platform) "macintosh"]} { | |
123 | package unknown [list tcl::MacPkgUnknown [package unknown]] | |
124 | } | |
125 | } | |
126 | ||
127 | # Conditionalize for presence of exec. | |
128 | ||
129 | if {[llength [info commands exec]] == 0} { | |
130 | ||
131 | # Some machines, such as the Macintosh, do not have exec. Also, on all | |
132 | # platforms, safe interpreters do not have exec. | |
133 | ||
134 | set auto_noexec 1 | |
135 | } | |
136 | set errorCode "" | |
137 | set errorInfo "" | |
138 | ||
139 | # Define a log command (which can be overwitten to log errors | |
140 | # differently, specially when stderr is not available) | |
141 | ||
142 | if {[llength [info commands tclLog]] == 0} { | |
143 | proc tclLog {string} { | |
144 | catch {puts stderr $string} | |
145 | } | |
146 | } | |
147 | ||
148 | # unknown -- | |
149 | # This procedure is called when a Tcl command is invoked that doesn't | |
150 | # exist in the interpreter. It takes the following steps to make the | |
151 | # command available: | |
152 | # | |
153 | # 1. See if the command has the form "namespace inscope ns cmd" and | |
154 | # if so, concatenate its arguments onto the end and evaluate it. | |
155 | # 2. See if the autoload facility can locate the command in a | |
156 | # Tcl script file. If so, load it and execute it. | |
157 | # 3. If the command was invoked interactively at top-level: | |
158 | # (a) see if the command exists as an executable UNIX program. | |
159 | # If so, "exec" the command. | |
160 | # (b) see if the command requests csh-like history substitution | |
161 | # in one of the common forms !!, !<number>, or ^old^new. If | |
162 | # so, emulate csh's history substitution. | |
163 | # (c) see if the command is a unique abbreviation for another | |
164 | # command. If so, invoke the command. | |
165 | # | |
166 | # Arguments: | |
167 | # args - A list whose elements are the words of the original | |
168 | # command, including the command name. | |
169 | ||
170 | proc unknown args { | |
171 | global auto_noexec auto_noload env unknown_pending tcl_interactive | |
172 | global errorCode errorInfo | |
173 | ||
174 | # If the command word has the form "namespace inscope ns cmd" | |
175 | # then concatenate its arguments onto the end and evaluate it. | |
176 | ||
177 | set cmd [lindex $args 0] | |
178 | if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} { | |
179 | set arglist [lrange $args 1 end] | |
180 | set ret [catch {uplevel 1 ::$cmd $arglist} result] | |
181 | if {$ret == 0} { | |
182 | return $result | |
183 | } else { | |
184 | return -code $ret -errorcode $errorCode $result | |
185 | } | |
186 | } | |
187 | ||
188 | # Save the values of errorCode and errorInfo variables, since they | |
189 | # may get modified if caught errors occur below. The variables will | |
190 | # be restored just before re-executing the missing command. | |
191 | ||
192 | # Safety check in case something unsets the variables | |
193 | # ::errorInfo or ::errorCode. [Bug 1063707] | |
194 | if {![info exists errorCode]} { | |
195 | set errorCode "" | |
196 | } | |
197 | if {![info exists errorInfo]} { | |
198 | set errorInfo "" | |
199 | } | |
200 | set savedErrorCode $errorCode | |
201 | set savedErrorInfo $errorInfo | |
202 | set name [lindex $args 0] | |
203 | if {![info exists auto_noload]} { | |
204 | # | |
205 | # Make sure we're not trying to load the same proc twice. | |
206 | # | |
207 | if {[info exists unknown_pending($name)]} { | |
208 | return -code error "self-referential recursion in \"unknown\" for command \"$name\""; | |
209 | } | |
210 | set unknown_pending($name) pending; | |
211 | set ret [catch {auto_load $name [uplevel 1 {::namespace current}]} msg] | |
212 | unset unknown_pending($name); | |
213 | if {$ret != 0} { | |
214 | append errorInfo "\n (autoloading \"$name\")" | |
215 | return -code $ret -errorcode $errorCode -errorinfo $errorInfo $msg | |
216 | } | |
217 | if {![array size unknown_pending]} { | |
218 | unset unknown_pending | |
219 | } | |
220 | if {$msg} { | |
221 | set errorCode $savedErrorCode | |
222 | set errorInfo $savedErrorInfo | |
223 | set code [catch {uplevel 1 $args} msg] | |
224 | if {$code == 1} { | |
225 | # | |
226 | # Compute stack trace contribution from the [uplevel]. | |
227 | # Note the dependence on how Tcl_AddErrorInfo, etc. | |
228 | # construct the stack trace. | |
229 | # | |
230 | set cinfo $args | |
231 | set ellipsis "" | |
232 | while {[string bytelength $cinfo] > 150} { | |
233 | set cinfo [string range $cinfo 0 end-1] | |
234 | set ellipsis "..." | |
235 | } | |
236 | append cinfo $ellipsis "\"\n (\"uplevel\" body line 1)" | |
237 | append cinfo "\n invoked from within" | |
238 | append cinfo "\n\"uplevel 1 \$args\"" | |
239 | # | |
240 | # Try each possible form of the stack trace | |
241 | # and trim the extra contribution from the matching case | |
242 | # | |
243 | set expect "$msg\n while executing\n\"$cinfo" | |
244 | if {$errorInfo eq $expect} { | |
245 | # | |
246 | # The stack has only the eval from the expanded command | |
247 | # Do not generate any stack trace here. | |
248 | # | |
249 | return -code error -errorcode $errorCode $msg | |
250 | } | |
251 | # | |
252 | # Stack trace is nested, trim off just the contribution | |
253 | # from the extra "eval" of $args due to the "catch" above. | |
254 | # | |
255 | set expect "\n invoked from within\n\"$cinfo" | |
256 | set exlen [string length $expect] | |
257 | set eilen [string length $errorInfo] | |
258 | set i [expr {$eilen - $exlen - 1}] | |
259 | set einfo [string range $errorInfo 0 $i] | |
260 | # | |
261 | # For now verify that $errorInfo consists of what we are about | |
262 | # to return plus what we expected to trim off. | |
263 | # | |
264 | if {$errorInfo ne "$einfo$expect"} { | |
265 | error "Tcl bug: unexpected stack trace in \"unknown\"" {} \ | |
266 | [list CORE UNKNOWN BADTRACE $expect $errorInfo] | |
267 | } | |
268 | return -code error -errorcode $errorCode \ | |
269 | -errorinfo $einfo $msg | |
270 | } else { | |
271 | return -code $code $msg | |
272 | } | |
273 | } | |
274 | } | |
275 | ||
276 | if {([info level] == 1) && [string equal [info script] ""] \ | |
277 | && [info exists tcl_interactive] && $tcl_interactive} { | |
278 | if {![info exists auto_noexec]} { | |
279 | set new [auto_execok $name] | |
280 | if {$new != ""} { | |
281 | set errorCode $savedErrorCode | |
282 | set errorInfo $savedErrorInfo | |
283 | set redir "" | |
284 | if {[string equal [info commands console] ""]} { | |
285 | set redir ">&@stdout <@stdin" | |
286 | } | |
287 | return [uplevel 1 exec $redir $new [lrange $args 1 end]] | |
288 | } | |
289 | } | |
290 | set errorCode $savedErrorCode | |
291 | set errorInfo $savedErrorInfo | |
292 | if {[string equal $name "!!"]} { | |
293 | set newcmd [history event] | |
294 | } elseif {[regexp {^!(.+)$} $name dummy event]} { | |
295 | set newcmd [history event $event] | |
296 | } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} { | |
297 | set newcmd [history event -1] | |
298 | catch {regsub -all -- $old $newcmd $new newcmd} | |
299 | } | |
300 | if {[info exists newcmd]} { | |
301 | tclLog $newcmd | |
302 | history change $newcmd 0 | |
303 | return [uplevel 1 $newcmd] | |
304 | } | |
305 | ||
306 | set ret [catch {set candidates [info commands $name*]} msg] | |
307 | if {[string equal $name "::"]} { | |
308 | set name "" | |
309 | } | |
310 | if {$ret != 0} { | |
311 | return -code $ret -errorcode $errorCode \ | |
312 | "error in unknown while checking if \"$name\" is\ | |
313 | a unique command abbreviation:\n$msg" | |
314 | } | |
315 | # Filter out bogus matches when $name contained | |
316 | # a glob-special char [Bug 946952] | |
317 | set cmds [list] | |
318 | foreach x $candidates { | |
319 | if {[string range $x 0 [expr [string length $name]-1]] eq $name} { | |
320 | lappend cmds $x | |
321 | } | |
322 | } | |
323 | if {[llength $cmds] == 1} { | |
324 | return [uplevel 1 [lreplace $args 0 0 [lindex $cmds 0]]] | |
325 | } | |
326 | if {[llength $cmds]} { | |
327 | if {[string equal $name ""]} { | |
328 | return -code error "empty command name \"\"" | |
329 | } else { | |
330 | return -code error \ | |
331 | "ambiguous command name \"$name\": [lsort $cmds]" | |
332 | } | |
333 | } | |
334 | } | |
335 | return -code error "invalid command name \"$name\"" | |
336 | } | |
337 | ||
338 | # auto_load -- | |
339 | # Checks a collection of library directories to see if a procedure | |
340 | # is defined in one of them. If so, it sources the appropriate | |
341 | # library file to create the procedure. Returns 1 if it successfully | |
342 | # loaded the procedure, 0 otherwise. | |
343 | # | |
344 | # Arguments: | |
345 | # cmd - Name of the command to find and load. | |
346 | # namespace (optional) The namespace where the command is being used - must be | |
347 | # a canonical namespace as returned [namespace current] | |
348 | # for instance. If not given, namespace current is used. | |
349 | ||
350 | proc auto_load {cmd {namespace {}}} { | |
351 | global auto_index auto_oldpath auto_path | |
352 | ||
353 | if {[string length $namespace] == 0} { | |
354 | set namespace [uplevel 1 [list ::namespace current]] | |
355 | } | |
356 | set nameList [auto_qualify $cmd $namespace] | |
357 | # workaround non canonical auto_index entries that might be around | |
358 | # from older auto_mkindex versions | |
359 | lappend nameList $cmd | |
360 | foreach name $nameList { | |
361 | if {[info exists auto_index($name)]} { | |
362 | namespace eval :: $auto_index($name) | |
363 | # There's a couple of ways to look for a command of a given | |
364 | # name. One is to use | |
365 | # info commands $name | |
366 | # Unfortunately, if the name has glob-magic chars in it like * | |
367 | # or [], it may not match. For our purposes here, a better | |
368 | # route is to use | |
369 | # namespace which -command $name | |
370 | if {[namespace which -command $name] ne ""} { | |
371 | return 1 | |
372 | } | |
373 | } | |
374 | } | |
375 | if {![info exists auto_path]} { | |
376 | return 0 | |
377 | } | |
378 | ||
379 | if {![auto_load_index]} { | |
380 | return 0 | |
381 | } | |
382 | foreach name $nameList { | |
383 | if {[info exists auto_index($name)]} { | |
384 | namespace eval :: $auto_index($name) | |
385 | if {[namespace which -command $name] ne ""} { | |
386 | return 1 | |
387 | } | |
388 | } | |
389 | } | |
390 | return 0 | |
391 | } | |
392 | ||
393 | # auto_load_index -- | |
394 | # Loads the contents of tclIndex files on the auto_path directory | |
395 | # list. This is usually invoked within auto_load to load the index | |
396 | # of available commands. Returns 1 if the index is loaded, and 0 if | |
397 | # the index is already loaded and up to date. | |
398 | # | |
399 | # Arguments: | |
400 | # None. | |
401 | ||
402 | proc auto_load_index {} { | |
403 | global auto_index auto_oldpath auto_path errorInfo errorCode | |
404 | ||
405 | if {[info exists auto_oldpath] && \ | |
406 | [string equal $auto_oldpath $auto_path]} { | |
407 | return 0 | |
408 | } | |
409 | set auto_oldpath $auto_path | |
410 | ||
411 | # Check if we are a safe interpreter. In that case, we support only | |
412 | # newer format tclIndex files. | |
413 | ||
414 | set issafe [interp issafe] | |
415 | for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} { | |
416 | set dir [lindex $auto_path $i] | |
417 | set f "" | |
418 | if {$issafe} { | |
419 | catch {source [file join $dir tclIndex]} | |
420 | } elseif {[catch {set f [open [file join $dir tclIndex]]}]} { | |
421 | continue | |
422 | } else { | |
423 | set error [catch { | |
424 | set id [gets $f] | |
425 | if {[string equal $id \ | |
426 | "# Tcl autoload index file, version 2.0"]} { | |
427 | eval [read $f] | |
428 | } elseif {[string equal $id "# Tcl autoload index file: each line identifies a Tcl"]} { | |
429 | while {[gets $f line] >= 0} { | |
430 | if {[string equal [string index $line 0] "#"] \ | |
431 | || ([llength $line] != 2)} { | |
432 | continue | |
433 | } | |
434 | set name [lindex $line 0] | |
435 | set auto_index($name) \ | |
436 | "source [file join $dir [lindex $line 1]]" | |
437 | } | |
438 | } else { | |
439 | error "[file join $dir tclIndex] isn't a proper Tcl index file" | |
440 | } | |
441 | } msg] | |
442 | if {$f != ""} { | |
443 | close $f | |
444 | } | |
445 | if {$error} { | |
446 | error $msg $errorInfo $errorCode | |
447 | } | |
448 | } | |
449 | } | |
450 | return 1 | |
451 | } | |
452 | ||
453 | # auto_qualify -- | |
454 | # | |
455 | # Compute a fully qualified names list for use in the auto_index array. | |
456 | # For historical reasons, commands in the global namespace do not have leading | |
457 | # :: in the index key. The list has two elements when the command name is | |
458 | # relative (no leading ::) and the namespace is not the global one. Otherwise | |
459 | # only one name is returned (and searched in the auto_index). | |
460 | # | |
461 | # Arguments - | |
462 | # cmd The command name. Can be any name accepted for command | |
463 | # invocations (Like "foo::::bar"). | |
464 | # namespace The namespace where the command is being used - must be | |
465 | # a canonical namespace as returned by [namespace current] | |
466 | # for instance. | |
467 | ||
468 | proc auto_qualify {cmd namespace} { | |
469 | ||
470 | # count separators and clean them up | |
471 | # (making sure that foo:::::bar will be treated as foo::bar) | |
472 | set n [regsub -all {::+} $cmd :: cmd] | |
473 | ||
474 | # Ignore namespace if the name starts with :: | |
475 | # Handle special case of only leading :: | |
476 | ||
477 | # Before each return case we give an example of which category it is | |
478 | # with the following form : | |
479 | # ( inputCmd, inputNameSpace) -> output | |
480 | ||
481 | if {[regexp {^::(.*)$} $cmd x tail]} { | |
482 | if {$n > 1} { | |
483 | # ( ::foo::bar , * ) -> ::foo::bar | |
484 | return [list $cmd] | |
485 | } else { | |
486 | # ( ::global , * ) -> global | |
487 | return [list $tail] | |
488 | } | |
489 | } | |
490 | ||
491 | # Potentially returning 2 elements to try : | |
492 | # (if the current namespace is not the global one) | |
493 | ||
494 | if {$n == 0} { | |
495 | if {[string equal $namespace ::]} { | |
496 | # ( nocolons , :: ) -> nocolons | |
497 | return [list $cmd] | |
498 | } else { | |
499 | # ( nocolons , ::sub ) -> ::sub::nocolons nocolons | |
500 | return [list ${namespace}::$cmd $cmd] | |
501 | } | |
502 | } elseif {[string equal $namespace ::]} { | |
503 | # ( foo::bar , :: ) -> ::foo::bar | |
504 | return [list ::$cmd] | |
505 | } else { | |
506 | # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar | |
507 | return [list ${namespace}::$cmd ::$cmd] | |
508 | } | |
509 | } | |
510 | ||
511 | # auto_import -- | |
512 | # | |
513 | # Invoked during "namespace import" to make see if the imported commands | |
514 | # reside in an autoloaded library. If so, the commands are loaded so | |
515 | # that they will be available for the import links. If not, then this | |
516 | # procedure does nothing. | |
517 | # | |
518 | # Arguments - | |
519 | # pattern The pattern of commands being imported (like "foo::*") | |
520 | # a canonical namespace as returned by [namespace current] | |
521 | ||
522 | proc auto_import {pattern} { | |
523 | global auto_index | |
524 | ||
525 | # If no namespace is specified, this will be an error case | |
526 | ||
527 | if {![string match *::* $pattern]} { | |
528 | return | |
529 | } | |
530 | ||
531 | set ns [uplevel 1 [list ::namespace current]] | |
532 | set patternList [auto_qualify $pattern $ns] | |
533 | ||
534 | auto_load_index | |
535 | ||
536 | foreach pattern $patternList { | |
537 | foreach name [array names auto_index $pattern] { | |
538 | if {([namespace which -command $name] eq "") | |
539 | && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} { | |
540 | namespace eval :: $auto_index($name) | |
541 | } | |
542 | } | |
543 | } | |
544 | } | |
545 | ||
546 | # auto_execok -- | |
547 | # | |
548 | # Returns string that indicates name of program to execute if | |
549 | # name corresponds to a shell builtin or an executable in the | |
550 | # Windows search path, or "" otherwise. Builds an associative | |
551 | # array auto_execs that caches information about previous checks, | |
552 | # for speed. | |
553 | # | |
554 | # Arguments: | |
555 | # name - Name of a command. | |
556 | ||
557 | if {[string equal windows $tcl_platform(platform)]} { | |
558 | # Windows version. | |
559 | # | |
560 | # Note that info executable doesn't work under Windows, so we have to | |
561 | # look for files with .exe, .com, or .bat extensions. Also, the path | |
562 | # may be in the Path or PATH environment variables, and path | |
563 | # components are separated with semicolons, not colons as under Unix. | |
564 | # | |
565 | proc auto_execok name { | |
566 | global auto_execs env tcl_platform | |
567 | ||
568 | if {[info exists auto_execs($name)]} { | |
569 | return $auto_execs($name) | |
570 | } | |
571 | set auto_execs($name) "" | |
572 | ||
573 | set shellBuiltins [list cls copy date del erase dir echo mkdir \ | |
574 | md rename ren rmdir rd time type ver vol] | |
575 | if {[string equal $tcl_platform(os) "Windows NT"]} { | |
576 | # NT includes the 'start' built-in | |
577 | lappend shellBuiltins "start" | |
578 | } | |
579 | if {[info exists env(PATHEXT)]} { | |
580 | # Add an initial ; to have the {} extension check first. | |
581 | set execExtensions [split ";$env(PATHEXT)" ";"] | |
582 | } else { | |
583 | set execExtensions [list {} .com .exe .bat] | |
584 | } | |
585 | ||
586 | if {[lsearch -exact $shellBuiltins $name] != -1} { | |
587 | # When this is command.com for some reason on Win2K, Tcl won't | |
588 | # exec it unless the case is right, which this corrects. COMSPEC | |
589 | # may not point to a real file, so do the check. | |
590 | set cmd $env(COMSPEC) | |
591 | if {[file exists $cmd]} { | |
592 | set cmd [file attributes $cmd -shortname] | |
593 | } | |
594 | return [set auto_execs($name) [list $cmd /c $name]] | |
595 | } | |
596 | ||
597 | if {[llength [file split $name]] != 1} { | |
598 | foreach ext $execExtensions { | |
599 | set file ${name}${ext} | |
600 | if {[file exists $file] && ![file isdirectory $file]} { | |
601 | return [set auto_execs($name) [list $file]] | |
602 | } | |
603 | } | |
604 | return "" | |
605 | } | |
606 | ||
607 | set path "[file dirname [info nameof]];.;" | |
608 | if {[info exists env(WINDIR)]} { | |
609 | set windir $env(WINDIR) | |
610 | } | |
611 | if {[info exists windir]} { | |
612 | if {[string equal $tcl_platform(os) "Windows NT"]} { | |
613 | append path "$windir/system32;" | |
614 | } | |
615 | append path "$windir/system;$windir;" | |
616 | } | |
617 | ||
618 | foreach var {PATH Path path} { | |
619 | if {[info exists env($var)]} { | |
620 | append path ";$env($var)" | |
621 | } | |
622 | } | |
623 | ||
624 | foreach dir [split $path {;}] { | |
625 | # Skip already checked directories | |
626 | if {[info exists checked($dir)] || [string equal {} $dir]} { continue } | |
627 | set checked($dir) {} | |
628 | foreach ext $execExtensions { | |
629 | set file [file join $dir ${name}${ext}] | |
630 | if {[file exists $file] && ![file isdirectory $file]} { | |
631 | return [set auto_execs($name) [list $file]] | |
632 | } | |
633 | } | |
634 | } | |
635 | return "" | |
636 | } | |
637 | ||
638 | } else { | |
639 | # Unix version. | |
640 | # | |
641 | proc auto_execok name { | |
642 | global auto_execs env | |
643 | ||
644 | if {[info exists auto_execs($name)]} { | |
645 | return $auto_execs($name) | |
646 | } | |
647 | set auto_execs($name) "" | |
648 | if {[llength [file split $name]] != 1} { | |
649 | if {[file executable $name] && ![file isdirectory $name]} { | |
650 | set auto_execs($name) [list $name] | |
651 | } | |
652 | return $auto_execs($name) | |
653 | } | |
654 | foreach dir [split $env(PATH) :] { | |
655 | if {[string equal $dir ""]} { | |
656 | set dir . | |
657 | } | |
658 | set file [file join $dir $name] | |
659 | if {[file executable $file] && ![file isdirectory $file]} { | |
660 | set auto_execs($name) [list $file] | |
661 | return $auto_execs($name) | |
662 | } | |
663 | } | |
664 | return "" | |
665 | } | |
666 | ||
667 | } | |
668 | ||
669 | # ::tcl::CopyDirectory -- | |
670 | # | |
671 | # This procedure is called by Tcl's core when attempts to call the | |
672 | # filesystem's copydirectory function fail. The semantics of the call | |
673 | # are that 'dest' does not yet exist, i.e. dest should become the exact | |
674 | # image of src. If dest does exist, we throw an error. | |
675 | # | |
676 | # Note that making changes to this procedure can change the results | |
677 | # of running Tcl's tests. | |
678 | # | |
679 | # Arguments: | |
680 | # action - "renaming" or "copying" | |
681 | # src - source directory | |
682 | # dest - destination directory | |
683 | proc tcl::CopyDirectory {action src dest} { | |
684 | set nsrc [file normalize $src] | |
685 | set ndest [file normalize $dest] | |
686 | if {[string equal $action "renaming"]} { | |
687 | # Can't rename volumes. We could give a more precise | |
688 | # error message here, but that would break the test suite. | |
689 | if {[lsearch -exact [file volumes] $nsrc] != -1} { | |
690 | return -code error "error $action \"$src\" to\ | |
691 | \"$dest\": trying to rename a volume or move a directory\ | |
692 | into itself" | |
693 | } | |
694 | } | |
695 | if {[file exists $dest]} { | |
696 | if {$nsrc == $ndest} { | |
697 | return -code error "error $action \"$src\" to\ | |
698 | \"$dest\": trying to rename a volume or move a directory\ | |
699 | into itself" | |
700 | } | |
701 | if {[string equal $action "copying"]} { | |
702 | return -code error "error $action \"$src\" to\ | |
703 | \"$dest\": file already exists" | |
704 | } else { | |
705 | # Depending on the platform, and on the current | |
706 | # working directory, the directories '.', '..' | |
707 | # can be returned in various combinations. Anyway, | |
708 | # if any other file is returned, we must signal an error. | |
709 | set existing [glob -nocomplain -directory $dest * .*] | |
710 | eval [list lappend existing] \ | |
711 | [glob -nocomplain -directory $dest -type hidden * .*] | |
712 | foreach s $existing { | |
713 | if {([file tail $s] != ".") && ([file tail $s] != "..")} { | |
714 | return -code error "error $action \"$src\" to\ | |
715 | \"$dest\": file already exists" | |
716 | } | |
717 | } | |
718 | } | |
719 | } else { | |
720 | if {[string first $nsrc $ndest] != -1} { | |
721 | set srclen [expr {[llength [file split $nsrc]] -1}] | |
722 | set ndest [lindex [file split $ndest] $srclen] | |
723 | if {$ndest == [file tail $nsrc]} { | |
724 | return -code error "error $action \"$src\" to\ | |
725 | \"$dest\": trying to rename a volume or move a directory\ | |
726 | into itself" | |
727 | } | |
728 | } | |
729 | file mkdir $dest | |
730 | } | |
731 | # Have to be careful to capture both visible and hidden files. | |
732 | # We will also be more generous to the file system and not | |
733 | # assume the hidden and non-hidden lists are non-overlapping. | |
734 | # | |
735 | # On Unix 'hidden' files begin with '.'. On other platforms | |
736 | # or filesystems hidden files may have other interpretations. | |
737 | set filelist [concat [glob -nocomplain -directory $src *] \ | |
738 | [glob -nocomplain -directory $src -types hidden *]] | |
739 | ||
740 | foreach s [lsort -unique $filelist] { | |
741 | if {([file tail $s] != ".") && ([file tail $s] != "..")} { | |
742 | file copy $s [file join $dest [file tail $s]] | |
743 | } | |
744 | } | |
745 | return | |
746 | } |