294 lines
21 KiB
C
294 lines
21 KiB
C
#include <tcl.h>
|
|
static char init_tcl[] =
|
|
"# init.tcl --\n#\n# Default system startup file for Tcl-based appli"
|
|
"cations. Defines\n# \"unknown\" procedure and auto-load facilities."
|
|
"\n#\n# SCCS: @(#) init.tcl 1.66 96/10/06 14:29:28\n#\n# Copyright (c)"
|
|
" 1991-1993 The Regents of the University of California.\n# Copyrig"
|
|
"ht (c) 1994-1996 Sun Microsystems, Inc.\n#\n# See the file \"license"
|
|
".terms\" for information on usage and redistribution\n# of this fil"
|
|
"e, and for a DISCLAIMER OF ALL WARRANTIES.\n#\n#-------------------"
|
|
"---------------------------------------------------------\n#\n# Mod"
|
|
"ified by Mark Koennecke in order to redirect unknown into the Sic"
|
|
"s\n# mechanism. Thereby disabling command shortcuts and execution "
|
|
"of shell\n# commands for security reasons.\n#\n# February 1997\n# Hac"
|
|
"ked for Tcl 8.0 September 1997, bad hack if problems start anew\n#"
|
|
"\n#---------------------------------------------------------------"
|
|
"------------\n \nif {[info commands package] == \"\"} {\n error \"ve"
|
|
"rsion mismatch: library\\nscripts expect Tcl version 7.5b1 or late"
|
|
"r but the loaded version is\\nonly [info patchlevel]\"\n}\npackage re"
|
|
"quire -exact Tcl 8.0\n#if [catch {set auto_path $env(TCLLIBPATH)}]"
|
|
" {\n# set auto_path \"\"\n#}\nif {[lsearch -exact $auto_path [info "
|
|
"library]] < 0} {\n lappend auto_path [info library]\n}\ncatch {\n "
|
|
" foreach dir $tcl_pkgPath {\n\tif {[lsearch -exact $auto_path $di"
|
|
"r] < 0} {\n\t lappend auto_path $dir\n\t}\n }\n unset dir\n}\npa"
|
|
"ckage unknown tclPkgUnknown\n\n# Some machines, such as the Macinto"
|
|
"sh, do not have exec. Also, on all\n# platforms, safe interpreters"
|
|
" do not have exec.\n# exec hereby disabled for Security reasons! M"
|
|
"K\n set auto_noexec 1\n\n\nset errorCode \"\"\nset errorInfo \"\"\n\n# un"
|
|
"known --\n# This procedure is called when a Tcl command is invoked"
|
|
" that doesn't\n# exist in the interpreter. It takes the following"
|
|
" steps to make the\n# command available:\n#\n#\t1. See if the autoloa"
|
|
"d facility can locate the command in a\n#\t Tcl script file. If "
|
|
"so, load it and execute it.\n#\t2. If the command was invoked inter"
|
|
"actively at top-level:\n#\t (a) see if the command exists as an "
|
|
"executable UNIX program.\n#\t\tIf so, \"exec\" the command.\n#\t (b) "
|
|
"see if the command requests csh-like history substitution\n#\t\tin o"
|
|
"ne of the common forms !!, !<number>, or ^old^new. If\n#\t\tso, emu"
|
|
"late csh's history substitution.\n#\t (c) see if the command is "
|
|
"a unique abbreviation for another\n#\t\tcommand. If so, invoke the "
|
|
"command.\n#\n# Arguments:\n# args -\tA list whose elements are the wo"
|
|
"rds of the original\n#\t\tcommand, including the command name.\n\nproc"
|
|
" unknown args {\n global auto_noexec auto_noload env unknown_pe"
|
|
"nding tcl_interactive\n global errorCode errorInfo\n\n # Save "
|
|
"the values of errorCode and errorInfo variables, since they\n #"
|
|
" may get modified if caught errors occur below. The variables wi"
|
|
"ll\n # be restored just before re-executing the missing command"
|
|
".\n\n set savedErrorCode $errorCode\n set savedErrorInfo $erro"
|
|
"rInfo\n set name [lindex $args 0]\n if ![info exists auto_nol"
|
|
"oad] {\n\t#\n\t# Make sure we're not trying to load the same proc twi"
|
|
"ce.\n\t#\n\tif [info exists unknown_pending($name)] {\n\t return -co"
|
|
"de error \"self-referential recursion in \\\"unknown\\\" for command \\"
|
|
"\"$name\\\"\";\n\t}\n\tset unknown_pending($name) pending;\n\tset ret [catc"
|
|
"h {auto_load $name} msg]\n\tunset unknown_pending($name);\n\tif {$ret"
|
|
" != 0} {\n\t return -code $ret -errorcode $errorCode \\\n\t\t\"error "
|
|
"while autoloading \\\"$name\\\": $msg\"\n\t}\n\tif ![array size unknown_pe"
|
|
"nding] {\n\t unset unknown_pending\n\t}\n\tif $msg {\n\t set errorC"
|
|
"ode $savedErrorCode\n\t set errorInfo $savedErrorInfo\n\t set c"
|
|
"ode [catch {uplevel $args} msg]\n\t if {$code == 1} {\n\t\t#\n\t\t# S"
|
|
"trip the last five lines off the error stack (they're\n\t\t# from th"
|
|
"e \"uplevel\" command).\n\t\t#\n\n\t\tset new [split $errorInfo \\n]\n\t\tset "
|
|
"new [join [lrange $new 0 [expr [llength $new] - 6]] \\n]\n\t\treturn "
|
|
"-code error -errorcode $errorCode \\\n\t\t\t-errorinfo $new $msg\n\t "
|
|
"} else {\n\t\treturn -code $code $msg\n\t }\n\t}\n }\n \n # Try"
|
|
" running SICS for a change\n set ret [catch {uplevel #0 SicsUnk"
|
|
"nown $args} msg]\n if {$ret == 1} {\n return -code error "
|
|
"$msg\n } else {\n return -code ok $msg\n }\n}\n\n# auto_lo"
|
|
"ad --\n# Checks a collection of library directories to see if a pr"
|
|
"ocedure\n# is defined in one of them. If so, it sources the appro"
|
|
"priate\n# library file to create the procedure. Returns 1 if it s"
|
|
"uccessfully\n# loaded the procedure, 0 otherwise.\n#\n# Arguments: \n"
|
|
"# cmd -\t\t\tName of the command to find and load.\n\nproc auto_load c"
|
|
"md {\n global auto_index auto_oldpath auto_path env errorInfo e"
|
|
"rrorCode\n\n if [info exists auto_index($cmd)] {\n\tuplevel #0 $au"
|
|
"to_index($cmd)\n\treturn [expr {[info commands $cmd] != \"\"}]\n }\n"
|
|
" if ![info exists auto_path] {\n\treturn 0\n }\n if [info ex"
|
|
"ists auto_oldpath] {\n\tif {$auto_oldpath == $auto_path} {\n\t ret"
|
|
"urn 0\n\t}\n }\n set auto_oldpath $auto_path\n for {set i [ex"
|
|
"pr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {\n\tset dir [l"
|
|
"index $auto_path $i]\n\tset f \"\"\n\tif [catch {set f [open [file join"
|
|
" $dir tclIndex]]}] {\n\t continue\n\t}\n\tset error [catch {\n\t se"
|
|
"t id [gets $f]\n\t if {$id == \"# Tcl autoload index file, versio"
|
|
"n 2.0\"} {\n\t\teval [read $f]\n\t } elseif {$id == \"# Tcl autoload "
|
|
"index file: each line identifies a Tcl\"} {\n\t\twhile {[gets $f line"
|
|
"] >= 0} {\n\t\t if {([string index $line 0] == \"#\")\n\t\t\t || ([l"
|
|
"length $line] != 2)} {\n\t\t\tcontinue\n\t\t }\n\t\t set name [lindex"
|
|
" $line 0]\n\t\t set auto_index($name) \\\n\t\t\t\"source [file join $di"
|
|
"r [lindex $line 1]]\"\n\t\t}\n\t } else {\n\t\terror \"[file join $dir t"
|
|
"clIndex] isn't a proper Tcl index file\"\n\t }\n\t} msg]\n\tif {$f !="
|
|
" \"\"} {\n\t close $f\n\t}\n\tif $error {\n\t error $msg $errorInfo $"
|
|
"errorCode\n\t}\n }\n if [info exists auto_index($cmd)] {\n\tuplev"
|
|
"el #0 $auto_index($cmd)\n\tif {[info commands $cmd] != \"\"} {\n\t r"
|
|
"eturn 1\n\t}\n }\n return 0\n}\n\nif {[string compare $tcl_platfor"
|
|
"m(platform) windows] == 0} {\n\n# auto_execok --\n#\n# Returns string"
|
|
" that indicates name of program to execute if \n# name corresponds"
|
|
" to a shell builtin or an executable in the\n# Windows search path"
|
|
", or \"\" otherwise. Builds an associative \n# array auto_execs tha"
|
|
"t caches information about previous checks, \n# for speed.\n#\n# Arg"
|
|
"uments: \n# name -\t\t\tName of a command.\n\n# Windows version.\n#\n# No"
|
|
"te that info executable doesn't work under Windows, so we have to"
|
|
"\n# look for files with .exe, .com, or .bat extensions. Also, the"
|
|
" path\n# may be in the Path or PATH environment variables, and pat"
|
|
"h\n# components are separated with semicolons, not colons as under"
|
|
" Unix.\n#\nproc auto_execok name {\n global auto_execs env tcl_pl"
|
|
"atform\n\n if [info exists auto_execs($name)] {\n\treturn $auto_ex"
|
|
"ecs($name)\n }\n set auto_execs($name) \"\"\n\n if {[lsearch -"
|
|
"exact {cls copy date del erase dir echo mkdir md rename \n\t ren"
|
|
" rmdir rd time type ver vol} $name] != -1} {\n\tif {[info exists en"
|
|
"v(COMSPEC)]} {\n\t set comspec $env(COMSPEC) \n\t} elseif {[info e"
|
|
"xists env(ComSpec)]} {\n\t set comspec $env(ComSpec)\n\t} elseif {"
|
|
"$tcl_platform(os) == \"Windows NT\"} {\n\t set comspec \"cmd.exe\"\n\t"
|
|
"} else {\n\t set comspec \"command.com\"\n\t}\n\treturn [set auto_exec"
|
|
"s($name) [list $comspec /c $name]]\n }\n\n if {[llength [file "
|
|
"split $name]] != 1} {\n\tforeach ext {{} .com .exe .bat} {\n\t set"
|
|
" file ${name}${ext}\n\t if {[file exists $file] && ![file isdire"
|
|
"ctory $file]} {\n\t\treturn [set auto_execs($name) $file]\n\t }\n\t}\n"
|
|
"\treturn \"\"\n }\n\n set path \"[file dirname [info nameof]];.;\"\n"
|
|
" if {[info exists env(WINDIR)]} {\n\tset windir $env(WINDIR) \n "
|
|
" } elseif {[info exists env(windir)]} {\n\tset windir $env(windir)"
|
|
"\n }\n if {[info exists windir]} {\n\tif {$tcl_platform(os) == "
|
|
"\"Windows NT\"} {\n\t append path \"$windir/system32;\"\n\t}\n\tappend p"
|
|
"ath \"$windir/system;$windir;\"\n }\n\n if {! [info exists env(P"
|
|
"ATH)]} {\n\tif [info exists env(Path)] {\n\t append path $env(Path"
|
|
")\n\t} else {\n\t return \"\"\n\t}\n } else {\n\tappend path $env(PATH"
|
|
")\n }\n\n foreach dir [split $path {;}] {\n\tif {$dir == \"\"} {\n\t"
|
|
" set dir .\n\t}\n\tforeach ext {{} .com .exe .bat} {\n\t set file"
|
|
" [file join $dir ${name}${ext}]\n\t if {[file exists $file] && !"
|
|
"[file isdirectory $file]} {\n\t\treturn [set auto_execs($name) $file"
|
|
"]\n\t }\n\t}\n }\n return \"\"\n}\n\n} else {\n\n# auto_execok --\n#\n#"
|
|
" Returns string that indicates name of program to execute if \n# n"
|
|
"ame corresponds to an executable in the path. Builds an associati"
|
|
"ve \n# array auto_execs that caches information about previous che"
|
|
"cks, \n# for speed.\n#\n# Arguments: \n# name -\t\t\tName of a command.\n"
|
|
"\n# Unix version.\n#\nproc auto_execok name {\n global auto_execs "
|
|
"env\n\n if [info exists auto_execs($name)] {\n\treturn $auto_execs"
|
|
"($name)\n }\n set auto_execs($name) \"\"\n if {[llength [file"
|
|
" split $name]] != 1} {\n\tif {[file executable $name] && ![file isd"
|
|
"irectory $name]} {\n\t set auto_execs($name) $name\n\t}\n\treturn $a"
|
|
"uto_execs($name)\n }\n foreach dir [split $env(PATH) :] {\n\tif"
|
|
" {$dir == \"\"} {\n\t set dir .\n\t}\n\tset file [file join $dir $name"
|
|
"]\n\tif {[file executable $file] && ![file isdirectory $file]} {\n\t "
|
|
" set auto_execs($name) $file\n\t return $file\n\t}\n }\n ret"
|
|
"urn \"\"\n}\n\n}\n# auto_reset --\n# Destroy all cached information for "
|
|
"auto-loading and auto-execution,\n# so that the information gets r"
|
|
"ecomputed the next time it's needed.\n# Also delete any procedures"
|
|
" that are listed in the auto-load index\n# except those defined in"
|
|
" this file.\n#\n# Arguments: \n# None.\n\nproc auto_reset {} {\n glo"
|
|
"bal auto_execs auto_index auto_oldpath\n foreach p [info procs]"
|
|
" {\n\tif {[info exists auto_index($p)] && ![string match auto_* $p]"
|
|
"\n\t\t&& ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup\n\t\t\ttclPkg"
|
|
"Unknown} $p] < 0)} {\n\t rename $p {}\n\t}\n }\n catch {unset "
|
|
"auto_execs}\n catch {unset auto_index}\n catch {unset auto_ol"
|
|
"dpath}\n}\n\n# auto_mkindex --\n# Regenerate a tclIndex file from Tcl"
|
|
" source files. Takes as argument\n# the name of the directory in "
|
|
"which the tclIndex file is to be placed,\n# followed by any number"
|
|
" of glob patterns to use in that directory to\n# locate all of the"
|
|
" relevant files.\n#\n# Arguments: \n# dir -\t\t\tName of the directory "
|
|
"in which to create an index.\n# args -\t\tAny number of additional a"
|
|
"rguments giving the\n#\t\t\tnames of files within dir. If no additio"
|
|
"nal\n#\t\t\tare given auto_mkindex will look for *.tcl.\n\nproc auto_mk"
|
|
"index {dir args} {\n global errorCode errorInfo\n set oldDir "
|
|
"[pwd]\n cd $dir\n set dir [pwd]\n append index \"# Tcl autol"
|
|
"oad index file, version 2.0\\n\"\n append index \"# This file is g"
|
|
"enerated by the \\\"auto_mkindex\\\" command\\n\"\n append index \"# a"
|
|
"nd sourced to set up indexing information for one or\\n\"\n appen"
|
|
"d index \"# more commands. Typically each line is a command that\\"
|
|
"n\"\n append index \"# sets an element in the auto_index array, w"
|
|
"here the\\n\"\n append index \"# element name is the name of a com"
|
|
"mand and the value is\\n\"\n append index \"# a script that loads "
|
|
"the command.\\n\\n\"\n if {$args == \"\"} {\n\tset args *.tcl\n }\n "
|
|
" foreach file [eval glob $args] {\n\tset f \"\"\n\tset error [catch {\n"
|
|
"\t set f [open $file]\n\t while {[gets $f line] >= 0} {\n\t\tif ["
|
|
"regexp {^proc[ \t]+([^ \t]*)} $line match procName] {\n\t\t append "
|
|
"index \"set [list auto_index($procName)]\"\n\t\t append index \" \\[l"
|
|
"ist source \\[file join \\$dir [list $file]\\]\\]\\n\"\n\t\t}\n\t }\n\t "
|
|
"close $f\n\t} msg]\n\tif $error {\n\t set code $errorCode\n\t set i"
|
|
"nfo $errorInfo\n\t catch {close $f}\n\t cd $oldDir\n\t error $"
|
|
"msg $info $code\n\t}\n }\n set f \"\"\n set error [catch {\n\tset"
|
|
" f [open tclIndex w]\n\tputs $f $index nonewline\n\tclose $f\n\tcd $old"
|
|
"Dir\n } msg]\n if $error {\n\tset code $errorCode\n\tset info $er"
|
|
"rorInfo\n\tcatch {close $f}\n\tcd $oldDir\n\terror $msg $info $code\n "
|
|
" }\n}\n\n# pkg_mkIndex --\n# This procedure creates a package index i"
|
|
"n a given directory. The\n# package index consists of a \"pkgIndex"
|
|
".tcl\" file whose contents are\n# a Tcl script that sets up package"
|
|
" information with \"package require\"\n# commands. The commands des"
|
|
"cribe all of the packages defined by the\n# files given as argumen"
|
|
"ts.\n#\n# Arguments:\n# dir -\t\t\tName of the directory in which to cr"
|
|
"eate the index.\n# args -\t\tAny number of additional arguments, eac"
|
|
"h giving\n#\t\t\ta glob pattern that matches the names of one or\n#\t\t\t"
|
|
"more shared libraries or Tcl script files in\n#\t\t\tdir.\n\nproc pkg_m"
|
|
"kIndex {dir args} {\n global errorCode errorInfo\n append ind"
|
|
"ex \"# Tcl package index file, version 1.0\\n\"\n append index \"# "
|
|
"This file is generated by the \\\"pkg_mkIndex\\\" command\\n\"\n appe"
|
|
"nd index \"# and sourced either when an application starts up or\\n"
|
|
"\"\n append index \"# by a \\\"package unknown\\\" script. It invoke"
|
|
"s the\\n\"\n append index \"# \\\"package ifneeded\\\" command to set "
|
|
"up package-related\\n\"\n append index \"# information so that pac"
|
|
"kages will be loaded automatically\\n\"\n append index \"# in resp"
|
|
"onse to \\\"package require\\\" commands. When this\\n\"\n append in"
|
|
"dex \"# script is sourced, the variable \\$dir must contain the\\n\"\n"
|
|
" append index \"# full path name of this file's directory.\\n\"\n "
|
|
" set oldDir [pwd]\n cd $dir\n foreach file [eval glob $args"
|
|
"] {\n\t# For each file, figure out what commands and packages it pr"
|
|
"ovides.\n\t# To do this, create a child interpreter, load the file "
|
|
"into the\n\t# interpreter, and get a list of the new commands and p"
|
|
"ackages\n\t# that are defined. Define an empty \"package unknown\" s"
|
|
"cript so\n\t# that there are no recursive package inclusions.\n\n\tset"
|
|
" c [interp create]\n\n\t# If Tk is loaded in the parent interpreter,"
|
|
" load it into the\n\t# child also, in case the extension depends on"
|
|
" it.\n\n\tforeach pkg [info loaded] {\n\t if {[lindex $pkg 1] == \"T"
|
|
"k\"} {\n\t\t$c eval {set argv {-geometry +0+0}}\n\t\tload [lindex $pkg 0"
|
|
"] Tk $c\n\t\tbreak\n\t }\n\t}\n\t$c eval [list set file $file]\n\tif [cat"
|
|
"ch {\n\t $c eval {\n\t\tproc dummy args {}\n\t\tpackage unknown dummy\n"
|
|
"\t\tset origCmds [info commands]\n\t\tset dir \"\"\t\t;# in case file is p"
|
|
"kgIndex.tcl\n\t\tset pkgs \"\"\n\n\t\t# Try to load the file if it has the"
|
|
" shared library extension,\n\t\t# otherwise source it. It's importa"
|
|
"nt not to try to load\n\t\t# files that aren't shared libraries, bec"
|
|
"ause on some systems\n\t\t# (like SunOS) the loader will abort the w"
|
|
"hole application\n\t\t# when it gets an error.\n\n\t\tif {[string compar"
|
|
"e [file extension $file] \\\n\t\t\t[info sharedlibextension]] == 0} {\n"
|
|
"\n\t\t # The \"file join .\" command below is necessary. Without\n\t"
|
|
"\t # it, if the file name has no \\'s and we're on UNIX, the\n\t\t "
|
|
" # load command will invoke the LD_LIBRARY_PATH search\n\t\t # "
|
|
"mechanism, which could cause the wrong file to be used.\n\n\t\t lo"
|
|
"ad [file join . $file]\n\t\t set type load\n\t\t} else {\n\t\t sourc"
|
|
"e $file\n\t\t set type source\n\t\t}\n\t\tforeach i [info commands] {\n\t"
|
|
"\t set cmds($i) 1\n\t\t}\n\t\tforeach i $origCmds {\n\t\t catch {unse"
|
|
"t cmds($i)}\n\t\t}\n\t\tforeach i [package names] {\n\t\t if {([string "
|
|
"compare [package provide $i] \"\"] != 0)\n\t\t\t && ([string compare"
|
|
" $i Tcl] != 0)\n\t\t\t && ([string compare $i Tk] != 0)} {\n\t\t\tlapp"
|
|
"end pkgs [list $i [package provide $i]]\n\t\t }\n\t\t}\n\t }\n\t} msg"
|
|
"] {\n\t puts \"error while loading or sourcing $file: $msg\"\n\t}\n\tf"
|
|
"oreach pkg [$c eval set pkgs] {\n\t lappend files($pkg) [list $f"
|
|
"ile [$c eval set type] \\\n\t\t [lsort [$c eval array names cmds]]"
|
|
"]\n\t}\n\tinterp delete $c\n }\n foreach pkg [lsort [array names "
|
|
"files]] {\n\tappend index \"\\npackage ifneeded $pkg\\\n\t\t\\[list tclPkg"
|
|
"Setup \\$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\\\n\t\t[list $files($"
|
|
"pkg)]\\]\"\n }\n set f [open pkgIndex.tcl w]\n puts $f $index"
|
|
"\n close $f\n cd $oldDir\n}\n\n# tclPkgSetup --\n# This is a util"
|
|
"ity procedure use by pkgIndex.tcl files. It is invoked\n# as part"
|
|
" of a \"package ifneeded\" script. It calls \"package provide\"\n# to"
|
|
" indicate that a package is available, then sets entries in the\n#"
|
|
" auto_index array so that the package's files will be auto-loaded"
|
|
" when\n# the commands are used.\n#\n# Arguments:\n# dir -\t\t\tDirectory"
|
|
" containing all the files for this package.\n# pkg -\t\t\tName of the"
|
|
" package (no version number).\n# version -\t\tVersion number for the"
|
|
" package, such as 2.1.3.\n# files -\t\tList of files that constitute"
|
|
" the package. Each\n#\t\t\telement is a sub-list with three elements"
|
|
". The first\n#\t\t\tis the name of a file relative to $dir, the seco"
|
|
"nd is\n#\t\t\t\"load\" or \"source\", indicating whether the file is a\n#\t"
|
|
"\t\tloadable binary or a script to source, and the third\n#\t\t\tis a l"
|
|
"ist of commands defined by this file.\n\nproc tclPkgSetup {dir pkg "
|
|
"version files} {\n global auto_index\n\n package provide $pkg "
|
|
"$version\n foreach fileInfo $files {\n\tset f [lindex $fileInfo 0"
|
|
"]\n\tset type [lindex $fileInfo 1]\n\tforeach cmd [lindex $fileInfo 2"
|
|
"] {\n\t if {$type == \"load\"} {\n\t\tset auto_index($cmd) [list load"
|
|
" [file join $dir $f] $pkg]\n\t } else {\n\t\tset auto_index($cmd) ["
|
|
"list source [file join $dir $f]]\n\t } \n\t}\n }\n}\n\n# tclMacPkgS"
|
|
"earch --\n# The procedure is used on the Macintosh to search a giv"
|
|
"en directory for files\n# with a TEXT resource named \"pkgIndex\". "
|
|
"If it exists it is sourced in to the\n# interpreter to setup the p"
|
|
"ackage database.\n\nproc tclMacPkgSearch {dir} {\n foreach x [glo"
|
|
"b -nocomplain [file join $dir *.shlb]] {\n\tif [file isfile $x] {\n\t"
|
|
" set res [resource open $x]\n\t foreach y [resource list TEXT"
|
|
" $res] {\n\t\tif {$y == \"pkgIndex\"} {source -rsrc pkgIndex}\n\t }\n\t"
|
|
" resource close $res\n\t}\n }\n}\n\n# tclPkgUnknown --\n# This pro"
|
|
"cedure provides the default for the \"package unknown\" function.\n#"
|
|
" It is invoked when a package that's needed can't be found. It s"
|
|
"cans\n# the auto_path directories and their immediate children loo"
|
|
"king for\n# pkgIndex.tcl files and sources any such files that are"
|
|
" found to setup\n# the package database. (On the Macintosh we als"
|
|
"o search for pkgIndex\n# TEXT resources in all files.)\n#\n# Argumen"
|
|
"ts:\n# name -\t\tName of desired package. Not used.\n# version -\t\tVe"
|
|
"rsion of desired package. Not used.\n# exact -\t\tEither \"-exact\" o"
|
|
"r omitted. Not used.\n\nproc tclPkgUnknown {name version {exact {}"
|
|
"}} {\n global auto_path tcl_platform env\n\n if ![info exists "
|
|
"auto_path] {\n\treturn\n }\n for {set i [expr [llength $auto_pa"
|
|
"th] - 1]} {$i >= 0} {incr i -1} {\n\tset dir [lindex $auto_path $i]"
|
|
"\n\tset file [file join $dir pkgIndex.tcl]\n\tif [file readable $file"
|
|
"] {\n\t source $file\n\t}\n\tforeach file [glob -nocomplain [file jo"
|
|
"in $dir * pkgIndex.tcl]] {\n\t if [file readable $file] {\n\t\tset "
|
|
"dir [file dirname $file]\n\t\tsource $file\n\t }\n\t}\n\t# On the Macin"
|
|
"tosh we also look in the resource fork \n\t# of shared libraries\n\ti"
|
|
"f {$tcl_platform(platform) == \"macintosh\"} {\n\t set dir [lindex"
|
|
" $auto_path $i]\n\t tclMacPkgSearch $dir\n\t foreach x [glob -n"
|
|
"ocomplain [file join $dir *]] {\n\t\tif [file isdirectory $x] {\n\t\t "
|
|
" set dir $x\n\t\t tclMacPkgSearch $dir\n\t\t}\n\t }\n\t}\n }\n}\n";
|
|
int initcl_Init(Tcl_Interp * interp)
|
|
{
|
|
Tcl_SetVar(interp, "package_name", "init", TCL_GLOBAL_ONLY);
|
|
if (Tcl_GlobalEval(interp, init_tcl) != TCL_OK)
|
|
return TCL_ERROR;
|
|
Tcl_UnsetVar(interp, "package_name", TCL_GLOBAL_ONLY);
|
|
return TCL_OK;
|
|
}
|