mattia/BiblioMxWeb
Archived
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add files via upload

Browse Source
This commit is contained in:
MatMasIt 2021-06-17 01:31:27 +02:00 committed by GitHub
parent deec015f45
commit 09e111b960
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
10 changed files with 8857 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

646
windowsAgent/dist/tcl/auto.tcl vendored Normal file
View File

@ -0,0 +1,646 @@
# auto.tcl --
#
# utility procs formerly in init.tcl dealing with auto execution of commands
# and can be auto loaded themselves.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# auto_reset --
#
# Destroy all cached information for auto-loading and auto-execution, so that
# the information gets recomputed the next time it's needed. Also delete any
# commands that are listed in the auto-load index.
#
# Arguments:
# None.
proc auto_reset {} {
global auto_execs auto_index auto_path
if {[array exists auto_index]} {
foreach cmdName [array names auto_index] {
set fqcn [namespace which $cmdName]
if {$fqcn eq ""} {
continue
}
rename $fqcn {}
}
}
unset -nocomplain auto_execs auto_index ::tcl::auto_oldpath
if {[catch {llength $auto_path}]} {
set auto_path [list [info library]]
} elseif {[info library] ni $auto_path} {
lappend auto_path [info library]
}
}
# tcl_findLibrary --
#
# This is a utility for extensions that searches for a library directory
# using a canonical searching algorithm. A side effect is to source the
# initialization script and set a global library variable.
#
# Arguments:
# basename Prefix of the directory name, (e.g., "tk")
# version Version number of the package, (e.g., "8.0")
# patch Patchlevel of the package, (e.g., "8.0.3")
# initScript Initialization script to source (e.g., tk.tcl)
# enVarName environment variable to honor (e.g., TK_LIBRARY)
# varName Global variable to set when done (e.g., tk_library)
proc tcl_findLibrary {basename version patch initScript enVarName varName} {
upvar #0 $varName the_library
global auto_path env tcl_platform
set dirs {}
set errors {}
# The C application may have hardwired a path, which we honor
if {[info exists the_library] && $the_library ne ""} {
lappend dirs $the_library
} else {
# Do the canonical search
# 1. From an environment variable, if it exists. Placing this first
# gives the end-user ultimate control to work-around any bugs, or
# to customize.
if {[info exists env($enVarName)]} {
lappend dirs $env($enVarName)
}
# 2. In the package script directory registered within the
# configuration of the package itself.
catch {
lappend dirs [::${basename}::pkgconfig get scriptdir,runtime]
}
# 3. Relative to auto_path directories. This checks relative to the
# Tcl library as well as allowing loading of libraries added to the
# auto_path that is not relative to the core library or binary paths.
foreach d $auto_path {
lappend dirs [file join $d $basename$version]
if {$tcl_platform(platform) eq "unix"
&& $tcl_platform(os) eq "Darwin"} {
# 4. On MacOSX, check the Resources/Scripts subdir too
lappend dirs [file join $d $basename$version Resources Scripts]
}
}
# 3. Various locations relative to the executable
# ../lib/foo1.0 (From bin directory in install hierarchy)
# ../../lib/foo1.0 (From bin/arch directory in install hierarchy)
# ../library (From unix directory in build hierarchy)
#
# Remaining locations are out of date (when relevant, they ought to be
# covered by the $::auto_path seach above) and disabled.
#
# ../../library (From unix/arch directory in build hierarchy)
# ../../foo1.0.1/library
# (From unix directory in parallel build hierarchy)
# ../../../foo1.0.1/library
# (From unix/arch directory in parallel build hierarchy)
set parentDir [file dirname [file dirname [info nameofexecutable]]]
set grandParentDir [file dirname $parentDir]
lappend dirs [file join $parentDir lib $basename$version]
lappend dirs [file join $grandParentDir lib $basename$version]
lappend dirs [file join $parentDir library]
if {0} {
lappend dirs [file join $grandParentDir library]
lappend dirs [file join $grandParentDir $basename$patch library]
lappend dirs [file join [file dirname $grandParentDir] \
$basename$patch library]
}
}
# uniquify $dirs in order
array set seen {}
foreach i $dirs {
# Make sure $i is unique under normalization. Avoid repeated [source].
if {[interp issafe]} {
# Safe interps have no [file normalize].
set norm $i
} else {
set norm [file normalize $i]
}
if {[info exists seen($norm)]} {
continue
}
set seen($norm) {}
set the_library $i
set file [file join $i $initScript]
# source everything when in a safe interpreter because we have a
# source command, but no file exists command
if {[interp issafe] || [file exists $file]} {
if {![catch {uplevel #0 [list source $file]} msg opts]} {
return
}
append errors "$file: $msg\n"
append errors [dict get $opts -errorinfo]\n
}
}
unset -nocomplain the_library
set msg "Can't find a usable $initScript in the following directories: \n"
append msg " $dirs\n\n"
append msg "$errors\n\n"
append msg "This probably means that $basename wasn't installed properly.\n"
error $msg
}
# ----------------------------------------------------------------------
# auto_mkindex
# ----------------------------------------------------------------------
# The following procedures are used to generate the tclIndex file from Tcl
# source files. They use a special safe interpreter to parse Tcl source
# files, writing out index entries as "proc" commands are encountered. This
# implementation won't work in a safe interpreter, since a safe interpreter
# can't create the special parser and mess with its commands.
if {[interp issafe]} {
return ;# Stop sourcing the file here
}
# auto_mkindex --
# Regenerate a tclIndex file from Tcl source files. Takes as argument the
# name of the directory in which the tclIndex file is to be placed, followed
# by any number of glob patterns to use in that directory to locate all of the
# relevant files.
#
# Arguments:
# dir - Name of the directory in which to create an index.
# args - Any number of additional arguments giving the names of files
# within dir. If no additional are given auto_mkindex will look
# for *.tcl.
proc auto_mkindex {dir args} {
if {[interp issafe]} {
error "can't generate index within safe interpreter"
}
set oldDir [pwd]
cd $dir
append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"auto_mkindex\" command\n"
append index "# and sourced to set up indexing information for one or\n"
append index "# more commands. Typically each line is a command that\n"
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
if {![llength $args]} {
set args *.tcl
}
auto_mkindex_parser::init
foreach file [lsort [glob -- {*}$args]] {
try {
append index [auto_mkindex_parser::mkindex $file]
} on error {msg opts} {
cd $oldDir
return -options $opts $msg
}
}
auto_mkindex_parser::cleanup
set fid [open "tclIndex" w]
puts -nonewline $fid $index
close $fid
cd $oldDir
}
# Original version of auto_mkindex that just searches the source code for
# "proc" at the beginning of the line.
proc auto_mkindex_old {dir args} {
set oldDir [pwd]
cd $dir
set dir [pwd]
append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"auto_mkindex\" command\n"
append index "# and sourced to set up indexing information for one or\n"
append index "# more commands. Typically each line is a command that\n"
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
if {![llength $args]} {
set args *.tcl
}
foreach file [lsort [glob -- {*}$args]] {
set f ""
set error [catch {
set f [open $file]
while {[gets $f line] >= 0} {
if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} {
set procName [lindex [auto_qualify $procName "::"] 0]
append index "set [list auto_index($procName)]"
append index " \[list source \[file join \$dir [list $file]\]\]\n"
}
}
close $f
} msg opts]
if {$error} {
catch {close $f}
cd $oldDir
return -options $opts $msg
}
}
set f ""
set error [catch {
set f [open tclIndex w]
puts -nonewline $f $index
close $f
cd $oldDir
} msg opts]
if {$error} {
catch {close $f}
cd $oldDir
error $msg $info $code
return -options $opts $msg
}
}
# Create a safe interpreter that can be used to parse Tcl source files
# generate a tclIndex file for autoloading. This interp contains commands for
# things that need index entries. Each time a command is executed, it writes
# an entry out to the index file.
namespace eval auto_mkindex_parser {
variable parser "" ;# parser used to build index
variable index "" ;# maintains index as it is built
variable scriptFile "" ;# name of file being processed
variable contextStack "" ;# stack of namespace scopes
variable imports "" ;# keeps track of all imported cmds
variable initCommands ;# list of commands that create aliases
if {![info exists initCommands]} {
set initCommands [list]
}
proc init {} {
variable parser
variable initCommands
if {![interp issafe]} {
set parser [interp create -safe]
$parser hide info
$parser hide rename
$parser hide proc
$parser hide namespace
$parser hide eval
$parser hide puts
foreach ns [$parser invokehidden namespace children ::] {
# MUST NOT DELETE "::tcl" OR BAD THINGS HAPPEN!
if {$ns eq "::tcl"} continue
$parser invokehidden namespace delete $ns
}
foreach cmd [$parser invokehidden info commands ::*] {
$parser invokehidden rename $cmd {}
}
$parser invokehidden proc unknown {args} {}
# We'll need access to the "namespace" command within the
# interp. Put it back, but move it out of the way.
$parser expose namespace
$parser invokehidden rename namespace _%@namespace
$parser expose eval
$parser invokehidden rename eval _%@eval
# Install all the registered psuedo-command implementations
foreach cmd $initCommands {
eval $cmd
}
}
}
proc cleanup {} {
variable parser
interp delete $parser
unset parser
}
}
# auto_mkindex_parser::mkindex --
#
# Used by the "auto_mkindex" command to create a "tclIndex" file for the given
# Tcl source file. Executes the commands in the file, and handles things like
# the "proc" command by adding an entry for the index file. Returns a string
# that represents the index file.
#
# Arguments:
# file Name of Tcl source file to be indexed.
proc auto_mkindex_parser::mkindex {file} {
variable parser
variable index
variable scriptFile
variable contextStack
variable imports
set scriptFile $file
set fid [open $file]
set contents [read $fid]
close $fid
# There is one problem with sourcing files into the safe interpreter:
# references like "$x" will fail since code is not really being executed
# and variables do not really exist. To avoid this, we replace all $ with
# \0 (literally, the null char) later, when getting proc names we will
# have to reverse this replacement, in case there were any $ in the proc
# name. This will cause a problem if somebody actually tries to have a \0
# in their proc name. Too bad for them.
set contents [string map [list \$ \0] $contents]
set index ""
set contextStack ""
set imports ""
$parser eval $contents
foreach name $imports {
catch {$parser eval [list _%@namespace forget $name]}
}
return $index
}
# auto_mkindex_parser::hook command
#
# Registers a Tcl command to evaluate when initializing the slave interpreter
# used by the mkindex parser. The command is evaluated in the master
# interpreter, and can use the variable auto_mkindex_parser::parser to get to
# the slave
proc auto_mkindex_parser::hook {cmd} {
variable initCommands
lappend initCommands $cmd
}
# auto_mkindex_parser::slavehook command
#
# Registers a Tcl command to evaluate when initializing the slave interpreter
# used by the mkindex parser. The command is evaluated in the slave
# interpreter.
proc auto_mkindex_parser::slavehook {cmd} {
variable initCommands
# The $parser variable is defined to be the name of the slave interpreter
# when this command is used later.
lappend initCommands "\$parser eval [list $cmd]"
}
# auto_mkindex_parser::command --
#
# Registers a new command with the "auto_mkindex_parser" interpreter that
# parses Tcl files. These commands are fake versions of things like the
# "proc" command. When you execute them, they simply write out an entry to a
# "tclIndex" file for auto-loading.
#
# This procedure allows extensions to register their own commands with the
# auto_mkindex facility. For example, a package like [incr Tcl] might
# register a "class" command so that class definitions could be added to a
# "tclIndex" file for auto-loading.
#
# Arguments:
# name Name of command recognized in Tcl files.
# arglist Argument list for command.
# body Implementation of command to handle indexing.
proc auto_mkindex_parser::command {name arglist body} {
hook [list auto_mkindex_parser::commandInit $name $arglist $body]
}
# auto_mkindex_parser::commandInit --
#
# This does the actual work set up by auto_mkindex_parser::command. This is
# called when the interpreter used by the parser is created.
#
# Arguments:
# name Name of command recognized in Tcl files.
# arglist Argument list for command.
# body Implementation of command to handle indexing.
proc auto_mkindex_parser::commandInit {name arglist body} {
variable parser
set ns [namespace qualifiers $name]
set tail [namespace tail $name]
if {$ns eq ""} {
set fakeName [namespace current]::_%@fake_$tail
} else {
set fakeName [namespace current]::[string map {:: _} _%@fake_$name]
}
proc $fakeName $arglist $body
# YUK! Tcl won't let us alias fully qualified command names, so we can't
# handle names like "::itcl::class". Instead, we have to build procs with
# the fully qualified names, and have the procs point to the aliases.
if {[string match *::* $name]} {
set exportCmd [list _%@namespace export [namespace tail $name]]
$parser eval [list _%@namespace eval $ns $exportCmd]
# The following proc definition does not work if you want to tolerate
# space or something else diabolical in the procedure name, (i.e.,
# space in $alias). The following does not work:
# "_%@eval {$alias} \$args"
# because $alias gets concat'ed to $args. The following does not work
# because $cmd is somehow undefined
# "set cmd {$alias} \; _%@eval {\$cmd} \$args"
# A gold star to someone that can make test autoMkindex-3.3 work
# properly
set alias [namespace tail $fakeName]
$parser invokehidden proc $name {args} "_%@eval {$alias} \$args"
$parser alias $alias $fakeName
} else {
$parser alias $name $fakeName
}
return
}
# auto_mkindex_parser::fullname --
#
# Used by commands like "proc" within the auto_mkindex parser. Returns the
# qualified namespace name for the "name" argument. If the "name" does not
# start with "::", elements are added from the current namespace stack to
# produce a qualified name. Then, the name is examined to see whether or not
# it should really be qualified. If the name has more than the leading "::",
# it is returned as a fully qualified name. Otherwise, it is returned as a
# simple name. That way, the Tcl autoloader will recognize it properly.
#
# Arguments:
# name - Name that is being added to index.
proc auto_mkindex_parser::fullname {name} {
variable contextStack
if {![string match ::* $name]} {
foreach ns $contextStack {
set name "${ns}::$name"
if {[string match ::* $name]} {
break
}
}
}
if {[namespace qualifiers $name] eq ""} {
set name [namespace tail $name]
} elseif {![string match ::* $name]} {
set name "::$name"
}
# Earlier, mkindex replaced all $'s with \0. Now, we have to reverse that
# replacement.
return [string map [list \0 \$] $name]
}
# auto_mkindex_parser::indexEntry --
#
# Used by commands like "proc" within the auto_mkindex parser to add a
# correctly-quoted entry to the index. This is shared code so it is done
# *right*, in one place.
#
# Arguments:
# name - Name that is being added to index.
proc auto_mkindex_parser::indexEntry {name} {
variable index
variable scriptFile
# We convert all metacharacters to their backslashed form, and pre-split
# the file name that we know about (which will be a proper list, and so
# correctly quoted).
set name [string range [list \}[fullname $name]] 2 end]
set filenameParts [file split $scriptFile]
append index [format \
{set auto_index(%s) [list source [file join $dir %s]]%s} \
$name $filenameParts \n]
return
}
if {[llength $::auto_mkindex_parser::initCommands]} {
return
}
# Register all of the procedures for the auto_mkindex parser that will build
# the "tclIndex" file.
# AUTO MKINDEX: proc name arglist body
# Adds an entry to the auto index list for the given procedure name.
auto_mkindex_parser::command proc {name args} {
indexEntry $name
}
# Conditionally add support for Tcl byte code files. There are some tricky
# details here. First, we need to get the tbcload library initialized in the
# current interpreter. We cannot load tbcload into the slave until we have
# done so because it needs access to the tcl_patchLevel variable. Second,
# because the package index file may defer loading the library until we invoke
# a command, we need to explicitly invoke auto_load to force it to be loaded.
# This should be a noop if the package has already been loaded
auto_mkindex_parser::hook {
try {
package require tbcload
} on error {} {
# OK, don't have it so do nothing
} on ok {} {
if {[namespace which -command tbcload::bcproc] eq ""} {
auto_load tbcload::bcproc
}
load {} tbcload $auto_mkindex_parser::parser
# AUTO MKINDEX: tbcload::bcproc name arglist body
# Adds an entry to the auto index list for the given pre-compiled
# procedure name.
auto_mkindex_parser::commandInit tbcload::bcproc {name args} {
indexEntry $name
}
}
}
# AUTO MKINDEX: namespace eval name command ?arg arg...?
# Adds the namespace name onto the context stack and evaluates the associated
# body of commands.
#
# AUTO MKINDEX: namespace import ?-force? pattern ?pattern...?
# Performs the "import" action in the parser interpreter. This is important
# for any commands contained in a namespace that affect the index. For
# example, a script may say "itcl::class ...", or it may import "itcl::*" and
# then say "class ...". This procedure does the import operation, but keeps
# track of imported patterns so we can remove the imports later.
auto_mkindex_parser::command namespace {op args} {
switch -- $op {
eval {
variable parser
variable contextStack
set name [lindex $args 0]
set args [lrange $args 1 end]
set contextStack [linsert $contextStack 0 $name]
$parser eval [list _%@namespace eval $name] $args
set contextStack [lrange $contextStack 1 end]
}
import {
variable parser
variable imports
foreach pattern $args {
if {$pattern ne "-force"} {
lappend imports $pattern
}
}
catch {$parser eval "_%@namespace import $args"}
}
ensemble {
variable parser
variable contextStack
if {[lindex $args 0] eq "create"} {
set name ::[join [lreverse $contextStack] ::]
catch {
set name [dict get [lrange $args 1 end] -command]
if {![string match ::* $name]} {
set name ::[join [lreverse $contextStack] ::]$name
}
regsub -all ::+ $name :: name
}
# create artifical proc to force an entry in the tclIndex
$parser eval [list ::proc $name {} {}]
}
}
}
}
# AUTO MKINDEX: oo::class create name ?definition?
# Adds an entry to the auto index list for the given class name.
auto_mkindex_parser::command oo::class {op name {body ""}} {
if {$op eq "create"} {
indexEntry $name
}
}
auto_mkindex_parser::command class {op name {body ""}} {
if {$op eq "create"} {
indexEntry $name
}
}
return

4547
windowsAgent/dist/tcl/clock.tcl vendored Normal file
View File

File diff suppressed because it is too large Load Diff

335
windowsAgent/dist/tcl/history.tcl vendored Normal file
View File

@ -0,0 +1,335 @@
# history.tcl --
#
# Implementation of the history command.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# The tcl::history array holds the history list and some additional
# bookkeeping variables.
#
# nextid the index used for the next history list item.
# keep the max size of the history list
# oldest the index of the oldest item in the history.
namespace eval ::tcl {
variable history
if {![info exists history]} {
array set history {
nextid 0
keep 20
oldest -20
}
}
namespace ensemble create -command ::tcl::history -map {
add ::tcl::HistAdd
change ::tcl::HistChange
clear ::tcl::HistClear
event ::tcl::HistEvent
info ::tcl::HistInfo
keep ::tcl::HistKeep
nextid ::tcl::HistNextID
redo ::tcl::HistRedo
}
}
# history --
#
# This is the main history command. See the man page for its interface.
# This does some argument checking and calls the helper ensemble in the
# tcl namespace.
proc ::history {args} {
# If no command given, we're doing 'history info'. Can't be done with an
# ensemble unknown handler, as those don't fire when no subcommand is
# given at all.
if {![llength $args]} {
set args info
}
# Tricky stuff needed to make stack and errors come out right!
tailcall apply {arglist {tailcall history {*}$arglist} ::tcl} $args
}
# (unnamed) --
#
# Callback when [::history] is destroyed. Destroys the implementation.
#
# Parameters:
# oldName what the command was called.
# newName what the command is now called (an empty string).
# op the operation (= delete).
#
# Results:
# none
#
# Side Effects:
# The implementation of the [::history] command ceases to exist.
trace add command ::history delete [list apply {{oldName newName op} {
variable history
unset -nocomplain history
foreach c [info procs ::tcl::Hist*] {
rename $c {}
}
rename ::tcl::history {}
} ::tcl}]
# tcl::HistAdd --
#
# Add an item to the history, and optionally eval it at the global scope
#
# Parameters:
# event the command to add
# exec (optional) a substring of "exec" causes the command to
# be evaled.
# Results:
# If executing, then the results of the command are returned
#
# Side Effects:
# Adds to the history list
proc ::tcl::HistAdd {event {exec {}}} {
variable history
if {
[prefix longest {exec {}} $exec] eq ""
&& [llength [info level 0]] == 3
} then {
return -code error "bad argument \"$exec\": should be \"exec\""
}
# Do not add empty commands to the history
if {[string trim $event] eq ""} {
return ""
}
# Maintain the history
set history([incr history(nextid)]) $event
unset -nocomplain history([incr history(oldest)])
# Only execute if 'exec' (or non-empty prefix of it) given
if {$exec eq ""} {
return ""
}
tailcall eval $event
}
# tcl::HistKeep --
#
# Set or query the limit on the length of the history list
#
# Parameters:
# limit (optional) the length of the history list
#
# Results:
# If no limit is specified, the current limit is returned
#
# Side Effects:
# Updates history(keep) if a limit is specified
proc ::tcl::HistKeep {{count {}}} {
variable history
if {[llength [info level 0]] == 1} {
return $history(keep)
}
if {![string is integer -strict $count] || ($count < 0)} {
return -code error "illegal keep count \"$count\""
}
set oldold $history(oldest)
set history(oldest) [expr {$history(nextid) - $count}]
for {} {$oldold <= $history(oldest)} {incr oldold} {
unset -nocomplain history($oldold)
}
set history(keep) $count
}
# tcl::HistClear --
#
# Erase the history list
#
# Parameters:
# none
#
# Results:
# none
#
# Side Effects:
# Resets the history array, except for the keep limit
proc ::tcl::HistClear {} {
variable history
set keep $history(keep)
unset history
array set history [list \
nextid 0 \
keep $keep \
oldest -$keep \
]
}
# tcl::HistInfo --
#
# Return a pretty-printed version of the history list
#
# Parameters:
# num (optional) the length of the history list to return
#
# Results:
# A formatted history list
proc ::tcl::HistInfo {{count {}}} {
variable history
if {[llength [info level 0]] == 1} {
set count [expr {$history(keep) + 1}]
} elseif {![string is integer -strict $count]} {
return -code error "bad integer \"$count\""
}
set result {}
set newline ""
for {set i [expr {$history(nextid) - $count + 1}]} \
{$i <= $history(nextid)} {incr i} {
if {![info exists history($i)]} {
continue
}
set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]]
append result $newline[format "%6d %s" $i $cmd]
set newline \n
}
return $result
}
# tcl::HistRedo --
#
# Fetch the previous or specified event, execute it, and then replace
# the current history item with that event.
#
# Parameters:
# event (optional) index of history item to redo. Defaults to -1,
# which means the previous event.
#
# Results:
# Those of the command being redone.
#
# Side Effects:
# Replaces the current history list item with the one being redone.
proc ::tcl::HistRedo {{event -1}} {
variable history
set i [HistIndex $event]
if {$i == $history(nextid)} {
return -code error "cannot redo the current event"
}
set cmd $history($i)
HistChange $cmd 0
tailcall eval $cmd
}
# tcl::HistIndex --
#
# Map from an event specifier to an index in the history list.
#
# Parameters:
# event index of history item to redo.
# If this is a positive number, it is used directly.
# If it is a negative number, then it counts back to a previous
# event, where -1 is the most recent event.
# A string can be matched, either by being the prefix of a
# command or by matching a command with string match.
#
# Results:
# The index into history, or an error if the index didn't match.
proc ::tcl::HistIndex {event} {
variable history
if {![string is integer -strict $event]} {
for {set i [expr {$history(nextid)-1}]} {[info exists history($i)]} \
{incr i -1} {
if {[string match $event* $history($i)]} {
return $i
}
if {[string match $event $history($i)]} {
return $i
}
}
return -code error "no event matches \"$event\""
} elseif {$event <= 0} {
set i [expr {$history(nextid) + $event}]
} else {
set i $event
}
if {$i <= $history(oldest)} {
return -code error "event \"$event\" is too far in the past"
}
if {$i > $history(nextid)} {
return -code error "event \"$event\" hasn't occured yet"
}
return $i
}
# tcl::HistEvent --
#
# Map from an event specifier to the value in the history list.
#
# Parameters:
# event index of history item to redo. See index for a description of
# possible event patterns.
#
# Results:
# The value from the history list.
proc ::tcl::HistEvent {{event -1}} {
variable history
set i [HistIndex $event]
if {![info exists history($i)]} {
return ""
}
return [string trimright $history($i) \ \n]
}
# tcl::HistChange --
#
# Replace a value in the history list.
#
# Parameters:
# newValue The new value to put into the history list.
# event (optional) index of history item to redo. See index for a
# description of possible event patterns. This defaults to 0,
# which specifies the current event.
#
# Side Effects:
# Changes the history list.
proc ::tcl::HistChange {newValue {event 0}} {
variable history
set i [HistIndex $event]
set history($i) $newValue
}
# tcl::HistNextID --
#
# Returns the number of the next history event.
#
# Parameters:
# None.
#
# Side Effects:
# None.
proc ::tcl::HistNextID {} {
variable history
return [expr {$history(nextid) + 1}]
}
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End:

819
windowsAgent/dist/tcl/init.tcl vendored Normal file
View File

@ -0,0 +1,819 @@
# init.tcl --
#
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# This test intentionally written in pre-7.5 Tcl
if {[info commands package] == ""} {
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
package require -exact Tcl 8.6.9
# Compute the auto path to use in this interpreter.
# The values on the path come from several locations:
#
# The environment variable TCLLIBPATH
#
# tcl_library, which is the directory containing this init.tcl script.
# [tclInit] (Tcl_Init()) searches around for the directory containing this
# init.tcl and defines tcl_library to that location before sourcing it.
#
# The parent directory of tcl_library. Adding the parent
# means that packages in peer directories will be found automatically.
#
# Also add the directory ../lib relative to the directory where the
# executable is located. This is meant to find binary packages for the
# same architecture as the current executable.
#
# tcl_pkgPath, which is set by the platform-specific initialization routines
# On UNIX it is compiled in
# On Windows, it is not used
if {![info exists auto_path]} {
if {[info exists env(TCLLIBPATH)]} {
set auto_path $env(TCLLIBPATH)
} else {
set auto_path ""
}
}
namespace eval tcl {
variable Dir
foreach Dir [list $::tcl_library [file dirname $::tcl_library]] {
if {$Dir ni $::auto_path} {
lappend ::auto_path $Dir
}
}
set Dir [file join [file dirname [file dirname \
[info nameofexecutable]]] lib]
if {$Dir ni $::auto_path} {
lappend ::auto_path $Dir
}
catch {
foreach Dir $::tcl_pkgPath {
if {$Dir ni $::auto_path} {
lappend ::auto_path $Dir
}
}
}
if {![interp issafe]} {
variable Path [encoding dirs]
set Dir [file join $::tcl_library encoding]
if {$Dir ni $Path} {
lappend Path $Dir
encoding dirs $Path
}
}
# TIP #255 min and max functions
namespace eval mathfunc {
proc min {args} {
if {![llength $args]} {
return -code error \
"too few arguments to math function \"min\""
}
set val Inf
foreach arg $args {
# This will handle forcing the numeric value without
# ruining the internal type of a numeric object
if {[catch {expr {double($arg)}} err]} {
return -code error $err
}
if {$arg < $val} {set val $arg}
}
return $val
}
proc max {args} {
if {![llength $args]} {
return -code error \
"too few arguments to math function \"max\""
}
set val -Inf
foreach arg $args {
# This will handle forcing the numeric value without
# ruining the internal type of a numeric object
if {[catch {expr {double($arg)}} err]} {
return -code error $err
}
if {$arg > $val} {set val $arg}
}
return $val
}
namespace export min max
}
}
# Windows specific end of initialization
if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
namespace eval tcl {
proc EnvTraceProc {lo n1 n2 op} {
global env
set x $env($n2)
set env($lo) $x
set env([string toupper $lo]) $x
}
proc InitWinEnv {} {
global env tcl_platform
foreach p [array names env] {
set u [string toupper $p]
if {$u ne $p} {
switch -- $u {
COMSPEC -
PATH {
set temp $env($p)
unset env($p)
set env($u) $temp
trace add variable env($p) write \
[namespace code [list EnvTraceProc $p]]
trace add variable env($u) write \
[namespace code [list EnvTraceProc $p]]
}
}
}
}
if {![info exists env(COMSPEC)]} {
set env(COMSPEC) cmd.exe
}
}
InitWinEnv
}
}
# Setup the unknown package handler
if {[interp issafe]} {
package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
} else {
# Set up search for Tcl Modules (TIP #189).
# and setup platform specific unknown package handlers
if {$tcl_platform(os) eq "Darwin"
&& $tcl_platform(platform) eq "unix"} {
package unknown {::tcl::tm::UnknownHandler \
{::tcl::MacOSXPkgUnknown ::tclPkgUnknown}}
} else {
package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
}
# Set up the 'clock' ensemble
namespace eval ::tcl::clock [list variable TclLibDir $::tcl_library]
proc ::tcl::initClock {} {
# Auto-loading stubs for 'clock.tcl'
foreach cmd {add format scan} {
proc ::tcl::clock::$cmd args {
variable TclLibDir
source -encoding utf-8 [file join $TclLibDir clock.tcl]
return [uplevel 1 [info level 0]]
}
}
rename ::tcl::initClock {}
}
::tcl::initClock
}
# Conditionalize for presence of exec.
if {[namespace which -command exec] eq ""} {
# Some machines do not have exec. Also, on all
# platforms, safe interpreters do not have exec.
set auto_noexec 1
}
# Define a log command (which can be overwitten to log errors
# differently, specially when stderr is not available)
if {[namespace which -command tclLog] eq ""} {
proc tclLog {string} {
catch {puts stderr $string}
}
}
# unknown --
# This procedure is called when a Tcl command is invoked that doesn't
# exist in the interpreter. It takes the following steps to make the
# command available:
#
# 1. See if the autoload facility can locate the command in a
# Tcl script file. If so, load it and execute it.
# 2. If the command was invoked interactively at top-level:
# (a) see if the command exists as an executable UNIX program.
# If so, "exec" the command.
# (b) see if the command requests csh-like history substitution
# in one of the common forms !!, !<number>, or ^old^new. If
# so, emulate csh's history substitution.
# (c) see if the command is a unique abbreviation for another
# command. If so, invoke the command.
#
# Arguments:
# args - A list whose elements are the words of the original
# command, including the command name.
proc unknown args {
variable ::tcl::UnknownPending
global auto_noexec auto_noload env tcl_interactive errorInfo errorCode
if {[info exists errorInfo]} {
set savedErrorInfo $errorInfo
}
if {[info exists errorCode]} {
set savedErrorCode $errorCode
}
set name [lindex $args 0]
if {![info exists auto_noload]} {
#
# Make sure we're not trying to load the same proc twice.
#
if {[info exists UnknownPending($name)]} {
return -code error "self-referential recursion\
in \"unknown\" for command \"$name\""
}
set UnknownPending($name) pending
set ret [catch {
auto_load $name [uplevel 1 {::namespace current}]
} msg opts]
unset UnknownPending($name)
if {$ret != 0} {
dict append opts -errorinfo "\n (autoloading \"$name\")"
return -options $opts $msg
}
if {![array size UnknownPending]} {
unset UnknownPending
}
if {$msg} {
if {[info exists savedErrorCode]} {
set ::errorCode $savedErrorCode
} else {
unset -nocomplain ::errorCode
}
if {[info exists savedErrorInfo]} {
set errorInfo $savedErrorInfo
} else {
unset -nocomplain errorInfo
}
set code [catch {uplevel 1 $args} msg opts]
if {$code == 1} {
#
# Compute stack trace contribution from the [uplevel].
# Note the dependence on how Tcl_AddErrorInfo, etc.
# construct the stack trace.
#
set errInfo [dict get $opts -errorinfo]
set errCode [dict get $opts -errorcode]
set cinfo $args
if {[string bytelength $cinfo] > 150} {
set cinfo [string range $cinfo 0 150]
while {[string bytelength $cinfo] > 150} {
set cinfo [string range $cinfo 0 end-1]
}
append cinfo ...
}
set tail "\n (\"uplevel\" body line 1)\n invoked\
from within\n\"uplevel 1 \$args\""
set expect "$msg\n while executing\n\"$cinfo\"$tail"
if {$errInfo eq $expect} {
#
# The stack has only the eval from the expanded command
# Do not generate any stack trace here.
#
dict unset opts -errorinfo
dict incr opts -level
return -options $opts $msg
}
#
# Stack trace is nested, trim off just the contribution
# from the extra "eval" of $args due to the "catch" above.
#
set last [string last $tail $errInfo]
if {$last + [string length $tail] != [string length $errInfo]} {
# Very likely cannot happen
return -options $opts $msg
}
set errInfo [string range $errInfo 0 $last-1]
set tail "\"$cinfo\""
set last [string last $tail $errInfo]
if {$last + [string length $tail] != [string length $errInfo]} {
return -code error -errorcode $errCode \
-errorinfo $errInfo $msg
}
set errInfo [string range $errInfo 0 $last-1]
set tail "\n invoked from within\n"
set last [string last $tail $errInfo]
if {$last + [string length $tail] == [string length $errInfo]} {
return -code error -errorcode $errCode \
-errorinfo [string range $errInfo 0 $last-1] $msg
}
set tail "\n while executing\n"
set last [string last $tail $errInfo]
if {$last + [string length $tail] == [string length $errInfo]} {
return -code error -errorcode $errCode \
-errorinfo [string range $errInfo 0 $last-1] $msg
}
return -options $opts $msg
} else {
dict incr opts -level
return -options $opts $msg
}
}
}
if {([info level] == 1) && ([info script] eq "")
&& [info exists tcl_interactive] && $tcl_interactive} {
if {![info exists auto_noexec]} {
set new [auto_execok $name]
if {$new ne ""} {
set redir ""
if {[namespace which -command console] eq ""} {
set redir ">&@stdout <@stdin"
}
uplevel 1 [list ::catch \
[concat exec $redir $new [lrange $args 1 end]] \
::tcl::UnknownResult ::tcl::UnknownOptions]
dict incr ::tcl::UnknownOptions -level
return -options $::tcl::UnknownOptions $::tcl::UnknownResult
}
}
if {$name eq "!!"} {
set newcmd [history event]
} elseif {[regexp {^!(.+)$} $name -> event]} {
set newcmd [history event $event]
} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} {
set newcmd [history event -1]
catch {regsub -all -- $old $newcmd $new newcmd}
}
if {[info exists newcmd]} {
tclLog $newcmd
history change $newcmd 0
uplevel 1 [list ::catch $newcmd \
::tcl::UnknownResult ::tcl::UnknownOptions]
dict incr ::tcl::UnknownOptions -level
return -options $::tcl::UnknownOptions $::tcl::UnknownResult
}
set ret [catch {set candidates [info commands $name*]} msg]
if {$name eq "::"} {
set name ""
}
if {$ret != 0} {
dict append opts -errorinfo \
"\n (expanding command prefix \"$name\" in unknown)"
return -options $opts $msg
}
# Filter out bogus matches when $name contained
# a glob-special char [Bug 946952]
if {$name eq ""} {
# Handle empty $name separately due to strangeness
# in [string first] (See RFE 1243354)
set cmds $candidates
} else {
set cmds [list]
foreach x $candidates {
if {[string first $name $x] == 0} {
lappend cmds $x
}
}
}
if {[llength $cmds] == 1} {
uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \
::tcl::UnknownResult ::tcl::UnknownOptions]
dict incr ::tcl::UnknownOptions -level
return -options $::tcl::UnknownOptions $::tcl::UnknownResult
}
if {[llength $cmds]} {
return -code error "ambiguous command name \"$name\": [lsort $cmds]"
}
}
return -code error -errorcode [list TCL LOOKUP COMMAND $name] \
"invalid command name \"$name\""
}
# auto_load --
# Checks a collection of library directories to see if a procedure
# is defined in one of them. If so, it sources the appropriate
# library file to create the procedure. Returns 1 if it successfully
# loaded the procedure, 0 otherwise.
#
# Arguments:
# cmd - Name of the command to find and load.
# namespace (optional) The namespace where the command is being used - must be
# a canonical namespace as returned [namespace current]
# for instance. If not given, namespace current is used.
proc auto_load {cmd {namespace {}}} {
global auto_index auto_path
if {$namespace eq ""} {
set namespace [uplevel 1 [list ::namespace current]]
}
set nameList [auto_qualify $cmd $namespace]
# workaround non canonical auto_index entries that might be around
# from older auto_mkindex versions
lappend nameList $cmd
foreach name $nameList {
if {[info exists auto_index($name)]} {
namespace eval :: $auto_index($name)
# There's a couple of ways to look for a command of a given
# name. One is to use
# info commands $name
# Unfortunately, if the name has glob-magic chars in it like *
# or [], it may not match. For our purposes here, a better
# route is to use
# namespace which -command $name
if {[namespace which -command $name] ne ""} {
return 1
}
}
}
if {![info exists auto_path]} {
return 0
}
if {![auto_load_index]} {
return 0
}
foreach name $nameList {
if {[info exists auto_index($name)]} {
namespace eval :: $auto_index($name)
if {[namespace which -command $name] ne ""} {
return 1
}
}
}
return 0
}
# auto_load_index --
# Loads the contents of tclIndex files on the auto_path directory
# list. This is usually invoked within auto_load to load the index
# of available commands. Returns 1 if the index is loaded, and 0 if
# the index is already loaded and up to date.
#
# Arguments:
# None.
proc auto_load_index {} {
variable ::tcl::auto_oldpath
global auto_index auto_path
if {[info exists auto_oldpath] && ($auto_oldpath eq $auto_path)} {
return 0
}
set auto_oldpath $auto_path
# Check if we are a safe interpreter. In that case, we support only
# newer format tclIndex files.
set issafe [interp issafe]
for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
set dir [lindex $auto_path $i]
set f ""
if {$issafe} {
catch {source [file join $dir tclIndex]}
} elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
continue
} else {
set error [catch {
set id [gets $f]
if {$id eq "# Tcl autoload index file, version 2.0"} {
eval [read $f]
} elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} {
while {[gets $f line] >= 0} {
if {([string index $line 0] eq "#") \
|| ([llength $line] != 2)} {
continue
}
set name [lindex $line 0]
set auto_index($name) \
"source [file join $dir [lindex $line 1]]"
}
} else {
error "[file join $dir tclIndex] isn't a proper Tcl index file"
}
} msg opts]
if {$f ne ""} {
close $f
}
if {$error} {
return -options $opts $msg
}
}
}
return 1
}
# auto_qualify --
#
# Compute a fully qualified names list for use in the auto_index array.
# For historical reasons, commands in the global namespace do not have leading
# :: in the index key. The list has two elements when the command name is
# relative (no leading ::) and the namespace is not the global one. Otherwise
# only one name is returned (and searched in the auto_index).
#
# Arguments -
# cmd The command name. Can be any name accepted for command
# invocations (Like "foo::::bar").
# namespace The namespace where the command is being used - must be
# a canonical namespace as returned by [namespace current]
# for instance.
proc auto_qualify {cmd namespace} {
# count separators and clean them up
# (making sure that foo:::::bar will be treated as foo::bar)
set n [regsub -all {::+} $cmd :: cmd]
# Ignore namespace if the name starts with ::
# Handle special case of only leading ::
# Before each return case we give an example of which category it is
# with the following form :
# (inputCmd, inputNameSpace) -> output
if {[string match ::* $cmd]} {
if {$n > 1} {
# (::foo::bar , *) -> ::foo::bar
return [list $cmd]
} else {
# (::global , *) -> global
return [list [string range $cmd 2 end]]
}
}
# Potentially returning 2 elements to try :
# (if the current namespace is not the global one)
if {$n == 0} {
if {$namespace eq "::"} {
# (nocolons , ::) -> nocolons
return [list $cmd]
} else {
# (nocolons , ::sub) -> ::sub::nocolons nocolons
return [list ${namespace}::$cmd $cmd]
}
} elseif {$namespace eq "::"} {
# (foo::bar , ::) -> ::foo::bar
return [list ::$cmd]
} else {
# (foo::bar , ::sub) -> ::sub::foo::bar ::foo::bar
return [list ${namespace}::$cmd ::$cmd]
}
}
# auto_import --
#
# Invoked during "namespace import" to make see if the imported commands
# reside in an autoloaded library. If so, the commands are loaded so
# that they will be available for the import links. If not, then this
# procedure does nothing.
#
# Arguments -
# pattern The pattern of commands being imported (like "foo::*")
# a canonical namespace as returned by [namespace current]
proc auto_import {pattern} {
global auto_index
# If no namespace is specified, this will be an error case
if {![string match *::* $pattern]} {
return
}
set ns [uplevel 1 [list ::namespace current]]
set patternList [auto_qualify $pattern $ns]
auto_load_index
foreach pattern $patternList {
foreach name [array names auto_index $pattern] {
if {([namespace which -command $name] eq "")
&& ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} {
namespace eval :: $auto_index($name)
}
}
}
}
# auto_execok --
#
# Returns string that indicates name of program to execute if
# name corresponds to a shell builtin or an executable in the
# Windows search path, or "" otherwise. Builds an associative
# array auto_execs that caches information about previous checks,
# for speed.
#
# Arguments:
# name - Name of a command.
if {$tcl_platform(platform) eq "windows"} {
# Windows version.
#
# Note that file executable doesn't work under Windows, so we have to
# look for files with .exe, .com, or .bat extensions. Also, the path
# may be in the Path or PATH environment variables, and path
# components are separated with semicolons, not colons as under Unix.
#
proc auto_execok name {
global auto_execs env tcl_platform
if {[info exists auto_execs($name)]} {
return $auto_execs($name)
}
set auto_execs($name) ""
set shellBuiltins [list assoc cls copy date del dir echo erase ftype \
md mkdir mklink move rd ren rename rmdir start time type ver vol]
if {[info exists env(PATHEXT)]} {
# Add an initial ; to have the {} extension check first.
set execExtensions [split ";$env(PATHEXT)" ";"]
} else {
set execExtensions [list {} .com .exe .bat .cmd]
}
if {[string tolower $name] in $shellBuiltins} {
# When this is command.com for some reason on Win2K, Tcl won't
# exec it unless the case is right, which this corrects. COMSPEC
# may not point to a real file, so do the check.
set cmd $env(COMSPEC)
if {[file exists $cmd]} {
set cmd [file attributes $cmd -shortname]
}
return [set auto_execs($name) [list $cmd /c $name]]
}
if {[llength [file split $name]] != 1} {
foreach ext $execExtensions {
set file ${name}${ext}
if {[file exists $file] && ![file isdirectory $file]} {
return [set auto_execs($name) [list $file]]
}
}
return ""
}
set path "[file dirname [info nameof]];.;"
if {[info exists env(WINDIR)]} {
set windir $env(WINDIR)
}
if {[info exists windir]} {
if {$tcl_platform(os) eq "Windows NT"} {
append path "$windir/system32;"
}
append path "$windir/system;$windir;"
}
foreach var {PATH Path path} {
if {[info exists env($var)]} {
append path ";$env($var)"
}
}
foreach ext $execExtensions {
unset -nocomplain checked
foreach dir [split $path {;}] {
# Skip already checked directories
if {[info exists checked($dir)] || ($dir eq "")} {
continue
}
set checked($dir) {}
set file [file join $dir ${name}${ext}]
if {[file exists $file] && ![file isdirectory $file]} {
return [set auto_execs($name) [list $file]]
}
}
}
return ""
}
} else {
# Unix version.
#
proc auto_execok name {
global auto_execs env
if {[info exists auto_execs($name)]} {
return $auto_execs($name)
}
set auto_execs($name) ""
if {[llength [file split $name]] != 1} {
if {[file executable $name] && ![file isdirectory $name]} {
set auto_execs($name) [list $name]
}
return $auto_execs($name)
}
foreach dir [split $env(PATH) :] {
if {$dir eq ""} {
set dir .
}
set file [file join $dir $name]
if {[file executable $file] && ![file isdirectory $file]} {
set auto_execs($name) [list $file]
return $auto_execs($name)
}
}
return ""
}
}
# ::tcl::CopyDirectory --
#
# This procedure is called by Tcl's core when attempts to call the
# filesystem's copydirectory function fail. The semantics of the call
# are that 'dest' does not yet exist, i.e. dest should become the exact
# image of src. If dest does exist, we throw an error.
#
# Note that making changes to this procedure can change the results
# of running Tcl's tests.
#
# Arguments:
# action - "renaming" or "copying"
# src - source directory
# dest - destination directory
proc tcl::CopyDirectory {action src dest} {
set nsrc [file normalize $src]
set ndest [file normalize $dest]
if {$action eq "renaming"} {
# Can't rename volumes. We could give a more precise
# error message here, but that would break the test suite.
if {$nsrc in [file volumes]} {
return -code error "error $action \"$src\" to\
\"$dest\": trying to rename a volume or move a directory\
into itself"
}
}
if {[file exists $dest]} {
if {$nsrc eq $ndest} {
return -code error "error $action \"$src\" to\
\"$dest\": trying to rename a volume or move a directory\
into itself"
}
if {$action eq "copying"} {
# We used to throw an error here, but, looking more closely
# at the core copy code in tclFCmd.c, if the destination
# exists, then we should only call this function if -force
# is true, which means we just want to over-write. So,
# the following code is now commented out.
#
# return -code error "error $action \"$src\" to\
# \"$dest\": file already exists"
} else {
# Depending on the platform, and on the current
# working directory, the directories '.', '..'
# can be returned in various combinations. Anyway,
# if any other file is returned, we must signal an error.
set existing [glob -nocomplain -directory $dest * .*]
lappend existing {*}[glob -nocomplain -directory $dest \
-type hidden * .*]
foreach s $existing {
if {[file tail $s] ni {. ..}} {
return -code error "error $action \"$src\" to\
\"$dest\": file already exists"
}
}
}
} else {
if {[string first $nsrc $ndest] != -1} {
set srclen [expr {[llength [file split $nsrc]] - 1}]
set ndest [lindex [file split $ndest] $srclen]
if {$ndest eq [file tail $nsrc]} {
return -code error "error $action \"$src\" to\
\"$dest\": trying to rename a volume or move a directory\
into itself"
}
}
file mkdir $dest
}
# Have to be careful to capture both visible and hidden files.
# We will also be more generous to the file system and not
# assume the hidden and non-hidden lists are non-overlapping.
#
# On Unix 'hidden' files begin with '.'. On other platforms
# or filesystems hidden files may have other interpretations.
set filelist [concat [glob -nocomplain -directory $src *] \
[glob -nocomplain -directory $src -types hidden *]]
foreach s [lsort -unique $filelist] {
if {[file tail $s] ni {. ..}} {
file copy -force -- $s [file join $dest [file tail $s]]
}
}
return
}

747
windowsAgent/dist/tcl/package.tcl vendored Normal file
View File

@ -0,0 +1,747 @@
# package.tcl --
#
# utility procs formerly in init.tcl which can be loaded on demand
# for package management.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
namespace eval tcl::Pkg {}
# ::tcl::Pkg::CompareExtension --
#
# Used internally by pkg_mkIndex to compare the extension of a file to a given
# extension. On Windows, it uses a case-insensitive comparison because the
# file system can be file insensitive.
#
# Arguments:
# fileName name of a file whose extension is compared
# ext (optional) The extension to compare against; you must
# provide the starting dot.
# Defaults to [info sharedlibextension]
#
# Results:
# Returns 1 if the extension matches, 0 otherwise
proc tcl::Pkg::CompareExtension {fileName {ext {}}} {
global tcl_platform
if {$ext eq ""} {set ext [info sharedlibextension]}
if {$tcl_platform(platform) eq "windows"} {
return [string equal -nocase [file extension $fileName] $ext]
} else {
# Some unices add trailing numbers after the .so, so
# we could have something like '.so.1.2'.
set root $fileName
while {1} {
set currExt [file extension $root]
if {$currExt eq $ext} {
return 1
}
# The current extension does not match; if it is not a numeric
# value, quit, as we are only looking to ignore version number
# extensions. Otherwise we might return 1 in this case:
# tcl::Pkg::CompareExtension foo.so.bar .so
# which should not match.
if {![string is integer -strict [string range $currExt 1 end]]} {
return 0
}
set root [file rootname $root]
}
}
}
# pkg_mkIndex --
# This procedure creates a package index in a given directory. The package
# index consists of a "pkgIndex.tcl" file whose contents are a Tcl script that
# sets up package information with "package require" commands. The commands
# describe all of the packages defined by the files given as arguments.
#
# Arguments:
# -direct (optional) If this flag is present, the generated
# code in pkgMkIndex.tcl will cause the package to be
# loaded when "package require" is executed, rather
# than lazily when the first reference to an exported
# procedure in the package is made.
# -verbose (optional) Verbose output; the name of each file that
# was successfully rocessed is printed out. Additionally,
# if processing of a file failed a message is printed.
# -load pat (optional) Preload any packages whose names match
# the pattern. Used to handle DLLs that depend on
# other packages during their Init procedure.
# dir - Name of the directory in which to create the index.
# args - Any number of additional arguments, each giving
# a glob pattern that matches the names of one or
# more shared libraries or Tcl script files in
# dir.
proc pkg_mkIndex {args} {
set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"}
set argCount [llength $args]
if {$argCount < 1} {
return -code error "wrong # args: should be\n$usage"
}
set more ""
set direct 1
set doVerbose 0
set loadPat ""
for {set idx 0} {$idx < $argCount} {incr idx} {
set flag [lindex $args $idx]
switch -glob -- $flag {
-- {
# done with the flags
incr idx
break
}
-verbose {
set doVerbose 1
}
-lazy {
set direct 0
append more " -lazy"
}
-direct {
append more " -direct"
}
-load {
incr idx
set loadPat [lindex $args $idx]
append more " -load $loadPat"
}
-* {
return -code error "unknown flag $flag: should be\n$usage"
}
default {
# done with the flags
break
}
}
}
set dir [lindex $args $idx]
set patternList [lrange $args [expr {$idx + 1}] end]
if {![llength $patternList]} {
set patternList [list "*.tcl" "*[info sharedlibextension]"]
}
try {
set fileList [glob -directory $dir -tails -types {r f} -- \
{*}$patternList]
} on error {msg opt} {
return -options $opt $msg
}
foreach file $fileList {
# For each file, figure out what commands and packages it provides.
# To do this, create a child interpreter, load the file into the
# interpreter, and get a list of the new commands and packages that
# are defined.
if {$file eq "pkgIndex.tcl"} {
continue
}
set c [interp create]
# Load into the child any packages currently loaded in the parent
# interpreter that match the -load pattern.
if {$loadPat ne ""} {
if {$doVerbose} {
tclLog "currently loaded packages: '[info loaded]'"
tclLog "trying to load all packages matching $loadPat"
}
if {![llength [info loaded]]} {
tclLog "warning: no packages are currently loaded, nothing"
tclLog "can possibly match '$loadPat'"
}
}
foreach pkg [info loaded] {
if {![string match -nocase $loadPat [lindex $pkg 1]]} {
continue
}
if {$doVerbose} {
tclLog "package [lindex $pkg 1] matches '$loadPat'"
}
try {
load [lindex $pkg 0] [lindex $pkg 1] $c
} on error err {
if {$doVerbose} {
tclLog "warning: load [lindex $pkg 0]\
[lindex $pkg 1]\nfailed with: $err"
}
} on ok {} {
if {$doVerbose} {
tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
}
}
if {[lindex $pkg 1] eq "Tk"} {
# Withdraw . if Tk was loaded, to avoid showing a window.
$c eval [list wm withdraw .]
}
}
$c eval {
# Stub out the package command so packages can require other
# packages.
rename package __package_orig
proc package {what args} {
switch -- $what {
require {
return; # Ignore transitive requires
}
default {
__package_orig $what {*}$args
}
}
}
proc tclPkgUnknown args {}
package unknown tclPkgUnknown
# Stub out the unknown command so package can call into each other
# during their initialilzation.
proc unknown {args} {}
# Stub out the auto_import mechanism
proc auto_import {args} {}
# reserve the ::tcl namespace for support procs and temporary
# variables. This might make it awkward to generate a
# pkgIndex.tcl file for the ::tcl namespace.
namespace eval ::tcl {
variable dir ;# Current directory being processed
variable file ;# Current file being processed
variable direct ;# -direct flag value
variable x ;# Loop variable
variable debug ;# For debugging
variable type ;# "load" or "source", for -direct
variable namespaces ;# Existing namespaces (e.g., ::tcl)
variable packages ;# Existing packages (e.g., Tcl)
variable origCmds ;# Existing commands
variable newCmds ;# Newly created commands
variable newPkgs {} ;# Newly created packages
}
}
$c eval [list set ::tcl::dir $dir]
$c eval [list set ::tcl::file $file]
$c eval [list set ::tcl::direct $direct]
# Download needed procedures into the slave because we've just deleted
# the unknown procedure. This doesn't handle procedures with default
# arguments.
foreach p {::tcl::Pkg::CompareExtension} {
$c eval [list namespace eval [namespace qualifiers $p] {}]
$c eval [list proc $p [info args $p] [info body $p]]
}
try {
$c eval {
set ::tcl::debug "loading or sourcing"
# we need to track command defined by each package even in the
# -direct case, because they are needed internally by the
# "partial pkgIndex.tcl" step above.
proc ::tcl::GetAllNamespaces {{root ::}} {
set list $root
foreach ns [namespace children $root] {
lappend list {*}[::tcl::GetAllNamespaces $ns]
}
return $list
}
# init the list of existing namespaces, packages, commands
foreach ::tcl::x [::tcl::GetAllNamespaces] {
set ::tcl::namespaces($::tcl::x) 1
}
foreach ::tcl::x [package names] {
if {[package provide $::tcl::x] ne ""} {
set ::tcl::packages($::tcl::x) 1
}
}
set ::tcl::origCmds [info commands]
# Try to load the file if it has the shared library extension,
# otherwise source it. It's important not to try to load
# files that aren't shared libraries, because on some systems
# (like SunOS) the loader will abort the whole application
# when it gets an error.
if {[::tcl::Pkg::CompareExtension $::tcl::file [info sharedlibextension]]} {
# The "file join ." command below is necessary. Without
# it, if the file name has no \'s and we're on UNIX, the
# load command will invoke the LD_LIBRARY_PATH search
# mechanism, which could cause the wrong file to be used.
set ::tcl::debug loading
load [file join $::tcl::dir $::tcl::file]
set ::tcl::type load
} else {
set ::tcl::debug sourcing
source [file join $::tcl::dir $::tcl::file]
set ::tcl::type source
}
# As a performance optimization, if we are creating direct
# load packages, don't bother figuring out the set of commands
# created by the new packages. We only need that list for
# setting up the autoloading used in the non-direct case.
if {!$::tcl::direct} {
# See what new namespaces appeared, and import commands
# from them. Only exported commands go into the index.
foreach ::tcl::x [::tcl::GetAllNamespaces] {
if {![info exists ::tcl::namespaces($::tcl::x)]} {
namespace import -force ${::tcl::x}::*
}
# Figure out what commands appeared
foreach ::tcl::x [info commands] {
set ::tcl::newCmds($::tcl::x) 1
}
foreach ::tcl::x $::tcl::origCmds {
unset -nocomplain ::tcl::newCmds($::tcl::x)
}
foreach ::tcl::x [array names ::tcl::newCmds] {
# determine which namespace a command comes from
set ::tcl::abs [namespace origin $::tcl::x]
# special case so that global names have no
# leading ::, this is required by the unknown
# command
set ::tcl::abs \
[lindex [auto_qualify $::tcl::abs ::] 0]
if {$::tcl::x ne $::tcl::abs} {
# Name changed during qualification
set ::tcl::newCmds($::tcl::abs) 1
unset ::tcl::newCmds($::tcl::x)
}
}
}
}
# Look through the packages that appeared, and if there is a
# version provided, then record it
foreach ::tcl::x [package names] {
if {[package provide $::tcl::x] ne ""
&& ![info exists ::tcl::packages($::tcl::x)]} {
lappend ::tcl::newPkgs \
[list $::tcl::x [package provide $::tcl::x]]
}
}
}
} on error msg {
set what [$c eval set ::tcl::debug]
if {$doVerbose} {
tclLog "warning: error while $what $file: $msg"
}
} on ok {} {
set what [$c eval set ::tcl::debug]
if {$doVerbose} {
tclLog "successful $what of $file"
}
set type [$c eval set ::tcl::type]
set cmds [lsort [$c eval array names ::tcl::newCmds]]
set pkgs [$c eval set ::tcl::newPkgs]
if {$doVerbose} {
if {!$direct} {
tclLog "commands provided were $cmds"
}
tclLog "packages provided were $pkgs"
}
if {[llength $pkgs] > 1} {
tclLog "warning: \"$file\" provides more than one package ($pkgs)"
}
foreach pkg $pkgs {
# cmds is empty/not used in the direct case
lappend files($pkg) [list $file $type $cmds]
}
if {$doVerbose} {
tclLog "processed $file"
}
}
interp delete $c
}
append index "# Tcl package index file, version 1.1\n"
append index "# This file is generated by the \"pkg_mkIndex$more\" command\n"
append index "# and sourced either when an application starts up or\n"
append index "# by a \"package unknown\" script. It invokes the\n"
append index "# \"package ifneeded\" command to set up package-related\n"
append index "# information so that packages will be loaded automatically\n"
append index "# in response to \"package require\" commands. When this\n"
append index "# script is sourced, the variable \$dir must contain the\n"
append index "# full path name of this file's directory.\n"
foreach pkg [lsort [array names files]] {
set cmd {}
lassign $pkg name version
lappend cmd ::tcl::Pkg::Create -name $name -version $version
foreach spec [lsort -index 0 $files($pkg)] {
foreach {file type procs} $spec {
if {$direct} {
set procs {}
}
lappend cmd "-$type" [list $file $procs]
}
}
append index "\n[eval $cmd]"
}
set f [open [file join $dir pkgIndex.tcl] w]
puts $f $index
close $f
}
# tclPkgSetup --
# This is a utility procedure use by pkgIndex.tcl files. It is invoked as
# part of a "package ifneeded" script. It calls "package provide" to indicate
# that a package is available, then sets entries in the auto_index array so
# that the package's files will be auto-loaded when the commands are used.
#
# Arguments:
# dir - Directory containing all the files for this package.
# pkg - Name of the package (no version number).
# version - Version number for the package, such as 2.1.3.
# files - List of files that constitute the package. Each
# element is a sub-list with three elements. The first
# is the name of a file relative to $dir, the second is
# "load" or "source", indicating whether the file is a
# loadable binary or a script to source, and the third
# is a list of commands defined by this file.
proc tclPkgSetup {dir pkg version files} {
global auto_index
package provide $pkg $version
foreach fileInfo $files {
set f [lindex $fileInfo 0]
set type [lindex $fileInfo 1]
foreach cmd [lindex $fileInfo 2] {
if {$type eq "load"} {
set auto_index($cmd) [list load [file join $dir $f] $pkg]
} else {
set auto_index($cmd) [list source [file join $dir $f]]
}
}
}
}
# tclPkgUnknown --
# This procedure provides the default for the "package unknown" function. It
# is invoked when a package that's needed can't be found. It scans the
# auto_path directories and their immediate children looking for pkgIndex.tcl
# files and sources any such files that are found to setup the package
# database. As it searches, it will recognize changes to the auto_path and
# scan any new directories.
#
# Arguments:
# name - Name of desired package. Not used.
# version - Version of desired package. Not used.
# exact - Either "-exact" or omitted. Not used.
proc tclPkgUnknown {name args} {
global auto_path env
if {![info exists auto_path]} {
return
}
# Cache the auto_path, because it may change while we run through the
# first set of pkgIndex.tcl files
set old_path [set use_path $auto_path]
while {[llength $use_path]} {
set dir [lindex $use_path end]
# Make sure we only scan each directory one time.
if {[info exists tclSeenPath($dir)]} {
set use_path [lrange $use_path 0 end-1]
continue
}
set tclSeenPath($dir) 1
# we can't use glob in safe interps, so enclose the following in a
# catch statement, where we get the pkgIndex files out of the
# subdirectories
catch {
foreach file [glob -directory $dir -join -nocomplain \
* pkgIndex.tcl] {
set dir [file dirname $file]
if {![info exists procdDirs($dir)]} {
try {
source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
} on error msg {
tclLog "error reading package index file $file: $msg"
} on ok {} {
set procdDirs($dir) 1
}
}
}
}
set dir [lindex $use_path end]
if {![info exists procdDirs($dir)]} {
set file [file join $dir pkgIndex.tcl]
# safe interps usually don't have "file exists",
if {([interp issafe] || [file exists $file])} {
try {
source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
} on error msg {
tclLog "error reading package index file $file: $msg"
} on ok {} {
set procdDirs($dir) 1
}
}
}
set use_path [lrange $use_path 0 end-1]
# Check whether any of the index scripts we [source]d above set a new
# value for $::auto_path. If so, then find any new directories on the
# $::auto_path, and lappend them to the $use_path we are working from.
# This gives index scripts the (arguably unwise) power to expand the
# index script search path while the search is in progress.
set index 0
if {[llength $old_path] == [llength $auto_path]} {
foreach dir $auto_path old $old_path {
if {$dir ne $old} {
# This entry in $::auto_path has changed.
break
}
incr index
}
}
# $index now points to the first element of $auto_path that has
# changed, or the beginning if $auto_path has changed length Scan the
# new elements of $auto_path for directories to add to $use_path.
# Don't add directories we've already seen, or ones already on the
# $use_path.
foreach dir [lrange $auto_path $index end] {
if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} {
lappend use_path $dir
}
}
set old_path $auto_path
}
}
# tcl::MacOSXPkgUnknown --
# This procedure extends the "package unknown" function for MacOSX. It scans
# the Resources/Scripts directories of the immediate children of the auto_path
# directories for pkgIndex files.
#
# Arguments:
# original - original [package unknown] procedure
# name - Name of desired package. Not used.
# version - Version of desired package. Not used.
# exact - Either "-exact" or omitted. Not used.
proc tcl::MacOSXPkgUnknown {original name args} {
# First do the cross-platform default search
uplevel 1 $original [linsert $args 0 $name]
# Now do MacOSX specific searching
global auto_path
if {![info exists auto_path]} {
return
}
# Cache the auto_path, because it may change while we run through the
# first set of pkgIndex.tcl files
set old_path [set use_path $auto_path]
while {[llength $use_path]} {
set dir [lindex $use_path end]
# Make sure we only scan each directory one time.
if {[info exists tclSeenPath($dir)]} {
set use_path [lrange $use_path 0 end-1]
continue
}
set tclSeenPath($dir) 1
# get the pkgIndex files out of the subdirectories
foreach file [glob -directory $dir -join -nocomplain \
* Resources Scripts pkgIndex.tcl] {
set dir [file dirname $file]
if {![info exists procdDirs($dir)]} {
try {
source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
} on error msg {
tclLog "error reading package index file $file: $msg"
} on ok {} {
set procdDirs($dir) 1
}
}
}
set use_path [lrange $use_path 0 end-1]
# Check whether any of the index scripts we [source]d above set a new
# value for $::auto_path. If so, then find any new directories on the
# $::auto_path, and lappend them to the $use_path we are working from.
# This gives index scripts the (arguably unwise) power to expand the
# index script search path while the search is in progress.
set index 0
if {[llength $old_path] == [llength $auto_path]} {
foreach dir $auto_path old $old_path {
if {$dir ne $old} {
# This entry in $::auto_path has changed.
break
}
incr index
}
}
# $index now points to the first element of $auto_path that has
# changed, or the beginning if $auto_path has changed length Scan the
# new elements of $auto_path for directories to add to $use_path.
# Don't add directories we've already seen, or ones already on the
# $use_path.
foreach dir [lrange $auto_path $index end] {
if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} {
lappend use_path $dir
}
}
set old_path $auto_path
}
}
# ::tcl::Pkg::Create --
#
# Given a package specification generate a "package ifneeded" statement
# for the package, suitable for inclusion in a pkgIndex.tcl file.
#
# Arguments:
# args arguments used by the Create function:
# -name packageName
# -version packageVersion
# -load {filename ?{procs}?}
# ...
# -source {filename ?{procs}?}
# ...
#
# Any number of -load and -source parameters may be
# specified, so long as there is at least one -load or
# -source parameter. If the procs component of a module
# specifier is left off, that module will be set up for
# direct loading; otherwise, it will be set up for lazy
# loading. If both -source and -load are specified, the
# -load'ed files will be loaded first, followed by the
# -source'd files.
#
# Results:
# An appropriate "package ifneeded" statement for the package.
proc ::tcl::Pkg::Create {args} {
append err(usage) "[lindex [info level 0] 0] "
append err(usage) "-name packageName -version packageVersion"
append err(usage) "?-load {filename ?{procs}?}? ... "
append err(usage) "?-source {filename ?{procs}?}? ..."
set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\""
set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\""
set err(unknownOpt) "unknown option \"%s\": should be \"$err(usage)\""
set err(noLoadOrSource) "at least one of -load and -source must be given"
# process arguments
set len [llength $args]
if {$len < 6} {
error $err(wrongNumArgs)
}
# Initialize parameters
array set opts {-name {} -version {} -source {} -load {}}
# process parameters
for {set i 0} {$i < $len} {incr i} {
set flag [lindex $args $i]
incr i
switch -glob -- $flag {
"-name" -
"-version" {
if {$i >= $len} {
error [format $err(valueMissing) $flag]
}
set opts($flag) [lindex $args $i]
}
"-source" -
"-load" {
if {$i >= $len} {
error [format $err(valueMissing) $flag]
}
lappend opts($flag) [lindex $args $i]
}
default {
error [format $err(unknownOpt) [lindex $args $i]]
}
}
}
# Validate the parameters
if {![llength $opts(-name)]} {
error [format $err(valueMissing) "-name"]
}
if {![llength $opts(-version)]} {
error [format $err(valueMissing) "-version"]
}
if {!([llength $opts(-source)] || [llength $opts(-load)])} {
error $err(noLoadOrSource)
}
# OK, now everything is good. Generate the package ifneeded statment.
set cmdline "package ifneeded $opts(-name) $opts(-version) "
set cmdList {}
set lazyFileList {}
# Handle -load and -source specs
foreach key {load source} {
foreach filespec $opts(-$key) {
lassign $filespec filename proclist
if { [llength $proclist] == 0 } {
set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
lappend cmdList $cmd
} else {
lappend lazyFileList [list $filename $key $proclist]
}
}
}
if {[llength $lazyFileList]} {
lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\
$opts(-version) [list $lazyFileList]\]"
}
append cmdline [join $cmdList "\\n"]
return $cmdline
}
interp alias {} ::pkg::create {} ::tcl::Pkg::Create

28
windowsAgent/dist/tcl/parray.tcl vendored Normal file
View File

@ -0,0 +1,28 @@
# parray:
# Print the contents of a global array on stdout.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
proc parray {a {pattern *}} {
upvar 1 $a array
if {![array exists array]} {
return -code error "\"$a\" isn't an array"
}
set maxl 0
set names [lsort [array names array $pattern]]
foreach name $names {
if {[string length $name] > $maxl} {
set maxl [string length $name]
}
}
set maxl [expr {$maxl + [string length $a] + 2}]
foreach name $names {
set nameString [format %s(%s) $a $name]
puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
}
}

1133
windowsAgent/dist/tcl/safe.tcl vendored Normal file
View File

File diff suppressed because it is too large Load Diff

75
windowsAgent/dist/tcl/tclIndex vendored Normal file
View File

@ -0,0 +1,75 @@
# Tcl autoload index file, version 2.0
# -*- tcl -*-
# This file is generated by the "auto_mkindex" command
# and sourced to set up indexing information for one or
# more commands. Typically each line is a command that
# sets an element in the auto_index array, where the
# element name is the name of a command and the value is
# a script that loads the command.
set auto_index(auto_reset) [list source [file join $dir auto.tcl]]
set auto_index(tcl_findLibrary) [list source [file join $dir auto.tcl]]
set auto_index(auto_mkindex) [list source [file join $dir auto.tcl]]
set auto_index(auto_mkindex_old) [list source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::init) [list source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::cleanup) [list source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::mkindex) [list source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::hook) [list source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::slavehook) [list source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::command) [list source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::commandInit) [list source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::fullname) [list source [file join $dir auto.tcl]]
set auto_index(history) [list source [file join $dir history.tcl]]
set auto_index(::tcl::HistAdd) [list source [file join $dir history.tcl]]
set auto_index(::tcl::HistKeep) [list source [file join $dir history.tcl]]
set auto_index(::tcl::HistClear) [list source [file join $dir history.tcl]]
set auto_index(::tcl::HistInfo) [list source [file join $dir history.tcl]]
set auto_index(::tcl::HistRedo) [list source [file join $dir history.tcl]]
set auto_index(::tcl::HistIndex) [list source [file join $dir history.tcl]]
set auto_index(::tcl::HistEvent) [list source [file join $dir history.tcl]]
set auto_index(::tcl::HistChange) [list source [file join $dir history.tcl]]
set auto_index(pkg_mkIndex) [list source [file join $dir package.tcl]]
set auto_index(tclPkgSetup) [list source [file join $dir package.tcl]]
set auto_index(tclPkgUnknown) [list source [file join $dir package.tcl]]
set auto_index(::tcl::MacOSXPkgUnknown) [list source [file join $dir package.tcl]]
set auto_index(::pkg::create) [list source [file join $dir package.tcl]]
set auto_index(parray) [list source [file join $dir parray.tcl]]
set auto_index(::safe::InterpStatics) [list source [file join $dir safe.tcl]]
set auto_index(::safe::InterpNested) [list source [file join $dir safe.tcl]]
set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]]
set auto_index(::safe::interpInit) [list source [file join $dir safe.tcl]]
set auto_index(::safe::CheckInterp) [list source [file join $dir safe.tcl]]
set auto_index(::safe::interpConfigure) [list source [file join $dir safe.tcl]]
set auto_index(::safe::InterpCreate) [list source [file join $dir safe.tcl]]
set auto_index(::safe::InterpSetConfig) [list source [file join $dir safe.tcl]]
set auto_index(::safe::interpFindInAccessPath) [list source [file join $dir safe.tcl]]
set auto_index(::safe::interpAddToAccessPath) [list source [file join $dir safe.tcl]]
set auto_index(::safe::InterpInit) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AddSubDirs) [list source [file join $dir safe.tcl]]
set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]]
set auto_index(::safe::setLogCmd) [list source [file join $dir safe.tcl]]
set auto_index(::safe::SyncAccessPath) [list source [file join $dir safe.tcl]]
set auto_index(::safe::PathToken) [list source [file join $dir safe.tcl]]
set auto_index(::safe::TranslatePath) [list source [file join $dir safe.tcl]]
set auto_index(::safe::Log) [list source [file join $dir safe.tcl]]
set auto_index(::safe::CheckFileName) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasGlob) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasSource) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasLoad) [list source [file join $dir safe.tcl]]
set auto_index(::safe::FileInAccessPath) [list source [file join $dir safe.tcl]]
set auto_index(::safe::DirInAccessPath) [list source [file join $dir safe.tcl]]
set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasEncoding) [list source [file join $dir safe.tcl]]
set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]]
set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]]
set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]]
set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]]
set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]]
set auto_index(::tcl::tm::add) [list source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::remove) [list source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::list) [list source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::Defaults) [list source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::UnknownHandler) [list source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::roots) [list source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::path) [list source [file join $dir tm.tcl]]

375
windowsAgent/dist/tcl/tm.tcl vendored Normal file
View File

@ -0,0 +1,375 @@
# -*- tcl -*-
#
# Searching for Tcl Modules. Defines a procedure, declares it as the primary
# command for finding packages, however also uses the former 'package unknown'
# command as a fallback.
#
# Locates all possible packages in a directory via a less restricted glob. The
# targeted directory is derived from the name of the requested package, i.e.
# the TM scan will look only at directories which can contain the requested
# package. It will register all packages it found in the directory so that
# future requests have a higher chance of being fulfilled by the ifneeded
# database without having to come to us again.
#
# We do not remember where we have been and simply rescan targeted directories
# when invoked again. The reasoning is this:
#
# - The only way we get back to the same directory is if someone is trying to
# [package require] something that wasn't there on the first scan.
#
# Either
# 1) It is there now: If we rescan, you get it; if not you don't.
#
# This covers the possibility that the application asked for a package
# late, and the package was actually added to the installation after the
# application was started. It shoukld still be able to find it.
#
# 2) It still is not there: Either way, you don't get it, but the rescan
# takes time. This is however an error case and we dont't care that much
# about it
#
# 3) It was there the first time; but for some reason a "package forget" has
# been run, and "package" doesn't know about it anymore.
#
# This can be an indication that the application wishes to reload some
# functionality. And should work as well.
#
# Note that this also strikes a balance between doing a glob targeting a
# single package, and thus most likely requiring multiple globs of the same
# directory when the application is asking for many packages, and trying to
# glob for _everything_ in all subdirectories when looking for a package,
# which comes with a heavy startup cost.
#
# We scan for regular packages only if no satisfying module was found.
namespace eval ::tcl::tm {
# Default paths. None yet.
variable paths {}
# The regex pattern a file name has to match to make it a Tcl Module.
set pkgpattern {^([_[:alpha:]][:_[:alnum:]]*)-([[:digit:]].*)[.]tm$}
# Export the public API
namespace export path
namespace ensemble create -command path -subcommands {add remove list}
}
# ::tcl::tm::path implementations --
#
# Public API to the module path. See specification.
#
# Arguments
# cmd - The subcommand to execute
# args - The paths to add/remove. Must not appear querying the
# path with 'list'.
#
# Results
# No result for subcommands 'add' and 'remove'. A list of paths for
# 'list'.
#
# Sideeffects
# The subcommands 'add' and 'remove' manipulate the list of paths to
# search for Tcl Modules. The subcommand 'list' has no sideeffects.
proc ::tcl::tm::add {args} {
# PART OF THE ::tcl::tm::path ENSEMBLE
#
# The path is added at the head to the list of module paths.
#
# The command enforces the restriction that no path may be an ancestor
# directory of any other path on the list. If the new path violates this
# restriction an error wil be raised.
#
# If the path is already present as is no error will be raised and no
# action will be taken.
variable paths
# We use a copy of the path as source during validation, and extend it as
# well. Because we not only have to detect if the new paths are bogus with
# respect to the existing paths, but also between themselves. Otherwise we
# can still add bogus paths, by specifying them in a single call. This
# makes the use of the new paths simpler as well, a trivial assignment of
# the collected paths to the official state var.
set newpaths $paths
foreach p $args {
if {$p in $newpaths} {
# Ignore a path already on the list.
continue
}
# Search for paths which are subdirectories of the new one. If there
# are any then the new path violates the restriction about ancestors.
set pos [lsearch -glob $newpaths ${p}/*]
# Cannot use "in", we need the position for the message.
if {$pos >= 0} {
return -code error \
"$p is ancestor of existing module path [lindex $newpaths $pos]."
}
# Now look for existing paths which are ancestors of the new one. This
# reverse question forces us to loop over the existing paths, as each
# element is the pattern, not the new path :(
foreach ep $newpaths {
if {[string match ${ep}/* $p]} {
return -code error \
"$p is subdirectory of existing module path $ep."
}
}
set newpaths [linsert $newpaths 0 $p]
}
# The validation of the input is complete and successful, and everything
# in newpaths is either an old path, or added. We can now extend the
# official list of paths, a simple assignment is sufficient.
set paths $newpaths
return
}
proc ::tcl::tm::remove {args} {
# PART OF THE ::tcl::tm::path ENSEMBLE
#
# Removes the path from the list of module paths. The command is silently
# ignored if the path is not on the list.
variable paths
foreach p $args {
set pos [lsearch -exact $paths $p]
if {$pos >= 0} {
set paths [lreplace $paths $pos $pos]
}
}
}
proc ::tcl::tm::list {} {
# PART OF THE ::tcl::tm::path ENSEMBLE
variable paths
return $paths
}
# ::tcl::tm::UnknownHandler --
#
# Unknown handler for Tcl Modules, i.e. packages in module form.
#
# Arguments
# original - Original [package unknown] procedure.
# name - Name of desired package.
# version - Version of desired package. Can be the
# empty string.
# exact - Either -exact or ommitted.
#
# Name, version, and exact are used to determine satisfaction. The
# original is called iff no satisfaction was achieved. The name is also
# used to compute the directory to target in the search.
#
# Results
# None.
#
# Sideeffects
# May populate the package ifneeded database with additional provide
# scripts.
proc ::tcl::tm::UnknownHandler {original name args} {
# Import the list of paths to search for packages in module form.
# Import the pattern used to check package names in detail.
variable paths
variable pkgpattern
# Without paths to search we can do nothing. (Except falling back to the
# regular search).
if {[llength $paths]} {
set pkgpath [string map {:: /} $name]
set pkgroot [file dirname $pkgpath]
if {$pkgroot eq "."} {
set pkgroot ""
}
# We don't remember a copy of the paths while looping. Tcl Modules are
# unable to change the list while we are searching for them. This also
# simplifies the loop, as we cannot get additional directories while
# iterating over the list. A simple foreach is sufficient.
set satisfied 0
foreach path $paths {
if {![interp issafe] && ![file exists $path]} {
continue
}
set currentsearchpath [file join $path $pkgroot]
if {![interp issafe] && ![file exists $currentsearchpath]} {
continue
}
set strip [llength [file split $path]]
# We can't use glob in safe interps, so enclose the following in a
# catch statement, where we get the module files out of the
# subdirectories. In other words, Tcl Modules are not-functional
# in such an interpreter. This is the same as for the command
# "tclPkgUnknown", i.e. the search for regular packages.
catch {
# We always look for _all_ possible modules in the current
# path, to get the max result out of the glob.
foreach file [glob -nocomplain -directory $currentsearchpath *.tm] {
set pkgfilename [join [lrange [file split $file] $strip end] ::]
if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} {
# Ignore everything not matching our pattern for
# package names.
continue
}
try {
package vcompare $pkgversion 0
} on error {} {
# Ignore everything where the version part is not
# acceptable to "package vcompare".
continue
}
if {[package ifneeded $pkgname $pkgversion] ne {}} {
# There's already a provide script registered for
# this version of this package. Since all units of
# code claiming to be the same version of the same
# package ought to be identical, just stick with
# the one we already have.
continue
}
# We have found a candidate, generate a "provide script"
# for it, and remember it. Note that we are using ::list
# to do this; locally [list] means something else without
# the namespace specifier.
# NOTE. When making changes to the format of the provide
# command generated below CHECK that the 'LOCATE'
# procedure in core file 'platform/shell.tcl' still
# understands it, or, if not, update its implementation
# appropriately.
#
# Right now LOCATE's implementation assumes that the path
# of the package file is the last element in the list.
package ifneeded $pkgname $pkgversion \
"[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]"
# We abort in this unknown handler only if we got a
# satisfying candidate for the requested package.
# Otherwise we still have to fallback to the regular
# package search to complete the processing.
if {($pkgname eq $name)
&& [package vsatisfies $pkgversion {*}$args]} {
set satisfied 1
# We do not abort the loop, and keep adding provide
# scripts for every candidate in the directory, just
# remember to not fall back to the regular search
# anymore.
}
}
}
}
if {$satisfied} {
return
}
}
# Fallback to previous command, if existing. See comment above about
# ::list...
if {[llength $original]} {
uplevel 1 $original [::linsert $args 0 $name]
}
}
# ::tcl::tm::Defaults --
#
# Determines the default search paths.
#
# Arguments
# None
#
# Results
# None.
#
# Sideeffects
# May add paths to the list of defaults.
proc ::tcl::tm::Defaults {} {
global env tcl_platform
lassign [split [info tclversion] .] major minor
set exe [file normalize [info nameofexecutable]]
# Note that we're using [::list], not [list] because [list] means
# something other than [::list] in this namespace.
roots [::list \
[file dirname [info library]] \
[file join [file dirname [file dirname $exe]] lib] \
]
if {$tcl_platform(platform) eq "windows"} {
set sep ";"
} else {
set sep ":"
}
for {set n $minor} {$n >= 0} {incr n -1} {
foreach ev [::list \
TCL${major}.${n}_TM_PATH \
TCL${major}_${n}_TM_PATH \
] {
if {![info exists env($ev)]} continue
foreach p [split $env($ev) $sep] {
path add $p
}
}
}
return
}
# ::tcl::tm::roots --
#
# Public API to the module path. See specification.
#
# Arguments
# paths - List of 'root' paths to derive search paths from.
#
# Results
# No result.
#
# Sideeffects
# Calls 'path add' to paths to the list of module search paths.
proc ::tcl::tm::roots {paths} {
regexp {^(\d+)\.(\d+)} [package present Tcl] - major minor
foreach pa $paths {
set p [file join $pa tcl$major]
for {set n $minor} {$n >= 0} {incr n -1} {
set px [file join $p ${major}.${n}]
if {![interp issafe]} {set px [file normalize $px]}
path add $px
}
set px [file join $p site-tcl]
if {![interp issafe]} {set px [file normalize $px]}
path add $px
}
return
}
# Initialization. Set up the default paths, then insert the new handler into
# the chain.
if {![interp issafe]} {::tcl::tm::Defaults}

152
windowsAgent/dist/tcl/word.tcl vendored Normal file
View File

@ -0,0 +1,152 @@
# word.tcl --
#
# This file defines various procedures for computing word boundaries in
# strings. This file is primarily needed so Tk text and entry widgets behave
# properly for different platforms.
#
# Copyright (c) 1996 by Sun Microsystems, Inc.
# Copyright (c) 1998 by Scritpics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# The following variables are used to determine which characters are
# interpreted as white space.
if {$::tcl_platform(platform) eq "windows"} {
# Windows style - any but a unicode space char
if {![info exists ::tcl_wordchars]} {
set ::tcl_wordchars {\S}
}
if {![info exists ::tcl_nonwordchars]} {
set ::tcl_nonwordchars {\s}
}
} else {
# Motif style - any unicode word char (number, letter, or underscore)
if {![info exists ::tcl_wordchars]} {
set ::tcl_wordchars {\w}
}
if {![info exists ::tcl_nonwordchars]} {
set ::tcl_nonwordchars {\W}
}
}
# Arrange for caches of the real matcher REs to be kept, which enables the REs
# themselves to be cached for greater performance (and somewhat greater
# clarity too).
namespace eval ::tcl {
variable WordBreakRE
array set WordBreakRE {}
proc UpdateWordBreakREs args {
# Ignores the arguments
global tcl_wordchars tcl_nonwordchars
variable WordBreakRE
# To keep the RE strings short...
set letter $tcl_wordchars
set space $tcl_nonwordchars
set WordBreakRE(after) "$letter$space|$space$letter"
set WordBreakRE(before) "^.*($letter$space|$space$letter)"
set WordBreakRE(end) "$space*$letter+$space"
set WordBreakRE(next) "$letter*$space+$letter"
set WordBreakRE(previous) "$space*($letter+)$space*\$"
}
# Initialize the cache
UpdateWordBreakREs
trace add variable ::tcl_wordchars write ::tcl::UpdateWordBreakREs
trace add variable ::tcl_nonwordchars write ::tcl::UpdateWordBreakREs
}
# tcl_wordBreakAfter --
#
# This procedure returns the index of the first word boundary after the
# starting point in the given string, or -1 if there are no more boundaries in
# the given string. The index returned refers to the first character of the
# pair that comprises a boundary.
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_wordBreakAfter {str start} {
variable ::tcl::WordBreakRE
set result {-1 -1}
regexp -indices -start $start -- $WordBreakRE(after) $str result
return [lindex $result 1]
}
# tcl_wordBreakBefore --
#
# This procedure returns the index of the first word boundary before the
# starting point in the given string, or -1 if there are no more boundaries in
# the given string. The index returned refers to the second character of the
# pair that comprises a boundary.
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_wordBreakBefore {str start} {
variable ::tcl::WordBreakRE
set result {-1 -1}
regexp -indices -- $WordBreakRE(before) [string range $str 0 $start] result
return [lindex $result 1]
}
# tcl_endOfWord --
#
# This procedure returns the index of the first end-of-word location after a
# starting index in the given string. An end-of-word location is defined to be
# the first whitespace character following the first non-whitespace character
# after the starting point. Returns -1 if there are no more words after the
# starting point.
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_endOfWord {str start} {
variable ::tcl::WordBreakRE
set result {-1 -1}
regexp -indices -start $start -- $WordBreakRE(end) $str result
return [lindex $result 1]
}
# tcl_startOfNextWord --
#
# This procedure returns the index of the first start-of-word location after a
# starting index in the given string. A start-of-word location is defined to
# be a non-whitespace character following a whitespace character. Returns -1
# if there are no more start-of-word locations after the starting point.
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_startOfNextWord {str start} {
variable ::tcl::WordBreakRE
set result {-1 -1}
regexp -indices -start $start -- $WordBreakRE(next) $str result
return [lindex $result 1]
}
# tcl_startOfPreviousWord --
#
# This procedure returns the index of the first start-of-word location before
# a starting index in the given string.
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_startOfPreviousWord {str start} {
variable ::tcl::WordBreakRE
set word {-1 -1}
regexp -indices -- $WordBreakRE(previous) [string range $str 0 $start-1] \
result word
return [lindex $word 0]
}