home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tk42r2x.zip / TclTk / lib / tcl7.6 / init.tcl next >
Text File  |  1999-07-27  |  19KB  |  635 lines
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # SCCS: @(#) init.tcl 1.67 96/11/07 17:09:47
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  10. #
  11. # See the file "license.terms" for information on usage and redistribution
  12. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13. #
  14.  
  15. if {[info commands package] == ""} {
  16.     error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
  17. }
  18. package require -exact Tcl 7.6
  19. if [catch {set auto_path $env(TCLLIBPATH)}] {
  20.     set auto_path ""
  21. }
  22. if {[lsearch -exact $auto_path [info library]] < 0} {
  23.     lappend auto_path [info library]
  24. }
  25. catch {
  26.     foreach dir $tcl_pkgPath {
  27.     if {[lsearch -exact $auto_path $dir] < 0} {
  28.         lappend auto_path $dir
  29.     }
  30.     }
  31.     unset dir
  32. }
  33. package unknown tclPkgUnknown
  34. if {[info commands exec] == ""} {
  35.  
  36.     # Some machines, such as the Macintosh, do not have exec. Also, on all
  37.     # platforms, safe interpreters do not have exec.
  38.  
  39.     set auto_noexec 1
  40. }
  41. set errorCode ""
  42. set errorInfo ""
  43.  
  44. # unknown --
  45. # This procedure is called when a Tcl command is invoked that doesn't
  46. # exist in the interpreter.  It takes the following steps to make the
  47. # command available:
  48. #
  49. #    1. See if the autoload facility can locate the command in a
  50. #       Tcl script file.  If so, load it and execute it.
  51. #    2. If the command was invoked interactively at top-level:
  52. #        (a) see if the command exists as an executable UNIX program.
  53. #        If so, "exec" the command.
  54. #        (b) see if the command requests csh-like history substitution
  55. #        in one of the common forms !!, !<number>, or ^old^new.  If
  56. #        so, emulate csh's history substitution.
  57. #        (c) see if the command is a unique abbreviation for another
  58. #        command.  If so, invoke the command.
  59. #
  60. # Arguments:
  61. # args -    A list whose elements are the words of the original
  62. #        command, including the command name.
  63.  
  64. proc unknown args {
  65.     global auto_noexec auto_noload env unknown_pending tcl_interactive
  66.     global errorCode errorInfo
  67.  
  68.     # Save the values of errorCode and errorInfo variables, since they
  69.     # may get modified if caught errors occur below.  The variables will
  70.     # be restored just before re-executing the missing command.
  71.  
  72.     set savedErrorCode $errorCode
  73.     set savedErrorInfo $errorInfo
  74.     set name [lindex $args 0]
  75.     if ![info exists auto_noload] {
  76.     #
  77.     # Make sure we're not trying to load the same proc twice.
  78.     #
  79.     if [info exists unknown_pending($name)] {
  80.         return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  81.     }
  82.     set unknown_pending($name) pending;
  83.     set ret [catch {auto_load $name} msg]
  84.     unset unknown_pending($name);
  85.     if {$ret != 0} {
  86.         return -code $ret -errorcode $errorCode \
  87.         "error while autoloading \"$name\": $msg"
  88.     }
  89.     if ![array size unknown_pending] {
  90.         unset unknown_pending
  91.     }
  92.     if $msg {
  93.         set errorCode $savedErrorCode
  94.         set errorInfo $savedErrorInfo
  95.         set code [catch {uplevel $args} msg]
  96.         if {$code ==  1} {
  97.         #
  98.         # Strip the last five lines off the error stack (they're
  99.         # from the "uplevel" command).
  100.         #
  101.  
  102.         set new [split $errorInfo \n]
  103.         set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
  104.         return -code error -errorcode $errorCode \
  105.             -errorinfo $new $msg
  106.         } else {
  107.         return -code $code $msg
  108.         }
  109.     }
  110.     }
  111.     if {([info level] == 1) && ([info script] == "") \
  112.         && [info exists tcl_interactive] && $tcl_interactive} {
  113.     if ![info exists auto_noexec] {
  114.         set new [auto_execok $name]
  115.         if {$new != ""} {
  116.         set errorCode $savedErrorCode
  117.         set errorInfo $savedErrorInfo
  118.         return [uplevel exec >&@stdout <@stdin [list $new] [lrange $args 1 end]]
  119.         }
  120.     }
  121.     set errorCode $savedErrorCode
  122.     set errorInfo $savedErrorInfo
  123.     if {$name == "!!"} {
  124.         return [uplevel {history redo}]
  125.     }
  126.     if [regexp {^!(.+)$} $name dummy event] {
  127.         return [uplevel [list history redo $event]]
  128.     }
  129.     if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
  130.         return [uplevel [list history substitute $old $new]]
  131.     }
  132.     set cmds [info commands $name*]
  133.     if {[llength $cmds] == 1} {
  134.         return [uplevel [lreplace $args 0 0 $cmds]]
  135.     }
  136.     if {[llength $cmds] != 0} {
  137.         if {$name == ""} {
  138.         return -code error "empty command name \"\""
  139.         } else {
  140.         return -code error \
  141.             "ambiguous command name \"$name\": [lsort $cmds]"
  142.         }
  143.     }
  144.     }
  145.     return -code error "invalid command name \"$name\""
  146. }
  147.  
  148. # auto_load --
  149. # Checks a collection of library directories to see if a procedure
  150. # is defined in one of them.  If so, it sources the appropriate
  151. # library file to create the procedure.  Returns 1 if it successfully
  152. # loaded the procedure, 0 otherwise.
  153. #
  154. # Arguments: 
  155. # cmd -            Name of the command to find and load.
  156.  
  157. proc auto_load cmd {
  158.     global auto_index auto_oldpath auto_path env errorInfo errorCode
  159.  
  160.     if [info exists auto_index($cmd)] {
  161.     uplevel #0 $auto_index($cmd)
  162.     return [expr {[info commands $cmd] != ""}]
  163.     }
  164.     if ![info exists auto_path] {
  165.     return 0
  166.     }
  167.     if [info exists auto_oldpath] {
  168.     if {$auto_oldpath == $auto_path} {
  169.         return 0
  170.     }
  171.     }
  172.     set auto_oldpath $auto_path
  173.     for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
  174.     set dir [lindex $auto_path $i]
  175.     set f ""
  176.     if [catch {set f [open [file join $dir tclIndex]]}] {
  177.         continue
  178.     }
  179.     set error [catch {
  180.         set id [gets $f]
  181.         if {$id == "# Tcl autoload index file, version 2.0"} {
  182.         eval [read $f]
  183.         } elseif {$id == "# Tcl autoload index file: each line identifies a Tcl"} {
  184.         while {[gets $f line] >= 0} {
  185.             if {([string index $line 0] == "#")
  186.                 || ([llength $line] != 2)} {
  187.             continue
  188.             }
  189.             set name [lindex $line 0]
  190.             set auto_index($name) \
  191.             "source [file join $dir [lindex $line 1]]"
  192.         }
  193.         } else {
  194.         error "[file join $dir tclIndex] isn't a proper Tcl index file"
  195.         }
  196.     } msg]
  197.     if {$f != ""} {
  198.         close $f
  199.     }
  200.     if $error {
  201.         error $msg $errorInfo $errorCode
  202.     }
  203.     }
  204.     if [info exists auto_index($cmd)] {
  205.     uplevel #0 $auto_index($cmd)
  206.     if {[info commands $cmd] != ""} {
  207.         return 1
  208.     }
  209.     }
  210.     return 0
  211. }
  212.  
  213. if {[string compare $tcl_platform(platform) windows] == 0} {
  214.  
  215. # auto_execok --
  216. #
  217. # Returns string that indicates name of program to execute if 
  218. # name corresponds to a shell builtin or an executable in the
  219. # Windows search path, or "" otherwise.  Builds an associative 
  220. # array auto_execs that caches information about previous checks, 
  221. # for speed.
  222. #
  223. # Arguments: 
  224. # name -            Name of a command.
  225.  
  226. # Windows version.
  227. #
  228. # Note that info executable doesn't work under Windows, so we have to
  229. # look for files with .exe, .com, or .bat extensions.  Also, the path
  230. # may be in the Path or PATH environment variables, and path
  231. # components are separated with semicolons, not colons as under Unix.
  232. #
  233. proc auto_execok name {
  234.     global auto_execs env tcl_platform
  235.  
  236.     if [info exists auto_execs($name)] {
  237.     return $auto_execs($name)
  238.     }
  239.     set auto_execs($name) ""
  240.  
  241.     if {[lsearch -exact {cls copy date del erase dir echo mkdir md rename 
  242.         ren rmdir rd time type ver vol} $name] != -1} {
  243.     if {[info exists env(COMSPEC)]} {
  244.         set comspec $env(COMSPEC) 
  245.     } elseif {[info exists env(ComSpec)]} {
  246.         set comspec $env(ComSpec)
  247.     } elseif {$tcl_platform(os) == "Windows NT"} {
  248.         set comspec "cmd.exe"
  249.     } else {
  250.         set comspec "command.com"
  251.     }
  252.     return [set auto_execs($name) [list $comspec /c $name]]
  253.     }
  254.  
  255.     if {[llength [file split $name]] != 1} {
  256.     foreach ext {{} .com .exe .bat} {
  257.         set file ${name}${ext}
  258.         if {[file exists $file] && ![file isdirectory $file]} {
  259.         return [set auto_execs($name) $file]
  260.         }
  261.     }
  262.     return ""
  263.     }
  264.  
  265.     set path "[file dirname [info nameof]];.;"
  266.     if {[info exists env(WINDIR)]} {
  267.     set windir $env(WINDIR) 
  268.     } elseif {[info exists env(windir)]} {
  269.     set windir $env(windir)
  270.     }
  271.     if {[info exists windir]} {
  272.     if {$tcl_platform(os) == "Windows NT"} {
  273.         append path "$windir/system32;"
  274.     }
  275.     append path "$windir/system;$windir;"
  276.     }
  277.  
  278.     if {! [info exists env(PATH)]} {
  279.     if [info exists env(Path)] {
  280.         append path $env(Path)
  281.     } else {
  282.         return ""
  283.     }
  284.     } else {
  285.     append path $env(PATH)
  286.     }
  287.  
  288.     foreach dir [split $path {;}] {
  289.     if {$dir == ""} {
  290.         set dir .
  291.     }
  292.     foreach ext {{} .com .exe .bat} {
  293.         set file [file join $dir ${name}${ext}]
  294.         if {[file exists $file] && ![file isdirectory $file]} {
  295.         return [set auto_execs($name) $file]
  296.         }
  297.     }
  298.     }
  299.     return ""
  300. }
  301.  
  302. } else {
  303.  
  304. # auto_execok --
  305. #
  306. # Returns string that indicates name of program to execute if 
  307. # name corresponds to an executable in the path. Builds an associative 
  308. # array auto_execs that caches information about previous checks, 
  309. # for speed.
  310. #
  311. # Arguments: 
  312. # name -            Name of a command.
  313.  
  314. # Unix version.
  315. #
  316. proc auto_execok name {
  317.     global auto_execs env
  318.  
  319.     if [info exists auto_execs($name)] {
  320.     return $auto_execs($name)
  321.     }
  322.     set auto_execs($name) ""
  323.     if {[llength [file split $name]] != 1} {
  324.     if {[file executable $name] && ![file isdirectory $name]} {
  325.         set auto_execs($name) $name
  326.     }
  327.     return $auto_execs($name)
  328.     }
  329.     foreach dir [split $env(PATH) :] {
  330.     if {$dir == ""} {
  331.         set dir .
  332.     }
  333.     set file [file join $dir $name]
  334.     if {[file executable $file] && ![file isdirectory $file]} {
  335.         set auto_execs($name) $file
  336.         return $file
  337.     }
  338.     }
  339.     return ""
  340. }
  341.  
  342. }
  343. # auto_reset --
  344. # Destroy all cached information for auto-loading and auto-execution,
  345. # so that the information gets recomputed the next time it's needed.
  346. # Also delete any procedures that are listed in the auto-load index
  347. # except those defined in this file.
  348. #
  349. # Arguments: 
  350. # None.
  351.  
  352. proc auto_reset {} {
  353.     global auto_execs auto_index auto_oldpath
  354.     foreach p [info procs] {
  355.     if {[info exists auto_index($p)] && ![string match auto_* $p]
  356.         && ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup
  357.             tclPkgUnknown} $p] < 0)} {
  358.         rename $p {}
  359.     }
  360.     }
  361.     catch {unset auto_execs}
  362.     catch {unset auto_index}
  363.     catch {unset auto_oldpath}
  364. }
  365.  
  366. # auto_mkindex --
  367. # Regenerate a tclIndex file from Tcl source files.  Takes as argument
  368. # the name of the directory in which the tclIndex file is to be placed,
  369. # followed by any number of glob patterns to use in that directory to
  370. # locate all of the relevant files.
  371. #
  372. # Arguments: 
  373. # dir -            Name of the directory in which to create an index.
  374. # args -        Any number of additional arguments giving the
  375. #            names of files within dir.  If no additional
  376. #            are given auto_mkindex will look for *.tcl.
  377.  
  378. proc auto_mkindex {dir args} {
  379.     global errorCode errorInfo
  380.     set oldDir [pwd]
  381.     cd $dir
  382.     set dir [pwd]
  383.     append index "# Tcl autoload index file, version 2.0\n"
  384.     append index "# This file is generated by the \"auto_mkindex\" command\n"
  385.     append index "# and sourced to set up indexing information for one or\n"
  386.     append index "# more commands.  Typically each line is a command that\n"
  387.     append index "# sets an element in the auto_index array, where the\n"
  388.     append index "# element name is the name of a command and the value is\n"
  389.     append index "# a script that loads the command.\n\n"
  390.     if {$args == ""} {
  391.     set args *.tcl
  392.     }
  393.     foreach file [eval glob $args] {
  394.     set f ""
  395.     set error [catch {
  396.         set f [open $file]
  397.         while {[gets $f line] >= 0} {
  398.         if [regexp {^proc[     ]+([^     ]*)} $line match procName] {
  399.             append index "set [list auto_index($procName)]"
  400.             append index " \[list source \[file join \$dir [list $file]\]\]\n"
  401.         }
  402.         }
  403.         close $f
  404.     } msg]
  405.     if $error {
  406.         set code $errorCode
  407.         set info $errorInfo
  408.         catch {close $f}
  409.         cd $oldDir
  410.         error $msg $info $code
  411.     }
  412.     }
  413.     set f ""
  414.     set error [catch {
  415.     set f [open tclIndex w]
  416.     puts $f $index nonewline
  417.     close $f
  418.     cd $oldDir
  419.     } msg]
  420.     if $error {
  421.     set code $errorCode
  422.     set info $errorInfo
  423.     catch {close $f}
  424.     cd $oldDir
  425.     error $msg $info $code
  426.     }
  427. }
  428.  
  429. # pkg_mkIndex --
  430. # This procedure creates a package index in a given directory.  The
  431. # package index consists of a "pkgIndex.tcl" file whose contents are
  432. # a Tcl script that sets up package information with "package require"
  433. # commands.  The commands describe all of the packages defined by the
  434. # files given as arguments.
  435. #
  436. # Arguments:
  437. # dir -            Name of the directory in which to create the index.
  438. # args -        Any number of additional arguments, each giving
  439. #            a glob pattern that matches the names of one or
  440. #            more shared libraries or Tcl script files in
  441. #            dir.
  442.  
  443. proc pkg_mkIndex {dir args} {
  444.     global errorCode errorInfo
  445.     append index "# Tcl package index file, version 1.0\n"
  446.     append index "# This file is generated by the \"pkg_mkIndex\" command\n"
  447.     append index "# and sourced either when an application starts up or\n"
  448.     append index "# by a \"package unknown\" script.  It invokes the\n"
  449.     append index "# \"package ifneeded\" command to set up package-related\n"
  450.     append index "# information so that packages will be loaded automatically\n"
  451.     append index "# in response to \"package require\" commands.  When this\n"
  452.     append index "# script is sourced, the variable \$dir must contain the\n"
  453.     append index "# full path name of this file's directory.\n"
  454.     set oldDir [pwd]
  455.     cd $dir
  456.     foreach file [eval glob $args] {
  457.     # For each file, figure out what commands and packages it provides.
  458.     # To do this, create a child interpreter, load the file into the
  459.     # interpreter, and get a list of the new commands and packages
  460.     # that are defined.  Define an empty "package unknown" script so
  461.     # that there are no recursive package inclusions.
  462.  
  463.     set c [interp create]
  464.  
  465.     # If Tk is loaded in the parent interpreter, load it into the
  466.     # child also, in case the extension depends on it.
  467.  
  468.     foreach pkg [info loaded] {
  469.         if {[lindex $pkg 1] == "Tk"} {
  470.         $c eval {set argv {-geometry +0+0}}
  471.         load [lindex $pkg 0] Tk $c
  472.         break
  473.         }
  474.     }
  475.     $c eval [list set file $file]
  476.     if [catch {
  477.         $c eval {
  478.         proc dummy args {}
  479.         package unknown dummy
  480.         set origCmds [info commands]
  481.         set dir ""        ;# in case file is pkgIndex.tcl
  482.         set pkgs ""
  483.  
  484.         # Try to load the file if it has the shared library extension,
  485.         # otherwise source it.  It's important not to try to load
  486.         # files that aren't shared libraries, because on some systems
  487.         # (like SunOS) the loader will abort the whole application
  488.         # when it gets an error.
  489.  
  490.         if {[string compare [file extension $file] \
  491.             [info sharedlibextension]] == 0} {
  492.  
  493.             # The "file join ." command below is necessary.  Without
  494.             # it, if the file name has no \'s and we're on UNIX, the
  495.             # load command will invoke the LD_LIBRARY_PATH search
  496.             # mechanism, which could cause the wrong file to be used.
  497.  
  498.             load [file join . $file]
  499.             set type load
  500.         } else {
  501.             source $file
  502.             set type source
  503.         }
  504.         foreach i [info commands] {
  505.             set cmds($i) 1
  506.         }
  507.         foreach i $origCmds {
  508.             catch {unset cmds($i)}
  509.         }
  510.         foreach i [package names] {
  511.             if {([string compare [package provide $i] ""] != 0)
  512.                 && ([string compare $i Tcl] != 0)
  513.                 && ([string compare $i Tk] != 0)} {
  514.             lappend pkgs [list $i [package provide $i]]
  515.             }
  516.         }
  517.         }
  518.     } msg] {
  519.         puts "error while loading or sourcing $file: $msg"
  520.     }
  521.     foreach pkg [$c eval set pkgs] {
  522.         lappend files($pkg) [list $file [$c eval set type] \
  523.             [lsort [$c eval array names cmds]]]
  524.     }
  525.     interp delete $c
  526.     }
  527.     foreach pkg [lsort [array names files]] {
  528.     append index "\npackage ifneeded $pkg\
  529.         \[list tclPkgSetup \$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\
  530.         [list $files($pkg)]\]"
  531.     }
  532.     set f [open pkgIndex.tcl w]
  533.     puts $f $index
  534.     close $f
  535.     cd $oldDir
  536. }
  537.  
  538. # tclPkgSetup --
  539. # This is a utility procedure use by pkgIndex.tcl files.  It is invoked
  540. # as part of a "package ifneeded" script.  It calls "package provide"
  541. # to indicate that a package is available, then sets entries in the
  542. # auto_index array so that the package's files will be auto-loaded when
  543. # the commands are used.
  544. #
  545. # Arguments:
  546. # dir -            Directory containing all the files for this package.
  547. # pkg -            Name of the package (no version number).
  548. # version -        Version number for the package, such as 2.1.3.
  549. # files -        List of files that constitute the package.  Each
  550. #            element is a sub-list with three elements.  The first
  551. #            is the name of a file relative to $dir, the second is
  552. #            "load" or "source", indicating whether the file is a
  553. #            loadable binary or a script to source, and the third
  554. #            is a list of commands defined by this file.
  555.  
  556. proc tclPkgSetup {dir pkg version files} {
  557.     global auto_index
  558.  
  559.     package provide $pkg $version
  560.     foreach fileInfo $files {
  561.     set f [lindex $fileInfo 0]
  562.     set type [lindex $fileInfo 1]
  563.     foreach cmd [lindex $fileInfo 2] {
  564.         if {$type == "load"} {
  565.         set auto_index($cmd) [list load [file join $dir $f] $pkg]
  566.         } else {
  567.         set auto_index($cmd) [list source [file join $dir $f]]
  568.         } 
  569.     }
  570.     }
  571. }
  572.  
  573. # tclMacPkgSearch --
  574. # The procedure is used on the Macintosh to search a given directory for files
  575. # with a TEXT resource named "pkgIndex".  If it exists it is sourced in to the
  576. # interpreter to setup the package database.
  577.  
  578. proc tclMacPkgSearch {dir} {
  579.     foreach x [glob -nocomplain [file join $dir *.shlb]] {
  580.     if [file isfile $x] {
  581.         set res [resource open $x]
  582.         foreach y [resource list TEXT $res] {
  583.         if {$y == "pkgIndex"} {source -rsrc pkgIndex}
  584.         }
  585.         resource close $res
  586.     }
  587.     }
  588. }
  589.  
  590. # tclPkgUnknown --
  591. # This procedure provides the default for the "package unknown" function.
  592. # It is invoked when a package that's needed can't be found.  It scans
  593. # the auto_path directories and their immediate children looking for
  594. # pkgIndex.tcl files and sources any such files that are found to setup
  595. # the package database.  (On the Macintosh we also search for pkgIndex
  596. # TEXT resources in all files.)
  597. #
  598. # Arguments:
  599. # name -        Name of desired package.  Not used.
  600. # version -        Version of desired package.  Not used.
  601. # exact -        Either "-exact" or omitted.  Not used.
  602.  
  603. proc tclPkgUnknown {name version {exact {}}} {
  604.     global auto_path tcl_platform env
  605.  
  606.     if ![info exists auto_path] {
  607.     return
  608.     }
  609.     for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
  610.     set dir [lindex $auto_path $i]
  611.     set file [file join $dir pkgIndex.tcl]
  612.     if [file readable $file] {
  613.         source $file
  614.     }
  615.     foreach file [glob -nocomplain [file join $dir * pkgIndex.tcl]] {
  616.         if [file readable $file] {
  617.         set dir [file dirname $file]
  618.         source $file
  619.         }
  620.     }
  621.     # On the Macintosh we also look in the resource fork 
  622.     # of shared libraries
  623.     if {$tcl_platform(platform) == "macintosh"} {
  624.         set dir [lindex $auto_path $i]
  625.         tclMacPkgSearch $dir
  626.         foreach x [glob -nocomplain [file join $dir *]] {
  627.         if [file isdirectory $x] {
  628.             set dir $x
  629.             tclMacPkgSearch $dir
  630.         }
  631.         }
  632.     }
  633.     }
  634. }
  635.