Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: data/media/tcl8.4/init.tcl @ 5523

Last change on this file since 5523 was 5167, checked in by rgrieder, 16 years ago

added svn property svn:eol-style native to all tcl files

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