home *** CD-ROM | disk | FTP | other *** search
/ PC World 2001 April / PCWorld_2001-04_cd.bin / Software / TemaCD / webclean / !!!python!!! / BeOpen-Python-2.0.exe / INIT.TCL < prev    next >
Encoding:
Text File  |  2000-08-07  |  16.9 KB  |  588 lines
  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.39.2.1 2000/08/07 21:31:33 hobbs 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.3
  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 where the executable is located, plus ../lib
  34. # relative to that path.
  35. #
  36. # tcl_pkgPath, which is set by the platform-specific initialization routines
  37. #    On UNIX it is compiled in
  38. #       On Windows, it is not used
  39. #    On Macintosh it is "Tool Command Language" in the Extensions folder
  40.  
  41. if {![info exists auto_path]} {
  42.     if {[info exist env(TCLLIBPATH)]} {
  43.     set auto_path $env(TCLLIBPATH)
  44.     } else {
  45.     set auto_path ""
  46.     }
  47. }
  48. if {[string compare [info library] {}]} {
  49.     foreach __dir [list [info library] [file dirname [info library]]] {
  50.     if {[lsearch -exact $auto_path $__dir] < 0} {
  51.         lappend auto_path $__dir
  52.     }
  53.     }
  54. }
  55. set __dir [file join [file dirname [file dirname \
  56.     [info nameofexecutable]]] lib]
  57. if {[lsearch -exact $auto_path $__dir] < 0} {
  58.     lappend auto_path $__dir
  59. }
  60. if {[info exist tcl_pkgPath]} {
  61.     foreach __dir $tcl_pkgPath {
  62.     if {[lsearch -exact $auto_path $__dir] < 0} {
  63.         lappend auto_path $__dir
  64.     }
  65.     }
  66. }
  67. if {[info exists __dir]} {
  68.     unset __dir
  69. }
  70.   
  71. # Windows specific end of initialization
  72.  
  73. if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} {
  74.     namespace eval tcl {
  75.     proc envTraceProc {lo n1 n2 op} {
  76.         set x $::env($n2)
  77.         set ::env($lo) $x
  78.         set ::env([string toupper $lo]) $x
  79.     }
  80.     }
  81.     foreach p [array names env] {
  82.     set u [string toupper $p]
  83.     if {[string compare $u $p]} {
  84.         switch -- $u {
  85.         COMSPEC -
  86.         PATH {
  87.             if {![info exists env($u)]} {
  88.             set env($u) $env($p)
  89.             }
  90.             trace variable env($p) w [list tcl::envTraceProc $p]
  91.             trace variable env($u) w [list tcl::envTraceProc $p]
  92.         }
  93.         }
  94.     }
  95.     }
  96.     if {[info exists p]} {
  97.     unset p
  98.     }
  99.     if {[info exists u]} {
  100.     unset u
  101.     }
  102.     if {![info exists env(COMSPEC)]} {
  103.     if {[string equal $tcl_platform(os) "Windows NT"]} {
  104.         set env(COMSPEC) cmd.exe
  105.     } else {
  106.         set env(COMSPEC) command.com
  107.     }
  108.     }
  109. }
  110.  
  111. # Setup the unknown package handler
  112.  
  113. package unknown tclPkgUnknown
  114.  
  115. # Conditionalize for presence of exec.
  116.  
  117. if {[llength [info commands exec]] == 0} {
  118.  
  119.     # Some machines, such as the Macintosh, do not have exec. Also, on all
  120.     # platforms, safe interpreters do not have exec.
  121.  
  122.     set auto_noexec 1
  123. }
  124. set errorCode ""
  125. set errorInfo ""
  126.  
  127. # Define a log command (which can be overwitten to log errors
  128. # differently, specially when stderr is not available)
  129.  
  130. if {[llength [info commands tclLog]] == 0} {
  131.     proc tclLog {string} {
  132.     catch {puts stderr $string}
  133.     }
  134. }
  135.  
  136. # unknown --
  137. # This procedure is called when a Tcl command is invoked that doesn't
  138. # exist in the interpreter.  It takes the following steps to make the
  139. # command available:
  140. #
  141. #    1. See if the command has the form "namespace inscope ns cmd" and
  142. #       if so, concatenate its arguments onto the end and evaluate it.
  143. #    2. See if the autoload facility can locate the command in a
  144. #       Tcl script file.  If so, load it and execute it.
  145. #    3. If the command was invoked interactively at top-level:
  146. #        (a) see if the command exists as an executable UNIX program.
  147. #        If so, "exec" the command.
  148. #        (b) see if the command requests csh-like history substitution
  149. #        in one of the common forms !!, !<number>, or ^old^new.  If
  150. #        so, emulate csh's history substitution.
  151. #        (c) see if the command is a unique abbreviation for another
  152. #        command.  If so, invoke the command.
  153. #
  154. # Arguments:
  155. # args -    A list whose elements are the words of the original
  156. #        command, including the command name.
  157.  
  158. proc unknown args {
  159.     global auto_noexec auto_noload env unknown_pending tcl_interactive
  160.     global errorCode errorInfo
  161.  
  162.     # If the command word has the form "namespace inscope ns cmd"
  163.     # then concatenate its arguments onto the end and evaluate it.
  164.  
  165.     set cmd [lindex $args 0]
  166.     if {[regexp "^namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
  167.         set arglist [lrange $args 1 end]
  168.     set ret [catch {uplevel $cmd $arglist} result]
  169.         if {$ret == 0} {
  170.             return $result
  171.         } else {
  172.         return -code $ret -errorcode $errorCode $result
  173.         }
  174.     }
  175.  
  176.     # Save the values of errorCode and errorInfo variables, since they
  177.     # may get modified if caught errors occur below.  The variables will
  178.     # be restored just before re-executing the missing command.
  179.  
  180.     set savedErrorCode $errorCode
  181.     set savedErrorInfo $errorInfo
  182.     set name [lindex $args 0]
  183.     if {![info exists auto_noload]} {
  184.     #
  185.     # Make sure we're not trying to load the same proc twice.
  186.     #
  187.     if {[info exists unknown_pending($name)]} {
  188.         return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  189.     }
  190.     set unknown_pending($name) pending;
  191.     set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg]
  192.     unset unknown_pending($name);
  193.     if {$ret != 0} {
  194.         append errorInfo "\n    (autoloading \"$name\")"
  195.         return -code $ret -errorcode $errorCode -errorinfo $errorInfo $msg
  196.     }
  197.     if {![array size unknown_pending]} {
  198.         unset unknown_pending
  199.     }
  200.     if {$msg} {
  201.         set errorCode $savedErrorCode
  202.         set errorInfo $savedErrorInfo
  203.         set code [catch {uplevel 1 $args} msg]
  204.         if {$code ==  1} {
  205.         #
  206.         # Strip the last five lines off the error stack (they're
  207.         # from the "uplevel" command).
  208.         #
  209.  
  210.         set new [split $errorInfo \n]
  211.         set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \n]
  212.         return -code error -errorcode $errorCode \
  213.             -errorinfo $new $msg
  214.         } else {
  215.         return -code $code $msg
  216.         }
  217.     }
  218.     }
  219.  
  220.     if {([info level] == 1) && [string equal [info script] ""] \
  221.         && [info exists tcl_interactive] && $tcl_interactive} {
  222.     if {![info exists auto_noexec]} {
  223.         set new [auto_execok $name]
  224.         if {[string compare {} $new]} {
  225.         set errorCode $savedErrorCode
  226.         set errorInfo $savedErrorInfo
  227.         set redir ""
  228.         if {[string equal [info commands console] ""]} {
  229.             set redir ">&@stdout <@stdin"
  230.         }
  231.         return [uplevel exec $redir $new [lrange $args 1 end]]
  232.         }
  233.     }
  234.     set errorCode $savedErrorCode
  235.     set errorInfo $savedErrorInfo
  236.     if {[string equal $name "!!"]} {
  237.         set newcmd [history event]
  238.     } elseif {[regexp {^!(.+)$} $name dummy event]} {
  239.         set newcmd [history event $event]
  240.     } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
  241.         set newcmd [history event -1]
  242.         catch {regsub -all -- $old $newcmd $new newcmd}
  243.     }
  244.     if {[info exists newcmd]} {
  245.         tclLog $newcmd
  246.         history change $newcmd 0
  247.         return [uplevel $newcmd]
  248.     }
  249.  
  250.     set ret [catch {set cmds [info commands $name*]} msg]
  251.     if {[string equal $name "::"]} {
  252.         set name ""
  253.     }
  254.     if {$ret != 0} {
  255.         return -code $ret -errorcode $errorCode \
  256.         "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
  257.     }
  258.     if {[llength $cmds] == 1} {
  259.         return [uplevel [lreplace $args 0 0 $cmds]]
  260.     }
  261.     if {[llength $cmds]} {
  262.         if {[string equal $name ""]} {
  263.         return -code error "empty command name \"\""
  264.         } else {
  265.         return -code error \
  266.             "ambiguous command name \"$name\": [lsort $cmds]"
  267.         }
  268.     }
  269.     }
  270.     return -code error "invalid command name \"$name\""
  271. }
  272.  
  273. # auto_load --
  274. # Checks a collection of library directories to see if a procedure
  275. # is defined in one of them.  If so, it sources the appropriate
  276. # library file to create the procedure.  Returns 1 if it successfully
  277. # loaded the procedure, 0 otherwise.
  278. #
  279. # Arguments: 
  280. # cmd -            Name of the command to find and load.
  281. # namespace (optional)  The namespace where the command is being used - must be
  282. #                       a canonical namespace as returned [namespace current]
  283. #                       for instance. If not given, namespace current is used.
  284.  
  285. proc auto_load {cmd {namespace {}}} {
  286.     global auto_index auto_oldpath auto_path
  287.  
  288.     if {[string length $namespace] == 0} {
  289.     set namespace [uplevel {namespace current}]
  290.     }
  291.     set nameList [auto_qualify $cmd $namespace]
  292.     # workaround non canonical auto_index entries that might be around
  293.     # from older auto_mkindex versions
  294.     lappend nameList $cmd
  295.     foreach name $nameList {
  296.     if {[info exists auto_index($name)]} {
  297.         uplevel #0 $auto_index($name)
  298.         return [expr {[info commands $name] != ""}]
  299.     }
  300.     }
  301.     if {![info exists auto_path]} {
  302.     return 0
  303.     }
  304.  
  305.     if {![auto_load_index]} {
  306.     return 0
  307.     }
  308.     foreach name $nameList {
  309.     if {[info exists auto_index($name)]} {
  310.         uplevel #0 $auto_index($name)
  311.         # There's a couple of ways to look for a command of a given
  312.         # name.  One is to use
  313.         #    info commands $name
  314.         # Unfortunately, if the name has glob-magic chars in it like *
  315.         # or [], it may not match.  For our purposes here, a better
  316.         # route is to use 
  317.         #    namespace which -command $name
  318.         if { ![string equal [namespace which -command $name] ""] } {
  319.         return 1
  320.         }
  321.     }
  322.     }
  323.     return 0
  324. }
  325.  
  326. # auto_load_index --
  327. # Loads the contents of tclIndex files on the auto_path directory
  328. # list.  This is usually invoked within auto_load to load the index
  329. # of available commands.  Returns 1 if the index is loaded, and 0 if
  330. # the index is already loaded and up to date.
  331. #
  332. # Arguments: 
  333. # None.
  334.  
  335. proc auto_load_index {} {
  336.     global auto_index auto_oldpath auto_path errorInfo errorCode
  337.  
  338.     if {[info exists auto_oldpath] && \
  339.         [string equal $auto_oldpath $auto_path]} {
  340.     return 0
  341.     }
  342.     set auto_oldpath $auto_path
  343.  
  344.     # Check if we are a safe interpreter. In that case, we support only
  345.     # newer format tclIndex files.
  346.  
  347.     set issafe [interp issafe]
  348.     for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
  349.     set dir [lindex $auto_path $i]
  350.     set f ""
  351.     if {$issafe} {
  352.         catch {source [file join $dir tclIndex]}
  353.     } elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
  354.         continue
  355.     } else {
  356.         set error [catch {
  357.         set id [gets $f]
  358.         if {[string equal $id \
  359.             "# Tcl autoload index file, version 2.0"]} {
  360.             eval [read $f]
  361.         } elseif {[string equal $id "# Tcl autoload index file: each line identifies a Tcl"]} {
  362.             while {[gets $f line] >= 0} {
  363.             if {[string equal [string index $line 0] "#"] \
  364.                 || ([llength $line] != 2)} {
  365.                 continue
  366.             }
  367.             set name [lindex $line 0]
  368.             set auto_index($name) \
  369.                 "source [file join $dir [lindex $line 1]]"
  370.             }
  371.         } else {
  372.             error "[file join $dir tclIndex] isn't a proper Tcl index file"
  373.         }
  374.         } msg]
  375.         if {[string compare $f ""]} {
  376.         close $f
  377.         }
  378.         if {$error} {
  379.         error $msg $errorInfo $errorCode
  380.         }
  381.     }
  382.     }
  383.     return 1
  384. }
  385.  
  386. # auto_qualify --
  387. #
  388. # Compute a fully qualified names list for use in the auto_index array.
  389. # For historical reasons, commands in the global namespace do not have leading
  390. # :: in the index key. The list has two elements when the command name is
  391. # relative (no leading ::) and the namespace is not the global one. Otherwise
  392. # only one name is returned (and searched in the auto_index).
  393. #
  394. # Arguments -
  395. # cmd        The command name. Can be any name accepted for command
  396. #               invocations (Like "foo::::bar").
  397. # namespace    The namespace where the command is being used - must be
  398. #               a canonical namespace as returned by [namespace current]
  399. #               for instance.
  400.  
  401. proc auto_qualify {cmd namespace} {
  402.  
  403.     # count separators and clean them up
  404.     # (making sure that foo:::::bar will be treated as foo::bar)
  405.     set n [regsub -all {::+} $cmd :: cmd]
  406.  
  407.     # Ignore namespace if the name starts with ::
  408.     # Handle special case of only leading ::
  409.  
  410.     # Before each return case we give an example of which category it is
  411.     # with the following form :
  412.     # ( inputCmd, inputNameSpace) -> output
  413.  
  414.     if {[regexp {^::(.*)$} $cmd x tail]} {
  415.     if {$n > 1} {
  416.         # ( ::foo::bar , * ) -> ::foo::bar
  417.         return [list $cmd]
  418.     } else {
  419.         # ( ::global , * ) -> global
  420.         return [list $tail]
  421.     }
  422.     }
  423.     
  424.     # Potentially returning 2 elements to try  :
  425.     # (if the current namespace is not the global one)
  426.  
  427.     if {$n == 0} {
  428.     if {[string equal $namespace ::]} {
  429.         # ( nocolons , :: ) -> nocolons
  430.         return [list $cmd]
  431.     } else {
  432.         # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
  433.         return [list ${namespace}::$cmd $cmd]
  434.     }
  435.     } elseif {[string equal $namespace ::]} {
  436.     #  ( foo::bar , :: ) -> ::foo::bar
  437.     return [list ::$cmd]
  438.     } else {
  439.     # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
  440.     return [list ${namespace}::$cmd ::$cmd]
  441.     }
  442. }
  443.  
  444. # auto_import --
  445. #
  446. # Invoked during "namespace import" to make see if the imported commands
  447. # reside in an autoloaded library.  If so, the commands are loaded so
  448. # that they will be available for the import links.  If not, then this
  449. # procedure does nothing.
  450. #
  451. # Arguments -
  452. # pattern    The pattern of commands being imported (like "foo::*")
  453. #               a canonical namespace as returned by [namespace current]
  454.  
  455. proc auto_import {pattern} {
  456.     global auto_index
  457.  
  458.     # If no namespace is specified, this will be an error case
  459.  
  460.     if {![string match *::* $pattern]} {
  461.     return
  462.     }
  463.  
  464.     set ns [uplevel namespace current]
  465.     set patternList [auto_qualify $pattern $ns]
  466.  
  467.     auto_load_index
  468.  
  469.     foreach pattern $patternList {
  470.         foreach name [array names auto_index] {
  471.             if {[string match $pattern $name] && \
  472.             [string equal "" [info commands $name]]} {
  473.                 uplevel #0 $auto_index($name)
  474.             }
  475.         }
  476.     }
  477. }
  478.  
  479. # auto_execok --
  480. #
  481. # Returns string that indicates name of program to execute if 
  482. # name corresponds to a shell builtin or an executable in the
  483. # Windows search path, or "" otherwise.  Builds an associative 
  484. # array auto_execs that caches information about previous checks, 
  485. # for speed.
  486. #
  487. # Arguments: 
  488. # name -            Name of a command.
  489.  
  490. if {[string equal windows $tcl_platform(platform)]} {
  491. # Windows version.
  492. #
  493. # Note that info executable doesn't work under Windows, so we have to
  494. # look for files with .exe, .com, or .bat extensions.  Also, the path
  495. # may be in the Path or PATH environment variables, and path
  496. # components are separated with semicolons, not colons as under Unix.
  497. #
  498. proc auto_execok name {
  499.     global auto_execs env tcl_platform
  500.  
  501.     if {[info exists auto_execs($name)]} {
  502.     return $auto_execs($name)
  503.     }
  504.     set auto_execs($name) ""
  505.  
  506.     set shellBuiltins [list cls copy date del erase dir echo mkdir \
  507.         md rename ren rmdir rd time type ver vol]
  508.     if {[string equal $tcl_platform(os) "Windows NT"]} {
  509.     # NT includes the 'start' built-in
  510.     lappend shellBuiltins "start"
  511.     }
  512.  
  513.     if {[lsearch -exact $shellBuiltins $name] != -1} {
  514.     return [set auto_execs($name) [list $env(COMSPEC) /c $name]]
  515.     }
  516.  
  517.     if {[llength [file split $name]] != 1} {
  518.     foreach ext {{} .com .exe .bat} {
  519.         set file ${name}${ext}
  520.         if {[file exists $file] && ![file isdirectory $file]} {
  521.         return [set auto_execs($name) [list $file]]
  522.         }
  523.     }
  524.     return ""
  525.     }
  526.  
  527.     set path "[file dirname [info nameof]];.;"
  528.     if {[info exists env(WINDIR)]} {
  529.     set windir $env(WINDIR) 
  530.     }
  531.     if {[info exists windir]} {
  532.     if {[string equal $tcl_platform(os) "Windows NT"]} {
  533.         append path "$windir/system32;"
  534.     }
  535.     append path "$windir/system;$windir;"
  536.     }
  537.  
  538.     foreach var {PATH Path path} {
  539.     if {[info exists env($var)]} {
  540.         append path ";$env($var)"
  541.     }
  542.     }
  543.  
  544.     foreach dir [split $path {;}] {
  545.     # Skip already checked directories
  546.     if {[info exists checked($dir)] || [string equal {} $dir]} { continue }
  547.     set checked($dir) {}
  548.     foreach ext {{} .com .exe .bat} {
  549.         set file [file join $dir ${name}${ext}]
  550.         if {[file exists $file] && ![file isdirectory $file]} {
  551.         return [set auto_execs($name) [list $file]]
  552.         }
  553.     }
  554.     }
  555.     return ""
  556. }
  557.  
  558. } else {
  559. # Unix version.
  560. #
  561. proc auto_execok name {
  562.     global auto_execs env
  563.  
  564.     if {[info exists auto_execs($name)]} {
  565.     return $auto_execs($name)
  566.     }
  567.     set auto_execs($name) ""
  568.     if {[llength [file split $name]] != 1} {
  569.     if {[file executable $name] && ![file isdirectory $name]} {
  570.         set auto_execs($name) [list $name]
  571.     }
  572.     return $auto_execs($name)
  573.     }
  574.     foreach dir [split $env(PATH) :] {
  575.     if {[string equal $dir ""]} {
  576.         set dir .
  577.     }
  578.     set file [file join $dir $name]
  579.     if {[file executable $file] && ![file isdirectory $file]} {
  580.         set auto_execs($name) [list $file]
  581.         return $auto_execs($name)
  582.     }
  583.     }
  584.     return ""
  585. }
  586.  
  587. }
  588.