Wishkit.app/ 0040755 0000000 0000024 00000000000 10153113671 012105 5 ustar root staff Wishkit.app/Contents/ 0040755 0000000 0000024 00000000000 10153074464 013710 5 ustar root staff Wishkit.app/Contents/Frameworks/ 0040755 0000000 0000024 00000000000 10153074451 016024 5 ustar root staff Wishkit.app/Contents/Frameworks/Tcl.framework/ 0040755 0000000 0000024 00000000000 10153074464 020546 5 ustar root staff Wishkit.app/Contents/Frameworks/Tcl.framework/Resources 0120755 0000000 0000024 00000000000 10153113663 027555 2Versions/Current/Resources ustar root staff Wishkit.app/Contents/Frameworks/Tcl.framework/Tcl 0120755 0000000 0000024 00000000000 10153113663 025075 2Versions/Current/Tcl ustar root staff Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/ 0040755 0000000 0000024 00000000000 10153074415 022352 5 ustar root staff Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/ 0040755 0000000 0000024 00000000000 10153114231 022652 5 ustar root staff Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/ 0040755 0000000 0000024 00000000000 10153074415 024635 5 ustar root staff Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Info.plist 0100644 0000000 0000120 00000001671 10153074415 026571 0 ustar root admin
CFBundleDevelopmentRegion
English
CFBundleExecutable
Tcl
CFBundleGetInfoString
Tcl Library 8.4, Copyright © 2004 Tcl Core Team.
MacOS X Port by Jim Ingham <jingham@apple.com> & Ian Reid, Copyright © 2001-2002, Apple Computer, Inc.
CFBundleIdentifier
com.tcltk.tcllibrary
CFBundleInfoDictionaryVersion
6.0
CFBundleName
Tcl Library 8.4
CFBundlePackageType
FMWK
CFBundleShortVersionString
8.4.8
CFBundleSignature
Tcl
CFBundleVersion
8.4.8
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/ 0040755 0000000 0000024 00000000000 10153074464 026270 5 ustar root staff Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/auto.tcl 0100644 0000000 0000120 00000050032 10146430441 027714 0 ustar root admin # auto.tcl --
#
# utility procs formerly in init.tcl dealing with auto execution
# of commands and can be auto loaded themselves.
#
# RCS: @(#) $Id: auto.tcl,v 1.12.2.1 2004/11/16 16:56:01 dgp Exp $
#
# 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 procedures that are listed in the auto-load index
# except those defined in this file.
#
# Arguments:
# None.
proc auto_reset {} {
global auto_execs auto_index auto_oldpath
foreach p [info procs] {
if {[info exists auto_index($p)] && ![string match auto_* $p]
&& ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup
tcl_findLibrary pkg_compareExtension
tclPkgUnknown tcl::MacOSXPkgUnknown
tcl::MacPkgUnknown} $p] < 0)} {
rename $p {}
}
}
catch {unset auto_execs}
catch {unset auto_index}
catch {unset auto_oldpath}
}
# 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 env errorInfo
set dirs {}
set errors {}
# The C application may have hardwired a path, which we honor
set variableSet [info exists the_library]
if {$variableSet && $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.
#
# Only do this for Tcl 8.5+, when Tcl_RegsiterConfig() is available.
#if {[catch {
# ::${basename}::pkgconfig get scriptdir,runtime
#} value] == 0} {
# lappend dirs $value
#}
# 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)
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]
# Remaining locations are out of date (when relevant, they ought
# to be covered by the $::auto_path seach above).
#
# ../../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)
#
# For the sake of extra compatibility safety, we keep adding these
# paths during the 8.4.* release series.
if {1} {
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 {
if {[interp issafe]} {
set norm $i
} else {
set norm [file normalize $i]
}
if {[info exists seen($norm)]} { continue }
set seen($norm) ""
lappend uniqdirs $norm
}
set dirs $uniqdirs
foreach i $dirs {
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]} {
return
} else {
append errors "$file: $msg\n$errorInfo\n"
}
}
}
if {!$variableSet} {
unset 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} {
global errorCode errorInfo
if {[interp issafe]} {
error "can't generate index within safe interpreter"
}
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 {$args == ""} {
set args *.tcl
}
auto_mkindex_parser::init
foreach file [eval glob $args] {
if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} {
append index $msg
} else {
set code $errorCode
set info $errorInfo
cd $oldDir
error $msg $info $code
}
}
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} {
global errorCode errorInfo
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 {[string equal $args ""]} {
set args *.tcl
}
foreach file [eval 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]
if {$error} {
set code $errorCode
set info $errorInfo
catch {close $f}
cd $oldDir
error $msg $info $code
}
}
set f ""
set error [catch {
set f [open tclIndex w]
puts -nonewline $f $index
close $f
cd $oldDir
} msg]
if {$error} {
set code $errorCode
set info $errorInfo
catch {close $f}
cd $oldDir
error $msg $info $code
}
}
# 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
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
$parser invokehidden namespace delete ::
$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.
regsub -all {\$} $contents "\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 {[string equal $ns ""]} {
set fakeName "[namespace current]::_%@fake_$tail"
} else {
set fakeName "_%@fake_$name"
regsub -all {::} $fakeName "_" fakeName
set fakeName "[namespace current]::$fakeName"
}
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 {[regexp {::} $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 {[string equal [namespace qualifiers $name] ""]} {
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.
regsub -all "\0" $name "\$" name
return $name
}
# 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} {
variable index
variable scriptFile
# Do some fancy reformatting on the "source" call to handle platform
# differences with respect to pathnames. Use format just so that the
# command is a little easier to read (otherwise it'd be full of
# backslashed dollar signs, etc.
append index [list set auto_index([fullname $name])] \
[format { [list source [file join $dir %s]]} \
[file split $scriptFile]] "\n"
}
# 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 {
if {![catch {package require tbcload}]} {
if {[llength [info commands tbcload::bcproc]] == 0} {
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} {
variable index
variable scriptFile
# Do some nice reformatting of the "source" call, to get around
# path differences on different platforms. We use the format
# command just so that the code is a little easier to read.
append index [list set auto_index([fullname $name])] \
[format { [list source [file join $dir %s]]} \
[file split $scriptFile]] "\n"
}
}
}
# 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 {[string compare $pattern "-force"]} {
lappend imports $pattern
}
}
catch {$parser eval "_%@namespace import $args"}
}
}
}
return
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/encoding/ 0040755 0000000 0000024 00000000000 10153074464 030056 5 ustar root staff Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/encoding/ascii.enc 0100644 0000000 0000120 00000002102 06705504201 031602 0 ustar root admin # Encoding file: ascii, single-byte
S
003F 0 1
00
0000000100020003000400050006000700080009000A000B000C000D000E000F
0010001100120013001400150016001700180019001A001B001C001D001E001F
0020002100220023002400250026002700280029002A002B002C002D002E002F
0030003100320033003400350036003700380039003A003B003C003D003E003F
0040004100420043004400450046004700480049004A004B004C004D004E004F
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E0000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/encoding/cp1252.enc 0100644 0000000 0000120 00000002103 07303043126 031426 0 ustar root admin # Encoding file: cp1252, single-byte
S
003F 0 1
00
0000000100020003000400050006000700080009000A000B000C000D000E000F
0010001100120013001400150016001700180019001A001B001C001D001E001F
0020002100220023002400250026002700280029002A002B002C002D002E002F
0030003100320033003400350036003700380039003A003B003C003D003E003F
0040004100420043004400450046004700480049004A004B004C004D004E004F
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
20AC0081201A0192201E20262020202102C62030016020390152008D017D008F
009020182019201C201D20222013201402DC21220161203A0153009D017E0178
00A000A100A200A300A400A500A600A700A800A900AA00AB00AC00AD00AE00AF
00B000B100B200B300B400B500B600B700B800B900BA00BB00BC00BD00BE00BF
00C000C100C200C300C400C500C600C700C800C900CA00CB00CC00CD00CE00CF
00D000D100D200D300D400D500D600D700D800D900DA00DB00DC00DD00DE00DF
00E000E100E200E300E400E500E600E700E800E900EA00EB00EC00ED00EE00EF
00F000F100F200F300F400F500F600F700F800F900FA00FB00FC00FD00FE00FF
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/encoding/iso8859-1.enc 0100644 0000000 0000120 00000002106 06705504215 032011 0 ustar root admin # Encoding file: iso8859-1, single-byte
S
003F 0 1
00
0000000100020003000400050006000700080009000A000B000C000D000E000F
0010001100120013001400150016001700180019001A001B001C001D001E001F
0020002100220023002400250026002700280029002A002B002C002D002E002F
0030003100320033003400350036003700380039003A003B003C003D003E003F
0040004100420043004400450046004700480049004A004B004C004D004E004F
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
0080008100820083008400850086008700880089008A008B008C008D008E008F
0090009100920093009400950096009700980099009A009B009C009D009E009F
00A000A100A200A300A400A500A600A700A800A900AA00AB00AC00AD00AE00AF
00B000B100B200B300B400B500B600B700B800B900BA00BB00BC00BD00BE00BF
00C000C100C200C300C400C500C600C700C800C900CA00CB00CC00CD00CE00CF
00D000D100D200D300D400D500D600D700D800D900DA00DB00DC00DD00DE00DF
00E000E100E200E300E400E500E600E700E800E900EA00EB00EC00ED00EE00EF
00F000F100F200F300F400F500F600F700F800F900FA00FB00FC00FD00FE00FF
././@LongLink 0000000 0000000 0000000 00000000145 00000000000 011706 L ustar root wheel Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/encoding/iso8859-15.enc Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/encoding/iso8859-15.en 0100644 0000000 0000120 00000002107 07271563407 031743 0 ustar root admin # Encoding file: iso8859-15, single-byte
S
003F 0 1
00
0000000100020003000400050006000700080009000A000B000C000D000E000F
0010001100120013001400150016001700180019001A001B001C001D001E001F
0020002100220023002400250026002700280029002A002B002C002D002E002F
0030003100320033003400350036003700380039003A003B003C003D003E003F
0040004100420043004400450046004700480049004A004B004C004D004E004F
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
0080008100820083008400850086008700880089008A008B008C008D008E008F
0090009100920093009400950096009700980099009A009B009C009D009E009F
00A000A100A200A320AC00A5016000A7016100A900AA00AB00AC00AD00AE00AF
00B000B100B200B3017D00B500B600B7017E00B900BA00BB01520153017800BF
00C000C100C200C300C400C500C600C700C800C900CA00CB00CC00CD00CE00CF
00D000D100D200D300D400D500D600D700D800D900DA00DB00DC00DD00DE00DF
00E000E100E200E300E400E500E600E700E800E900EA00EB00EC00ED00EE00EF
00F000F100F200F300F400F500F600F700F800F900FA00FB00FC00FD00FE00FF
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/encoding/iso8859-2.enc 0100644 0000000 0000120 00000002106 06705504215 032012 0 ustar root admin # Encoding file: iso8859-2, single-byte
S
003F 0 1
00
0000000100020003000400050006000700080009000A000B000C000D000E000F
0010001100120013001400150016001700180019001A001B001C001D001E001F
0020002100220023002400250026002700280029002A002B002C002D002E002F
0030003100320033003400350036003700380039003A003B003C003D003E003F
0040004100420043004400450046004700480049004A004B004C004D004E004F
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
0080008100820083008400850086008700880089008A008B008C008D008E008F
0090009100920093009400950096009700980099009A009B009C009D009E009F
00A0010402D8014100A4013D015A00A700A80160015E0164017900AD017D017B
00B0010502DB014200B4013E015B02C700B80161015F0165017A02DD017E017C
015400C100C2010200C40139010600C7010C00C9011800CB011A00CD00CE010E
01100143014700D300D4015000D600D70158016E00DA017000DC00DD016200DF
015500E100E2010300E4013A010700E7010D00E9011900EB011B00ED00EE010F
01110144014800F300F4015100F600F70159016F00FA017100FC00FD016302D9
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/encoding/macRoman.enc 0100644 0000000 0000120 00000002105 07357142515 032264 0 ustar root admin # Encoding file: macRoman, single-byte
S
003F 0 1
00
0000000100020003000400050006000700080009000A000B000C000D000E000F
0010001100120013001400150016001700180019001A001B001C001D001E001F
0020002100220023002400250026002700280029002A002B002C002D002E002F
0030003100320033003400350036003700380039003A003B003C003D003E003F
0040004100420043004400450046004700480049004A004B004C004D004E004F
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
00C400C500C700C900D100D600DC00E100E000E200E400E300E500E700E900E8
00EA00EB00ED00EC00EE00EF00F100F300F200F400F600F500FA00F900FB00FC
202000B000A200A300A7202200B600DF00AE00A9212200B400A8226000C600D8
221E00B12264226500A500B522022211220F03C0222B00AA00BA03A900E600F8
00BF00A100AC221A01922248220600AB00BB202600A000C000C300D501520153
20132014201C201D2018201900F725CA00FF0178204420AC2039203AFB01FB02
202100B7201A201E203000C200CA00C100CB00C800CD00CE00CF00CC00D300D4
F8FF00D200DA00DB00D9013102C602DC00AF02D802D902DA00B802DD02DB02C7
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/history.tcl 0100644 0000000 0000120 00000021624 07300704560 030456 0 ustar root admin # history.tcl --
#
# Implementation of the history command.
#
# RCS: @(#) $Id: history.tcl,v 1.5 2001/05/17 08:18:56 hobbs Exp $
#
# 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
}
}
}
# history --
#
# This is the main history command. See the man page for its interface.
# This does argument checking and calls helper procedures in the
# history namespace.
proc history {args} {
set len [llength $args]
if {$len == 0} {
return [tcl::HistInfo]
}
set key [lindex $args 0]
set options "add, change, clear, event, info, keep, nextid, or redo"
switch -glob -- $key {
a* { # history add
if {$len > 3} {
return -code error "wrong # args: should be \"history add event ?exec?\""
}
if {![string match $key* add]} {
return -code error "bad option \"$key\": must be $options"
}
if {$len == 3} {
set arg [lindex $args 2]
if {! ([string match e* $arg] && [string match $arg* exec])} {
return -code error "bad argument \"$arg\": should be \"exec\""
}
}
return [tcl::HistAdd [lindex $args 1] [lindex $args 2]]
}
ch* { # history change
if {($len > 3) || ($len < 2)} {
return -code error "wrong # args: should be \"history change newValue ?event?\""
}
if {![string match $key* change]} {
return -code error "bad option \"$key\": must be $options"
}
if {$len == 2} {
set event 0
} else {
set event [lindex $args 2]
}
return [tcl::HistChange [lindex $args 1] $event]
}
cl* { # history clear
if {($len > 1)} {
return -code error "wrong # args: should be \"history clear\""
}
if {![string match $key* clear]} {
return -code error "bad option \"$key\": must be $options"
}
return [tcl::HistClear]
}
e* { # history event
if {$len > 2} {
return -code error "wrong # args: should be \"history event ?event?\""
}
if {![string match $key* event]} {
return -code error "bad option \"$key\": must be $options"
}
if {$len == 1} {
set event -1
} else {
set event [lindex $args 1]
}
return [tcl::HistEvent $event]
}
i* { # history info
if {$len > 2} {
return -code error "wrong # args: should be \"history info ?count?\""
}
if {![string match $key* info]} {
return -code error "bad option \"$key\": must be $options"
}
return [tcl::HistInfo [lindex $args 1]]
}
k* { # history keep
if {$len > 2} {
return -code error "wrong # args: should be \"history keep ?count?\""
}
if {$len == 1} {
return [tcl::HistKeep]
} else {
set limit [lindex $args 1]
if {[catch {expr {~$limit}}] || ($limit < 0)} {
return -code error "illegal keep count \"$limit\""
}
return [tcl::HistKeep $limit]
}
}
n* { # history nextid
if {$len > 1} {
return -code error "wrong # args: should be \"history nextid\""
}
if {![string match $key* nextid]} {
return -code error "bad option \"$key\": must be $options"
}
return [expr {$tcl::history(nextid) + 1}]
}
r* { # history redo
if {$len > 2} {
return -code error "wrong # args: should be \"history redo ?event?\""
}
if {![string match $key* redo]} {
return -code error "bad option \"$key\": must be $options"
}
return [tcl::HistRedo [lindex $args 1]]
}
default {
return -code error "bad option \"$key\": must be $options"
}
}
}
# tcl::HistAdd --
#
# Add an item to the history, and optionally eval it at the global scope
#
# Parameters:
# command 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 {command {exec {}}} {
variable history
# Do not add empty commands to the history
if {[string trim $command] == ""} {
return ""
}
set i [incr history(nextid)]
set history($i) $command
set j [incr history(oldest)]
if {[info exists history($j)]} {unset history($j)}
if {[string match e* $exec]} {
return [uplevel #0 $command]
} else {
return {}
}
}
# 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 {{limit {}}} {
variable history
if {[string length $limit] == 0} {
return $history(keep)
} else {
set oldold $history(oldest)
set history(oldest) [expr {$history(nextid) - $limit}]
for {} {$oldold <= $history(oldest)} {incr oldold} {
if {[info exists history($oldold)]} {unset history($oldold)}
}
set history(keep) $limit
}
}
# 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 {{num {}}} {
variable history
if {$num == {}} {
set num [expr {$history(keep) + 1}]
}
set result {}
set newline ""
for {set i [expr {$history(nextid) - $num + 1}]} \
{$i <= $history(nextid)} {incr i} {
if {![info exists history($i)]} {
continue
}
set cmd [string trimright $history($i) \ \n]
regsub -all \n $cmd "\n\t" cmd
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
if {[string length $event] == 0} {
set event -1
}
set i [HistIndex $event]
if {$i == $history(nextid)} {
return -code error "cannot redo the current event"
}
set cmd $history($i)
HistChange $cmd 0
uplevel #0 $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 {[catch {expr {~$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} {
variable history
set i [HistIndex $event]
if {[info exists history($i)]} {
return [string trimright $history($i) \ \n]
} else {
return "";
}
}
# tcl::HistChange --
#
# Replace a value in the history list.
#
# Parameters:
# cmd 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 {cmd {event 0}} {
variable history
set i [HistIndex $event]
set history($i) $cmd
}
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/http2.5/ 0040755 0000000 0000024 00000000000 10153074405 027467 5 ustar root staff Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/http2.5/http.tcl 0100644 0000000 0000120 00000056654 10054746707 031164 0 ustar root admin # http.tcl --
#
# Client-side HTTP for GET, POST, and HEAD commands.
# These routines can be used in untrusted code that uses
# the Safesock security policy. These procedures use a
# callback interface to avoid using vwait, which is not
# defined in the safe base.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: http.tcl,v 1.43.2.4 2004/05/25 22:50:47 hobbs Exp $
# Rough version history:
# 1.0 Old http_get interface
# 2.0 http:: namespace and http::geturl
# 2.1 Added callbacks to handle arriving data, and timeouts
# 2.2 Added ability to fetch into a channel
# 2.3 Added SSL support, and ability to post from a channel
# This version also cleans up error cases and eliminates the
# "ioerror" status in favor of raising an error
# 2.4 Added -binary option to http::geturl and charset element
# to the state array.
package require Tcl 8.2
# keep this in sync with pkgIndex.tcl
# and with the install directories in Makefiles
package provide http 2.5.0
namespace eval http {
variable http
array set http {
-accept */*
-proxyhost {}
-proxyport {}
-proxyfilter http::ProxyRequired
-urlencoding utf-8
}
set http(-useragent) "Tcl http client package [package provide http]"
proc init {} {
variable formMap
variable alphanumeric a-zA-Z0-9
for {set i 0} {$i <= 256} {incr i} {
set c [format %c $i]
if {![string match \[$alphanumeric\] $c]} {
set formMap($c) %[format %.2x $i]
}
}
# These are handled specially
array set formMap { " " + \n %0d%0a }
}
init
variable urlTypes
array set urlTypes {
http {80 ::socket}
}
variable encodings [string tolower [encoding names]]
# This can be changed, but iso8859-1 is the RFC standard.
variable defaultCharset "iso8859-1"
namespace export geturl config reset wait formatQuery register unregister
# Useful, but not exported: data size status code
}
# http::register --
#
# See documentaion for details.
#
# Arguments:
# proto URL protocol prefix, e.g. https
# port Default port for protocol
# command Command to use to create socket
# Results:
# list of port and command that was registered.
proc http::register {proto port command} {
variable urlTypes
set urlTypes($proto) [list $port $command]
}
# http::unregister --
#
# Unregisters URL protocol handler
#
# Arguments:
# proto URL protocol prefix, e.g. https
# Results:
# list of port and command that was unregistered.
proc http::unregister {proto} {
variable urlTypes
if {![info exists urlTypes($proto)]} {
return -code error "unsupported url type \"$proto\""
}
set old $urlTypes($proto)
unset urlTypes($proto)
return $old
}
# http::config --
#
# See documentaion for details.
#
# Arguments:
# args Options parsed by the procedure.
# Results:
# TODO
proc http::config {args} {
variable http
set options [lsort [array names http -*]]
set usage [join $options ", "]
if {[llength $args] == 0} {
set result {}
foreach name $options {
lappend result $name $http($name)
}
return $result
}
set options [string map {- ""} $options]
set pat ^-([join $options |])$
if {[llength $args] == 1} {
set flag [lindex $args 0]
if {[regexp -- $pat $flag]} {
return $http($flag)
} else {
return -code error "Unknown option $flag, must be: $usage"
}
} else {
foreach {flag value} $args {
if {[regexp -- $pat $flag]} {
set http($flag) $value
} else {
return -code error "Unknown option $flag, must be: $usage"
}
}
}
}
# http::Finish --
#
# Clean up the socket and eval close time callbacks
#
# Arguments:
# token Connection token.
# errormsg (optional) If set, forces status to error.
# skipCB (optional) If set, don't call the -command callback. This
# is useful when geturl wants to throw an exception instead
# of calling the callback. That way, the same error isn't
# reported to two places.
#
# Side Effects:
# Closes the socket
proc http::Finish { token {errormsg ""} {skipCB 0}} {
variable $token
upvar 0 $token state
global errorInfo errorCode
if {[string length $errormsg] != 0} {
set state(error) [list $errormsg $errorInfo $errorCode]
set state(status) error
}
catch {close $state(sock)}
catch {after cancel $state(after)}
if {[info exists state(-command)] && !$skipCB} {
if {[catch {eval $state(-command) {$token}} err]} {
if {[string length $errormsg] == 0} {
set state(error) [list $err $errorInfo $errorCode]
set state(status) error
}
}
if {[info exists state(-command)]} {
# Command callback may already have unset our state
unset state(-command)
}
}
}
# http::reset --
#
# See documentaion for details.
#
# Arguments:
# token Connection token.
# why Status info.
#
# Side Effects:
# See Finish
proc http::reset { token {why reset} } {
variable $token
upvar 0 $token state
set state(status) $why
catch {fileevent $state(sock) readable {}}
catch {fileevent $state(sock) writable {}}
Finish $token
if {[info exists state(error)]} {
set errorlist $state(error)
unset state
eval ::error $errorlist
}
}
# http::geturl --
#
# Establishes a connection to a remote url via http.
#
# Arguments:
# url The http URL to goget.
# args Option value pairs. Valid options include:
# -blocksize, -validate, -headers, -timeout
# Results:
# Returns a token for this connection.
# This token is the name of an array that the caller should
# unset to garbage collect the state.
proc http::geturl { url args } {
variable http
variable urlTypes
variable defaultCharset
# Initialize the state variable, an array. We'll return the
# name of this array as the token for the transaction.
if {![info exists http(uid)]} {
set http(uid) 0
}
set token [namespace current]::[incr http(uid)]
variable $token
upvar 0 $token state
reset $token
# Process command options.
array set state {
-binary false
-blocksize 8192
-queryblocksize 8192
-validate 0
-headers {}
-timeout 0
-type application/x-www-form-urlencoded
-queryprogress {}
state header
meta {}
coding {}
currentsize 0
totalsize 0
querylength 0
queryoffset 0
type text/html
body {}
status ""
http ""
}
# These flags have their types verified [Bug 811170]
array set type {
-binary boolean
-blocksize integer
-queryblocksize integer
-validate boolean
-timeout integer
}
set state(charset) $defaultCharset
set options {-binary -blocksize -channel -command -handler -headers \
-progress -query -queryblocksize -querychannel -queryprogress\
-validate -timeout -type}
set usage [join $options ", "]
set options [string map {- ""} $options]
set pat ^-([join $options |])$
foreach {flag value} $args {
if {[regexp $pat $flag]} {
# Validate numbers
if {[info exists type($flag)] && \
![string is $type($flag) -strict $value]} {
unset $token
return -code error "Bad value for $flag ($value), must be $type($flag)"
}
set state($flag) $value
} else {
unset $token
return -code error "Unknown option $flag, can be: $usage"
}
}
# Make sure -query and -querychannel aren't both specified
set isQueryChannel [info exists state(-querychannel)]
set isQuery [info exists state(-query)]
if {$isQuery && $isQueryChannel} {
unset $token
return -code error "Can't combine -query and -querychannel options!"
}
# Validate URL, determine the server host and port, and check proxy case
# Recognize user:pass@host URLs also, although we do not do anything
# with that info yet.
set exp {^(([^:]*)://)?([^@]+@)?([^/:]+)(:([0-9]+))?(/.*)?$}
if {![regexp -nocase $exp $url x prefix proto user host y port srvurl]} {
unset $token
return -code error "Unsupported URL: $url"
}
if {[string length $proto] == 0} {
set proto http
set url ${proto}://$url
}
if {![info exists urlTypes($proto)]} {
unset $token
return -code error "Unsupported URL type \"$proto\""
}
set defport [lindex $urlTypes($proto) 0]
set defcmd [lindex $urlTypes($proto) 1]
if {[string length $port] == 0} {
set port $defport
}
if {[string length $srvurl] == 0} {
set srvurl /
}
if {[string length $proto] == 0} {
set url http://$url
}
set state(url) $url
if {![catch {$http(-proxyfilter) $host} proxy]} {
set phost [lindex $proxy 0]
set pport [lindex $proxy 1]
}
# If a timeout is specified we set up the after event
# and arrange for an asynchronous socket connection.
if {$state(-timeout) > 0} {
set state(after) [after $state(-timeout) \
[list http::reset $token timeout]]
set async -async
} else {
set async ""
}
# If we are using the proxy, we must pass in the full URL that
# includes the server name.
if {[info exists phost] && [string length $phost]} {
set srvurl $url
set conStat [catch {eval $defcmd $async {$phost $pport}} s]
} else {
set conStat [catch {eval $defcmd $async {$host $port}} s]
}
if {$conStat} {
# something went wrong while trying to establish the connection
# Clean up after events and such, but DON'T call the command callback
# (if available) because we're going to throw an exception from here
# instead.
Finish $token "" 1
cleanup $token
return -code error $s
}
set state(sock) $s
# Wait for the connection to complete
if {$state(-timeout) > 0} {
fileevent $s writable [list http::Connect $token]
http::wait $token
if {[string equal $state(status) "error"]} {
# something went wrong while trying to establish the connection
# Clean up after events and such, but DON'T call the command
# callback (if available) because we're going to throw an
# exception from here instead.
set err [lindex $state(error) 0]
cleanup $token
return -code error $err
} elseif {![string equal $state(status) "connect"]} {
# Likely to be connection timeout
return $token
}
set state(status) ""
}
# Send data in cr-lf format, but accept any line terminators
fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)
# The following is disallowed in safe interpreters, but the socket
# is already in non-blocking mode in that case.
catch {fconfigure $s -blocking off}
set how GET
if {$isQuery} {
set state(querylength) [string length $state(-query)]
if {$state(querylength) > 0} {
set how POST
set contDone 0
} else {
# there's no query data
unset state(-query)
set isQuery 0
}
} elseif {$state(-validate)} {
set how HEAD
} elseif {$isQueryChannel} {
set how POST
# The query channel must be blocking for the async Write to
# work properly.
fconfigure $state(-querychannel) -blocking 1 -translation binary
set contDone 0
}
if {[catch {
puts $s "$how $srvurl HTTP/1.0"
puts $s "Accept: $http(-accept)"
if {$port == $defport} {
# Don't add port in this case, to handle broken servers.
# [Bug #504508]
puts $s "Host: $host"
} else {
puts $s "Host: $host:$port"
}
puts $s "User-Agent: $http(-useragent)"
foreach {key value} $state(-headers) {
set value [string map [list \n "" \r ""] $value]
set key [string trim $key]
if {[string equal $key "Content-Length"]} {
set contDone 1
set state(querylength) $value
}
if {[string length $key]} {
puts $s "$key: $value"
}
}
if {$isQueryChannel && $state(querylength) == 0} {
# Try to determine size of data in channel
# If we cannot seek, the surrounding catch will trap us
set start [tell $state(-querychannel)]
seek $state(-querychannel) 0 end
set state(querylength) \
[expr {[tell $state(-querychannel)] - $start}]
seek $state(-querychannel) $start
}
# Flush the request header and set up the fileevent that will
# either push the POST data or read the response.
#
# fileevent note:
#
# It is possible to have both the read and write fileevents active
# at this point. The only scenario it seems to affect is a server
# that closes the connection without reading the POST data.
# (e.g., early versions TclHttpd in various error cases).
# Depending on the platform, the client may or may not be able to
# get the response from the server because of the error it will
# get trying to write the post data. Having both fileevents active
# changes the timing and the behavior, but no two platforms
# (among Solaris, Linux, and NT) behave the same, and none
# behave all that well in any case. Servers should always read thier
# POST data if they expect the client to read their response.
if {$isQuery || $isQueryChannel} {
puts $s "Content-Type: $state(-type)"
if {!$contDone} {
puts $s "Content-Length: $state(querylength)"
}
puts $s ""
fconfigure $s -translation {auto binary}
fileevent $s writable [list http::Write $token]
} else {
puts $s ""
flush $s
fileevent $s readable [list http::Event $token]
}
if {! [info exists state(-command)]} {
# geturl does EVERYTHING asynchronously, so if the user
# calls it synchronously, we just do a wait here.
wait $token
if {[string equal $state(status) "error"]} {
# Something went wrong, so throw the exception, and the
# enclosing catch will do cleanup.
return -code error [lindex $state(error) 0]
}
}
} err]} {
# The socket probably was never connected,
# or the connection dropped later.
# Clean up after events and such, but DON'T call the command callback
# (if available) because we're going to throw an exception from here
# instead.
# if state(status) is error, it means someone's already called Finish
# to do the above-described clean up.
if {[string equal $state(status) "error"]} {
Finish $token $err 1
}
cleanup $token
return -code error $err
}
return $token
}
# Data access functions:
# Data - the URL data
# Status - the transaction status: ok, reset, eof, timeout
# Code - the HTTP transaction code, e.g., 200
# Size - the size of the URL data
proc http::data {token} {
variable $token
upvar 0 $token state
return $state(body)
}
proc http::status {token} {
variable $token
upvar 0 $token state
return $state(status)
}
proc http::code {token} {
variable $token
upvar 0 $token state
return $state(http)
}
proc http::ncode {token} {
variable $token
upvar 0 $token state
if {[regexp {[0-9]{3}} $state(http) numeric_code]} {
return $numeric_code
} else {
return $state(http)
}
}
proc http::size {token} {
variable $token
upvar 0 $token state
return $state(currentsize)
}
proc http::error {token} {
variable $token
upvar 0 $token state
if {[info exists state(error)]} {
return $state(error)
}
return ""
}
# http::cleanup
#
# Garbage collect the state associated with a transaction
#
# Arguments
# token The token returned from http::geturl
#
# Side Effects
# unsets the state array
proc http::cleanup {token} {
variable $token
upvar 0 $token state
if {[info exists state]} {
unset state
}
}
# http::Connect
#
# This callback is made when an asyncronous connection completes.
#
# Arguments
# token The token returned from http::geturl
#
# Side Effects
# Sets the status of the connection, which unblocks
# the waiting geturl call
proc http::Connect {token} {
variable $token
upvar 0 $token state
global errorInfo errorCode
if {[eof $state(sock)] ||
[string length [fconfigure $state(sock) -error]]} {
Finish $token "connect failed [fconfigure $state(sock) -error]" 1
} else {
set state(status) connect
fileevent $state(sock) writable {}
}
return
}
# http::Write
#
# Write POST query data to the socket
#
# Arguments
# token The token for the connection
#
# Side Effects
# Write the socket and handle callbacks.
proc http::Write {token} {
variable $token
upvar 0 $token state
set s $state(sock)
# Output a block. Tcl will buffer this if the socket blocks
set done 0
if {[catch {
# Catch I/O errors on dead sockets
if {[info exists state(-query)]} {
# Chop up large query strings so queryprogress callback
# can give smooth feedback
puts -nonewline $s \
[string range $state(-query) $state(queryoffset) \
[expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
incr state(queryoffset) $state(-queryblocksize)
if {$state(queryoffset) >= $state(querylength)} {
set state(queryoffset) $state(querylength)
set done 1
}
} else {
# Copy blocks from the query channel
set outStr [read $state(-querychannel) $state(-queryblocksize)]
puts -nonewline $s $outStr
incr state(queryoffset) [string length $outStr]
if {[eof $state(-querychannel)]} {
set done 1
}
}
} err]} {
# Do not call Finish here, but instead let the read half of
# the socket process whatever server reply there is to get.
set state(posterror) $err
set done 1
}
if {$done} {
catch {flush $s}
fileevent $s writable {}
fileevent $s readable [list http::Event $token]
}
# Callback to the client after we've completely handled everything
if {[string length $state(-queryprogress)]} {
eval $state(-queryprogress) [list $token $state(querylength)\
$state(queryoffset)]
}
}
# http::Event
#
# Handle input on the socket
#
# Arguments
# token The token returned from http::geturl
#
# Side Effects
# Read the socket and handle callbacks.
proc http::Event {token} {
variable $token
upvar 0 $token state
set s $state(sock)
if {[eof $s]} {
Eof $token
return
}
if {[string equal $state(state) "header"]} {
if {[catch {gets $s line} n]} {
Finish $token $n
} elseif {$n == 0} {
variable encodings
set state(state) body
if {$state(-binary) || ![string match -nocase text* $state(type)]
|| [string match *gzip* $state(coding)]
|| [string match *compress* $state(coding)]} {
# Turn off conversions for non-text data
fconfigure $s -translation binary
if {[info exists state(-channel)]} {
fconfigure $state(-channel) -translation binary
}
} else {
# If we are getting text, set the incoming channel's
# encoding correctly. iso8859-1 is the RFC default, but
# this could be any IANA charset. However, we only know
# how to convert what we have encodings for.
set idx [lsearch -exact $encodings \
[string tolower $state(charset)]]
if {$idx >= 0} {
fconfigure $s -encoding [lindex $encodings $idx]
}
}
if {[info exists state(-channel)] && \
![info exists state(-handler)]} {
# Initiate a sequence of background fcopies
fileevent $s readable {}
CopyStart $s $token
}
} elseif {$n > 0} {
if {[regexp -nocase {^content-type:(.+)$} $line x type]} {
set state(type) [string trim $type]
# grab the optional charset information
regexp -nocase {charset\s*=\s*(\S+)} $type x state(charset)
}
if {[regexp -nocase {^content-length:(.+)$} $line x length]} {
set state(totalsize) [string trim $length]
}
if {[regexp -nocase {^content-encoding:(.+)$} $line x coding]} {
set state(coding) [string trim $coding]
}
if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
lappend state(meta) $key [string trim $value]
} elseif {[string match HTTP* $line]} {
set state(http) $line
}
}
} else {
if {[catch {
if {[info exists state(-handler)]} {
set n [eval $state(-handler) {$s $token}]
} else {
set block [read $s $state(-blocksize)]
set n [string length $block]
if {$n >= 0} {
append state(body) $block
}
}
if {$n >= 0} {
incr state(currentsize) $n
}
} err]} {
Finish $token $err
} else {
if {[info exists state(-progress)]} {
eval $state(-progress) \
{$token $state(totalsize) $state(currentsize)}
}
}
}
}
# http::CopyStart
#
# Error handling wrapper around fcopy
#
# Arguments
# s The socket to copy from
# token The token returned from http::geturl
#
# Side Effects
# This closes the connection upon error
proc http::CopyStart {s token} {
variable $token
upvar 0 $token state
if {[catch {
fcopy $s $state(-channel) -size $state(-blocksize) -command \
[list http::CopyDone $token]
} err]} {
Finish $token $err
}
}
# http::CopyDone
#
# fcopy completion callback
#
# Arguments
# token The token returned from http::geturl
# count The amount transfered
#
# Side Effects
# Invokes callbacks
proc http::CopyDone {token count {error {}}} {
variable $token
upvar 0 $token state
set s $state(sock)
incr state(currentsize) $count
if {[info exists state(-progress)]} {
eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
}
# At this point the token may have been reset
if {[string length $error]} {
Finish $token $error
} elseif {[catch {eof $s} iseof] || $iseof} {
Eof $token
} else {
CopyStart $s $token
}
}
# http::Eof
#
# Handle eof on the socket
#
# Arguments
# token The token returned from http::geturl
#
# Side Effects
# Clean up the socket
proc http::Eof {token} {
variable $token
upvar 0 $token state
if {[string equal $state(state) "header"]} {
# Premature eof
set state(status) eof
} else {
set state(status) ok
}
set state(state) eof
Finish $token
}
# http::wait --
#
# See documentaion for details.
#
# Arguments:
# token Connection token.
#
# Results:
# The status after the wait.
proc http::wait {token} {
variable $token
upvar 0 $token state
if {![info exists state(status)] || [string length $state(status)] == 0} {
# We must wait on the original variable name, not the upvar alias
vwait $token\(status)
}
return $state(status)
}
# http::formatQuery --
#
# See documentaion for details.
# Call http::formatQuery with an even number of arguments, where
# the first is a name, the second is a value, the third is another
# name, and so on.
#
# Arguments:
# args A list of name-value pairs.
#
# Results:
# TODO
proc http::formatQuery {args} {
set result ""
set sep ""
foreach i $args {
append result $sep [mapReply $i]
if {[string equal $sep "="]} {
set sep &
} else {
set sep =
}
}
return $result
}
# http::mapReply --
#
# Do x-www-urlencoded character mapping
#
# Arguments:
# string The string the needs to be encoded
#
# Results:
# The encoded string
proc http::mapReply {string} {
variable http
variable formMap
variable alphanumeric
# The spec says: "non-alphanumeric characters are replaced by '%HH'"
# 1 leave alphanumerics characters alone
# 2 Convert every other character to an array lookup
# 3 Escape constructs that are "special" to the tcl parser
# 4 "subst" the result, doing all the array substitutions
if {$http(-urlencoding) ne ""} {
set string [encoding convertto $http(-urlencoding) $string]
}
regsub -all \[^$alphanumeric\] $string {$formMap(&)} string
regsub -all {[][{})\\]\)} $string {\\&} string
return [subst -nocommand $string]
}
# http::ProxyRequired --
# Default proxy filter.
#
# Arguments:
# host The destination host
#
# Results:
# The current proxy settings
proc http::ProxyRequired {host} {
variable http
if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
if {![info exists http(-proxyport)] || \
![string length $http(-proxyport)]} {
set http(-proxyport) 8080
}
return [list $http(-proxyhost) $http(-proxyport)]
}
}
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/http2.5/pkgIndex.tcl 0100644 0000000 0000120 00000001326 10054746707 031740 0 ustar root admin # Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded http 2.5.0 [list tclPkgSetup $dir http 2.5.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister}}}]
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/init.tcl 0100644 0000000 0000120 00000000276 10153074464 027723 0 ustar root admin if {![interp issafe]} {set tcl_pkgPath [lsearch -all -inline $tcl_pkgPath [file join [file dirname [file dirname [info nameofexecutable]]] *]]}; source [file join $tcl_library realinit.tcl]
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/ldAout.tcl 0100644 0000000 0000120 00000015222 07354750261 030212 0 ustar root admin # ldAout.tcl --
#
# This "tclldAout" procedure in this script acts as a replacement
# for the "ld" command when linking an object file that will be
# loaded dynamically into Tcl or Tk using pseudo-static linking.
#
# Parameters:
# The arguments to the script are the command line options for
# an "ld" command.
#
# Results:
# The "ld" command is parsed, and the "-o" option determines the
# module name. ".a" and ".o" options are accumulated.
# The input archives and object files are examined with the "nm"
# command to determine whether the modules initialization
# entry and safe initialization entry are present. A trivial
# C function that locates the entries is composed, compiled, and
# its .o file placed before all others in the command; then
# "ld" is executed to bind the objects together.
#
# RCS: @(#) $Id: ldAout.tcl,v 1.5 2001/09/28 01:21:53 dgp Exp $
#
# Copyright (c) 1995, by General Electric Company. 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 work was supported in part by the ARPA Manufacturing Automation
# and Design Engineering (MADE) Initiative through ARPA contract
# F33615-94-C-4400.
proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
global env
global argv
if {[string equal $cc ""]} {
set cc $env(CC)
}
# if only two parameters are supplied there is assumed that the
# only shlib_suffix is missing. This parameter is anyway available
# as "info sharedlibextension" too, so there is no need to transfer
# 3 parameters to the function tclLdAout. For compatibility, this
# function now accepts both 2 and 3 parameters.
if {[string equal $shlib_suffix ""]} {
set shlib_cflags $env(SHLIB_CFLAGS)
} elseif {[string equal $shlib_cflags "none"]} {
set shlib_cflags $shlib_suffix
}
# seenDotO is nonzero if a .o or .a file has been seen
set seenDotO 0
# minusO is nonzero if the last command line argument was "-o".
set minusO 0
# head has command line arguments up to but not including the first
# .o or .a file. tail has the rest of the arguments.
set head {}
set tail {}
# nmCommand is the "nm" command that lists global symbols from the
# object files.
set nmCommand {|nm -g}
# entryProtos is the table of _Init and _SafeInit prototypes found in the
# module.
set entryProtos {}
# entryPoints is the table of _Init and _SafeInit entries found in the
# module.
set entryPoints {}
# libraries is the list of -L and -l flags to the linker.
set libraries {}
set libdirs {}
# Process command line arguments
foreach a $argv {
if {!$minusO && [regexp {\.[ao]$} $a]} {
set seenDotO 1
lappend nmCommand $a
}
if {$minusO} {
set outputFile $a
set minusO 0
} elseif {![string compare $a -o]} {
set minusO 1
}
if {[regexp {^-[lL]} $a]} {
lappend libraries $a
if {[regexp {^-L} $a]} {
lappend libdirs [string range $a 2 end]
}
} elseif {$seenDotO} {
lappend tail $a
} else {
lappend head $a
}
}
lappend libdirs /lib /usr/lib
# MIPS -- If there are corresponding G0 libraries, replace the
# ordinary ones with the G0 ones.
set libs {}
foreach lib $libraries {
if {[regexp {^-l} $lib]} {
set lname [string range $lib 2 end]
foreach dir $libdirs {
if {[file exists [file join $dir lib${lname}_G0.a]]} {
set lname ${lname}_G0
break
}
}
lappend libs -l$lname
} else {
lappend libs $lib
}
}
set libraries $libs
# Extract the module name from the "-o" option
if {![info exists outputFile]} {
error "-o option must be supplied to link a Tcl load module"
}
set m [file tail $outputFile]
if {[regexp {\.a$} $outputFile]} {
set shlib_suffix .a
} else {
set shlib_suffix ""
}
if {[regexp {\..*$} $outputFile match]} {
set l [expr {[string length $m] - [string length $match]}]
} else {
error "Output file does not appear to have a suffix"
}
set modName [string tolower $m 0 [expr {$l-1}]]
if {[regexp {^lib} $modName]} {
set modName [string range $modName 3 end]
}
if {[regexp {[0-9\.]*(_g0)?$} $modName match]} {
set modName [string range $modName 0 [expr {[string length $modName]-[string length $match]-1}]]
}
set modName [string totitle $modName]
# Catalog initialization entry points found in the module
set f [open $nmCommand r]
while {[gets $f l] >= 0} {
if {[regexp {T[ ]*_?([A-Z][a-z0-9_]*_(Safe)?Init(__FP10Tcl_Interp)?)$} $l trash symbol]} {
if {![regexp {_?([A-Z][a-z0-9_]*_(Safe)?Init)} $symbol trash s]} {
set s $symbol
}
append entryProtos {extern int } $symbol { (); } \n
append entryPoints { } \{ { "} $s {", } $symbol { } \} , \n
}
}
close $f
if {[string equal $entryPoints ""]} {
error "No entry point found in objects"
}
# Compose a C function that resolves the initialization entry points and
# embeds the required libraries in the object code.
set C {#include }
append C \n
append C {char TclLoadLibraries_} $modName { [] =} \n
append C { "@LIBS: } $libraries {";} \n
append C $entryProtos
append C {static struct } \{ \n
append C { char * name;} \n
append C { int (*value)();} \n
append C \} {dictionary [] = } \{ \n
append C $entryPoints
append C { 0, 0 } \n \} \; \n
append C {typedef struct Tcl_Interp Tcl_Interp;} \n
append C {typedef int Tcl_PackageInitProc (Tcl_Interp *);} \n
append C {Tcl_PackageInitProc *} \n
append C TclLoadDictionary_ $modName { (symbol)} \n
append C { CONST char * symbol;} \n
append C {
{
int i;
for (i = 0; dictionary [i] . name != 0; ++i) {
if (!strcmp (symbol, dictionary [i] . name)) {
return dictionary [i].value;
}
}
return 0;
}
}
append C \n
# Write the C module and compile it
set cFile tcl$modName.c
set f [open $cFile w]
puts -nonewline $f $C
close $f
set ccCommand "$cc -c $shlib_cflags $cFile"
puts stderr $ccCommand
eval exec $ccCommand
# Now compose and execute the ld command that packages the module
if {[string equal $shlib_suffix ".a"]} {
set ldCommand "ar cr $outputFile"
regsub { -o} $tail {} tail
} else {
set ldCommand ld
foreach item $head {
lappend ldCommand $item
}
}
lappend ldCommand tcl$modName.o
foreach item $tail {
lappend ldCommand $item
}
puts stderr $ldCommand
eval exec $ldCommand
if {[string equal $shlib_suffix ".a"]} {
exec ranlib $outputFile
}
# Clean up working files
exec /bin/rm $cFile [file rootname $cFile].o
}
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/msgcat1.3/ 0040755 0000000 0000024 00000000000 10153074406 027764 5 ustar root staff Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/msgcat1.3/msgcat.tcl 0100644 0000000 0000120 00000031506 10107233154 031726 0 ustar root admin # msgcat.tcl --
#
# This file defines various procedures which implement a
# message catalog facility for Tcl programs. It should be
# loaded with the command "package require msgcat".
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 1998 by Mark Harrison.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: msgcat.tcl,v 1.17.2.4 2004/08/13 21:45:16 dgp Exp $
package require Tcl 8.2
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the installation directory in the Makefiles.
package provide msgcat 1.3.3
namespace eval msgcat {
namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \
mcunknown
# Records the current locale as passed to mclocale
variable Locale ""
# Records the list of locales to search
variable Loclist {}
# Records the mapping between source strings and translated strings. The
# array key is of the form ",," and the value is
# the translated string.
array set Msgs {}
# Map of language codes used in Windows registry to those of ISO-639
array set WinRegToISO639 {
01 ar 0401 ar_SA 0801 ar_IQ 0c01 ar_EG 1001 ar_LY 1401 ar_DZ
1801 ar_MA 1c01 ar_TN 2001 ar_OM 2401 ar_YE 2801 ar_SY
2c01 ar_JO 3001 ar_LB 3401 ar_KW 3801 ar_AE 3c01 ar_BH
4001 ar_QA
02 bg 0402 bg_BG
03 ca 0403 ca_ES
04 zh 0404 zh_TW 0804 zh_CN 0c04 zh_HK 1004 zh_SG 1404 zh_MO
05 cs 0405 cs_CZ
06 da 0406 da_DK
07 de 0407 de_DE 0807 de_CH 0c07 de_AT 1007 de_LU 1407 de_LI
08 el 0408 el_GR
09 en 0409 en_US 0809 en_GB 0c09 en_AU 1009 en_CA 1409 en_NZ
1809 en_IE 1c09 en_ZA 2009 en_JM 2409 en_GD 2809 en_BZ
2c09 en_TT 3009 en_ZW 3409 en_PH
0a es 040a es_ES 080a es_MX 0c0a es_ES@modern 100a es_GT 140a es_CR
180a es_PA 1c0a es_DO 200a es_VE 240a es_CO 280a es_PE
2c0a es_AR 300a es_EC 340a es_CL 380a es_UY 3c0a es_PY
400a es_BO 440a es_SV 480a es_HN 4c0a es_NI 500a es_PR
0b fi 040b fi_FI
0c fr 040c fr_FR 080c fr_BE 0c0c fr_CA 100c fr_CH 140c fr_LU
180c fr_MC
0d he 040d he_IL
0e hu 040e hu_HU
0f is 040f is_IS
10 it 0410 it_IT 0810 it_CH
11 ja 0411 ja_JP
12 ko 0412 ko_KR
13 nl 0413 nl_NL 0813 nl_BE
14 no 0414 no_NO 0814 nn_NO
15 pl 0415 pl_PL
16 pt 0416 pt_BR 0816 pt_PT
17 rm 0417 rm_CH
18 ro 0418 ro_RO
19 ru
1a hr 041a hr_HR 081a sr_YU 0c1a sr_YU@cyrillic
1b sk 041b sk_SK
1c sq 041c sq_AL
1d sv 041d sv_SE 081d sv_FI
1e th 041e th_TH
1f tr 041f tr_TR
20 ur 0420 ur_PK 0820 ur_IN
21 id 0421 id_ID
22 uk 0422 uk_UA
23 be 0423 be_BY
24 sl 0424 sl_SI
25 et 0425 et_EE
26 lv 0426 lv_LV
27 lt 0427 lt_LT
28 tg 0428 tg_TJ
29 fa 0429 fa_IR
2a vi 042a vi_VN
2b hy 042b hy_AM
2c az 042c az_AZ@latin 082c az_AZ@cyrillic
2d eu
2e wen 042e wen_DE
2f mk 042f mk_MK
30 bnt 0430 bnt_TZ
31 ts 0431 ts_ZA
33 ven 0433 ven_ZA
34 xh 0434 xh_ZA
35 zu 0435 zu_ZA
36 af 0436 af_ZA
37 ka 0437 ka_GE
38 fo 0438 fo_FO
39 hi 0439 hi_IN
3a mt 043a mt_MT
3b se 043b se_NO
043c gd_UK 083c ga_IE
3d yi 043d yi_IL
3e ms 043e ms_MY 083e ms_BN
3f kk 043f kk_KZ
40 ky 0440 ky_KG
41 sw 0441 sw_KE
42 tk 0442 tk_TM
43 uz 0443 uz_UZ@latin 0843 uz_UZ@cyrillic
44 tt 0444 tt_RU
45 bn 0445 bn_IN
46 pa 0446 pa_IN
47 gu 0447 gu_IN
48 or 0448 or_IN
49 ta
4a te 044a te_IN
4b kn 044b kn_IN
4c ml 044c ml_IN
4d as 044d as_IN
4e mr 044e mr_IN
4f sa 044f sa_IN
50 mn
51 bo 0451 bo_CN
52 cy 0452 cy_GB
53 km 0453 km_KH
54 lo 0454 lo_LA
55 my 0455 my_MM
56 gl 0456 gl_ES
57 kok 0457 kok_IN
58 mni 0458 mni_IN
59 sd
5a syr 045a syr_TR
5b si 045b si_LK
5c chr 045c chr_US
5d iu 045d iu_CA
5e am 045e am_ET
5f ber 045f ber_MA
60 ks 0460 ks_PK 0860 ks_IN
61 ne 0461 ne_NP 0861 ne_IN
62 fy 0462 fy_NL
63 ps
64 tl 0464 tl_PH
65 div 0465 div_MV
66 bin 0466 bin_NG
67 ful 0467 ful_NG
68 ha 0468 ha_NG
69 nic 0469 nic_NG
6a yo 046a yo_NG
70 ibo 0470 ibo_NG
71 kau 0471 kau_NG
72 om 0472 om_ET
73 ti 0473 ti_ET
74 gn 0474 gn_PY
75 cpe 0475 cpe_US
76 la 0476 la_VA
77 so 0477 so_SO
78 sit 0478 sit_CN
79 pap 0479 pap_AN
}
}
# msgcat::mc --
#
# Find the translation for the given string based on the current
# locale setting. Check the local namespace first, then look in each
# parent namespace until the source is found. If additional args are
# specified, use the format command to work them into the traslated
# string.
#
# Arguments:
# src The string to translate.
# args Args to pass to the format command
#
# Results:
# Returns the translatd string. Propagates errors thrown by the
# format command.
proc msgcat::mc {src args} {
# Check for the src in each namespace starting from the local and
# ending in the global.
variable Msgs
variable Loclist
variable Locale
set ns [uplevel 1 [list ::namespace current]]
while {$ns != ""} {
foreach loc $Loclist {
if {[info exists Msgs($loc,$ns,$src)]} {
if {[llength $args] == 0} {
return $Msgs($loc,$ns,$src)
} else {
return [uplevel 1 \
[linsert $args 0 ::format $Msgs($loc,$ns,$src)]]
}
}
}
set ns [namespace parent $ns]
}
# we have not found the translation
return [uplevel 1 \
[linsert $args 0 [::namespace origin mcunknown] $Locale $src]]
}
# msgcat::mclocale --
#
# Query or set the current locale.
#
# Arguments:
# newLocale (Optional) The new locale string. Locale strings
# should be composed of one or more sublocale parts
# separated by underscores (e.g. en_US).
#
# Results:
# Returns the current locale.
proc msgcat::mclocale {args} {
variable Loclist
variable Locale
set len [llength $args]
if {$len > 1} {
error {wrong # args: should be "mclocale ?newLocale?"}
}
if {$len == 1} {
set newLocale [lindex $args 0]
if {$newLocale ne [file tail $newLocale]} {
return -code error "invalid newLocale value \"$newLocale\":\
could be path to unsafe code."
}
set Locale [string tolower $newLocale]
set Loclist {}
set word ""
foreach part [split $Locale _] {
set word [string trimleft "${word}_${part}" _]
set Loclist [linsert $Loclist 0 $word]
}
}
return $Locale
}
# msgcat::mcpreferences --
#
# Fetch the list of locales used to look up strings, ordered from
# most preferred to least preferred.
#
# Arguments:
# None.
#
# Results:
# Returns an ordered list of the locales preferred by the user.
proc msgcat::mcpreferences {} {
variable Loclist
return $Loclist
}
# msgcat::mcload --
#
# Attempt to load message catalogs for each locale in the
# preference list from the specified directory.
#
# Arguments:
# langdir The directory to search.
#
# Results:
# Returns the number of message catalogs that were loaded.
proc msgcat::mcload {langdir} {
set x 0
foreach p [mcpreferences] {
set langfile [file join $langdir $p.msg]
if {[file exists $langfile]} {
incr x
set fid [open $langfile "r"]
fconfigure $fid -encoding utf-8
uplevel 1 [read $fid]
close $fid
}
}
return $x
}
# msgcat::mcset --
#
# Set the translation for a given string in a specified locale.
#
# Arguments:
# locale The locale to use.
# src The source string.
# dest (Optional) The translated string. If omitted,
# the source string is used.
#
# Results:
# Returns the new locale.
proc msgcat::mcset {locale src {dest ""}} {
variable Msgs
if {[llength [info level 0]] == 3} { ;# dest not specified
set dest $src
}
set ns [uplevel 1 [list ::namespace current]]
set Msgs([string tolower $locale],$ns,$src) $dest
return $dest
}
# msgcat::mcmset --
#
# Set the translation for multiple strings in a specified locale.
#
# Arguments:
# locale The locale to use.
# pairs One or more src/dest pairs (must be even length)
#
# Results:
# Returns the number of pairs processed
proc msgcat::mcmset {locale pairs } {
variable Msgs
set length [llength $pairs]
if {$length % 2} {
error {bad translation list: should be "mcmset locale {src dest ...}"}
}
set locale [string tolower $locale]
set ns [uplevel 1 [list ::namespace current]]
foreach {src dest} $pairs {
set Msgs($locale,$ns,$src) $dest
}
return $length
}
# msgcat::mcunknown --
#
# This routine is called by msgcat::mc if a translation cannot
# be found for a string. This routine is intended to be replaced
# by an application specific routine for error reporting
# purposes. The default behavior is to return the source string.
# If additional args are specified, the format command will be used
# to work them into the traslated string.
#
# Arguments:
# locale The current locale.
# src The string to be translated.
# args Args to pass to the format command
#
# Results:
# Returns the translated value.
proc msgcat::mcunknown {locale src args} {
if {[llength $args]} {
return [uplevel 1 [linsert $args 0 ::format $src]]
} else {
return $src
}
}
# msgcat::mcmax --
#
# Calculates the maximun length of the translated strings of the given
# list.
#
# Arguments:
# args strings to translate.
#
# Results:
# Returns the length of the longest translated string.
proc msgcat::mcmax {args} {
set max 0
foreach string $args {
set translated [uplevel 1 [list [namespace origin mc] $string]]
set len [string length $translated]
if {$len>$max} {
set max $len
}
}
return $max
}
# Convert the locale values stored in environment variables to a form
# suitable for passing to [mclocale]
proc msgcat::ConvertLocale {value} {
# Assume $value is of form: $language[_$territory][.$codeset][@modifier]
# Convert to form: $language[_$territory][_$modifier]
#
# Comment out expanded RE version -- bugs alleged
# regexp -expanded {
# ^ # Match all the way to the beginning
# ([^_.@]*) # Match "lanugage"; ends with _, ., or @
# (_([^.@]*))? # Match (optional) "territory"; starts with _
# ([.]([^@]*))? # Match (optional) "codeset"; starts with .
# (@(.*))? # Match (optional) "modifier"; starts with @
# $ # Match all the way to the end
# } $value -> language _ territory _ codeset _ modifier
if {![regexp {^([^_.@]+)(_([^.@]*))?([.]([^@]*))?(@(.*))?$} $value \
-> language _ territory _ codeset _ modifier]} {
return -code error "invalid locale '$value': empty language part"
}
set ret $language
if {[string length $territory]} {
append ret _$territory
}
if {[string length $modifier]} {
append ret _$modifier
}
return $ret
}
# Initialize the default locale
proc msgcat::Init {} {
#
# set default locale, try to get from environment
#
foreach varName {LC_ALL LC_MESSAGES LANG} {
if {[info exists ::env($varName)]
&& ![string equal "" $::env($varName)]} {
if {![catch {mclocale [ConvertLocale $::env($varName)]}]} {
return
}
}
}
#
# The rest of this routine is special processing for Windows;
# all other platforms, get out now.
#
if { ![string equal $::tcl_platform(platform) windows] } {
mclocale C
return
}
#
# On Windows, try to set locale depending on registry settings,
# or fall back on locale of "C".
#
set key {HKEY_CURRENT_USER\Control Panel\International}
if {[catch {package require registry}] \
|| [catch {registry get $key "locale"} locale]} {
mclocale C
return
}
#
# Keep trying to match against smaller and smaller suffixes
# of the registry value, since the latter hexadigits appear
# to determine general language and earlier hexadigits determine
# more precise information, such as territory. For example,
# 0409 - English - United States
# 0809 - English - United Kingdom
# Add more translations to the WinRegToISO639 array above.
#
variable WinRegToISO639
set locale [string tolower $locale]
while {[string length $locale]} {
if {![catch {mclocale [ConvertLocale $WinRegToISO639($locale)]}]} {
return
}
set locale [string range $locale 1 end]
}
#
# No translation known. Fall back on "C" locale
#
mclocale C
}
msgcat::Init
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/msgcat1.3/pkgIndex.tcl 0100644 0000000 0000120 00000000206 10107233154 032212 0 ustar root admin if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded msgcat 1.3.3 [list source [file join $dir msgcat.tcl]]
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/opt0.4/ 0040755 0000000 0000024 00000000000 10153074406 027310 5 ustar root staff Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/opt0.4/optparse.tcl 0100644 0000000 0000120 00000100376 07727704707 031660 0 ustar root admin # optparse.tcl --
#
# (private) Option parsing package
# Primarily used internally by the safe:: code.
#
# WARNING: This code will go away in a future release
# of Tcl. It is NOT supported and you should not rely
# on it. If your code does rely on this package you
# may directly incorporate this code into your application.
#
# RCS: @(#) $Id: optparse.tcl,v 1.8.2.1 2003/09/10 20:29:59 dgp Exp $
package require Tcl 8.2
# When this version number changes, update the pkgIndex.tcl file
# and the install directory in the Makefiles.
package provide opt 0.4.4.1
namespace eval ::tcl {
# Exported APIs
namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
OptProc OptProcArgGiven OptParse \
Lempty Lget \
Lassign Lvarpop Lvarpop1 Lvarset Lvarincr \
SetMax SetMin
################# Example of use / 'user documentation' ###################
proc OptCreateTestProc {} {
# Defines ::tcl::OptParseTest as a test proc with parsed arguments
# (can't be defined before the code below is loaded (before "OptProc"))
# Every OptProc give usage information on "procname -help".
# Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and
# then other arguments.
#
# example of 'valid' call:
# ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\
# -nostatics false ch1
OptProc OptParseTest {
{subcommand -choice {save print} "sub command"}
{arg1 3 "some number"}
{-aflag}
{-intflag 7}
{-weirdflag "help string"}
{-noStatics "Not ok to load static packages"}
{-nestedloading1 true "OK to load into nested slaves"}
{-nestedloading2 -boolean true "OK to load into nested slaves"}
{-libsOK -choice {Tk SybTcl}
"List of packages that can be loaded"}
{-precision -int 12 "Number of digits of precision"}
{-intval 7 "An integer"}
{-scale -float 1.0 "Scale factor"}
{-zoom 1.0 "Zoom factor"}
{-arbitrary foobar "Arbitrary string"}
{-random -string 12 "Random string"}
{-listval -list {} "List value"}
{-blahflag -blah abc "Funny type"}
{arg2 -boolean "a boolean"}
{arg3 -choice "ch1 ch2"}
{?optarg? -list {} "optional argument"}
} {
foreach v [info locals] {
puts stderr [format "%14s : %s" $v [set $v]]
}
}
}
################### No User serviceable part below ! ###############
# Array storing the parsed descriptions
variable OptDesc;
array set OptDesc {};
# Next potentially free key id (numeric)
variable OptDescN 0;
# Inside algorithm/mechanism description:
# (not for the faint hearted ;-)
#
# The argument description is parsed into a "program tree"
# It is called a "program" because it is the program used by
# the state machine interpreter that use that program to
# actually parse the arguments at run time.
#
# The general structure of a "program" is
# notation (pseudo bnf like)
# name :== definition defines "name" as being "definition"
# { x y z } means list of x, y, and z
# x* means x repeated 0 or more time
# x+ means "x x*"
# x? means optionally x
# x | y means x or y
# "cccc" means the literal string
#
# program :== { programCounter programStep* }
#
# programStep :== program | singleStep
#
# programCounter :== {"P" integer+ }
#
# singleStep :== { instruction parameters* }
#
# instruction :== single element list
#
# (the difference between singleStep and program is that \
# llength [lindex $program 0] >= 2
# while
# llength [lindex $singleStep 0] == 1
# )
#
# And for this application:
#
# singleStep :== { instruction varname {hasBeenSet currentValue} type
# typeArgs help }
# instruction :== "flags" | "value"
# type :== knowType | anyword
# knowType :== "string" | "int" | "boolean" | "boolflag" | "float"
# | "choice"
#
# for type "choice" typeArgs is a list of possible choices, the first one
# is the default value. for all other types the typeArgs is the default value
#
# a "boolflag" is the type for a flag whose presence or absence, without
# additional arguments means respectively true or false (default flag type).
#
# programCounter is the index in the list of the currently processed
# programStep (thus starting at 1 (0 is {"P" prgCounterValue}).
# If it is a list it points toward each currently selected programStep.
# (like for "flags", as they are optional, form a set and programStep).
# Performance/Implementation issues
# ---------------------------------
# We use tcl lists instead of arrays because with tcl8.0
# they should start to be much faster.
# But this code use a lot of helper procs (like Lvarset)
# which are quite slow and would be helpfully optimized
# for instance by being written in C. Also our struture
# is complex and there is maybe some places where the
# string rep might be calculated at great exense. to be checked.
#
# Parse a given description and saves it here under the given key
# generate a unused keyid if not given
#
proc ::tcl::OptKeyRegister {desc {key ""}} {
variable OptDesc;
variable OptDescN;
if {[string equal $key ""]} {
# in case a key given to us as a parameter was a number
while {[info exists OptDesc($OptDescN)]} {incr OptDescN}
set key $OptDescN;
incr OptDescN;
}
# program counter
set program [list [list "P" 1]];
# are we processing flags (which makes a single program step)
set inflags 0;
set state {};
# flag used to detect that we just have a single (flags set) subprogram.
set empty 1;
foreach item $desc {
if {$state == "args"} {
# more items after 'args'...
return -code error "'args' special argument must be the last one";
}
set res [OptNormalizeOne $item];
set state [lindex $res 0];
if {$inflags} {
if {$state == "flags"} {
# add to 'subprogram'
lappend flagsprg $res;
} else {
# put in the flags
# structure for flag programs items is a list of
# {subprgcounter {prg flag 1} {prg flag 2} {...}}
lappend program $flagsprg;
# put the other regular stuff
lappend program $res;
set inflags 0;
set empty 0;
}
} else {
if {$state == "flags"} {
set inflags 1;
# sub program counter + first sub program
set flagsprg [list [list "P" 1] $res];
} else {
lappend program $res;
set empty 0;
}
}
}
if {$inflags} {
if {$empty} {
# We just have the subprogram, optimize and remove
# unneeded level:
set program $flagsprg;
} else {
lappend program $flagsprg;
}
}
set OptDesc($key) $program;
return $key;
}
#
# Free the storage for that given key
#
proc ::tcl::OptKeyDelete {key} {
variable OptDesc;
unset OptDesc($key);
}
# Get the parsed description stored under the given key.
proc OptKeyGetDesc {descKey} {
variable OptDesc;
if {![info exists OptDesc($descKey)]} {
return -code error "Unknown option description key \"$descKey\"";
}
set OptDesc($descKey);
}
# Parse entry point for ppl who don't want to register with a key,
# for instance because the description changes dynamically.
# (otherwise one should really use OptKeyRegister once + OptKeyParse
# as it is way faster or simply OptProc which does it all)
# Assign a temporary key, call OptKeyParse and then free the storage
proc ::tcl::OptParse {desc arglist} {
set tempkey [OptKeyRegister $desc];
set ret [catch {uplevel 1 [list ::tcl::OptKeyParse $tempkey $arglist]} res];
OptKeyDelete $tempkey;
return -code $ret $res;
}
# Helper function, replacement for proc that both
# register the description under a key which is the name of the proc
# (and thus unique to that code)
# and add a first line to the code to call the OptKeyParse proc
# Stores the list of variables that have been actually given by the user
# (the other will be sets to their default value)
# into local variable named "Args".
proc ::tcl::OptProc {name desc body} {
set namespace [uplevel 1 [list ::namespace current]];
if {[string match "::*" $name] || [string equal $namespace "::"]} {
# absolute name or global namespace, name is the key
set key $name;
} else {
# we are relative to some non top level namespace:
set key "${namespace}::${name}";
}
OptKeyRegister $desc $key;
uplevel 1 [list ::proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"];
return $key;
}
# Check that a argument has been given
# assumes that "OptProc" has been used as it will check in "Args" list
proc ::tcl::OptProcArgGiven {argname} {
upvar Args alist;
expr {[lsearch $alist $argname] >=0}
}
#######
# Programs/Descriptions manipulation
# Return the instruction word/list of a given step/(sub)program
proc OptInstr {lst} {
lindex $lst 0;
}
# Is a (sub) program or a plain instruction ?
proc OptIsPrg {lst} {
expr {[llength [OptInstr $lst]]>=2}
}
# Is this instruction a program counter or a real instr
proc OptIsCounter {item} {
expr {[lindex $item 0]=="P"}
}
# Current program counter (2nd word of first word)
proc OptGetPrgCounter {lst} {
Lget $lst {0 1}
}
# Current program counter (2nd word of first word)
proc OptSetPrgCounter {lstName newValue} {
upvar $lstName lst;
set lst [lreplace $lst 0 0 [concat "P" $newValue]];
}
# returns a list of currently selected items.
proc OptSelection {lst} {
set res {};
foreach idx [lrange [lindex $lst 0] 1 end] {
lappend res [Lget $lst $idx];
}
return $res;
}
# Advance to next description
proc OptNextDesc {descName} {
uplevel 1 [list Lvarincr $descName {0 1}];
}
# Get the current description, eventually descend
proc OptCurDesc {descriptions} {
lindex $descriptions [OptGetPrgCounter $descriptions];
}
# get the current description, eventually descend
# through sub programs as needed.
proc OptCurDescFinal {descriptions} {
set item [OptCurDesc $descriptions];
# Descend untill we get the actual item and not a sub program
while {[OptIsPrg $item]} {
set item [OptCurDesc $item];
}
return $item;
}
# Current final instruction adress
proc OptCurAddr {descriptions {start {}}} {
set adress [OptGetPrgCounter $descriptions];
lappend start $adress;
set item [lindex $descriptions $adress];
if {[OptIsPrg $item]} {
return [OptCurAddr $item $start];
} else {
return $start;
}
}
# Set the value field of the current instruction
proc OptCurSetValue {descriptionsName value} {
upvar $descriptionsName descriptions
# get the current item full adress
set adress [OptCurAddr $descriptions];
# use the 3th field of the item (see OptValue / OptNewInst)
lappend adress 2
Lvarset descriptions $adress [list 1 $value];
# ^hasBeenSet flag
}
# empty state means done/paste the end of the program
proc OptState {item} {
lindex $item 0
}
# current state
proc OptCurState {descriptions} {
OptState [OptCurDesc $descriptions];
}
#######
# Arguments manipulation
# Returns the argument that has to be processed now
proc OptCurrentArg {lst} {
lindex $lst 0;
}
# Advance to next argument
proc OptNextArg {argsName} {
uplevel 1 [list Lvarpop1 $argsName];
}
#######
# Loop over all descriptions, calling OptDoOne which will
# eventually eat all the arguments.
proc OptDoAll {descriptionsName argumentsName} {
upvar $descriptionsName descriptions
upvar $argumentsName arguments;
# puts "entered DoAll";
# Nb: the places where "state" can be set are tricky to figure
# because DoOne sets the state to flagsValue and return -continue
# when needed...
set state [OptCurState $descriptions];
# We'll exit the loop in "OptDoOne" or when state is empty.
while 1 {
set curitem [OptCurDesc $descriptions];
# Do subprograms if needed, call ourselves on the sub branch
while {[OptIsPrg $curitem]} {
OptDoAll curitem arguments
# puts "done DoAll sub";
# Insert back the results in current tree;
Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\
$curitem;
OptNextDesc descriptions;
set curitem [OptCurDesc $descriptions];
set state [OptCurState $descriptions];
}
# puts "state = \"$state\" - arguments=($arguments)";
if {[Lempty $state]} {
# Nothing left to do, we are done in this branch:
break;
}
# The following statement can make us terminate/continue
# as it use return -code {break, continue, return and error}
# codes
OptDoOne descriptions state arguments;
# If we are here, no special return code where issued,
# we'll step to next instruction :
# puts "new state = \"$state\"";
OptNextDesc descriptions;
set state [OptCurState $descriptions];
}
}
# Process one step for the state machine,
# eventually consuming the current argument.
proc OptDoOne {descriptionsName stateName argumentsName} {
upvar $argumentsName arguments;
upvar $descriptionsName descriptions;
upvar $stateName state;
# the special state/instruction "args" eats all
# the remaining args (if any)
if {($state == "args")} {
if {![Lempty $arguments]} {
# If there is no additional arguments, leave the default value
# in.
OptCurSetValue descriptions $arguments;
set arguments {};
}
# puts "breaking out ('args' state: consuming every reminding args)"
return -code break;
}
if {[Lempty $arguments]} {
if {$state == "flags"} {
# no argument and no flags : we're done
# puts "returning to previous (sub)prg (no more args)";
return -code return;
} elseif {$state == "optValue"} {
set state next; # not used, for debug only
# go to next state
return ;
} else {
return -code error [OptMissingValue $descriptions];
}
} else {
set arg [OptCurrentArg $arguments];
}
switch $state {
flags {
# A non-dash argument terminates the options, as does --
# Still a flag ?
if {![OptIsFlag $arg]} {
# don't consume the argument, return to previous prg
return -code return;
}
# consume the flag
OptNextArg arguments;
if {[string equal "--" $arg]} {
# return from 'flags' state
return -code return;
}
set hits [OptHits descriptions $arg];
if {$hits > 1} {
return -code error [OptAmbigous $descriptions $arg]
} elseif {$hits == 0} {
return -code error [OptFlagUsage $descriptions $arg]
}
set item [OptCurDesc $descriptions];
if {[OptNeedValue $item]} {
# we need a value, next state is
set state flagValue;
} else {
OptCurSetValue descriptions 1;
}
# continue
return -code continue;
}
flagValue -
value {
set item [OptCurDesc $descriptions];
# Test the values against their required type
if {[catch {OptCheckType $arg\
[OptType $item] [OptTypeArgs $item]} val]} {
return -code error [OptBadValue $item $arg $val]
}
# consume the value
OptNextArg arguments;
# set the value
OptCurSetValue descriptions $val;
# go to next state
if {$state == "flagValue"} {
set state flags
return -code continue;
} else {
set state next; # not used, for debug only
return ; # will go on next step
}
}
optValue {
set item [OptCurDesc $descriptions];
# Test the values against their required type
if {![catch {OptCheckType $arg\
[OptType $item] [OptTypeArgs $item]} val]} {
# right type, so :
# consume the value
OptNextArg arguments;
# set the value
OptCurSetValue descriptions $val;
}
# go to next state
set state next; # not used, for debug only
return ; # will go on next step
}
}
# If we reach this point: an unknown
# state as been entered !
return -code error "Bug! unknown state in DoOne \"$state\"\
(prg counter [OptGetPrgCounter $descriptions]:\
[OptCurDesc $descriptions])";
}
# Parse the options given the key to previously registered description
# and arguments list
proc ::tcl::OptKeyParse {descKey arglist} {
set desc [OptKeyGetDesc $descKey];
# make sure -help always give usage
if {[string equal -nocase "-help" $arglist]} {
return -code error [OptError "Usage information:" $desc 1];
}
OptDoAll desc arglist;
if {![Lempty $arglist]} {
return -code error [OptTooManyArgs $desc $arglist];
}
# Analyse the result
# Walk through the tree:
OptTreeVars $desc "#[expr {[info level]-1}]" ;
}
# determine string length for nice tabulated output
proc OptTreeVars {desc level {vnamesLst {}}} {
foreach item $desc {
if {[OptIsCounter $item]} continue;
if {[OptIsPrg $item]} {
set vnamesLst [OptTreeVars $item $level $vnamesLst];
} else {
set vname [OptVarName $item];
upvar $level $vname var
if {[OptHasBeenSet $item]} {
# puts "adding $vname"
# lets use the input name for the returned list
# it is more usefull, for instance you can check that
# no flags at all was given with expr
# {![string match "*-*" $Args]}
lappend vnamesLst [OptName $item];
set var [OptValue $item];
} else {
set var [OptDefaultValue $item];
}
}
}
return $vnamesLst
}
# Check the type of a value
# and emit an error if arg is not of the correct type
# otherwise returns the canonical value of that arg (ie 0/1 for booleans)
proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
# puts "checking '$arg' against '$type' ($typeArgs)";
# only types "any", "choice", and numbers can have leading "-"
switch -exact -- $type {
int {
if {![string is integer -strict $arg]} {
error "not an integer"
}
return $arg;
}
float {
return [expr {double($arg)}]
}
script -
list {
# if llength fail : malformed list
if {[llength $arg]==0 && [OptIsFlag $arg]} {
error "no values with leading -"
}
return $arg;
}
boolean {
if {![string is boolean -strict $arg]} {
error "non canonic boolean"
}
# convert true/false because expr/if is broken with "!,...
return [expr {$arg ? 1 : 0}]
}
choice {
if {[lsearch -exact $typeArgs $arg] < 0} {
error "invalid choice"
}
return $arg;
}
any {
return $arg;
}
string -
default {
if {[OptIsFlag $arg]} {
error "no values with leading -"
}
return $arg
}
}
return neverReached;
}
# internal utilities
# returns the number of flags matching the given arg
# sets the (local) prg counter to the list of matches
proc OptHits {descName arg} {
upvar $descName desc;
set hits 0
set hitems {}
set i 1;
set larg [string tolower $arg];
set len [string length $larg];
set last [expr {$len-1}];
foreach item [lrange $desc 1 end] {
set flag [OptName $item]
# lets try to match case insensitively
# (string length ought to be cheap)
set lflag [string tolower $flag];
if {$len == [string length $lflag]} {
if {[string equal $larg $lflag]} {
# Exact match case
OptSetPrgCounter desc $i;
return 1;
}
} elseif {[string equal $larg [string range $lflag 0 $last]]} {
lappend hitems $i;
incr hits;
}
incr i;
}
if {$hits} {
OptSetPrgCounter desc $hitems;
}
return $hits
}
# Extract fields from the list structure:
proc OptName {item} {
lindex $item 1;
}
proc OptHasBeenSet {item} {
Lget $item {2 0};
}
proc OptValue {item} {
Lget $item {2 1};
}
proc OptIsFlag {name} {
string match "-*" $name;
}
proc OptIsOpt {name} {
string match {\?*} $name;
}
proc OptVarName {item} {
set name [OptName $item];
if {[OptIsFlag $name]} {
return [string range $name 1 end];
} elseif {[OptIsOpt $name]} {
return [string trim $name "?"];
} else {
return $name;
}
}
proc OptType {item} {
lindex $item 3
}
proc OptTypeArgs {item} {
lindex $item 4
}
proc OptHelp {item} {
lindex $item 5
}
proc OptNeedValue {item} {
expr {![string equal [OptType $item] boolflag]}
}
proc OptDefaultValue {item} {
set val [OptTypeArgs $item]
switch -exact -- [OptType $item] {
choice {return [lindex $val 0]}
boolean -
boolflag {
# convert back false/true to 0/1 because expr !$bool
# is broken..
if {$val} {
return 1
} else {
return 0
}
}
}
return $val
}
# Description format error helper
proc OptOptUsage {item {what ""}} {
return -code error "invalid description format$what: $item\n\
should be a list of {varname|-flagname ?-type? ?defaultvalue?\
?helpstring?}";
}
# Generate a canonical form single instruction
proc OptNewInst {state varname type typeArgs help} {
list $state $varname [list 0 {}] $type $typeArgs $help;
# ^ ^
# | |
# hasBeenSet=+ +=currentValue
}
# Translate one item to canonical form
proc OptNormalizeOne {item} {
set lg [Lassign $item varname arg1 arg2 arg3];
# puts "called optnormalizeone '$item' v=($varname), lg=$lg";
set isflag [OptIsFlag $varname];
set isopt [OptIsOpt $varname];
if {$isflag} {
set state "flags";
} elseif {$isopt} {
set state "optValue";
} elseif {![string equal $varname "args"]} {
set state "value";
} else {
set state "args";
}
# apply 'smart' 'fuzzy' logic to try to make
# description writer's life easy, and our's difficult :
# let's guess the missing arguments :-)
switch $lg {
1 {
if {$isflag} {
return [OptNewInst $state $varname boolflag false ""];
} else {
return [OptNewInst $state $varname any "" ""];
}
}
2 {
# varname default
# varname help
set type [OptGuessType $arg1]
if {[string equal $type "string"]} {
if {$isflag} {
set type boolflag
set def false
} else {
set type any
set def ""
}
set help $arg1
} else {
set help ""
set def $arg1
}
return [OptNewInst $state $varname $type $def $help];
}
3 {
# varname type value
# varname value comment
if {[regexp {^-(.+)$} $arg1 x type]} {
# flags/optValue as they are optional, need a "value",
# on the contrary, for a variable (non optional),
# default value is pointless, 'cept for choices :
if {$isflag || $isopt || ($type == "choice")} {
return [OptNewInst $state $varname $type $arg2 ""];
} else {
return [OptNewInst $state $varname $type "" $arg2];
}
} else {
return [OptNewInst $state $varname\
[OptGuessType $arg1] $arg1 $arg2]
}
}
4 {
if {[regexp {^-(.+)$} $arg1 x type]} {
return [OptNewInst $state $varname $type $arg2 $arg3];
} else {
return -code error [OptOptUsage $item];
}
}
default {
return -code error [OptOptUsage $item];
}
}
}
# Auto magic lasy type determination
proc OptGuessType {arg} {
if {[regexp -nocase {^(true|false)$} $arg]} {
return boolean
}
if {[regexp {^(-+)?[0-9]+$} $arg]} {
return int
}
if {![catch {expr {double($arg)}}]} {
return float
}
return string
}
# Error messages front ends
proc OptAmbigous {desc arg} {
OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc]
}
proc OptFlagUsage {desc arg} {
OptError "bad flag \"$arg\", must be one of" $desc;
}
proc OptTooManyArgs {desc arguments} {
OptError "too many arguments (unexpected argument(s): $arguments),\
usage:"\
$desc 1
}
proc OptParamType {item} {
if {[OptIsFlag $item]} {
return "flag";
} else {
return "parameter";
}
}
proc OptBadValue {item arg {err {}}} {
# puts "bad val err = \"$err\"";
OptError "bad value \"$arg\" for [OptParamType $item]"\
[list $item]
}
proc OptMissingValue {descriptions} {
# set item [OptCurDescFinal $descriptions];
set item [OptCurDesc $descriptions];
OptError "no value given for [OptParamType $item] \"[OptName $item]\"\
(use -help for full usage) :"\
[list $item]
}
proc ::tcl::OptKeyError {prefix descKey {header 0}} {
OptError $prefix [OptKeyGetDesc $descKey] $header;
}
# determine string length for nice tabulated output
proc OptLengths {desc nlName tlName dlName} {
upvar $nlName nl;
upvar $tlName tl;
upvar $dlName dl;
foreach item $desc {
if {[OptIsCounter $item]} continue;
if {[OptIsPrg $item]} {
OptLengths $item nl tl dl
} else {
SetMax nl [string length [OptName $item]]
SetMax tl [string length [OptType $item]]
set dv [OptTypeArgs $item];
if {[OptState $item] != "header"} {
set dv "($dv)";
}
set l [string length $dv];
# limit the space allocated to potentially big "choices"
if {([OptType $item] != "choice") || ($l<=12)} {
SetMax dl $l
} else {
if {![info exists dl]} {
set dl 0
}
}
}
}
}
# output the tree
proc OptTree {desc nl tl dl} {
set res "";
foreach item $desc {
if {[OptIsCounter $item]} continue;
if {[OptIsPrg $item]} {
append res [OptTree $item $nl $tl $dl];
} else {
set dv [OptTypeArgs $item];
if {[OptState $item] != "header"} {
set dv "($dv)";
}
append res [format "\n %-*s %-*s %-*s %s" \
$nl [OptName $item] $tl [OptType $item] \
$dl $dv [OptHelp $item]]
}
}
return $res;
}
# Give nice usage string
proc ::tcl::OptError {prefix desc {header 0}} {
# determine length
if {$header} {
# add faked instruction
set h [list [OptNewInst header Var/FlagName Type Value Help]];
lappend h [OptNewInst header ------------ ---- ----- ----];
lappend h [OptNewInst header {( -help} "" "" {gives this help )}]
set desc [concat $h $desc]
}
OptLengths $desc nl tl dl
# actually output
return "$prefix[OptTree $desc $nl $tl $dl]"
}
################ General Utility functions #######################
#
# List utility functions
# Naming convention:
# "Lvarxxx" take the list VARiable name as argument
# "Lxxxx" take the list value as argument
# (which is not costly with Tcl8 objects system
# as it's still a reference and not a copy of the values)
#
# Is that list empty ?
proc ::tcl::Lempty {list} {
expr {[llength $list]==0}
}
# Gets the value of one leaf of a lists tree
proc ::tcl::Lget {list indexLst} {
if {[llength $indexLst] <= 1} {
return [lindex $list $indexLst];
}
Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end];
}
# Sets the value of one leaf of a lists tree
# (we use the version that does not create the elements because
# it would be even slower... needs to be written in C !)
# (nb: there is a non trivial recursive problem with indexes 0,
# which appear because there is no difference between a list
# of 1 element and 1 element alone : [list "a"] == "a" while
# it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1
# and [listp "a b"] maybe 0. listp does not exist either...)
proc ::tcl::Lvarset {listName indexLst newValue} {
upvar $listName list;
if {[llength $indexLst] <= 1} {
Lvarset1nc list $indexLst $newValue;
} else {
set idx [lindex $indexLst 0];
set targetList [lindex $list $idx];
# reduce refcount on targetList (not really usefull now,
# could be with optimizing compiler)
# Lvarset1 list $idx {};
# recursively replace in targetList
Lvarset targetList [lrange $indexLst 1 end] $newValue;
# put updated sub list back in the tree
Lvarset1nc list $idx $targetList;
}
}
# Set one cell to a value, eventually create all the needed elements
# (on level-1 of lists)
variable emptyList {}
proc ::tcl::Lvarset1 {listName index newValue} {
upvar $listName list;
if {$index < 0} {return -code error "invalid negative index"}
set lg [llength $list];
if {$index >= $lg} {
variable emptyList;
for {set i $lg} {$i<$index} {incr i} {
lappend list $emptyList;
}
lappend list $newValue;
} else {
set list [lreplace $list $index $index $newValue];
}
}
# same as Lvarset1 but no bound checking / creation
proc ::tcl::Lvarset1nc {listName index newValue} {
upvar $listName list;
set list [lreplace $list $index $index $newValue];
}
# Increments the value of one leaf of a lists tree
# (which must exists)
proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} {
upvar $listName list;
if {[llength $indexLst] <= 1} {
Lvarincr1 list $indexLst $howMuch;
} else {
set idx [lindex $indexLst 0];
set targetList [lindex $list $idx];
# reduce refcount on targetList
Lvarset1nc list $idx {};
# recursively replace in targetList
Lvarincr targetList [lrange $indexLst 1 end] $howMuch;
# put updated sub list back in the tree
Lvarset1nc list $idx $targetList;
}
}
# Increments the value of one cell of a list
proc ::tcl::Lvarincr1 {listName index {howMuch 1}} {
upvar $listName list;
set newValue [expr {[lindex $list $index]+$howMuch}];
set list [lreplace $list $index $index $newValue];
return $newValue;
}
# Removes the first element of a list
# and returns the new list value
proc ::tcl::Lvarpop1 {listName} {
upvar $listName list;
set list [lrange $list 1 end];
}
# Same but returns the removed element
# (Like the tclX version)
proc ::tcl::Lvarpop {listName} {
upvar $listName list;
set el [lindex $list 0];
set list [lrange $list 1 end];
return $el;
}
# Assign list elements to variables and return the length of the list
proc ::tcl::Lassign {list args} {
# faster than direct blown foreach (which does not byte compile)
set i 0;
set lg [llength $list];
foreach vname $args {
if {$i>=$lg} break
uplevel 1 [list ::set $vname [lindex $list $i]];
incr i;
}
return $lg;
}
# Misc utilities
# Set the varname to value if value is greater than varname's current value
# or if varname is undefined
proc ::tcl::SetMax {varname value} {
upvar 1 $varname var
if {![info exists var] || $value > $var} {
set var $value
}
}
# Set the varname to value if value is smaller than varname's current value
# or if varname is undefined
proc ::tcl::SetMin {varname value} {
upvar 1 $varname var
if {![info exists var] || $value < $var} {
set var $value
}
}
# everything loaded fine, lets create the test proc:
# OptCreateTestProc
# Don't need the create temp proc anymore:
# rename OptCreateTestProc {}
}
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/opt0.4/pkgIndex.tcl 0100644 0000000 0000120 00000001141 07727704707 031562 0 ustar root admin # Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded opt 0.4.4.1 [list source [file join $dir optparse.tcl]]
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/package.tcl 0100644 0000000 0000120 00000056710 07707713565 030374 0 ustar root admin # package.tcl --
#
# utility procs formerly in init.tcl which can be loaded on demand
# for package management.
#
# RCS: @(#) $Id: package.tcl,v 1.23.2.2 2003/07/24 08:23:17 rmax Exp $
#
# 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.
#
# Create the package namespace
namespace eval ::pkg {
}
# 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 pkg_compareExtension { fileName {ext {}} } {
global tcl_platform
if {![string length $ext]} {set ext [info sharedlibextension]}
if {[string equal $tcl_platform(platform) "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 {[string equal $currExt $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:
# 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} {
global errorCode errorInfo
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] == 0} {
set patternList [list "*.tcl" "*[info sharedlibextension]"]
}
set oldDir [pwd]
cd $dir
if {[catch {eval glob $patternList} fileList]} {
global errorCode errorInfo
cd $oldDir
return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList
}
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 {[string equal $file "pkgIndex.tcl"]} {
continue
}
# Changed back to the original directory before initializing the
# slave in case TCL_LIBRARY is a relative path (e.g. in the test
# suite).
cd $oldDir
set c [interp create]
# Load into the child any packages currently loaded in the parent
# interpreter that match the -load pattern.
if {[string length $loadPat]} {
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'"
}
if {[catch {
load [lindex $pkg 0] [lindex $pkg 1] $c
} err]} {
if {$doVerbose} {
tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
}
} elseif {$doVerbose} {
tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
}
if {[string equal [lindex $pkg 1] "Tk"]} {
# Withdraw . if Tk was loaded, to avoid showing a window.
$c eval [list wm withdraw .]
}
}
cd $dir
$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 { eval __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 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::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 {pkg_compareExtension} {
$c eval [list proc $p [info args $p] [info body $p]]
}
if {[catch {
$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] {
eval 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 {[string compare [package provide $::tcl::x] ""]} {
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 {[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::file]
set ::tcl::type load
} else {
set ::tcl::debug sourcing
source $::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 {
catch {unset ::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 {[string compare $::tcl::x $::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 {[string compare [package provide $::tcl::x] ""] \
&& ![info exists ::tcl::packages($::tcl::x)]} {
lappend ::tcl::newPkgs \
[list $::tcl::x [package provide $::tcl::x]]
}
}
}
} msg] == 1} {
set what [$c eval set ::tcl::debug]
if {$doVerbose} {
tclLog "warning: error while $what $file: $msg"
}
} else {
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 {}
foreach {name version} $pkg {
break
}
lappend cmd ::pkg::create -name $name -version $version
foreach spec $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 pkgIndex.tcl w]
puts $f $index
close $f
cd $oldDir
}
# 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 {[string equal $type "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. (On the Macintosh we also search for pkgIndex
# TEXT resources in all files.) 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 version {exact {}}} {
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)] && [file readable $file]} {
if {[catch {source $file} msg]} {
tclLog "error reading package index file $file: $msg"
} else {
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 readable",
# nor stderr channel
if {([interp issafe] || [file readable $file])} {
if {[catch {source $file} msg] && ![interp issafe]} {
tclLog "error reading package index file $file: $msg"
} else {
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)]
&& ([lsearch -exact $use_path $dir] == -1) } {
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.
# Only installed in interps that are not safe so we don't check
# for [interp issafe] as in tclPkgUnknown.
#
# 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 version {exact {}}} {
# First do the cross-platform default search
uplevel 1 $original [list $name $version $exact]
# 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]
# 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 {[file readable $file] && ![info exists procdDirs($dir)]} {
if {[catch {source $file} msg]} {
tclLog "error reading package index file $file: $msg"
} else {
set procdDirs($dir) 1
}
}
}
set use_path [lrange $use_path 0 end-1]
if {[string compare $old_path $auto_path]} {
foreach dir $auto_path {
lappend use_path $dir
}
set old_path $auto_path
}
}
}
# tcl::MacPkgUnknown --
# This procedure extends the "package unknown" function for Mac.
# It searches for pkgIndex TEXT resources in all files
# Only installed in interps that are not safe so we don't check
# for [interp issafe] as in tclPkgUnknown.
#
# 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::MacPkgUnknown {original name version {exact {}}} {
# First do the cross-platform default search
uplevel 1 $original [list $name $version $exact]
# Now do Mac 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]} {
# We look for pkgIndex TEXT resources in the resource fork of shared libraries
set dir [lindex $use_path end]
foreach x [concat [list $dir] [glob -directory $dir -nocomplain *] ] {
if {[file isdirectory $x] && ![info exists procdDirs($x)]} {
set dir $x
foreach x [glob -directory $dir -nocomplain *.shlb] {
if {[file isfile $x]} {
set res [resource open $x]
foreach y [resource list TEXT $res] {
if {[string equal $y "pkgIndex"]} {source -rsrc pkgIndex}
}
catch {resource close $res}
}
}
set procdDirs($dir) 1
}
}
set use_path [lrange $use_path 0 end-1]
if {[string compare $old_path $auto_path]} {
foreach dir $auto_path {
lappend use_path $dir
}
set old_path $auto_path
}
}
}
# ::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 ::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
set opts(-name) {}
set opts(-version) {}
set opts(-source) {}
set opts(-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)] == 0 } {
error [format $err(valueMissing) "-name"]
}
if { [llength $opts(-version)] == 0 } {
error [format $err(valueMissing) "-version"]
}
if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } {
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) {
foreach {filename proclist} {{} {}} {
break
}
foreach {filename proclist} $filespec {
break
}
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] > 0 } {
lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\
$opts(-version) [list $lazyFileList]\]"
}
append cmdline [join $cmdList "\\n"]
return $cmdline
}
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/parray.tcl 0100644 0000000 0000120 00000001562 06577261403 030263 0 ustar root admin # parray:
# Print the contents of a global array on stdout.
#
# RCS: @(#) $Id: parray.tcl,v 1.3 1998/09/14 18:40:03 stanton Exp $
#
# 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]} {
error "\"$a\" isn't an array"
}
set maxl 0
foreach name [lsort [array names array $pattern]] {
if {[string length $name] > $maxl} {
set maxl [string length $name]
}
}
set maxl [expr {$maxl + [string length $a] + 2}]
foreach name [lsort [array names array $pattern]] {
set nameString [format %s(%s) $a $name]
puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
}
}
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/realinit.tcl 0100644 0000000 0000120 00000054705 10145254126 030571 0 ustar root admin # init.tcl --
#
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
# RCS: @(#) $Id: init.tcl,v 1.55.2.4 2004/11/13 00:41:58 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
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.4
# 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.
# tclInitScript.h 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
# On Macintosh it is "Tool Command Language" in the Extensions folder
if {![info exists auto_path]} {
if {[info exists env(TCLLIBPATH)]} {
set auto_path $env(TCLLIBPATH)
} else {
set auto_path ""
}
}
namespace eval tcl {
variable Dir
if {[info library] != ""} {
foreach Dir [list [info library] [file dirname [info library]]] {
if {[lsearch -exact $::auto_path $Dir] < 0} {
lappend ::auto_path $Dir
}
}
}
set Dir [file join [file dirname [file dirname \
[info nameofexecutable]]] lib]
if {[lsearch -exact $::auto_path $Dir] < 0} {
lappend ::auto_path $Dir
}
if {[info exists ::tcl_pkgPath]} {
foreach Dir $::tcl_pkgPath {
if {[lsearch -exact $::auto_path $Dir] < 0} {
lappend ::auto_path $Dir
}
}
}
}
# Windows specific end of initialization
if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} {
namespace eval tcl {
proc EnvTraceProc {lo n1 n2 op} {
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 {![string equal $u $p]} {
switch -- $u {
COMSPEC -
PATH {
if {![info exists env($u)]} {
set env($u) $env($p)
}
trace variable env($p) w \
[namespace code [list EnvTraceProc $p]]
trace variable env($u) w \
[namespace code [list EnvTraceProc $p]]
}
}
}
}
if {![info exists env(COMSPEC)]} {
if {[string equal $tcl_platform(os) "Windows NT"]} {
set env(COMSPEC) cmd.exe
} else {
set env(COMSPEC) command.com
}
}
}
InitWinEnv
}
}
# Setup the unknown package handler
package unknown tclPkgUnknown
if {![interp issafe]} {
# setup platform specific unknown package handlers
if {[string equal $::tcl_platform(platform) "unix"] && \
[string equal $::tcl_platform(os) "Darwin"]} {
package unknown [list tcl::MacOSXPkgUnknown [package unknown]]
}
if {[string equal $::tcl_platform(platform) "macintosh"]} {
package unknown [list tcl::MacPkgUnknown [package unknown]]
}
}
# Conditionalize for presence of exec.
if {[llength [info commands exec]] == 0} {
# Some machines, such as the Macintosh, do not have exec. Also, on all
# platforms, safe interpreters do not have exec.
set auto_noexec 1
}
set errorCode ""
set errorInfo ""
# Define a log command (which can be overwitten to log errors
# differently, specially when stderr is not available)
if {[llength [info commands tclLog]] == 0} {
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 command has the form "namespace inscope ns cmd" and
# if so, concatenate its arguments onto the end and evaluate it.
# 2. See if the autoload facility can locate the command in a
# Tcl script file. If so, load it and execute it.
# 3. 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 !!, !, 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 {
global auto_noexec auto_noload env unknown_pending tcl_interactive
global errorCode errorInfo
# If the command word has the form "namespace inscope ns cmd"
# then concatenate its arguments onto the end and evaluate it.
set cmd [lindex $args 0]
if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
set arglist [lrange $args 1 end]
set ret [catch {uplevel 1 ::$cmd $arglist} result]
if {$ret == 0} {
return $result
} else {
return -code $ret -errorcode $errorCode $result
}
}
# Save the values of errorCode and errorInfo variables, since they
# may get modified if caught errors occur below. The variables will
# be restored just before re-executing the missing command.
# Safety check in case something unsets the variables
# ::errorInfo or ::errorCode. [Bug 1063707]
if {![info exists errorCode]} {
set errorCode ""
}
if {![info exists errorInfo]} {
set errorInfo ""
}
set savedErrorCode $errorCode
set savedErrorInfo $errorInfo
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 unknown_pending($name)]} {
return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
}
set unknown_pending($name) pending;
set ret [catch {auto_load $name [uplevel 1 {::namespace current}]} msg]
unset unknown_pending($name);
if {$ret != 0} {
append errorInfo "\n (autoloading \"$name\")"
return -code $ret -errorcode $errorCode -errorinfo $errorInfo $msg
}
if {![array size unknown_pending]} {
unset unknown_pending
}
if {$msg} {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
set code [catch {uplevel 1 $args} msg]
if {$code == 1} {
#
# Compute stack trace contribution from the [uplevel].
# Note the dependence on how Tcl_AddErrorInfo, etc.
# construct the stack trace.
#
set cinfo $args
set ellipsis ""
while {[string bytelength $cinfo] > 150} {
set cinfo [string range $cinfo 0 end-1]
set ellipsis "..."
}
append cinfo $ellipsis "\"\n (\"uplevel\" body line 1)"
append cinfo "\n invoked from within"
append cinfo "\n\"uplevel 1 \$args\""
#
# Try each possible form of the stack trace
# and trim the extra contribution from the matching case
#
set expect "$msg\n while executing\n\"$cinfo"
if {$errorInfo eq $expect} {
#
# The stack has only the eval from the expanded command
# Do not generate any stack trace here.
#
return -code error -errorcode $errorCode $msg
}
#
# Stack trace is nested, trim off just the contribution
# from the extra "eval" of $args due to the "catch" above.
#
set expect "\n invoked from within\n\"$cinfo"
set exlen [string length $expect]
set eilen [string length $errorInfo]
set i [expr {$eilen - $exlen - 1}]
set einfo [string range $errorInfo 0 $i]
#
# For now verify that $errorInfo consists of what we are about
# to return plus what we expected to trim off.
#
if {$errorInfo ne "$einfo$expect"} {
error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
[list CORE UNKNOWN BADTRACE $expect $errorInfo]
}
return -code error -errorcode $errorCode \
-errorinfo $einfo $msg
} else {
return -code $code $msg
}
}
}
if {([info level] == 1) && [string equal [info script] ""] \
&& [info exists tcl_interactive] && $tcl_interactive} {
if {![info exists auto_noexec]} {
set new [auto_execok $name]
if {$new != ""} {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
set redir ""
if {[string equal [info commands console] ""]} {
set redir ">&@stdout <@stdin"
}
return [uplevel 1 exec $redir $new [lrange $args 1 end]]
}
}
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
if {[string equal $name "!!"]} {
set newcmd [history event]
} elseif {[regexp {^!(.+)$} $name dummy event]} {
set newcmd [history event $event]
} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
set newcmd [history event -1]
catch {regsub -all -- $old $newcmd $new newcmd}
}
if {[info exists newcmd]} {
tclLog $newcmd
history change $newcmd 0
return [uplevel 1 $newcmd]
}
set ret [catch {set candidates [info commands $name*]} msg]
if {[string equal $name "::"]} {
set name ""
}
if {$ret != 0} {
return -code $ret -errorcode $errorCode \
"error in unknown while checking if \"$name\" is\
a unique command abbreviation:\n$msg"
}
# Filter out bogus matches when $name contained
# a glob-special char [Bug 946952]
set cmds [list]
foreach x $candidates {
if {[string range $x 0 [expr [string length $name]-1]] eq $name} {
lappend cmds $x
}
}
if {[llength $cmds] == 1} {
return [uplevel 1 [lreplace $args 0 0 $cmds]]
}
if {[llength $cmds]} {
if {[string equal $name ""]} {
return -code error "empty command name \"\""
} else {
return -code error \
"ambiguous command name \"$name\": [lsort $cmds]"
}
}
}
return -code error "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_oldpath auto_path
if {[string length $namespace] == 0} {
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 {} {
global auto_index auto_oldpath auto_path errorInfo errorCode
if {[info exists auto_oldpath] && \
[string equal $auto_oldpath $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 {[string equal $id \
"# Tcl autoload index file, version 2.0"]} {
eval [read $f]
} elseif {[string equal $id "# Tcl autoload index file: each line identifies a Tcl"]} {
while {[gets $f line] >= 0} {
if {[string equal [string index $line 0] "#"] \
|| ([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]
if {$f != ""} {
close $f
}
if {$error} {
error $msg $errorInfo $errorCode
}
}
}
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 {[regexp {^::(.*)$} $cmd x tail]} {
if {$n > 1} {
# ( ::foo::bar , * ) -> ::foo::bar
return [list $cmd]
} else {
# ( ::global , * ) -> global
return [list $tail]
}
}
# Potentially returning 2 elements to try :
# (if the current namespace is not the global one)
if {$n == 0} {
if {[string equal $namespace ::]} {
# ( nocolons , :: ) -> nocolons
return [list $cmd]
} else {
# ( nocolons , ::sub ) -> ::sub::nocolons nocolons
return [list ${namespace}::$cmd $cmd]
}
} elseif {[string equal $namespace ::]} {
# ( 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 {[string equal windows $tcl_platform(platform)]} {
# Windows version.
#
# Note that info 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 cls copy date del erase dir echo mkdir \
md rename ren rmdir rd time type ver vol]
if {[string equal $tcl_platform(os) "Windows NT"]} {
# NT includes the 'start' built-in
lappend shellBuiltins "start"
}
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]
}
if {[lsearch -exact $shellBuiltins $name] != -1} {
# 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 {[string equal $tcl_platform(os) "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 dir [split $path {;}] {
# Skip already checked directories
if {[info exists checked($dir)] || [string equal {} $dir]} { continue }
set checked($dir) {}
foreach ext $execExtensions {
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 {[string equal $dir ""]} {
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 {[string equal $action "renaming"]} {
# Can't rename volumes. We could give a more precise
# error message here, but that would break the test suite.
if {[lsearch -exact [file volumes] $nsrc] != -1} {
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 == $ndest} {
return -code error "error $action \"$src\" to\
\"$dest\": trying to rename a volume or move a directory\
into itself"
}
if {[string equal $action "copying"]} {
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 * .*]
eval [list lappend existing] \
[glob -nocomplain -directory $dest -type hidden * .*]
foreach s $existing {
if {([file tail $s] != ".") && ([file tail $s] != "..")} {
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 == [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] != ".") && ([file tail $s] != "..")} {
file copy $s [file join $dest [file tail $s]]
}
}
return
}
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/safe.tcl 0100644 0000000 0000120 00000066114 10070234265 027674 0 ustar root admin # safe.tcl --
#
# This file provide a safe loading/sourcing mechanism for safe interpreters.
# It implements a virtual path mecanism to hide the real pathnames from the
# slave. It runs in a master interpreter and sets up data structure and
# aliases that will be invoked when used from a slave interpreter.
#
# See the safe.n man page for details.
#
# Copyright (c) 1996-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.
#
# RCS: @(#) $Id: safe.tcl,v 1.9.2.2 2004/06/29 09:39:01 dkf Exp $
#
# The implementation is based on namespaces. These naming conventions
# are followed:
# Private procs starts with uppercase.
# Public procs are exported and starts with lowercase
#
# Needed utilities package
package require opt 0.4.1;
# Create the safe namespace
namespace eval ::safe {
# Exported API:
namespace export interpCreate interpInit interpConfigure interpDelete \
interpAddToAccessPath interpFindInAccessPath setLogCmd
####
#
# Setup the arguments parsing
#
####
# Make sure that our temporary variable is local to this
# namespace. [Bug 981733]
variable temp
# Share the descriptions
set temp [::tcl::OptKeyRegister {
{-accessPath -list {} "access path for the slave"}
{-noStatics "prevent loading of statically linked pkgs"}
{-statics true "loading of statically linked pkgs"}
{-nestedLoadOk "allow nested loading"}
{-nested false "nested loading"}
{-deleteHook -script {} "delete hook"}
}]
# create case (slave is optional)
::tcl::OptKeyRegister {
{?slave? -name {} "name of the slave (optional)"}
} ::safe::interpCreate
# adding the flags sub programs to the command program
# (relying on Opt's internal implementation details)
lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp)
# init and configure (slave is needed)
::tcl::OptKeyRegister {
{slave -name {} "name of the slave"}
} ::safe::interpIC
# adding the flags sub programs to the command program
# (relying on Opt's internal implementation details)
lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp)
# temp not needed anymore
::tcl::OptKeyDelete $temp
# Helper function to resolve the dual way of specifying staticsok
# (either by -noStatics or -statics 0)
proc InterpStatics {} {
foreach v {Args statics noStatics} {
upvar $v $v
}
set flag [::tcl::OptProcArgGiven -noStatics];
if {$flag && ($noStatics == $statics)
&& ([::tcl::OptProcArgGiven -statics])} {
return -code error\
"conflicting values given for -statics and -noStatics"
}
if {$flag} {
return [expr {!$noStatics}]
} else {
return $statics
}
}
# Helper function to resolve the dual way of specifying nested loading
# (either by -nestedLoadOk or -nested 1)
proc InterpNested {} {
foreach v {Args nested nestedLoadOk} {
upvar $v $v
}
set flag [::tcl::OptProcArgGiven -nestedLoadOk];
# note that the test here is the opposite of the "InterpStatics"
# one (it is not -noNested... because of the wanted default value)
if {$flag && ($nestedLoadOk != $nested)
&& ([::tcl::OptProcArgGiven -nested])} {
return -code error\
"conflicting values given for -nested and -nestedLoadOk"
}
if {$flag} {
# another difference with "InterpStatics"
return $nestedLoadOk
} else {
return $nested
}
}
####
#
# API entry points that needs argument parsing :
#
####
# Interface/entry point function and front end for "Create"
proc interpCreate {args} {
set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
InterpCreate $slave $accessPath \
[InterpStatics] [InterpNested] $deleteHook
}
proc interpInit {args} {
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
if {![::interp exists $slave]} {
return -code error "\"$slave\" is not an interpreter"
}
InterpInit $slave $accessPath \
[InterpStatics] [InterpNested] $deleteHook;
}
proc CheckInterp {slave} {
if {![IsInterp $slave]} {
return -code error \
"\"$slave\" is not an interpreter managed by ::safe::"
}
}
# Interface/entry point function and front end for "Configure"
# This code is awfully pedestrian because it would need
# more coupling and support between the way we store the
# configuration values in safe::interp's and the Opt package
# Obviously we would like an OptConfigure
# to avoid duplicating all this code everywhere. -> TODO
# (the app should share or access easily the program/value
# stored by opt)
# This is even more complicated by the boolean flags with no values
# that we had the bad idea to support for the sake of user simplicity
# in create/init but which makes life hard in configure...
# So this will be hopefully written and some integrated with opt1.0
# (hopefully for tcl8.1 ?)
proc interpConfigure {args} {
switch [llength $args] {
1 {
# If we have exactly 1 argument
# the semantic is to return all the current configuration
# We still call OptKeyParse though we know that "slave"
# is our given argument because it also checks
# for the "-help" option.
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
CheckInterp $slave
set res {}
lappend res [list -accessPath [Set [PathListName $slave]]]
lappend res [list -statics [Set [StaticsOkName $slave]]]
lappend res [list -nested [Set [NestedOkName $slave]]]
lappend res [list -deleteHook [Set [DeleteHookName $slave]]]
join $res
}
2 {
# If we have exactly 2 arguments
# the semantic is a "configure get"
::tcl::Lassign $args slave arg
# get the flag sub program (we 'know' about Opt's internal
# representation of data)
set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]
set hits [::tcl::OptHits desc $arg]
if {$hits > 1} {
return -code error [::tcl::OptAmbigous $desc $arg]
} elseif {$hits == 0} {
return -code error [::tcl::OptFlagUsage $desc $arg]
}
CheckInterp $slave
set item [::tcl::OptCurDesc $desc]
set name [::tcl::OptName $item]
switch -exact -- $name {
-accessPath {
return [list -accessPath [Set [PathListName $slave]]]
}
-statics {
return [list -statics [Set [StaticsOkName $slave]]]
}
-nested {
return [list -nested [Set [NestedOkName $slave]]]
}
-deleteHook {
return [list -deleteHook [Set [DeleteHookName $slave]]]
}
-noStatics {
# it is most probably a set in fact
# but we would need then to jump to the set part
# and it is not *sure* that it is a set action
# that the user want, so force it to use the
# unambigous -statics ?value? instead:
return -code error\
"ambigous query (get or set -noStatics ?)\
use -statics instead"
}
-nestedLoadOk {
return -code error\
"ambigous query (get or set -nestedLoadOk ?)\
use -nested instead"
}
default {
return -code error "unknown flag $name (bug)"
}
}
}
default {
# Otherwise we want to parse the arguments like init and create
# did
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
CheckInterp $slave
# Get the current (and not the default) values of
# whatever has not been given:
if {![::tcl::OptProcArgGiven -accessPath]} {
set doreset 1
set accessPath [Set [PathListName $slave]]
} else {
set doreset 0
}
if {(![::tcl::OptProcArgGiven -statics]) \
&& (![::tcl::OptProcArgGiven -noStatics]) } {
set statics [Set [StaticsOkName $slave]]
} else {
set statics [InterpStatics]
}
if {([::tcl::OptProcArgGiven -nested]) \
|| ([::tcl::OptProcArgGiven -nestedLoadOk]) } {
set nested [InterpNested]
} else {
set nested [Set [NestedOkName $slave]]
}
if {![::tcl::OptProcArgGiven -deleteHook]} {
set deleteHook [Set [DeleteHookName $slave]]
}
# we can now reconfigure :
InterpSetConfig $slave $accessPath $statics $nested $deleteHook
# auto_reset the slave (to completly synch the new access_path)
if {$doreset} {
if {[catch {::interp eval $slave {auto_reset}} msg]} {
Log $slave "auto_reset failed: $msg"
} else {
Log $slave "successful auto_reset" NOTICE
}
}
}
}
}
####
#
# Functions that actually implements the exported APIs
#
####
#
# safe::InterpCreate : doing the real job
#
# This procedure creates a safe slave and initializes it with the
# safe base aliases.
# NB: slave name must be simple alphanumeric string, no spaces,
# no (), no {},... {because the state array is stored as part of the name}
#
# Returns the slave name.
#
# Optional Arguments :
# + slave name : if empty, generated name will be used
# + access_path: path list controlling where load/source can occur,
# if empty: the master auto_path will be used.
# + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx)
# if 1 :static packages are ok.
# + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub)
# if 1 : multiple levels are ok.
# use the full name and no indent so auto_mkIndex can find us
proc ::safe::InterpCreate {
slave
access_path
staticsok
nestedok
deletehook
} {
# Create the slave.
if {$slave ne ""} {
::interp create -safe $slave
} else {
# empty argument: generate slave name
set slave [::interp create -safe]
}
Log $slave "Created" NOTICE
# Initialize it. (returns slave name)
InterpInit $slave $access_path $staticsok $nestedok $deletehook
}
#
# InterpSetConfig (was setAccessPath) :
# Sets up slave virtual auto_path and corresponding structure
# within the master. Also sets the tcl_library in the slave
# to be the first directory in the path.
# Nb: If you change the path after the slave has been initialized
# you probably need to call "auto_reset" in the slave in order that it
# gets the right auto_index() array values.
proc ::safe::InterpSetConfig {slave access_path staticsok\
nestedok deletehook} {
# determine and store the access path if empty
if {[string equal "" $access_path]} {
set access_path [uplevel \#0 set auto_path]
# Make sure that tcl_library is in auto_path
# and at the first position (needed by setAccessPath)
set where [lsearch -exact $access_path [info library]]
if {$where == -1} {
# not found, add it.
set access_path [concat [list [info library]] $access_path]
Log $slave "tcl_library was not in auto_path,\
added it to slave's access_path" NOTICE
} elseif {$where != 0} {
# not first, move it first
set access_path [concat [list [info library]]\
[lreplace $access_path $where $where]]
Log $slave "tcl_libray was not in first in auto_path,\
moved it to front of slave's access_path" NOTICE
}
# Add 1st level sub dirs (will searched by auto loading from tcl
# code in the slave using glob and thus fail, so we add them
# here so by default it works the same).
set access_path [AddSubDirs $access_path]
}
Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\
nestedok=$nestedok deletehook=($deletehook)" NOTICE
# clear old autopath if it existed
set nname [PathNumberName $slave]
if {[Exists $nname]} {
set n [Set $nname]
for {set i 0} {$i<$n} {incr i} {
Unset [PathToken $i $slave]
}
}
# build new one
set slave_auto_path {}
set i 0
foreach dir $access_path {
Set [PathToken $i $slave] $dir
lappend slave_auto_path "\$[PathToken $i]"
incr i
}
Set $nname $i
Set [PathListName $slave] $access_path
Set [VirtualPathListName $slave] $slave_auto_path
Set [StaticsOkName $slave] $staticsok
Set [NestedOkName $slave] $nestedok
Set [DeleteHookName $slave] $deletehook
SyncAccessPath $slave
}
#
#
# FindInAccessPath:
# Search for a real directory and returns its virtual Id
# (including the "$")
proc ::safe::interpFindInAccessPath {slave path} {
set access_path [GetAccessPath $slave]
set where [lsearch -exact $access_path $path]
if {$where == -1} {
return -code error "$path not found in access path $access_path"
}
return "\$[PathToken $where]"
}
#
# addToAccessPath:
# add (if needed) a real directory to access path
# and return its virtual token (including the "$").
proc ::safe::interpAddToAccessPath {slave path} {
# first check if the directory is already in there
if {![catch {interpFindInAccessPath $slave $path} res]} {
return $res
}
# new one, add it:
set nname [PathNumberName $slave]
set n [Set $nname]
Set [PathToken $n $slave] $path
set token "\$[PathToken $n]"
Lappend [VirtualPathListName $slave] $token
Lappend [PathListName $slave] $path
Set $nname [expr {$n+1}]
SyncAccessPath $slave
return $token
}
# This procedure applies the initializations to an already existing
# interpreter. It is useful when you want to install the safe base
# aliases into a preexisting safe interpreter.
proc ::safe::InterpInit {
slave
access_path
staticsok
nestedok
deletehook
} {
# Configure will generate an access_path when access_path is
# empty.
InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook
# These aliases let the slave load files to define new commands
# NB we need to add [namespace current], aliases are always
# absolute paths.
::interp alias $slave source {} [namespace current]::AliasSource $slave
::interp alias $slave load {} [namespace current]::AliasLoad $slave
# This alias lets the slave use the encoding names, convertfrom,
# convertto, and system, but not "encoding system " to set
# the system encoding.
::interp alias $slave encoding {} [namespace current]::AliasEncoding \
$slave
# This alias lets the slave have access to a subset of the 'file'
# command functionality.
AliasSubset $slave file file dir.* join root.* ext.* tail \
path.* split
# This alias interposes on the 'exit' command and cleanly terminates
# the slave.
::interp alias $slave exit {} [namespace current]::interpDelete $slave
# The allowed slave variables already have been set
# by Tcl_MakeSafe(3)
# Source init.tcl into the slave, to get auto_load and other
# procedures defined:
# We don't try to use the -rsrc on the mac because it would get
# confusing if you would want to customize init.tcl
# for a given set of safe slaves, on all the platforms
# you just need to give a specific access_path and
# the mac should be no exception. As there is no
# obvious full "safe ressources" design nor implementation
# for the mac, safe interps there will just don't
# have that ability. (A specific app can still reenable
# that using custom aliases if they want to).
# It would also make the security analysis and the Safe Tcl security
# model platform dependant and thus more error prone.
if {[catch {::interp eval $slave\
{source [file join $tcl_library init.tcl]}} msg]} {
Log $slave "can't source init.tcl ($msg)"
error "can't source init.tcl into slave $slave ($msg)"
}
return $slave
}
# Add (only if needed, avoid duplicates) 1 level of
# sub directories to an existing path list.
# Also removes non directories from the returned list.
proc AddSubDirs {pathList} {
set res {}
foreach dir $pathList {
if {[file isdirectory $dir]} {
# check that we don't have it yet as a children
# of a previous dir
if {[lsearch -exact $res $dir]<0} {
lappend res $dir
}
foreach sub [glob -directory $dir -nocomplain *] {
if {([file isdirectory $sub]) \
&& ([lsearch -exact $res $sub]<0) } {
# new sub dir, add it !
lappend res $sub
}
}
}
}
return $res
}
# This procedure deletes a safe slave managed by Safe Tcl and
# cleans up associated state:
proc ::safe::interpDelete {slave} {
Log $slave "About to delete" NOTICE
# If the slave has a cleanup hook registered, call it.
# check the existance because we might be called to delete an interp
# which has not been registered with us at all
set hookname [DeleteHookName $slave]
if {[Exists $hookname]} {
set hook [Set $hookname]
if {![::tcl::Lempty $hook]} {
# remove the hook now, otherwise if the hook
# calls us somehow, we'll loop
Unset $hookname
if {[catch {eval $hook [list $slave]} err]} {
Log $slave "Delete hook error ($err)"
}
}
}
# Discard the global array of state associated with the slave, and
# delete the interpreter.
set statename [InterpStateName $slave]
if {[Exists $statename]} {
Unset $statename
}
# if we have been called twice, the interp might have been deleted
# already
if {[::interp exists $slave]} {
::interp delete $slave
Log $slave "Deleted" NOTICE
}
return
}
# Set (or get) the loging mecanism
proc ::safe::setLogCmd {args} {
variable Log
if {[llength $args] == 0} {
return $Log
} else {
if {[llength $args] == 1} {
set Log [lindex $args 0]
} else {
set Log $args
}
}
}
# internal variable
variable Log {}
# ------------------- END OF PUBLIC METHODS ------------
#
# sets the slave auto_path to the master recorded value.
# also sets tcl_library to the first token of the virtual path.
#
proc SyncAccessPath {slave} {
set slave_auto_path [Set [VirtualPathListName $slave]]
::interp eval $slave [list set auto_path $slave_auto_path]
Log $slave "auto_path in $slave has been set to $slave_auto_path"\
NOTICE
::interp eval $slave [list set tcl_library [lindex $slave_auto_path 0]]
}
# base name for storing all the slave states
# the array variable name for slave foo is thus "Sfoo"
# and for sub slave {foo bar} "Sfoo bar" (spaces are handled
# ok everywhere (or should))
# We add the S prefix to avoid that a slave interp called "Log"
# would smash our "Log" variable.
proc InterpStateName {slave} {
return "S$slave"
}
# Check that the given slave is "one of us"
proc IsInterp {slave} {
expr {[Exists [InterpStateName $slave]] && [::interp exists $slave]}
}
# returns the virtual token for directory number N
# if the slave argument is given,
# it will return the corresponding master global variable name
proc PathToken {n {slave ""}} {
if {$slave ne ""} {
return "[InterpStateName $slave](access_path,$n)"
} else {
# We need to have a ":" in the token string so
# [file join] on the mac won't turn it into a relative
# path.
return "p(:$n:)"
}
}
# returns the variable name of the complete path list
proc PathListName {slave} {
return "[InterpStateName $slave](access_path)"
}
# returns the variable name of the complete path list
proc VirtualPathListName {slave} {
return "[InterpStateName $slave](access_path_slave)"
}
# returns the variable name of the number of items
proc PathNumberName {slave} {
return "[InterpStateName $slave](access_path,n)"
}
# returns the staticsok flag var name
proc StaticsOkName {slave} {
return "[InterpStateName $slave](staticsok)"
}
# returns the nestedok flag var name
proc NestedOkName {slave} {
return "[InterpStateName $slave](nestedok)"
}
# Run some code at the namespace toplevel
proc Toplevel {args} {
namespace eval [namespace current] $args
}
# set/get values
proc Set {args} {
eval [list Toplevel set] $args
}
# lappend on toplevel vars
proc Lappend {args} {
eval [list Toplevel lappend] $args
}
# unset a var/token (currently just an global level eval)
proc Unset {args} {
eval [list Toplevel unset] $args
}
# test existance
proc Exists {varname} {
Toplevel info exists $varname
}
# short cut for access path getting
proc GetAccessPath {slave} {
Set [PathListName $slave]
}
# short cut for statics ok flag getting
proc StaticsOk {slave} {
Set [StaticsOkName $slave]
}
# short cut for getting the multiples interps sub loading ok flag
proc NestedOk {slave} {
Set [NestedOkName $slave]
}
# interp deletion storing hook name
proc DeleteHookName {slave} {
return [InterpStateName $slave](cleanupHook)
}
#
# translate virtual path into real path
#
proc TranslatePath {slave path} {
# somehow strip the namespaces 'functionality' out (the danger
# is that we would strip valid macintosh "../" queries... :
if {[regexp {(::)|(\.\.)} $path]} {
error "invalid characters in path $path"
}
set n [expr {[Set [PathNumberName $slave]]-1}]
for {} {$n>=0} {incr n -1} {
# fill the token virtual names with their real value
set [PathToken $n] [Set [PathToken $n $slave]]
}
# replaces the token by their value
subst -nobackslashes -nocommands $path
}
# Log eventually log an error
# to enable error logging, set Log to {puts stderr} for instance
proc Log {slave msg {type ERROR}} {
variable Log
if {[info exists Log] && [llength $Log]} {
eval $Log [list "$type for slave $slave : $msg"]
}
}
# file name control (limit access to files/ressources that should be
# a valid tcl source file)
proc CheckFileName {slave file} {
# This used to limit what can be sourced to ".tcl" and forbid files
# with more than 1 dot and longer than 14 chars, but I changed that
# for 8.4 as a safe interp has enough internal protection already
# to allow sourcing anything. - hobbs
if {![file exists $file]} {
# don't tell the file path
error "no such file or directory"
}
if {![file readable $file]} {
# don't tell the file path
error "not readable"
}
}
# AliasSource is the target of the "source" alias in safe interpreters.
proc AliasSource {slave args} {
set argc [llength $args]
# Allow only "source filename"
# (and not mac specific -rsrc for instance - see comment in ::init
# for current rationale)
if {$argc != 1} {
set msg "wrong # args: should be \"source fileName\""
Log $slave "$msg ($args)"
return -code error $msg
}
set file [lindex $args 0]
# get the real path from the virtual one.
if {[catch {set file [TranslatePath $slave $file]} msg]} {
Log $slave $msg
return -code error "permission denied"
}
# check that the path is in the access path of that slave
if {[catch {FileInAccessPath $slave $file} msg]} {
Log $slave $msg
return -code error "permission denied"
}
# do the checks on the filename :
if {[catch {CheckFileName $slave $file} msg]} {
Log $slave "$file:$msg"
return -code error $msg
}
# passed all the tests , lets source it:
if {[catch {::interp invokehidden $slave source $file} msg]} {
Log $slave $msg
return -code error "script error"
}
return $msg
}
# AliasLoad is the target of the "load" alias in safe interpreters.
proc AliasLoad {slave file args} {
set argc [llength $args]
if {$argc > 2} {
set msg "load error: too many arguments"
Log $slave "$msg ($argc) {$file $args}"
return -code error $msg
}
# package name (can be empty if file is not).
set package [lindex $args 0]
# Determine where to load. load use a relative interp path
# and {} means self, so we can directly and safely use passed arg.
set target [lindex $args 1]
if {[string length $target]} {
# we will try to load into a sub sub interp
# check that we want to authorize that.
if {![NestedOk $slave]} {
Log $slave "loading to a sub interp (nestedok)\
disabled (trying to load $package to $target)"
return -code error "permission denied (nested load)"
}
}
# Determine what kind of load is requested
if {[string length $file] == 0} {
# static package loading
if {[string length $package] == 0} {
set msg "load error: empty filename and no package name"
Log $slave $msg
return -code error $msg
}
if {![StaticsOk $slave]} {
Log $slave "static packages loading disabled\
(trying to load $package to $target)"
return -code error "permission denied (static package)"
}
} else {
# file loading
# get the real path from the virtual one.
if {[catch {set file [TranslatePath $slave $file]} msg]} {
Log $slave $msg
return -code error "permission denied"
}
# check the translated path
if {[catch {FileInAccessPath $slave $file} msg]} {
Log $slave $msg
return -code error "permission denied (path)"
}
}
if {[catch {::interp invokehidden\
$slave load $file $package $target} msg]} {
Log $slave $msg
return -code error $msg
}
return $msg
}
# FileInAccessPath raises an error if the file is not found in
# the list of directories contained in the (master side recorded) slave's
# access path.
# the security here relies on "file dirname" answering the proper
# result.... needs checking ?
proc FileInAccessPath {slave file} {
set access_path [GetAccessPath $slave]
if {[file isdirectory $file]} {
error "\"$file\": is a directory"
}
set parent [file dirname $file]
# Normalize paths for comparison since lsearch knows nothing of
# potential pathname anomalies.
set norm_parent [file normalize $parent]
foreach path $access_path {
lappend norm_access_path [file normalize $path]
}
if {[lsearch -exact $norm_access_path $norm_parent] == -1} {
error "\"$file\": not in access_path"
}
}
# This procedure enables access from a safe interpreter to only a subset of
# the subcommands of a command:
proc Subset {slave command okpat args} {
set subcommand [lindex $args 0]
if {[regexp $okpat $subcommand]} {
return [eval [list $command $subcommand] [lrange $args 1 end]]
}
set msg "not allowed to invoke subcommand $subcommand of $command"
Log $slave $msg
error $msg
}
# This procedure installs an alias in a slave that invokes "safesubset"
# in the master to execute allowed subcommands. It precomputes the pattern
# of allowed subcommands; you can use wildcards in the pattern if you wish
# to allow subcommand abbreviation.
#
# Syntax is: AliasSubset slave alias target subcommand1 subcommand2...
proc AliasSubset {slave alias target args} {
set pat ^(; set sep ""
foreach sub $args {
append pat $sep$sub
set sep |
}
append pat )\$
::interp alias $slave $alias {}\
[namespace current]::Subset $slave $target $pat
}
# AliasEncoding is the target of the "encoding" alias in safe interpreters.
proc AliasEncoding {slave args} {
set argc [llength $args]
set okpat "^(name.*|convert.*)\$"
set subcommand [lindex $args 0]
if {[regexp $okpat $subcommand]} {
return [eval ::interp invokehidden $slave encoding $subcommand \
[lrange $args 1 end]]
}
if {[string match $subcommand system]} {
if {$argc == 1} {
# passed all the tests , lets source it:
if {[catch {::interp invokehidden \
$slave encoding system} msg]} {
Log $slave $msg
return -code error "script error"
}
} else {
set msg "wrong # args: should be \"encoding system\""
Log $slave $msg
error $msg
}
} else {
set msg "wrong # args: should be \"encoding option ?arg ...?\""
Log $slave $msg
error $msg
}
return $msg
}
}
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/tclIndex 0100644 0000000 0000120 00000013721 07557263421 027757 0 ustar root admin # Tcl autoload index file, version 2.0
# 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(tclLdAout) [list source [file join $dir ldAout.tcl]]
set auto_index(pkg_compareExtension) [list source [file join $dir package.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(::tcl::MacPkgUnknown) [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::InterpStateName) [list source [file join $dir safe.tcl]]
set auto_index(::safe::IsInterp) [list source [file join $dir safe.tcl]]
set auto_index(::safe::PathToken) [list source [file join $dir safe.tcl]]
set auto_index(::safe::PathListName) [list source [file join $dir safe.tcl]]
set auto_index(::safe::VirtualPathListName) [list source [file join $dir safe.tcl]]
set auto_index(::safe::PathNumberName) [list source [file join $dir safe.tcl]]
set auto_index(::safe::StaticsOkName) [list source [file join $dir safe.tcl]]
set auto_index(::safe::NestedOkName) [list source [file join $dir safe.tcl]]
set auto_index(::safe::Toplevel) [list source [file join $dir safe.tcl]]
set auto_index(::safe::Set) [list source [file join $dir safe.tcl]]
set auto_index(::safe::Lappend) [list source [file join $dir safe.tcl]]
set auto_index(::safe::Unset) [list source [file join $dir safe.tcl]]
set auto_index(::safe::Exists) [list source [file join $dir safe.tcl]]
set auto_index(::safe::GetAccessPath) [list source [file join $dir safe.tcl]]
set auto_index(::safe::StaticsOk) [list source [file join $dir safe.tcl]]
set auto_index(::safe::NestedOk) [list source [file join $dir safe.tcl]]
set auto_index(::safe::DeleteHookName) [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::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::Subset) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasSubset) [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]]
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/tcltest2.2/ 0040755 0000000 0000024 00000000000 10153074406 030170 5 ustar root staff ././@LongLink 0000000 0000000 0000000 00000000145 00000000000 011706 L ustar root wheel Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/tcltest2.2/pkgIndex.tcl Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/tcltest2.2/pkgIndex.tc 0100644 0000000 0000120 00000001142 10140603576 032250 0 ustar root admin # Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.3]} {return}
package ifneeded tcltest 2.2.7 [list source [file join $dir tcltest.tcl]]
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/tcltest2.2/tcltest.tcl 0100644 0000000 0000120 00000300752 10141754753 032353 0 ustar root admin # tcltest.tcl --
#
# This file contains support code for the Tcl test suite. It
# defines the tcltest namespace and finds and defines the output
# directory, constraints available, output and error channels,
# etc. used by Tcl tests. See the tcltest man page for more
# details.
#
# This design was based on the Tcl testing approach designed and
# initially implemented by Mary Ann May-Pumphrey of Sun
# Microsystems.
#
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2000 by Ajuba Solutions
# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
# All rights reserved.
#
# RCS: @(#) $Id: tcltest.tcl,v 1.78.2.12 2004/11/02 19:03:07 dgp Exp $
package require Tcl 8.3 ;# uses [glob -directory]
namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
variable Version 2.2.7
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
# yourself. You don't need tcltest to wrap it for you.
variable version [package provide Tcl]
variable patchLevel [info patchlevel]
##### Export the public tcltest procs; several categories
#
# Export the main functional commands that do useful things
namespace export cleanupTests loadTestedCommands makeDirectory \
makeFile removeDirectory removeFile runAllTests test
# Export configuration commands that control the functional commands
namespace export configure customMatch errorChannel interpreter \
outputChannel testConstraint
# Export commands that are duplication (candidates for deprecation)
namespace export bytestring ;# dups [encoding convertfrom identity]
namespace export debug ;# [configure -debug]
namespace export errorFile ;# [configure -errfile]
namespace export limitConstraints ;# [configure -limitconstraints]
namespace export loadFile ;# [configure -loadfile]
namespace export loadScript ;# [configure -load]
namespace export match ;# [configure -match]
namespace export matchFiles ;# [configure -file]
namespace export matchDirectories ;# [configure -relateddir]
namespace export normalizeMsg ;# application of [customMatch]
namespace export normalizePath ;# [file normalize] (8.4)
namespace export outputFile ;# [configure -outfile]
namespace export preserveCore ;# [configure -preservecore]
namespace export singleProcess ;# [configure -singleproc]
namespace export skip ;# [configure -skip]
namespace export skipFiles ;# [configure -notfile]
namespace export skipDirectories ;# [configure -asidefromdir]
namespace export temporaryDirectory ;# [configure -tmpdir]
namespace export testsDirectory ;# [configure -testdir]
namespace export verbose ;# [configure -verbose]
namespace export viewFile ;# binary encoding [read]
namespace export workingDirectory ;# [cd] [pwd]
# Export deprecated commands for tcltest 1 compatibility
namespace export getMatchingFiles mainThread restoreState saveState \
threadReap
# tcltest::normalizePath --
#
# This procedure resolves any symlinks in the path thus creating
# a path without internal redirection. It assumes that the
# incoming path is absolute.
#
# Arguments
# pathVar - name of variable containing path to modify.
#
# Results
# The path is modified in place.
#
# Side Effects:
# None.
#
proc normalizePath {pathVar} {
upvar $pathVar path
set oldpwd [pwd]
catch {cd $path}
set path [pwd]
cd $oldpwd
return $path
}
##### Verification commands used to test values of variables and options
#
# Verification command that accepts everything
proc AcceptAll {value} {
return $value
}
# Verification command that accepts valid Tcl lists
proc AcceptList { list } {
return [lrange $list 0 end]
}
# Verification command that accepts a glob pattern
proc AcceptPattern { pattern } {
return [AcceptAll $pattern]
}
# Verification command that accepts integers
proc AcceptInteger { level } {
return [incr level 0]
}
# Verification command that accepts boolean values
proc AcceptBoolean { boolean } {
return [expr {$boolean && $boolean}]
}
# Verification command that accepts (syntactically) valid Tcl scripts
proc AcceptScript { script } {
if {![info complete $script]} {
return -code error "invalid Tcl script: $script"
}
return $script
}
# Verification command that accepts (converts to) absolute pathnames
proc AcceptAbsolutePath { path } {
return [file join [pwd] $path]
}
# Verification command that accepts existing readable directories
proc AcceptReadable { path } {
if {![file readable $path]} {
return -code error "\"$path\" is not readable"
}
return $path
}
proc AcceptDirectory { directory } {
set directory [AcceptAbsolutePath $directory]
if {![file exists $directory]} {
return -code error "\"$directory\" does not exist"
}
if {![file isdir $directory]} {
return -code error "\"$directory\" is not a directory"
}
return [AcceptReadable $directory]
}
##### Initialize internal arrays of tcltest, but only if the caller
# has not already pre-initialized them. This is done to support
# compatibility with older tests that directly access internals
# rather than go through command interfaces.
#
proc ArrayDefault {varName value} {
variable $varName
if {[array exists $varName]} {
return
}
if {[info exists $varName]} {
# Pre-initialized value is a scalar: destroy it!
unset $varName
}
array set $varName $value
}
# save the original environment so that it can be restored later
ArrayDefault originalEnv [array get ::env]
# initialize numTests array to keep track of the number of tests
# that pass, fail, and are skipped.
ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
# createdNewFiles will store test files as indices and the list of
# files (that should not have been) left behind by the test files
# as values.
ArrayDefault createdNewFiles {}
# initialize skippedBecause array to keep track of constraints that
# kept tests from running; a constraint name of "userSpecifiedSkip"
# means that the test appeared on the list of tests that matched the
# -skip value given to the flag; "userSpecifiedNonMatch" means that
# the test didn't match the argument given to the -match flag; both
# of these constraints are counted only if tcltest::debug is set to
# true.
ArrayDefault skippedBecause {}
# initialize the testConstraints array to keep track of valid
# predefined constraints (see the explanation for the
# InitConstraints proc for more details).
ArrayDefault testConstraints {}
##### Initialize internal variables of tcltest, but only if the caller
# has not already pre-initialized them. This is done to support
# compatibility with older tests that directly access internals
# rather than go through command interfaces.
#
proc Default {varName value {verify AcceptAll}} {
variable $varName
if {![info exists $varName]} {
variable $varName [$verify $value]
} else {
variable $varName [$verify [set $varName]]
}
}
# Save any arguments that we might want to pass through to other
# programs. This is used by the -args flag.
# FINDUSER
Default parameters {}
# Count the number of files tested (0 if runAllTests wasn't called).
# runAllTests will set testSingleFile to false, so stats will
# not be printed until runAllTests calls the cleanupTests proc.
# The currentFailure var stores the boolean value of whether the
# current test file has had any failures. The failFiles list
# stores the names of test files that had failures.
Default numTestFiles 0 AcceptInteger
Default testSingleFile true AcceptBoolean
Default currentFailure false AcceptBoolean
Default failFiles {} AcceptList
# Tests should remove all files they create. The test suite will
# check the current working dir for files created by the tests.
# filesMade keeps track of such files created using the makeFile and
# makeDirectory procedures. filesExisted stores the names of
# pre-existing files.
#
# Note that $filesExisted lists only those files that exist in
# the original [temporaryDirectory].
Default filesMade {} AcceptList
Default filesExisted {} AcceptList
proc FillFilesExisted {} {
variable filesExisted
# Save the names of files that already exist in the scratch directory.
foreach file [glob -nocomplain -directory [temporaryDirectory] *] {
lappend filesExisted [file tail $file]
}
# After successful filling, turn this into a no-op.
proc FillFilesExisted args {}
}
# Kept only for compatibility
Default constraintsSpecified {} AcceptList
trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \
[array names ::tcltest::testConstraints] ;# }
# tests that use threads need to know which is the main thread
Default mainThread 1
variable mainThread
if {[info commands thread::id] != {}} {
set mainThread [thread::id]
} elseif {[info commands testthread] != {}} {
set mainThread [testthread id]
}
# Set workingDirectory to [pwd]. The default output directory for
# Tcl tests is the working directory. Whenever this value changes
# change to that directory.
variable workingDirectory
trace variable workingDirectory w \
[namespace code {cd $workingDirectory ;#}]
Default workingDirectory [pwd] AcceptAbsolutePath
proc workingDirectory { {dir ""} } {
variable workingDirectory
if {[llength [info level 0]] == 1} {
return $workingDirectory
}
set workingDirectory [AcceptAbsolutePath $dir]
}
# Set the location of the execuatble
Default tcltest [info nameofexecutable]
trace variable tcltest w [namespace code {testConstraint stdio \
[eval [ConstraintInitializer stdio]] ;#}]
# save the platform information so it can be restored later
Default originalTclPlatform [array get ::tcl_platform]
# If a core file exists, save its modification time.
if {[file exists [file join [workingDirectory] core]]} {
Default coreModTime \
[file mtime [file join [workingDirectory] core]]
}
# stdout and stderr buffers for use when we want to store them
Default outData {}
Default errData {}
# keep track of test level for nested test commands
variable testLevel 0
# the variables and procs that existed when saveState was called are
# stored in a variable of the same name
Default saveState {}
# Internationalization support -- used in [SetIso8859_1_Locale] and
# [RestoreLocale]. Those commands are used in cmdIL.test.
if {![info exists [namespace current]::isoLocale]} {
variable isoLocale fr
switch -- $::tcl_platform(platform) {
"unix" {
# Try some 'known' values for some platforms:
switch -exact -- $::tcl_platform(os) {
"FreeBSD" {
set isoLocale fr_FR.ISO_8859-1
}
HP-UX {
set isoLocale fr_FR.iso88591
}
Linux -
IRIX {
set isoLocale fr
}
default {
# Works on SunOS 4 and Solaris, and maybe
# others... Define it to something else on your
# system if you want to test those.
set isoLocale iso_8859_1
}
}
}
"windows" {
set isoLocale French
}
}
}
variable ChannelsWeOpened; array set ChannelsWeOpened {}
# output goes to stdout by default
Default outputChannel stdout
proc outputChannel { {filename ""} } {
variable outputChannel
variable ChannelsWeOpened
# This is very subtle and tricky, so let me try to explain.
# (Hopefully this longer comment will be clear when I come
# back in a few months, unlike its predecessor :) )
#
# The [outputChannel] command (and underlying variable) have to
# be kept in sync with the [configure -outfile] configuration
# option ( and underlying variable Option(-outfile) ). This is
# accomplished with a write trace on Option(-outfile) that will
# update [outputChannel] whenver a new value is written. That
# much is easy.
#
# The trick is that in order to maintain compatibility with
# version 1 of tcltest, we must allow every configuration option
# to get its inital value from command line arguments. This is
# accomplished by setting initial read traces on all the
# configuration options to parse the command line option the first
# time they are read. These traces are cancelled whenever the
# program itself calls [configure].
#
# OK, then so to support tcltest 1 compatibility, it seems we want
# to get the return from [outputFile] to trigger the read traces,
# just in case.
#
# BUT! A little known feature of Tcl variable traces is that
# traces are disabled during the handling of other traces. So,
# if we trigger read traces on Option(-outfile) and that triggers
# command line parsing which turns around and sets an initial
# value for Option(-outfile) -- -- the write trace that
# would keep [outputChannel] in sync with that new initial value
# would not fire!
#
# SO, finally, as a workaround, instead of triggering read traces
# by invoking [outputFile], we instead trigger the same set of
# read traces by invoking [debug]. Any command that reads a
# configuration option would do. [debug] is just a handy one.
# The end result is that we support tcltest 1 compatibility and
# keep outputChannel and -outfile in sync in all cases.
debug
if {[llength [info level 0]] == 1} {
return $outputChannel
}
if {[info exists ChannelsWeOpened($outputChannel)]} {
close $outputChannel
unset ChannelsWeOpened($outputChannel)
}
switch -exact -- $filename {
stderr -
stdout {
set outputChannel $filename
}
default {
set outputChannel [open $filename a]
set ChannelsWeOpened($outputChannel) 1
# If we created the file in [temporaryDirectory], then
# [cleanupTests] will delete it, unless we claim it was
# already there.
set outdir [normalizePath [file dirname \
[file join [pwd] $filename]]]
if {[string equal $outdir [temporaryDirectory]]} {
variable filesExisted
FillFilesExisted
set filename [file tail $filename]
if {[lsearch -exact $filesExisted $filename] == -1} {
lappend filesExisted $filename
}
}
}
}
return $outputChannel
}
# errors go to stderr by default
Default errorChannel stderr
proc errorChannel { {filename ""} } {
variable errorChannel
variable ChannelsWeOpened
# This is subtle and tricky. See the comment above in
# [outputChannel] for a detailed explanation.
debug
if {[llength [info level 0]] == 1} {
return $errorChannel
}
if {[info exists ChannelsWeOpened($errorChannel)]} {
close $errorChannel
unset ChannelsWeOpened($errorChannel)
}
switch -exact -- $filename {
stderr -
stdout {
set errorChannel $filename
}
default {
set errorChannel [open $filename a]
set ChannelsWeOpened($errorChannel) 1
# If we created the file in [temporaryDirectory], then
# [cleanupTests] will delete it, unless we claim it was
# already there.
set outdir [normalizePath [file dirname \
[file join [pwd] $filename]]]
if {[string equal $outdir [temporaryDirectory]]} {
variable filesExisted
FillFilesExisted
set filename [file tail $filename]
if {[lsearch -exact $filesExisted $filename] == -1} {
lappend filesExisted $filename
}
}
}
}
return $errorChannel
}
##### Set up the configurable options
#
# The configurable options of the package
variable Option; array set Option {}
# Usage strings for those options
variable Usage; array set Usage {}
# Verification commands for those options
variable Verify; array set Verify {}
# Initialize the default values of the configurable options that are
# historically associated with an exported variable. If that variable
# is already set, support compatibility by accepting its pre-set value.
# Use [trace] to establish ongoing connection between the deprecated
# exported variable and the modern option kept as a true internal var.
# Also set up usage string and value testing for the option.
proc Option {option value usage {verify AcceptAll} {varName {}}} {
variable Option
variable Verify
variable Usage
variable OptionControlledVariables
set Usage($option) $usage
set Verify($option) $verify
if {[catch {$verify $value} msg]} {
return -code error $msg
} else {
set Option($option) $msg
}
if {[string length $varName]} {
variable $varName
if {[info exists $varName]} {
if {[catch {$verify [set $varName]} msg]} {
return -code error $msg
} else {
set Option($option) $msg
}
unset $varName
}
namespace eval [namespace current] \
[list upvar 0 Option($option) $varName]
# Workaround for Bug (now Feature Request) 572889. Grrrr....
# Track all the variables tied to options
lappend OptionControlledVariables $varName
# Later, set auto-configure read traces on all
# of them, since a single trace on Option does not work.
proc $varName {{value {}}} [subst -nocommands {
if {[llength [info level 0]] == 2} {
Configure $option [set value]
}
return [Configure $option]
}]
}
}
proc MatchingOption {option} {
variable Option
set match [array names Option $option*]
switch -- [llength $match] {
0 {
set sorted [lsort [array names Option]]
set values [join [lrange $sorted 0 end-1] ", "]
append values ", or [lindex $sorted end]"
return -code error "unknown option $option: should be\
one of $values"
}
1 {
return [lindex $match 0]
}
default {
# Exact match trumps ambiguity
if {[lsearch -exact $match $option] >= 0} {
return $option
}
set values [join [lrange $match 0 end-1] ", "]
append values ", or [lindex $match end]"
return -code error "ambiguous option $option:\
could match $values"
}
}
}
proc EstablishAutoConfigureTraces {} {
variable OptionControlledVariables
foreach varName [concat $OptionControlledVariables Option] {
variable $varName
trace variable $varName r [namespace code {ProcessCmdLineArgs ;#}]
}
}
proc RemoveAutoConfigureTraces {} {
variable OptionControlledVariables
foreach varName [concat $OptionControlledVariables Option] {
variable $varName
foreach pair [trace vinfo $varName] {
foreach {op cmd} $pair break
if {[string equal r $op]
&& [string match *ProcessCmdLineArgs* $cmd]} {
trace vdelete $varName $op $cmd
}
}
}
# Once the traces are removed, this can become a no-op
proc RemoveAutoConfigureTraces {} {}
}
proc Configure args {
variable Option
variable Verify
set n [llength $args]
if {$n == 0} {
return [lsort [array names Option]]
}
if {$n == 1} {
if {[catch {MatchingOption [lindex $args 0]} option]} {
return -code error $option
}
return $Option($option)
}
while {[llength $args] > 1} {
if {[catch {MatchingOption [lindex $args 0]} option]} {
return -code error $option
}
if {[catch {$Verify($option) [lindex $args 1]} value]} {
return -code error "invalid $option\
value \"[lindex $args 1]\": $value"
}
set Option($option) $value
set args [lrange $args 2 end]
}
if {[llength $args]} {
if {[catch {MatchingOption [lindex $args 0]} option]} {
return -code error $option
}
return -code error "missing value for option $option"
}
}
proc configure args {
RemoveAutoConfigureTraces
set code [catch {eval Configure $args} msg]
return -code $code $msg
}
proc AcceptVerbose { level } {
set level [AcceptList $level]
if {[llength $level] == 1} {
if {![regexp {^(pass|body|skip|start|error)$} $level]} {
# translate single characters abbreviations to expanded list
set level [string map {p pass b body s skip t start e error} \
[split $level {}]]
}
}
set valid [list]
foreach v $level {
if {[regexp {^(pass|body|skip|start|error)$} $v]} {
lappend valid $v
}
}
return $valid
}
proc IsVerbose {level} {
variable Option
return [expr {[lsearch -exact $Option(-verbose) $level] != -1}]
}
# Default verbosity is to show bodies of failed tests
Option -verbose {body error} {
Takes any combination of the values 'p', 's', 'b', 't' and 'e'.
Test suite will display all passed tests if 'p' is specified, all
skipped tests if 's' is specified, the bodies of failed tests if
'b' is specified, and when tests start if 't' is specified.
ErrorInfo is displayed if 'e' is specified.
} AcceptVerbose verbose
# Match and skip patterns default to the empty list, except for
# matchFiles, which defaults to all .test files in the
# testsDirectory and matchDirectories, which defaults to all
# directories.
Option -match * {
Run all tests within the specified files that match one of the
list of glob patterns given.
} AcceptList match
Option -skip {} {
Skip all tests within the specified tests (via -match) and files
that match one of the list of glob patterns given.
} AcceptList skip
Option -file *.test {
Run tests in all test files that match the glob pattern given.
} AcceptPattern matchFiles
# By default, skip files that appear to be SCCS lock files.
Option -notfile l.*.test {
Skip all test files that match the glob pattern given.
} AcceptPattern skipFiles
Option -relateddir * {
Run tests in directories that match the glob pattern given.
} AcceptPattern matchDirectories
Option -asidefromdir {} {
Skip tests in directories that match the glob pattern given.
} AcceptPattern skipDirectories
# By default, don't save core files
Option -preservecore 0 {
If 2, save any core files produced during testing in the directory
specified by -tmpdir. If 1, notify the user if core files are
created.
} AcceptInteger preserveCore
# debug output doesn't get printed by default; debug level 1 spits
# up only the tests that were skipped because they didn't match or
# were specifically skipped. A debug level of 2 would spit up the
# tcltest variables and flags provided; a debug level of 3 causes
# some additional output regarding operations of the test harness.
# The tcltest package currently implements only up to debug level 3.
Option -debug 0 {
Internal debug level
} AcceptInteger debug
proc SetSelectedConstraints args {
variable Option
foreach c $Option(-constraints) {
testConstraint $c 1
}
}
Option -constraints {} {
Do not skip the listed constraints listed in -constraints.
} AcceptList
trace variable Option(-constraints) w \
[namespace code {SetSelectedConstraints ;#}]
# Don't run only the "-constraint" specified tests by default
proc ClearUnselectedConstraints args {
variable Option
variable testConstraints
if {!$Option(-limitconstraints)} {return}
foreach c [array names testConstraints] {
if {[lsearch -exact $Option(-constraints) $c] == -1} {
testConstraint $c 0
}
}
}
Option -limitconstraints false {
whether to run only tests with the constraints
} AcceptBoolean limitConstraints
trace variable Option(-limitconstraints) w \
[namespace code {ClearUnselectedConstraints ;#}]
# A test application has to know how to load the tested commands
# into the interpreter.
Option -load {} {
Specifies the script to load the tested commands.
} AcceptScript loadScript
# Default is to run each test file in a separate process
Option -singleproc 0 {
whether to run all tests in one process
} AcceptBoolean singleProcess
proc AcceptTemporaryDirectory { directory } {
set directory [AcceptAbsolutePath $directory]
if {![file exists $directory]} {
file mkdir $directory
}
set directory [AcceptDirectory $directory]
if {![file writable $directory]} {
if {[string equal [workingDirectory] $directory]} {
# Special exception: accept the default value
# even if the directory is not writable
return $directory
}
return -code error "\"$directory\" is not writeable"
}
return $directory
}
# Directory where files should be created
Option -tmpdir [workingDirectory] {
Save temporary files in the specified directory.
} AcceptTemporaryDirectory temporaryDirectory
trace variable Option(-tmpdir) w \
[namespace code {normalizePath Option(-tmpdir) ;#}]
# Tests should not rely on the current working directory.
# Files that are part of the test suite should be accessed relative
# to [testsDirectory]
Option -testdir [workingDirectory] {
Search tests in the specified directory.
} AcceptDirectory testsDirectory
trace variable Option(-testdir) w \
[namespace code {normalizePath Option(-testdir) ;#}]
proc AcceptLoadFile { file } {
if {[string equal "" $file]} {return $file}
set file [file join [temporaryDirectory] $file]
return [AcceptReadable $file]
}
proc ReadLoadScript {args} {
variable Option
if {[string equal "" $Option(-loadfile)]} {return}
set tmp [open $Option(-loadfile) r]
loadScript [read $tmp]
close $tmp
}
Option -loadfile {} {
Read the script to load the tested commands from the specified file.
} AcceptLoadFile loadFile
trace variable Option(-loadfile) w [namespace code ReadLoadScript]
proc AcceptOutFile { file } {
if {[string equal stderr $file]} {return $file}
if {[string equal stdout $file]} {return $file}
return [file join [temporaryDirectory] $file]
}
# output goes to stdout by default
Option -outfile stdout {
Send output from test runs to the specified file.
} AcceptOutFile outputFile
trace variable Option(-outfile) w \
[namespace code {outputChannel $Option(-outfile) ;#}]
# errors go to stderr by default
Option -errfile stderr {
Send errors from test runs to the specified file.
} AcceptOutFile errorFile
trace variable Option(-errfile) w \
[namespace code {errorChannel $Option(-errfile) ;#}]
}
#####################################################################
# tcltest::Debug* --
#
# Internal helper procedures to write out debug information
# dependent on the chosen level. A test shell may overide
# them, f.e. to redirect the output into a different
# channel, or even into a GUI.
# tcltest::DebugPuts --
#
# Prints the specified string if the current debug level is
# higher than the provided level argument.
#
# Arguments:
# level The lowest debug level triggering the output
# string The string to print out.
#
# Results:
# Prints the string. Nothing else is allowed.
#
# Side Effects:
# None.
#
proc tcltest::DebugPuts {level string} {
variable debug
if {$debug >= $level} {
puts $string
}
return
}
# tcltest::DebugPArray --
#
# Prints the contents of the specified array if the current
# debug level is higher than the provided level argument
#
# Arguments:
# level The lowest debug level triggering the output
# arrayvar The name of the array to print out.
#
# Results:
# Prints the contents of the array. Nothing else is allowed.
#
# Side Effects:
# None.
#
proc tcltest::DebugPArray {level arrayvar} {
variable debug
if {$debug >= $level} {
catch {upvar $arrayvar $arrayvar}
parray $arrayvar
}
return
}
# Define our own [parray] in ::tcltest that will inherit use of the [puts]
# defined in ::tcltest. NOTE: Ought to construct with [info args] and
# [info default], but can't be bothered now. If [parray] changes, then
# this will need changing too.
auto_load ::parray
proc tcltest::parray {a {pattern *}} [info body ::parray]
# tcltest::DebugDo --
#
# Executes the script if the current debug level is greater than
# the provided level argument
#
# Arguments:
# level The lowest debug level triggering the execution.
# script The tcl script executed upon a debug level high enough.
#
# Results:
# Arbitrary side effects, dependent on the executed script.
#
# Side Effects:
# None.
#
proc tcltest::DebugDo {level script} {
variable debug
if {$debug >= $level} {
uplevel 1 $script
}
return
}
#####################################################################
proc tcltest::Warn {msg} {
puts [outputChannel] "WARNING: $msg"
}
# tcltest::mainThread
#
# Accessor command for tcltest variable mainThread.
#
proc tcltest::mainThread { {new ""} } {
variable mainThread
if {[llength [info level 0]] == 1} {
return $mainThread
}
set mainThread $new
}
# tcltest::testConstraint --
#
# sets a test constraint to a value; to do multiple constraints,
# call this proc multiple times. also returns the value of the
# named constraint if no value was supplied.
#
# Arguments:
# constraint - name of the constraint
# value - new value for constraint (should be boolean) - if not
# supplied, this is a query
#
# Results:
# content of tcltest::testConstraints($constraint)
#
# Side effects:
# none
proc tcltest::testConstraint {constraint {value ""}} {
variable testConstraints
variable Option
DebugPuts 3 "entering testConstraint $constraint $value"
if {[llength [info level 0]] == 2} {
return $testConstraints($constraint)
}
# Check for boolean values
if {[catch {expr {$value && $value}} msg]} {
return -code error $msg
}
if {[limitConstraints]
&& [lsearch -exact $Option(-constraints) $constraint] == -1} {
set value 0
}
set testConstraints($constraint) $value
}
# tcltest::interpreter --
#
# the interpreter name stored in tcltest::tcltest
#
# Arguments:
# executable name
#
# Results:
# content of tcltest::tcltest
#
# Side effects:
# None.
proc tcltest::interpreter { {interp ""} } {
variable tcltest
if {[llength [info level 0]] == 1} {
return $tcltest
}
if {[string equal {} $interp]} {
set tcltest {}
} else {
set tcltest $interp
}
}
#####################################################################
# tcltest::AddToSkippedBecause --
#
# Increments the variable used to track how many tests were
# skipped because of a particular constraint.
#
# Arguments:
# constraint The name of the constraint to be modified
#
# Results:
# Modifies tcltest::skippedBecause; sets the variable to 1 if
# didn't previously exist - otherwise, it just increments it.
#
# Side effects:
# None.
proc tcltest::AddToSkippedBecause { constraint {value 1}} {
# add the constraint to the list of constraints that kept tests
# from running
variable skippedBecause
if {[info exists skippedBecause($constraint)]} {
incr skippedBecause($constraint) $value
} else {
set skippedBecause($constraint) $value
}
return
}
# tcltest::PrintError --
#
# Prints errors to tcltest::errorChannel and then flushes that
# channel, making sure that all messages are < 80 characters per
# line.
#
# Arguments:
# errorMsg String containing the error to be printed
#
# Results:
# None.
#
# Side effects:
# None.
proc tcltest::PrintError {errorMsg} {
set InitialMessage "Error: "
set InitialMsgLen [string length $InitialMessage]
puts -nonewline [errorChannel] $InitialMessage
# Keep track of where the end of the string is.
set endingIndex [string length $errorMsg]
if {$endingIndex < (80 - $InitialMsgLen)} {
puts [errorChannel] $errorMsg
} else {
# Print up to 80 characters on the first line, including the
# InitialMessage.
set beginningIndex [string last " " [string range $errorMsg 0 \
[expr {80 - $InitialMsgLen}]]]
puts [errorChannel] [string range $errorMsg 0 $beginningIndex]
while {![string equal end $beginningIndex]} {
puts -nonewline [errorChannel] \
[string repeat " " $InitialMsgLen]
if {($endingIndex - $beginningIndex)
< (80 - $InitialMsgLen)} {
puts [errorChannel] [string trim \
[string range $errorMsg $beginningIndex end]]
break
} else {
set newEndingIndex [expr {[string last " " \
[string range $errorMsg $beginningIndex \
[expr {$beginningIndex
+ (80 - $InitialMsgLen)}]
]] + $beginningIndex}]
if {($newEndingIndex <= 0)
|| ($newEndingIndex <= $beginningIndex)} {
set newEndingIndex end
}
puts [errorChannel] [string trim \
[string range $errorMsg \
$beginningIndex $newEndingIndex]]
set beginningIndex $newEndingIndex
}
}
}
flush [errorChannel]
return
}
# tcltest::SafeFetch --
#
# The following trace procedure makes it so that we can safely
# refer to non-existent members of the testConstraints array
# without causing an error. Instead, reading a non-existent
# member will return 0. This is necessary because tests are
# allowed to use constraint "X" without ensuring that
# testConstraints("X") is defined.
#
# Arguments:
# n1 - name of the array (testConstraints)
# n2 - array key value (constraint name)
# op - operation performed on testConstraints (generally r)
#
# Results:
# none
#
# Side effects:
# sets testConstraints($n2) to 0 if it's referenced but never
# before used
proc tcltest::SafeFetch {n1 n2 op} {
variable testConstraints
DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
if {[string equal {} $n2]} {return}
if {![info exists testConstraints($n2)]} {
if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
testConstraint $n2 0
}
}
}
# tcltest::ConstraintInitializer --
#
# Get or set a script that when evaluated in the tcltest namespace
# will return a boolean value with which to initialize the
# associated constraint.
#
# Arguments:
# constraint - name of the constraint initialized by the script
# script - the initializer script
#
# Results
# boolean value of the constraint - enabled or disabled
#
# Side effects:
# Constraint is initialized for future reference by [test]
proc tcltest::ConstraintInitializer {constraint {script ""}} {
variable ConstraintInitializer
DebugPuts 3 "entering ConstraintInitializer $constraint $script"
if {[llength [info level 0]] == 2} {
return $ConstraintInitializer($constraint)
}
# Check for boolean values
if {![info complete $script]} {
return -code error "ConstraintInitializer must be complete script"
}
set ConstraintInitializer($constraint) $script
}
# tcltest::InitConstraints --
#
# Call all registered constraint initializers to force initialization
# of all known constraints.
# See the tcltest man page for the list of built-in constraints defined
# in this procedure.
#
# Arguments:
# none
#
# Results:
# The testConstraints array is reset to have an index for each
# built-in test constraint.
#
# Side Effects:
# None.
#
proc tcltest::InitConstraints {} {
variable ConstraintInitializer
initConstraintsHook
foreach constraint [array names ConstraintInitializer] {
testConstraint $constraint
}
}
proc tcltest::DefineConstraintInitializers {} {
ConstraintInitializer singleTestInterp {singleProcess}
# All the 'pc' constraints are here for backward compatibility and
# are not documented. They have been replaced with equivalent 'win'
# constraints.
ConstraintInitializer unixOnly \
{string equal $::tcl_platform(platform) unix}
ConstraintInitializer macOnly \
{string equal $::tcl_platform(platform) macintosh}
ConstraintInitializer pcOnly \
{string equal $::tcl_platform(platform) windows}
ConstraintInitializer winOnly \
{string equal $::tcl_platform(platform) windows}
ConstraintInitializer unix {testConstraint unixOnly}
ConstraintInitializer mac {testConstraint macOnly}
ConstraintInitializer pc {testConstraint pcOnly}
ConstraintInitializer win {testConstraint winOnly}
ConstraintInitializer unixOrPc \
{expr {[testConstraint unix] || [testConstraint pc]}}
ConstraintInitializer macOrPc \
{expr {[testConstraint mac] || [testConstraint pc]}}
ConstraintInitializer unixOrWin \
{expr {[testConstraint unix] || [testConstraint win]}}
ConstraintInitializer macOrWin \
{expr {[testConstraint mac] || [testConstraint win]}}
ConstraintInitializer macOrUnix \
{expr {[testConstraint mac] || [testConstraint unix]}}
ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"}
ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"}
ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"}
# The following Constraints switches are used to mark tests that
# should work, but have been temporarily disabled on certain
# platforms because they don't and we haven't gotten around to
# fixing the underlying problem.
ConstraintInitializer tempNotPc {expr {![testConstraint pc]}}
ConstraintInitializer tempNotWin {expr {![testConstraint win]}}
ConstraintInitializer tempNotMac {expr {![testConstraint mac]}}
ConstraintInitializer tempNotUnix {expr {![testConstraint unix]}}
# The following Constraints switches are used to mark tests that
# crash on certain platforms, so that they can be reactivated again
# when the underlying problem is fixed.
ConstraintInitializer pcCrash {expr {![testConstraint pc]}}
ConstraintInitializer winCrash {expr {![testConstraint win]}}
ConstraintInitializer macCrash {expr {![testConstraint mac]}}
ConstraintInitializer unixCrash {expr {![testConstraint unix]}}
# Skip empty tests
ConstraintInitializer emptyTest {format 0}
# By default, tests that expose known bugs are skipped.
ConstraintInitializer knownBug {format 0}
# By default, non-portable tests are skipped.
ConstraintInitializer nonPortable {format 0}
# Some tests require user interaction.
ConstraintInitializer userInteraction {format 0}
# Some tests must be skipped if the interpreter is not in
# interactive mode
ConstraintInitializer interactive \
{expr {[info exists ::tcl_interactive] && $::tcl_interactive}}
# Some tests can only be run if the installation came from a CD
# image instead of a web image. Some tests must be skipped if you
# are running as root on Unix. Other tests can only be run if you
# are running as root on Unix.
ConstraintInitializer root {expr \
{[string equal unix $::tcl_platform(platform)]
&& ([string equal root $::tcl_platform(user)]
|| [string equal "" $::tcl_platform(user)])}}
ConstraintInitializer notRoot {expr {![testConstraint root]}}
# Set nonBlockFiles constraint: 1 means this platform supports
# setting files into nonblocking mode.
ConstraintInitializer nonBlockFiles {
set code [expr {[catch {set f [open defs r]}]
|| [catch {fconfigure $f -blocking off}]}]
catch {close $f}
set code
}
# Set asyncPipeClose constraint: 1 means this platform supports
# async flush and async close on a pipe.
#
# Test for SCO Unix - cannot run async flushing tests because a
# potential problem with select is apparently interfering.
# (Mark Diekhans).
ConstraintInitializer asyncPipeClose {expr {
!([string equal unix $::tcl_platform(platform)]
&& ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}}
# Test to see if we have a broken version of sprintf with respect
# to the "e" format of floating-point numbers.
ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}
# Test to see if execed commands such as cat, echo, rm and so forth
# are present on this machine.
ConstraintInitializer unixExecs {
set code 1
if {[string equal macintosh $::tcl_platform(platform)]} {
set code 0
}
if {[string equal windows $::tcl_platform(platform)]} {
if {[catch {
set file _tcl_test_remove_me.txt
makeFile {hello} $file
}]} {
set code 0
} elseif {
[catch {exec cat $file}] ||
[catch {exec echo hello}] ||
[catch {exec sh -c echo hello}] ||
[catch {exec wc $file}] ||
[catch {exec sleep 1}] ||
[catch {exec echo abc > $file}] ||
[catch {exec chmod 644 $file}] ||
[catch {exec rm $file}] ||
[llength [auto_execok mkdir]] == 0 ||
[llength [auto_execok fgrep]] == 0 ||
[llength [auto_execok grep]] == 0 ||
[llength [auto_execok ps]] == 0
} {
set code 0
}
removeFile $file
}
set code
}
ConstraintInitializer stdio {
set code 0
if {![catch {set f [open "|[list [interpreter]]" w]}]} {
if {![catch {puts $f exit}]} {
if {![catch {close $f}]} {
set code 1
}
}
}
set code
}
# Deliberately call socket with the wrong number of arguments. The
# error message you get will indicate whether sockets are available
# on this system.
ConstraintInitializer socket {
catch {socket} msg
string compare $msg "sockets are not available on this system"
}
# Check for internationalization
ConstraintInitializer hasIsoLocale {
if {[llength [info commands testlocale]] == 0} {
set code 0
} else {
set code [string length [SetIso8859_1_Locale]]
RestoreLocale
}
set code
}
}
#####################################################################
# Usage and command line arguments processing.
# tcltest::PrintUsageInfo
#
# Prints out the usage information for package tcltest. This can
# be customized with the redefinition of [PrintUsageInfoHook].
#
# Arguments:
# none
#
# Results:
# none
#
# Side Effects:
# none
proc tcltest::PrintUsageInfo {} {
puts [Usage]
PrintUsageInfoHook
}
proc tcltest::Usage { {option ""} } {
variable Usage
variable Verify
if {[llength [info level 0]] == 1} {
set msg "Usage: [file tail [info nameofexecutable]] script "
append msg "?-help? ?flag value? ... \n"
append msg "Available flags (and valid input values) are:"
set max 0
set allOpts [concat -help [Configure]]
foreach opt $allOpts {
set foo [Usage $opt]
foreach [list x type($opt) usage($opt)] $foo break
set line($opt) " $opt $type($opt) "
set length($opt) [string length $line($opt)]
if {$length($opt) > $max} {set max $length($opt)}
}
set rest [expr {72 - $max}]
foreach opt $allOpts {
append msg \n$line($opt)
append msg [string repeat " " [expr {$max - $length($opt)}]]
set u [string trim $usage($opt)]
catch {append u " (default: \[[Configure $opt]])"}
regsub -all {\s*\n\s*} $u " " u
while {[string length $u] > $rest} {
set break [string wordstart $u $rest]
if {$break == 0} {
set break [string wordend $u 0]
}
append msg [string range $u 0 [expr {$break - 1}]]
set u [string trim [string range $u $break end]]
append msg \n[string repeat " " $max]
}
append msg $u
}
return $msg\n
} elseif {[string equal -help $option]} {
return [list -help "" "Display this usage information."]
} else {
set type [lindex [info args $Verify($option)] 0]
return [list $option $type $Usage($option)]
}
}
# tcltest::ProcessFlags --
#
# process command line arguments supplied in the flagArray - this
# is called by processCmdLineArgs. Modifies tcltest variables
# according to the content of the flagArray.
#
# Arguments:
# flagArray - array containing name/value pairs of flags
#
# Results:
# sets tcltest variables according to their values as defined by
# flagArray
#
# Side effects:
# None.
proc tcltest::ProcessFlags {flagArray} {
# Process -help first
if {[lsearch -exact $flagArray {-help}] != -1} {
PrintUsageInfo
exit 1
}
if {[llength $flagArray] == 0} {
RemoveAutoConfigureTraces
} else {
set args $flagArray
while {[llength $args]>1 && [catch {eval configure $args} msg]} {
# Something went wrong parsing $args for tcltest options
# Check whether the problem is "unknown option"
if {[regexp {^unknown option (\S+):} $msg -> option]} {
# Could be this is an option the Hook knows about
set moreOptions [processCmdLineArgsAddFlagsHook]
if {[lsearch -exact $moreOptions $option] == -1} {
# Nope. Report the error, including additional options,
# but keep going
if {[llength $moreOptions]} {
append msg ", "
append msg [join [lrange $moreOptions 0 end-1] ", "]
append msg "or [lindex $moreOptions end]"
}
Warn $msg
}
} else {
# error is something other than "unknown option"
# notify user of the error; and exit
puts [errorChannel] $msg
exit 1
}
# To recover, find that unknown option and remove up to it.
# then retry
while {![string equal [lindex $args 0] $option]} {
set args [lrange $args 2 end]
}
set args [lrange $args 2 end]
}
if {[llength $args] == 1} {
puts [errorChannel] \
"missing value for option [lindex $args 0]"
exit 1
}
}
# Call the hook
catch {
array set flag $flagArray
processCmdLineArgsHook [array get flag]
}
return
}
# tcltest::ProcessCmdLineArgs --
#
# This procedure must be run after constraint initialization is
# set up (by [DefineConstraintInitializers]) because some constraints
# can be overridden.
#
# Perform configuration according to the command-line options.
#
# Arguments:
# none
#
# Results:
# Sets the above-named variables in the tcltest namespace.
#
# Side Effects:
# None.
#
proc tcltest::ProcessCmdLineArgs {} {
variable originalEnv
variable testConstraints
# The "argv" var doesn't exist in some cases, so use {}.
if {![info exists ::argv]} {
ProcessFlags {}
} else {
ProcessFlags $::argv
}
# Spit out everything you know if we're at a debug level 2 or
# greater
DebugPuts 2 "Flags passed into tcltest:"
if {[info exists ::env(TCLTEST_OPTIONS)]} {
DebugPuts 2 \
" ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
}
if {[info exists ::argv]} {
DebugPuts 2 " argv: $::argv"
}
DebugPuts 2 "tcltest::debug = [debug]"
DebugPuts 2 "tcltest::testsDirectory = [testsDirectory]"
DebugPuts 2 "tcltest::workingDirectory = [workingDirectory]"
DebugPuts 2 "tcltest::temporaryDirectory = [temporaryDirectory]"
DebugPuts 2 "tcltest::outputChannel = [outputChannel]"
DebugPuts 2 "tcltest::errorChannel = [errorChannel]"
DebugPuts 2 "Original environment (tcltest::originalEnv):"
DebugPArray 2 originalEnv
DebugPuts 2 "Constraints:"
DebugPArray 2 testConstraints
}
#####################################################################
# Code to run the tests goes here.
# tcltest::TestPuts --
#
# Used to redefine puts in test environment. Stores whatever goes
# out on stdout in tcltest::outData and stderr in errData before
# sending it on to the regular puts.
#
# Arguments:
# same as standard puts
#
# Results:
# none
#
# Side effects:
# Intercepts puts; data that would otherwise go to stdout, stderr,
# or file channels specified in outputChannel and errorChannel
# does not get sent to the normal puts function.
namespace eval tcltest::Replace {
namespace export puts
}
proc tcltest::Replace::puts {args} {
variable [namespace parent]::outData
variable [namespace parent]::errData
switch [llength $args] {
1 {
# Only the string to be printed is specified
append outData [lindex $args 0]\n
return
# return [Puts [lindex $args 0]]
}
2 {
# Either -nonewline or channelId has been specified
if {[string equal -nonewline [lindex $args 0]]} {
append outData [lindex $args end]
return
# return [Puts -nonewline [lindex $args end]]
} else {
set channel [lindex $args 0]
set newline \n
}
}
3 {
if {[string equal -nonewline [lindex $args 0]]} {
# Both -nonewline and channelId are specified, unless
# it's an error. -nonewline is supposed to be argv[0].
set channel [lindex $args 1]
set newline ""
}
}
}
if {[info exists channel]} {
if {[string equal $channel [[namespace parent]::outputChannel]]
|| [string equal $channel stdout]} {
append outData [lindex $args end]$newline
return
} elseif {[string equal $channel [[namespace parent]::errorChannel]]
|| [string equal $channel stderr]} {
append errData [lindex $args end]$newline
return
}
}
# If we haven't returned by now, we don't know how to handle the
# input. Let puts handle it.
return [eval Puts $args]
}
# tcltest::Eval --
#
# Evaluate the script in the test environment. If ignoreOutput is
# false, store data sent to stderr and stdout in outData and
# errData. Otherwise, ignore this output altogether.
#
# Arguments:
# script Script to evaluate
# ?ignoreOutput? Indicates whether or not to ignore output
# sent to stdout & stderr
#
# Results:
# result from running the script
#
# Side effects:
# Empties the contents of outData and errData before running a
# test if ignoreOutput is set to 0.
proc tcltest::Eval {script {ignoreOutput 1}} {
variable outData
variable errData
DebugPuts 3 "[lindex [info level 0] 0] called"
if {!$ignoreOutput} {
set outData {}
set errData {}
rename ::puts [namespace current]::Replace::Puts
namespace eval :: \
[list namespace import [namespace origin Replace::puts]]
namespace import Replace::puts
}
set result [uplevel 1 $script]
if {!$ignoreOutput} {
namespace forget puts
namespace eval :: namespace forget puts
rename [namespace current]::Replace::Puts ::puts
}
return $result
}
# tcltest::CompareStrings --
#
# compares the expected answer to the actual answer, depending on
# the mode provided. Mode determines whether a regexp, exact,
# glob or custom comparison is done.
#
# Arguments:
# actual - string containing the actual result
# expected - pattern to be matched against
# mode - type of comparison to be done
#
# Results:
# result of the match
#
# Side effects:
# None.
proc tcltest::CompareStrings {actual expected mode} {
variable CustomMatch
if {![info exists CustomMatch($mode)]} {
return -code error "No matching command registered for `-match $mode'"
}
set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]]
if {[catch {expr {$match && $match}} result]} {
return -code error "Invalid result from `-match $mode' command: $result"
}
return $match
}
# tcltest::customMatch --
#
# registers a command to be called when a particular type of
# matching is required.
#
# Arguments:
# nickname - Keyword for the type of matching
# cmd - Incomplete command that implements that type of matching
# when completed with expected string and actual string
# and then evaluated.
#
# Results:
# None.
#
# Side effects:
# Sets the variable tcltest::CustomMatch
proc tcltest::customMatch {mode script} {
variable CustomMatch
if {![info complete $script]} {
return -code error \
"invalid customMatch script; can't evaluate after completion"
}
set CustomMatch($mode) $script
}
# tcltest::SubstArguments list
#
# This helper function takes in a list of words, then perform a
# substitution on the list as though each word in the list is a separate
# argument to the Tcl function. For example, if this function is
# invoked as:
#
# SubstArguments {$a {$a}}
#
# Then it is as though the function is invoked as:
#
# SubstArguments $a {$a}
#
# This code is adapted from Paul Duffin's function "SplitIntoWords".
# The original function can be found on:
#
# http://purl.org/thecliff/tcl/wiki/858.html
#
# Results:
# a list containing the result of the substitution
#
# Exceptions:
# An error may occur if the list containing unbalanced quote or
# unknown variable.
#
# Side Effects:
# None.
#
proc tcltest::SubstArguments {argList} {
# We need to split the argList up into tokens but cannot use list
# operations as they throw away some significant quoting, and
# [split] ignores braces as it should. Therefore what we do is
# gradually build up a string out of whitespace seperated strings.
# We cannot use [split] to split the argList into whitespace
# separated strings as it throws away the whitespace which maybe
# important so we have to do it all by hand.
set result {}
set token ""
while {[string length $argList]} {
# Look for the next word containing a quote: " { }
if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
$argList all]} {
# Get the text leading up to this word, but not including
# this word, from the argList.
set text [string range $argList 0 \
[expr {[lindex $all 0] - 1}]]
# Get the word with the quote
set word [string range $argList \
[lindex $all 0] [lindex $all 1]]
# Remove all text up to and including the word from the
# argList.
set argList [string range $argList \
[expr {[lindex $all 1] + 1}] end]
} else {
# Take everything up to the end of the argList.
set text $argList
set word {}
set argList {}
}
if {$token != {}} {
# If we saw a word with quote before, then there is a
# multi-word token starting with that word. In this case,
# add the text and the current word to this token.
append token $text $word
} else {
# Add the text to the result. There is no need to parse
# the text because it couldn't be a part of any multi-word
# token. Then start a new multi-word token with the word
# because we need to pass this token to the Tcl parser to
# check for balancing quotes
append result $text
set token $word
}
if { [catch {llength $token} length] == 0 && $length == 1} {
# The token is a valid list so add it to the result.
# lappend result [string trim $token]
append result \{$token\}
set token {}
}
}
# If the last token has not been added to the list then there
# is a problem.
if { [string length $token] } {
error "incomplete token \"$token\""
}
return $result
}
# tcltest::test --
#
# This procedure runs a test and prints an error message if the test
# fails. If verbose has been set, it also prints a message even if the
# test succeeds. The test will be skipped if it doesn't match the
# match variable, if it matches an element in skip, or if one of the
# elements of "constraints" turns out not to be true.
#
# If testLevel is 1, then this is a top level test, and we record
# pass/fail information; otherwise, this information is not logged and
# is not added to running totals.
#
# Attributes:
# Only description is a required attribute. All others are optional.
# Default values are indicated.
#
# constraints - A list of one or more keywords, each of which
# must be the name of an element in the array
# "testConstraints". If any of these elements is
# zero, the test is skipped. This attribute is
# optional; default is {}
# body - Script to run to carry out the test. It must
# return a result that can be checked for
# correctness. This attribute is optional;
# default is {}
# result - Expected result from script. This attribute is
# optional; default is {}.
# output - Expected output sent to stdout. This attribute
# is optional; default is {}.
# errorOutput - Expected output sent to stderr. This attribute
# is optional; default is {}.
# returnCodes - Expected return codes. This attribute is
# optional; default is {0 2}.
# setup - Code to run before $script (above). This
# attribute is optional; default is {}.
# cleanup - Code to run after $script (above). This
# attribute is optional; default is {}.
# match - specifies type of matching to do on result,
# output, errorOutput; this must be a string
# previously registered by a call to [customMatch].
# The strings exact, glob, and regexp are pre-registered
# by the tcltest package. Default value is exact.
#
# Arguments:
# name - Name of test, in the form foo-1.2.
# description - Short textual description of the test, to
# help humans understand what it does.
#
# Results:
# None.
#
# Side effects:
# Just about anything is possible depending on the test.
#
proc tcltest::test {name description args} {
global tcl_platform
variable testLevel
variable coreModTime
DebugPuts 3 "test $name $args"
DebugDo 1 {
variable TestNames
catch {
puts "test name '$name' re-used; prior use in $TestNames($name)"
}
set TestNames($name) [info script]
}
FillFilesExisted
incr testLevel
# Pre-define everything to null except output and errorOutput. We
# determine whether or not to trap output based on whether or not
# these variables (output & errorOutput) are defined.
foreach item {constraints setup cleanup body result returnCodes
match} {
set $item {}
}
# Set the default match mode
set match exact
# Set the default match values for return codes (0 is the standard
# expected return value if everything went well; 2 represents
# 'return' being used in the test script).
set returnCodes [list 0 2]
# The old test format can't have a 3rd argument (constraints or
# script) that starts with '-'.
if {[string match -* [lindex $args 0]]
|| ([llength $args] <= 1)} {
if {[llength $args] == 1} {
set list [SubstArguments [lindex $args 0]]
foreach {element value} $list {
set testAttributes($element) $value
}
foreach item {constraints match setup body cleanup \
result returnCodes output errorOutput} {
if {[info exists testAttributes(-$item)]} {
set testAttributes(-$item) [uplevel 1 \
::concat $testAttributes(-$item)]
}
}
} else {
array set testAttributes $args
}
set validFlags {-setup -cleanup -body -result -returnCodes \
-match -output -errorOutput -constraints}
foreach flag [array names testAttributes] {
if {[lsearch -exact $validFlags $flag] == -1} {
incr testLevel -1
set sorted [lsort $validFlags]
set options [join [lrange $sorted 0 end-1] ", "]
append options ", or [lindex $sorted end]"
return -code error "bad option \"$flag\": must be $options"
}
}
# store whatever the user gave us
foreach item [array names testAttributes] {
set [string trimleft $item "-"] $testAttributes($item)
}
# Check the values supplied for -match
variable CustomMatch
if {[lsearch [array names CustomMatch] $match] == -1} {
incr testLevel -1
set sorted [lsort [array names CustomMatch]]
set values [join [lrange $sorted 0 end-1] ", "]
append values ", or [lindex $sorted end]"
return -code error "bad -match value \"$match\":\
must be $values"
}
# Replace symbolic valies supplied for -returnCodes
foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
}
} else {
# This is parsing for the old test command format; it is here
# for backward compatibility.
set result [lindex $args end]
if {[llength $args] == 2} {
set body [lindex $args 0]
} elseif {[llength $args] == 3} {
set constraints [lindex $args 0]
set body [lindex $args 1]
} else {
incr testLevel -1
return -code error "wrong # args:\
should be \"test name desc ?options?\""
}
}
if {[Skipped $name $constraints]} {
incr testLevel -1
return
}
# Save information about the core file.
if {[preserveCore]} {
if {[file exists [file join [workingDirectory] core]]} {
set coreModTime [file mtime [file join [workingDirectory] core]]
}
}
# First, run the setup script
set code [catch {uplevel 1 $setup} setupMsg]
if {$code == 1} {
set errorInfo(setup) $::errorInfo
set errorCode(setup) $::errorCode
}
set setupFailure [expr {$code != 0}]
# Only run the test body if the setup was successful
if {!$setupFailure} {
# Verbose notification of $body start
if {[IsVerbose start]} {
puts [outputChannel] "---- $name start"
flush [outputChannel]
}
set command [list [namespace origin RunTest] $name $body]
if {[info exists output] || [info exists errorOutput]} {
set testResult [uplevel 1 [list [namespace origin Eval] $command 0]]
} else {
set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
}
foreach {actualAnswer returnCode} $testResult break
if {$returnCode == 1} {
set errorInfo(body) $::errorInfo
set errorCode(body) $::errorCode
}
}
# Always run the cleanup script
set code [catch {uplevel 1 $cleanup} cleanupMsg]
if {$code == 1} {
set errorInfo(cleanup) $::errorInfo
set errorCode(cleanup) $::errorCode
}
set cleanupFailure [expr {$code != 0}]
set coreFailure 0
set coreMsg ""
# check for a core file first - if one was created by the test,
# then the test failed
if {[preserveCore]} {
if {[file exists [file join [workingDirectory] core]]} {
# There's only a test failure if there is a core file
# and (1) there previously wasn't one or (2) the new
# one is different from the old one.
if {[info exists coreModTime]} {
if {$coreModTime != [file mtime \
[file join [workingDirectory] core]]} {
set coreFailure 1
}
} else {
set coreFailure 1
}
if {([preserveCore] > 1) && ($coreFailure)} {
append coreMsg "\nMoving file to:\
[file join [temporaryDirectory] core-$name]"
catch {file rename -force \
[file join [workingDirectory] core] \
[file join [temporaryDirectory] core-$name]
} msg
if {[string length $msg] > 0} {
append coreMsg "\nError:\
Problem renaming core file: $msg"
}
}
}
}
# check if the return code matched the expected return code
set codeFailure 0
if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} {
set codeFailure 1
}
# If expected output/error strings exist, we have to compare
# them. If the comparison fails, then so did the test.
set outputFailure 0
variable outData
if {[info exists output] && !$codeFailure} {
if {[set outputCompare [catch {
CompareStrings $outData $output $match
} outputMatch]] == 0} {
set outputFailure [expr {!$outputMatch}]
} else {
set outputFailure 1
}
}
set errorFailure 0
variable errData
if {[info exists errorOutput] && !$codeFailure} {
if {[set errorCompare [catch {
CompareStrings $errData $errorOutput $match
} errorMatch]] == 0} {
set errorFailure [expr {!$errorMatch}]
} else {
set errorFailure 1
}
}
# check if the answer matched the expected answer
# Only check if we ran the body of the test (no setup failure)
if {$setupFailure || $codeFailure} {
set scriptFailure 0
} elseif {[set scriptCompare [catch {
CompareStrings $actualAnswer $result $match
} scriptMatch]] == 0} {
set scriptFailure [expr {!$scriptMatch}]
} else {
set scriptFailure 1
}
# if we didn't experience any failures, then we passed
variable numTests
if {!($setupFailure || $cleanupFailure || $coreFailure
|| $outputFailure || $errorFailure || $codeFailure
|| $scriptFailure)} {
if {$testLevel == 1} {
incr numTests(Passed)
if {[IsVerbose pass]} {
puts [outputChannel] "++++ $name PASSED"
}
}
incr testLevel -1
return
}
# We know the test failed, tally it...
if {$testLevel == 1} {
incr numTests(Failed)
}
# ... then report according to the type of failure
variable currentFailure true
if {![IsVerbose body]} {
set body ""
}
puts [outputChannel] "\n==== $name\
[string trim $description] FAILED"
if {[string length $body]} {
puts [outputChannel] "==== Contents of test case:"
puts [outputChannel] $body
}
if {$setupFailure} {
puts [outputChannel] "---- Test setup\
failed:\n$setupMsg"
if {[info exists errorInfo(setup)]} {
puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)"
puts [outputChannel] "---- errorCode(setup): $errorCode(setup)"
}
}
if {$scriptFailure} {
if {$scriptCompare} {
puts [outputChannel] "---- Error testing result: $scriptMatch"
} else {
puts [outputChannel] "---- Result was:\n$actualAnswer"
puts [outputChannel] "---- Result should have been\
($match matching):\n$result"
}
}
if {$codeFailure} {
switch -- $returnCode {
0 { set msg "Test completed normally" }
1 { set msg "Test generated error" }
2 { set msg "Test generated return exception" }
3 { set msg "Test generated break exception" }
4 { set msg "Test generated continue exception" }
default { set msg "Test generated exception" }
}
puts [outputChannel] "---- $msg; Return code was: $returnCode"
puts [outputChannel] "---- Return code should have been\
one of: $returnCodes"
if {[IsVerbose error]} {
if {[info exists errorInfo(body)] && ([lsearch $returnCodes 1]<0)} {
puts [outputChannel] "---- errorInfo: $errorInfo(body)"
puts [outputChannel] "---- errorCode: $errorCode(body)"
}
}
}
if {$outputFailure} {
if {$outputCompare} {
puts [outputChannel] "---- Error testing output: $outputMatch"
} else {
puts [outputChannel] "---- Output was:\n$outData"
puts [outputChannel] "---- Output should have been\
($match matching):\n$output"
}
}
if {$errorFailure} {
if {$errorCompare} {
puts [outputChannel] "---- Error testing errorOutput: $errorMatch"
} else {
puts [outputChannel] "---- Error output was:\n$errData"
puts [outputChannel] "---- Error output should have\
been ($match matching):\n$errorOutput"
}
}
if {$cleanupFailure} {
puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
if {[info exists errorInfo(cleanup)]} {
puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)"
puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)"
}
}
if {$coreFailure} {
puts [outputChannel] "---- Core file produced while running\
test! $coreMsg"
}
puts [outputChannel] "==== $name FAILED\n"
incr testLevel -1
return
}
# Skipped --
#
# Given a test name and it constraints, returns a boolean indicating
# whether the current configuration says the test should be skipped.
#
# Side Effects: Maintains tally of total tests seen and tests skipped.
#
proc tcltest::Skipped {name constraints} {
variable testLevel
variable numTests
variable testConstraints
if {$testLevel == 1} {
incr numTests(Total)
}
# skip the test if it's name matches an element of skip
foreach pattern [skip] {
if {[string match $pattern $name]} {
if {$testLevel == 1} {
incr numTests(Skipped)
DebugDo 1 {AddToSkippedBecause userSpecifiedSkip}
}
return 1
}
}
# skip the test if it's name doesn't match any element of match
set ok 0
foreach pattern [match] {
if {[string match $pattern $name]} {
set ok 1
break
}
}
if {!$ok} {
if {$testLevel == 1} {
incr numTests(Skipped)
DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch}
}
return 1
}
if {[string equal {} $constraints]} {
# If we're limited to the listed constraints and there aren't
# any listed, then we shouldn't run the test.
if {[limitConstraints]} {
AddToSkippedBecause userSpecifiedLimitConstraint
if {$testLevel == 1} {
incr numTests(Skipped)
}
return 1
}
} else {
# "constraints" argument exists;
# make sure that the constraints are satisfied.
set doTest 0
if {[string match {*[$\[]*} $constraints] != 0} {
# full expression, e.g. {$foo > [info tclversion]}
catch {set doTest [uplevel #0 expr $constraints]}
} elseif {[regexp {[^.a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
# something like {a || b} should be turned into
# $testConstraints(a) || $testConstraints(b).
regsub -all {[.\w]+} $constraints {$testConstraints(&)} c
catch {set doTest [eval expr $c]}
} elseif {![catch {llength $constraints}]} {
# just simple constraints such as {unixOnly fonts}.
set doTest 1
foreach constraint $constraints {
if {(![info exists testConstraints($constraint)]) \
|| (!$testConstraints($constraint))} {
set doTest 0
# store the constraint that kept the test from
# running
set constraints $constraint
break
}
}
}
if {$doTest == 0} {
if {[IsVerbose skip]} {
puts [outputChannel] "++++ $name SKIPPED: $constraints"
}
if {$testLevel == 1} {
incr numTests(Skipped)
AddToSkippedBecause $constraints
}
return 1
}
}
return 0
}
# RunTest --
#
# This is where the body of a test is evaluated. The combination of
# [RunTest] and [Eval] allows the output and error output of the test
# body to be captured for comparison against the expected values.
proc tcltest::RunTest {name script} {
DebugPuts 3 "Running $name {$script}"
# If there is no "memory" command (because memory debugging isn't
# enabled), then don't attempt to use the command.
if {[llength [info commands memory]] == 1} {
memory tag $name
}
set code [catch {uplevel 1 $script} actualAnswer]
return [list $actualAnswer $code]
}
#####################################################################
# tcltest::cleanupTestsHook --
#
# This hook allows a harness that builds upon tcltest to specify
# additional things that should be done at cleanup.
#
if {[llength [info commands tcltest::cleanupTestsHook]] == 0} {
proc tcltest::cleanupTestsHook {} {}
}
# tcltest::cleanupTests --
#
# Remove files and dirs created using the makeFile and makeDirectory
# commands since the last time this proc was invoked.
#
# Print the names of the files created without the makeFile command
# since the tests were invoked.
#
# Print the number tests (total, passed, failed, and skipped) since the
# tests were invoked.
#
# Restore original environment (as reported by special variable env).
#
# Arguments:
# calledFromAllFile - if 0, behave as if we are running a single
# test file within an entire suite of tests. if we aren't running
# a single test file, then don't report status. check for new
# files created during the test run and report on them. if 1,
# report collated status from all the test file runs.
#
# Results:
# None.
#
# Side Effects:
# None
#
proc tcltest::cleanupTests {{calledFromAllFile 0}} {
variable filesMade
variable filesExisted
variable createdNewFiles
variable testSingleFile
variable numTests
variable numTestFiles
variable failFiles
variable skippedBecause
variable currentFailure
variable originalEnv
variable originalTclPlatform
variable coreModTime
FillFilesExisted
set testFileName [file tail [info script]]
# Call the cleanup hook
cleanupTestsHook
# Remove files and directories created by the makeFile and
# makeDirectory procedures. Record the names of files in
# workingDirectory that were not pre-existing, and associate them
# with the test file that created them.
if {!$calledFromAllFile} {
foreach file $filesMade {
if {[file exists $file]} {
DebugDo 1 {Warn "cleanupTests deleting $file..."}
catch {file delete -force $file}
}
}
set currentFiles {}
foreach file [glob -nocomplain \
-directory [temporaryDirectory] *] {
lappend currentFiles [file tail $file]
}
set newFiles {}
foreach file $currentFiles {
if {[lsearch -exact $filesExisted $file] == -1} {
lappend newFiles $file
}
}
set filesExisted $currentFiles
if {[llength $newFiles] > 0} {
set createdNewFiles($testFileName) $newFiles
}
}
if {$calledFromAllFile || $testSingleFile} {
# print stats
puts -nonewline [outputChannel] "$testFileName:"
foreach index [list "Total" "Passed" "Skipped" "Failed"] {
puts -nonewline [outputChannel] \
"\t$index\t$numTests($index)"
}
puts [outputChannel] ""
# print number test files sourced
# print names of files that ran tests which failed
if {$calledFromAllFile} {
puts [outputChannel] \
"Sourced $numTestFiles Test Files."
set numTestFiles 0
if {[llength $failFiles] > 0} {
puts [outputChannel] \
"Files with failing tests: $failFiles"
set failFiles {}
}
}
# if any tests were skipped, print the constraints that kept
# them from running.
set constraintList [array names skippedBecause]
if {[llength $constraintList] > 0} {
puts [outputChannel] \
"Number of tests skipped for each constraint:"
foreach constraint [lsort $constraintList] {
puts [outputChannel] \
"\t$skippedBecause($constraint)\t$constraint"
unset skippedBecause($constraint)
}
}
# report the names of test files in createdNewFiles, and reset
# the array to be empty.
set testFilesThatTurded [lsort [array names createdNewFiles]]
if {[llength $testFilesThatTurded] > 0} {
puts [outputChannel] "Warning: files left behind:"
foreach testFile $testFilesThatTurded {
puts [outputChannel] \
"\t$testFile:\t$createdNewFiles($testFile)"
unset createdNewFiles($testFile)
}
}
# reset filesMade, filesExisted, and numTests
set filesMade {}
foreach index [list "Total" "Passed" "Skipped" "Failed"] {
set numTests($index) 0
}
# exit only if running Tk in non-interactive mode
# This should be changed to determine if an event
# loop is running, which is the real issue.
# Actually, this doesn't belong here at all. A package
# really has no business [exit]-ing an application.
if {![catch {package present Tk}] && ![testConstraint interactive]} {
exit
}
} else {
# if we're deferring stat-reporting until all files are sourced,
# then add current file to failFile list if any tests in this
# file failed
if {$currentFailure \
&& ([lsearch -exact $failFiles $testFileName] == -1)} {
lappend failFiles $testFileName
}
set currentFailure false
# restore the environment to the state it was in before this package
# was loaded
set newEnv {}
set changedEnv {}
set removedEnv {}
foreach index [array names ::env] {
if {![info exists originalEnv($index)]} {
lappend newEnv $index
unset ::env($index)
} else {
if {$::env($index) != $originalEnv($index)} {
lappend changedEnv $index
set ::env($index) $originalEnv($index)
}
}
}
foreach index [array names originalEnv] {
if {![info exists ::env($index)]} {
lappend removedEnv $index
set ::env($index) $originalEnv($index)
}
}
if {[llength $newEnv] > 0} {
puts [outputChannel] \
"env array elements created:\t$newEnv"
}
if {[llength $changedEnv] > 0} {
puts [outputChannel] \
"env array elements changed:\t$changedEnv"
}
if {[llength $removedEnv] > 0} {
puts [outputChannel] \
"env array elements removed:\t$removedEnv"
}
set changedTclPlatform {}
foreach index [array names originalTclPlatform] {
if {$::tcl_platform($index) \
!= $originalTclPlatform($index)} {
lappend changedTclPlatform $index
set ::tcl_platform($index) $originalTclPlatform($index)
}
}
if {[llength $changedTclPlatform] > 0} {
puts [outputChannel] "tcl_platform array elements\
changed:\t$changedTclPlatform"
}
if {[file exists [file join [workingDirectory] core]]} {
if {[preserveCore] > 1} {
puts "rename core file (> 1)"
puts [outputChannel] "produced core file! \
Moving file to: \
[file join [temporaryDirectory] core-$testFileName]"
catch {file rename -force \
[file join [workingDirectory] core] \
[file join [temporaryDirectory] core-$testFileName]
} msg
if {[string length $msg] > 0} {
PrintError "Problem renaming file: $msg"
}
} else {
# Print a message if there is a core file and (1) there
# previously wasn't one or (2) the new one is different
# from the old one.
if {[info exists coreModTime]} {
if {$coreModTime != [file mtime \
[file join [workingDirectory] core]]} {
puts [outputChannel] "A core file was created!"
}
} else {
puts [outputChannel] "A core file was created!"
}
}
}
}
flush [outputChannel]
flush [errorChannel]
return
}
#####################################################################
# Procs that determine which tests/test files to run
# tcltest::GetMatchingFiles
#
# Looks at the patterns given to match and skip files and uses
# them to put together a list of the tests that will be run.
#
# Arguments:
# directory to search
#
# Results:
# The constructed list is returned to the user. This will
# primarily be used in 'all.tcl' files. It is used in
# runAllTests.
#
# Side Effects:
# None
# a lower case version is needed for compatibility with tcltest 1.0
proc tcltest::getMatchingFiles args {eval GetMatchingFiles $args}
proc tcltest::GetMatchingFiles { args } {
if {[llength $args]} {
set dirList $args
} else {
# Finding tests only in [testsDirectory] is normal operation.
# This procedure is written to accept multiple directory arguments
# only to satisfy version 1 compatibility.
set dirList [list [testsDirectory]]
}
set matchingFiles [list]
foreach directory $dirList {
# List files in $directory that match patterns to run.
set matchFileList [list]
foreach match [matchFiles] {
set matchFileList [concat $matchFileList \
[glob -directory $directory -nocomplain -- $match]]
}
# List files in $directory that match patterns to skip.
set skipFileList [list]
foreach skip [skipFiles] {
set skipFileList [concat $skipFileList \
[glob -directory $directory -nocomplain -- $skip]]
}
# Add to result list all files in match list and not in skip list
foreach file $matchFileList {
if {[lsearch -exact $skipFileList $file] == -1} {
lappend matchingFiles $file
}
}
}
if {[llength $matchingFiles] == 0} {
PrintError "No test files remain after applying your match and\
skip patterns!"
}
return $matchingFiles
}
# tcltest::GetMatchingDirectories --
#
# Looks at the patterns given to match and skip directories and
# uses them to put together a list of the test directories that we
# should attempt to run. (Only subdirectories containing an
# "all.tcl" file are put into the list.)
#
# Arguments:
# root directory from which to search
#
# Results:
# The constructed list is returned to the user. This is used in
# the primary all.tcl file.
#
# Side Effects:
# None.
proc tcltest::GetMatchingDirectories {rootdir} {
# Determine the skip list first, to avoid [glob]-ing over subdirectories
# we're going to throw away anyway. Be sure we skip the $rootdir if it
# comes up to avoid infinite loops.
set skipDirs [list $rootdir]
foreach pattern [skipDirectories] {
foreach path [glob -directory $rootdir -nocomplain -- $pattern] {
if {[file isdirectory $path]} {
lappend skipDirs $path
}
}
}
# Now step through the matching directories, prune out the skipped ones
# as you go.
set matchDirs [list]
foreach pattern [matchDirectories] {
foreach path [glob -directory $rootdir -nocomplain -- $pattern] {
if {[file isdirectory $path]} {
if {[lsearch -exact $skipDirs $path] == -1} {
set matchDirs [concat $matchDirs \
[GetMatchingDirectories $path]]
if {[file exists [file join $path all.tcl]]} {
lappend matchDirs $path
}
}
}
}
}
if {[llength $matchDirs] == 0} {
DebugPuts 1 "No test directories remain after applying match\
and skip patterns!"
}
return $matchDirs
}
# tcltest::runAllTests --
#
# prints output and sources test files according to the match and
# skip patterns provided. after sourcing test files, it goes on
# to source all.tcl files in matching test subdirectories.
#
# Arguments:
# shell being tested
#
# Results:
# None.
#
# Side effects:
# None.
proc tcltest::runAllTests { {shell ""} } {
variable testSingleFile
variable numTestFiles
variable numTests
variable failFiles
FillFilesExisted
if {[llength [info level 0]] == 1} {
set shell [interpreter]
}
set testSingleFile false
puts [outputChannel] "Tests running in interp: $shell"
puts [outputChannel] "Tests located in: [testsDirectory]"
puts [outputChannel] "Tests running in: [workingDirectory]"
puts [outputChannel] "Temporary files stored in\
[temporaryDirectory]"
# [file system] first available in Tcl 8.4
if {![catch {file system [testsDirectory]} result]
&& ![string equal native [lindex $result 0]]} {
# If we aren't running in the native filesystem, then we must
# run the tests in a single process (via 'source'), because
# trying to run then via a pipe will fail since the files don't
# really exist.
singleProcess 1
}
if {[singleProcess]} {
puts [outputChannel] \
"Test files sourced into current interpreter"
} else {
puts [outputChannel] \
"Test files run in separate interpreters"
}
if {[llength [skip]] > 0} {
puts [outputChannel] "Skipping tests that match: [skip]"
}
puts [outputChannel] "Running tests that match: [match]"
if {[llength [skipFiles]] > 0} {
puts [outputChannel] \
"Skipping test files that match: [skipFiles]"
}
if {[llength [matchFiles]] > 0} {
puts [outputChannel] \
"Only running test files that match: [matchFiles]"
}
set timeCmd {clock format [clock seconds]}
puts [outputChannel] "Tests began at [eval $timeCmd]"
# Run each of the specified tests
foreach file [lsort [GetMatchingFiles]] {
set tail [file tail $file]
puts [outputChannel] $tail
flush [outputChannel]
if {[singleProcess]} {
incr numTestFiles
uplevel 1 [list ::source $file]
} else {
# Pass along our configuration to the child processes.
# EXCEPT for the -outfile, because the parent process
# needs to read and process output of children.
set childargv [list]
foreach opt [Configure] {
if {[string equal $opt -outfile]} {continue}
lappend childargv $opt [Configure $opt]
}
set cmd [linsert $childargv 0 | $shell $file]
if {[catch {
incr numTestFiles
set pipeFd [open $cmd "r"]
while {[gets $pipeFd line] >= 0} {
if {[regexp [join {
{^([^:]+):\t}
{Total\t([0-9]+)\t}
{Passed\t([0-9]+)\t}
{Skipped\t([0-9]+)\t}
{Failed\t([0-9]+)}
} ""] $line null testFile \
Total Passed Skipped Failed]} {
foreach index {Total Passed Skipped Failed} {
incr numTests($index) [set $index]
}
if {$Failed > 0} {
lappend failFiles $testFile
}
} elseif {[regexp [join {
{^Number of tests skipped }
{for each constraint:}
{|^\t(\d+)\t(.+)$}
} ""] $line match skipped constraint]} {
if {[string match \t* $match]} {
AddToSkippedBecause $constraint $skipped
}
} else {
puts [outputChannel] $line
}
}
close $pipeFd
} msg]} {
puts [outputChannel] "Test file error: $msg"
# append the name of the test to a list to be reported
# later
lappend testFileFailures $file
}
}
}
# cleanup
puts [outputChannel] "\nTests ended at [eval $timeCmd]"
cleanupTests 1
if {[info exists testFileFailures]} {
puts [outputChannel] "\nTest files exiting with errors: \n"
foreach file $testFileFailures {
puts [outputChannel] " [file tail $file]\n"
}
}
# Checking for subdirectories in which to run tests
foreach directory [GetMatchingDirectories [testsDirectory]] {
set dir [file tail $directory]
puts [outputChannel] [string repeat ~ 44]
puts [outputChannel] "$dir test began at [eval $timeCmd]\n"
uplevel 1 [list ::source [file join $directory all.tcl]]
set endTime [eval $timeCmd]
puts [outputChannel] "\n$dir test ended at $endTime"
puts [outputChannel] ""
puts [outputChannel] [string repeat ~ 44]
}
return
}
#####################################################################
# Test utility procs - not used in tcltest, but may be useful for
# testing.
# tcltest::loadTestedCommands --
#
# Uses the specified script to load the commands to test. Allowed to
# be empty, as the tested commands could have been compiled into the
# interpreter.
#
# Arguments
# none
#
# Results
# none
#
# Side Effects:
# none.
proc tcltest::loadTestedCommands {} {
variable l
if {[string equal {} [loadScript]]} {
return
}
return [uplevel 1 [loadScript]]
}
# tcltest::saveState --
#
# Save information regarding what procs and variables exist.
#
# Arguments:
# none
#
# Results:
# Modifies the variable saveState
#
# Side effects:
# None.
proc tcltest::saveState {} {
variable saveState
uplevel 1 [list ::set [namespace which -variable saveState]] \
{[::list [::info procs] [::info vars]]}
DebugPuts 2 "[lindex [info level 0] 0]: $saveState"
return
}
# tcltest::restoreState --
#
# Remove procs and variables that didn't exist before the call to
# [saveState].
#
# Arguments:
# none
#
# Results:
# Removes procs and variables from your environment if they don't
# exist in the saveState variable.
#
# Side effects:
# None.
proc tcltest::restoreState {} {
variable saveState
foreach p [uplevel 1 {::info procs}] {
if {([lsearch [lindex $saveState 0] $p] < 0)
&& ![string equal [namespace current]::$p \
[uplevel 1 [list ::namespace origin $p]]]} {
DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p"
uplevel 1 [list ::catch [list ::rename $p {}]]
}
}
foreach p [uplevel 1 {::info vars}] {
if {[lsearch [lindex $saveState 1] $p] < 0} {
DebugPuts 2 "[lindex [info level 0] 0]:\
Removing variable $p"
uplevel 1 [list ::catch [list ::unset $p]]
}
}
return
}
# tcltest::normalizeMsg --
#
# Removes "extra" newlines from a string.
#
# Arguments:
# msg String to be modified
#
# Results:
# string with extra newlines removed
#
# Side effects:
# None.
proc tcltest::normalizeMsg {msg} {
regsub "\n$" [string tolower $msg] "" msg
set msg [string map [list "\n\n" "\n"] $msg]
return [string map [list "\n\}" "\}"] $msg]
}
# tcltest::makeFile --
#
# Create a new file with the name , and write to it.
#
# If this file hasn't been created via makeFile since the last time
# cleanupTests was called, add it to the $filesMade list, so it will be
# removed by the next call to cleanupTests.
#
# Arguments:
# contents content of the new file
# name name of the new file
# directory directory name for new file
#
# Results:
# absolute path to the file created
#
# Side effects:
# None.
proc tcltest::makeFile {contents name {directory ""}} {
variable filesMade
FillFilesExisted
if {[llength [info level 0]] == 3} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]:\
putting ``$contents'' into $fullName"
set fd [open $fullName w]
fconfigure $fd -translation lf
if {[string equal [string index $contents end] \n]} {
puts -nonewline $fd $contents
} else {
puts $fd $contents
}
close $fd
if {[lsearch -exact $filesMade $fullName] == -1} {
lappend filesMade $fullName
}
return $fullName
}
# tcltest::removeFile --
#
# Removes the named file from the filesystem
#
# Arguments:
# name file to be removed
# directory directory from which to remove file
#
# Results:
# return value from [file delete]
#
# Side effects:
# None.
proc tcltest::removeFile {name {directory ""}} {
variable filesMade
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
set idx [lsearch -exact $filesMade $fullName]
set filesMade [lreplace $filesMade $idx $idx]
if {$idx == -1} {
DebugDo 1 {
Warn "removeFile removing \"$fullName\":\n not created by makeFile"
}
}
if {![file isfile $fullName]} {
DebugDo 1 {
Warn "removeFile removing \"$fullName\":\n not a file"
}
}
return [file delete $fullName]
}
# tcltest::makeDirectory --
#
# Create a new dir with the name .
#
# If this dir hasn't been created via makeDirectory since the last time
# cleanupTests was called, add it to the $directoriesMade list, so it
# will be removed by the next call to cleanupTests.
#
# Arguments:
# name name of the new directory
# directory directory in which to create new dir
#
# Results:
# absolute path to the directory created
#
# Side effects:
# None.
proc tcltest::makeDirectory {name {directory ""}} {
variable filesMade
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName"
file mkdir $fullName
if {[lsearch -exact $filesMade $fullName] == -1} {
lappend filesMade $fullName
}
return $fullName
}
# tcltest::removeDirectory --
#
# Removes a named directory from the file system.
#
# Arguments:
# name Name of the directory to remove
# directory Directory from which to remove
#
# Results:
# return value from [file delete]
#
# Side effects:
# None
proc tcltest::removeDirectory {name {directory ""}} {
variable filesMade
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"
set idx [lsearch -exact $filesMade $fullName]
set filesMade [lreplace $filesMade $idx $idx]
if {$idx == -1} {
DebugDo 1 {
Warn "removeDirectory removing \"$fullName\":\n not created\
by makeDirectory"
}
}
if {![file isdirectory $fullName]} {
DebugDo 1 {
Warn "removeDirectory removing \"$fullName\":\n not a directory"
}
}
return [file delete -force $fullName]
}
# tcltest::viewFile --
#
# reads the content of a file and returns it
#
# Arguments:
# name of the file to read
# directory in which file is located
#
# Results:
# content of the named file
#
# Side effects:
# None.
proc tcltest::viewFile {name {directory ""}} {
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
set f [open $fullName]
set data [read -nonewline $f]
close $f
return $data
}
# tcltest::bytestring --
#
# Construct a string that consists of the requested sequence of bytes,
# as opposed to a string of properly formed UTF-8 characters.
# This allows the tester to
# 1. Create denormalized or improperly formed strings to pass to C
# procedures that are supposed to accept strings with embedded NULL
# bytes.
# 2. Confirm that a string result has a certain pattern of bytes, for
# instance to confirm that "\xe0\0" in a Tcl script is stored
# internally in UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
#
# Generally, it's a bad idea to examine the bytes in a Tcl string or to
# construct improperly formed strings in this manner, because it involves
# exposing that Tcl uses UTF-8 internally.
#
# Arguments:
# string being converted
#
# Results:
# result fom encoding
#
# Side effects:
# None
proc tcltest::bytestring {string} {
return [encoding convertfrom identity $string]
}
# tcltest::OpenFiles --
#
# used in io tests, uses testchannel
#
# Arguments:
# None.
#
# Results:
# ???
#
# Side effects:
# None.
proc tcltest::OpenFiles {} {
if {[catch {testchannel open} result]} {
return {}
}
return $result
}
# tcltest::LeakFiles --
#
# used in io tests, uses testchannel
#
# Arguments:
# None.
#
# Results:
# ???
#
# Side effects:
# None.
proc tcltest::LeakFiles {old} {
if {[catch {testchannel open} new]} {
return {}
}
set leak {}
foreach p $new {
if {[lsearch $old $p] < 0} {
lappend leak $p
}
}
return $leak
}
#
# Internationalization / ISO support procs -- dl
#
# tcltest::SetIso8859_1_Locale --
#
# used in cmdIL.test, uses testlocale
#
# Arguments:
# None.
#
# Results:
# None.
#
# Side effects:
# None.
proc tcltest::SetIso8859_1_Locale {} {
variable previousLocale
variable isoLocale
if {[info commands testlocale] != ""} {
set previousLocale [testlocale ctype]
testlocale ctype $isoLocale
}
return
}
# tcltest::RestoreLocale --
#
# used in cmdIL.test, uses testlocale
#
# Arguments:
# None.
#
# Results:
# None.
#
# Side effects:
# None.
proc tcltest::RestoreLocale {} {
variable previousLocale
if {[info commands testlocale] != ""} {
testlocale ctype $previousLocale
}
return
}
# tcltest::threadReap --
#
# Kill all threads except for the main thread.
# Do nothing if testthread is not defined.
#
# Arguments:
# none.
#
# Results:
# Returns the number of existing threads.
#
# Side Effects:
# none.
#
proc tcltest::threadReap {} {
if {[info commands testthread] != {}} {
# testthread built into tcltest
testthread errorproc ThreadNullError
while {[llength [testthread names]] > 1} {
foreach tid [testthread names] {
if {$tid != [mainThread]} {
catch {
testthread send -async $tid {testthread exit}
}
}
}
## Enter a bit a sleep to give the threads enough breathing
## room to kill themselves off, otherwise the end up with a
## massive queue of repeated events
after 1
}
testthread errorproc ThreadError
return [llength [testthread names]]
} elseif {[info commands thread::id] != {}} {
# Thread extension
thread::errorproc ThreadNullError
while {[llength [thread::names]] > 1} {
foreach tid [thread::names] {
if {$tid != [mainThread]} {
catch {thread::send -async $tid {thread::exit}}
}
}
## Enter a bit a sleep to give the threads enough breathing
## room to kill themselves off, otherwise the end up with a
## massive queue of repeated events
after 1
}
thread::errorproc ThreadError
return [llength [thread::names]]
} else {
return 1
}
return 0
}
# Initialize the constraints and set up command line arguments
namespace eval tcltest {
# Define initializers for all the built-in contraint definitions
DefineConstraintInitializers
# Set up the constraints in the testConstraints array to be lazily
# initialized by a registered initializer, or by "false" if no
# initializer is registered.
trace variable testConstraints r [namespace code SafeFetch]
# Only initialize constraints at package load time if an
# [initConstraintsHook] has been pre-defined. This is only
# for compatibility support. The modern way to add a custom
# test constraint is to just call the [testConstraint] command
# straight away, without all this "hook" nonsense.
if {[string equal [namespace current] \
[namespace qualifiers [namespace which initConstraintsHook]]]} {
InitConstraints
} else {
proc initConstraintsHook {} {}
}
# Define the standard match commands
customMatch exact [list string equal]
customMatch glob [list string match]
customMatch regexp [list regexp --]
# If the TCLTEST_OPTIONS environment variable exists, configure
# tcltest according to the option values it specifies. This has
# the effect of resetting tcltest's default configuration.
proc ConfigureFromEnvironment {} {
upvar #0 env(TCLTEST_OPTIONS) options
if {[catch {llength $options} msg]} {
Warn "invalid TCLTEST_OPTIONS \"$options\":\n invalid\
Tcl list: $msg"
return
}
if {[llength $::env(TCLTEST_OPTIONS)] % 2} {
Warn "invalid TCLTEST_OPTIONS: \"$options\":\n should be\
-option value ?-option value ...?"
return
}
if {[catch {eval Configure $::env(TCLTEST_OPTIONS)} msg]} {
Warn "invalid TCLTEST_OPTIONS: \"$options\":\n $msg"
return
}
}
if {[info exists ::env(TCLTEST_OPTIONS)]} {
ConfigureFromEnvironment
}
proc LoadTimeCmdLineArgParsingRequired {} {
set required false
if {[info exists ::argv] && [lsearch -exact $::argv -help] != -1} {
# The command line asks for -help, so give it (and exit)
# right now. ([configure] does not process -help)
set required true
}
foreach hook { PrintUsageInfoHook processCmdLineArgsHook
processCmdLineArgsAddFlagsHook } {
if {[string equal [namespace current] [namespace qualifiers \
[namespace which $hook]]]} {
set required true
} else {
proc $hook args {}
}
}
return $required
}
# Only initialize configurable options from the command line arguments
# at package load time if necessary for backward compatibility. This
# lets the tcltest user call [configure] for themselves if they wish.
# Traces are established for auto-configuration from the command line
# if any configurable options are accessed before the user calls
# [configure].
if {[LoadTimeCmdLineArgParsingRequired]} {
ProcessCmdLineArgs
} else {
EstablishAutoConfigureTraces
}
package provide [namespace tail [namespace current]] $Version
}
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Resources/Scripts/word.tcl 0100644 0000000 0000120 00000010427 07560345303 027733 0 ustar root admin # 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.
#
# RCS: @(#) $Id: word.tcl,v 1.7 2002/11/01 00:28:51 andreas_kupries Exp $
# The following variables are used to determine which characters are
# interpreted as white space.
if {[string equal $::tcl_platform(platform) "windows"]} {
# Windows style - any but a unicode space char
set tcl_wordchars "\\S"
set tcl_nonwordchars "\\s"
} else {
# Motif style - any unicode word char (number, letter, or underscore)
set tcl_wordchars "\\w"
set tcl_nonwordchars "\\W"
}
# 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} {
global tcl_nonwordchars tcl_wordchars
set str [string range $str $start end]
if {[regexp -indices "$tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars" $str result]} {
return [expr {[lindex $result 1] + $start}]
}
return -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} {
global tcl_nonwordchars tcl_wordchars
if {[string equal $start end]} {
set start [string length $str]
}
if {[regexp -indices "^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)" [string range $str 0 $start] result]} {
return [lindex $result 1]
}
return -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} {
global tcl_nonwordchars tcl_wordchars
if {[regexp -indices "$tcl_nonwordchars*$tcl_wordchars+$tcl_nonwordchars" \
[string range $str $start end] result]} {
return [expr {[lindex $result 1] + $start}]
}
return -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} {
global tcl_nonwordchars tcl_wordchars
if {[regexp -indices "$tcl_wordchars*$tcl_nonwordchars+$tcl_wordchars" \
[string range $str $start end] result]} {
return [expr {[lindex $result 1] + $start}]
}
return -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} {
global tcl_nonwordchars tcl_wordchars
if {[string equal $start end]} {
set start [string length $str]
}
if {[regexp -indices \
"$tcl_nonwordchars*($tcl_wordchars+)$tcl_nonwordchars*\$" \
[string range $str 0 [expr {$start - 1}]] result word]} {
return [lindex $word 0]
}
return -1
}
Wishkit.app/Contents/Frameworks/Tcl.framework/Versions/8.4/Tcl 0100755 0000000 0000120 00002613500 10153114231 023310 0 ustar root admin
X__TEXT
__text __TEXT
l l __picsymbol_stub__TEXT
t t $__picsymbolstub1__TEXT
t ^ t __cstring __TEXT
L __literal8 __TEXT
` ` __literal4 __TEXT
__const __TEXT
__eh_frame __TEXT
l h __DATA
__data __DATA
L __dyld __DATA
:L :L __la_symbol_ptr __DATA
:T :T __nl_symbol_ptr __DATA
F( F( __const __DATA
G G __bss __DATA
H$ __common __DATA
O 8__LINKEDIT
` @ P @
X A @executable_path/../Frameworks/Tcl.framework/Versions/8.4/Tcl 4 @# G /usr/lib/libSystem.B.dylib h AL&+ /System/Library/Frameworks/CoreFoundation.framework/Versions/A/CoreFoundation
D P [ [ '
>8 V
O
L # P ϸ. |B }|}cx= 2}|x= N }cxK|B }h|=k k2}iN | !B < 8c<8 @K @/ A < c>P}N! h8! `|N |B }= |9}N ||@ & p B A |3x! |yx;@ ; @A <_ B=;B X/ A / @ 8` H s A s 8` @W 8` / AT<8@ 9> 8|^ ,9` 8
;` > 0 4> ^ ^ ^ > 0Ub:9k bI. 4 @A8@ =? 8 `B9) Y 8@ 8` (Y 8@9 ^ h ` d l p t x H/ ||xy A dc ; <xxH T
dx| 8 | | $ dH à ~ `/ @8` d8 8
H }/ ~ @ x8 H DxH |}y@ XxH 8 xH } ~ / @d|dxxH |`x|dxx H %a~ 8 8 H ~ / @(xH 5 p A $H R|dx~ dH Yu d~ h~ `H ]] / @^ `8 ex8 p H 퀞 ~ p/ @~ `H m / @. A 8< 8 8 Fx8cH ~ `DxH |~ pDx8 H 1 pxH - ~ p8 H -U~ |~ pH -xH -A ,< 8 8 #Fx8cH~ pDx8 H 1U pxExH . / | x @ ; @ H;` DA <