diff --git a/build/Makefile.in b/build/Makefile.in
index 26ecfb5..10db975 100644
--- a/build/Makefile.in
+++ b/build/Makefile.in
@@ -22,98 +22,14 @@ PARTCL_LANG_DIR = $(PARROT_LIB_DIR)/languages/partcl
PARTCL_EXE = partcl$(EXE)
GEN_SOURCES = \
- src/ARE/Actions.pir \
- src/ARE/Compiler.pir \
- src/ARE/Grammar.pir \
- src/StringGlob/Actions.pir \
- src/StringGlob/Compiler.pir \
- src/StringGlob/Grammar.pir \
- src/FileGlob/Actions.pir \
- src/FileGlob/Compiler.pir \
- src/FileGlob/Grammar.pir \
src/Partcl/Actions.pir \
src/Partcl/Compiler.pir \
src/Partcl/Grammar.pir \
src/Partcl/Operators.pir \
- src/Partcl/commands/after.pir \
- src/Partcl/commands/append.pir \
- src/Partcl/commands/apply.pir \
- src/Partcl/commands/array.pir \
- src/Partcl/commands/binary.pir \
- src/Partcl/commands/break.pir \
- src/Partcl/commands/catch.pir \
- src/Partcl/commands/cd.pir \
- src/Partcl/commands/concat.pir \
- src/Partcl/commands/continue.pir \
- src/Partcl/commands/dict.pir \
- src/Partcl/commands/eof.pir \
- src/Partcl/commands/encoding.pir \
- src/Partcl/commands/error.pir \
- src/Partcl/commands/eval.pir \
- src/Partcl/commands/exit.pir \
- src/Partcl/commands/expr.pir \
- src/Partcl/commands/fileevent.pir \
- src/Partcl/commands/file.pir \
- src/Partcl/commands/flush.pir \
- src/Partcl/commands/foreach.pir \
- src/Partcl/commands/format.pir \
- src/Partcl/commands/for.pir \
- src/Partcl/commands/gets.pir \
- src/Partcl/commands/global.pir \
- src/Partcl/commands/glob.pir \
- src/Partcl/commands/if.pir \
- src/Partcl/commands/incr.pir \
- src/Partcl/commands/info.pir \
- src/Partcl/commands/interp.pir \
- src/Partcl/commands/join.pir \
- src/Partcl/commands/lappend.pir \
- src/Partcl/commands/lassign.pir \
- src/Partcl/commands/lindex.pir \
- src/Partcl/commands/linsert.pir \
- src/Partcl/commands/list.pir \
- src/Partcl/commands/llength.pir \
- src/Partcl/commands/lrange.pir \
- src/Partcl/commands/lrepeat.pir \
- src/Partcl/commands/lreplace.pir \
- src/Partcl/commands/lreverse.pir \
- src/Partcl/commands/lset.pir \
- src/Partcl/commands/lsort.pir \
- src/Partcl/commands/namespace.pir \
- src/Partcl/commands/package.pir \
- src/Partcl/commands/proc.pir \
- src/Partcl/commands/puts.pir \
- src/Partcl/commands/pwd.pir \
- src/Partcl/commands/regexp.pir \
- src/Partcl/commands/rename.pir \
- src/Partcl/commands/return.pir \
- src/Partcl/commands/set.pir \
- src/Partcl/commands/socket.pir \
- src/Partcl/commands/source.pir \
- src/Partcl/commands/split.pir \
- src/Partcl/commands/string.pir \
- src/Partcl/commands/subst.pir \
- src/Partcl/commands/switch.pir \
- src/Partcl/commands/time.pir \
- src/Partcl/commands/trace.pir \
- src/Partcl/commands/unset.pir \
- src/Partcl/commands/uplevel.pir \
- src/Partcl/commands/upvar.pir \
- src/Partcl/commands/variable.pir \
- src/Partcl/commands/vwait.pir \
- src/Partcl/commands/while.pir \
- src/TclArray.pir \
- src/TclLexPad.pir \
- src/TclList.pir \
- src/TclString.pir \
src/init.pir \
- src/options.pir
src/Partcl.pir: $(GEN_SOURCES)
-src/FileGlob/Actions.pm: src/StringGlob/Actions.pm
-src/FileGlob/Grammar.pm: src/StringGlob/Grammar.pm
-src/init.pm: src/TclLexPad.pm
-
all: $(PARTCL_EXE) .revision
$(PARTCL_EXE) : partcl.pbc
diff --git a/docs/overview.pod b/docs/overview.pod
deleted file mode 100644
index 960bf69..0000000
--- a/docs/overview.pod
+++ /dev/null
@@ -1,105 +0,0 @@
-=head1 Overview
-
-partcl-nqp is a tcl 8.5 compiler for the PVM (Parrot Virtual Machine).
-
-It uses the Parrot Compiler Toolkit (nqp-rx, HLL::Compiler) to generate
-PIR (Parrot Assembly), which is then compiled to PBC (Parrot Bytecode),
-which is then bundled into a "fakecutable". The fakecutable contains the
-bytecode, and enough C to invoke the VM. It is NOT a JITted version.
-
-=head1 Languages
-
-partcl-nqp is written primarily in NQP (Not Quite Perl 6; specifically
-nqp-rx), with as little PIR as we can manager.
-
-=head2 Grammars and Actions
-
-There are several Perl 6 Grammars in F; Partcl contains the main
-language, src/ARE is the standard tcl regexes, etc.
-
-Each F file contains the rules (See Perl 6's Synopsis 5) for
-parsing that mini language. The F file contains instructions to
-convert the parse into parrot's AST (Abstract Syntax Tree).
-
-The small F for each mini language takes advantage of the parrot
-library to convert the AST to an OST (opcode syntax tree), which is then
-converted to PIR, and finally PBC.
-
-=head1 Repository layout
-
-=over 4
-
-=item src/Partcl/
-
-The grammar/actions for the language itself and for [expr].
-
-=item src/Partcl/Operators.pm
-
-Operators to override NQP's default behavior to be partcl-specific. Used
-by [expr].
-
-=item src/Partcl/Tcl*.pm
-
-Override parrot's core types to conform to tcl behavior instead of parrot
-defaults. For example, the string representation of [list a b] in parrot
-is "2" (the size of the list); but in tcl is "a b".
-
-=item src/Partcl/commands/
-
-The Tcl builtins, e.g. for, puts, etc. Implemented in NQP. Any ensemble
-commands have their own file, logical groupings (e.g. all list-related
-commands) are bundled, with the remaining commands in main.pm
-
-So we can generate our own diagnostic error messages, any user-facing
-commands have an NQP function signature of C<*@> - however, especially for
-the ensemble commands, several smaller commands with NQP-specific paramters
-are used.
-
-=item src/ARE
-
-The grammar/actions for the regular expression engine.
-
-=item src/StringGlob
-
-The grammar/actions for [string match]
-
-=item src/FileGlob
-
-The grammar/actions for [glob]
-
-=item library/
-
-Portions of tcl's standard library - these files come directly from tcl's
-CVS repository.
-
-=item src/init.pm
-
-Internal initialization - set global variables, etc.
-
-=item src/options.pm
-
-helper methods for processing options/autocompleting subcommands.
-
-=item lib/test_more.tcl
-
-A very small test harness written in tcl that generates TAP,
-used to run the tests in t/; this is completely separate from tcltest.tcl,
-which is tcl's own non-TAP test harness.
-
-=item t/
-
-Test files, written in tcl, run using lib/test_more.tcl ; While tcl does
-have a suite of specification tests, it is very difficult for a new
-implementation to run them directly; Our goal is to be able to run the
-tests in this directory as a prelude to running the spec tests.
-
-=back
-
-=head1 Alternate history
-
-There is a version of partcl written using C & C. That version has
-no active development but is maintained minimally so it compiles with the
-latest version of parrot. Much of I version includes hand-translated
-NQP based on the PIR from that version.
-
-=cut
diff --git a/docs/todo.pod b/docs/todo.pod
deleted file mode 100644
index 41853e8..0000000
--- a/docs/todo.pod
+++ /dev/null
@@ -1,21 +0,0 @@
-=head1 Big Goals
-
-Document how to contribute to this version - ast, tcl, nqp ...
-
-=head1 Tasks/Bugs:
-
-=over 4
-
-=item [proc] {t/cmd_continue.t; t/cmd_break.t}
-
-User-defined procs should catch continue/break and complain about them, as
-should the :main PIR sub.
-
-=item list processing
-
-Single opening quotes are an invalid list element. {t/cmd_lappend.t}
-
-=item [proc] varargs support {t/cmd_proc.t; t/cmd_info.t}
-need to handle special {args} parameter.
-
-=back
diff --git a/library/README b/library/README
deleted file mode 100644
index 3ab8dfd..0000000
--- a/library/README
+++ /dev/null
@@ -1,14 +0,0 @@
-The files in this directory (except for this one) come from the tcl
-repository at: http://tcl.cvs.sourceforge.net/tcl/tcl/library/
-
-# to get a local copy to compare our checked in versions with, use
-
-make tcl-cvs
-
-in the top level directory.
-
-They are included here under the terms in license.terms
-
-We will probably switch to having the developer check them out,
-as soon as we can run tcltest with no modifications.
-
diff --git a/library/auto.tcl b/library/auto.tcl
deleted file mode 100644
index 881e6b9..0000000
--- a/library/auto.tcl
+++ /dev/null
@@ -1,610 +0,0 @@
-# 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.28 2006/11/03 00:34:52 hobbs 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 commands that are listed in the auto-load index.
-#
-# Arguments:
-# None.
-
-proc auto_reset {} {
- if {[array exists ::auto_index]} {
- foreach cmdName [array names ::auto_index] {
- set fqcn [namespace which $cmdName]
- if {$fqcn eq ""} {continue}
- rename $fqcn {}
- }
- }
- unset -nocomplain ::auto_execs ::auto_index ::tcl::auto_oldpath
- if {[catch {llength $::auto_path}]} {
- set ::auto_path [list [info library]]
- } else {
- if {[info library] ni $::auto_path} {
- lappend ::auto_path [info library]
- }
- }
-}
-
-# tcl_findLibrary --
-#
-# This is a utility for extensions that searches for a library directory
-# using a canonical searching algorithm. A side effect is to source
-# the initialization script and set a global library variable.
-#
-# Arguments:
-# basename Prefix of the directory name, (e.g., "tk")
-# version Version number of the package, (e.g., "8.0")
-# patch Patchlevel of the package, (e.g., "8.0.3")
-# initScript Initialization script to source (e.g., tk.tcl)
-# enVarName environment variable to honor (e.g., TK_LIBRARY)
-# varName Global variable to set when done (e.g., tk_library)
-
-proc tcl_findLibrary {basename version patch initScript enVarName varName} {
- upvar #0 $varName the_library
- global env
-
- set dirs {}
- set errors {}
-
- # The C application may have hardwired a path, which we honor
-
- if {[info exists the_library] && $the_library ne ""} {
- lappend dirs $the_library
- } else {
-
- # Do the canonical search
-
- # 1. From an environment variable, if it exists.
- # Placing this first gives the end-user ultimate control
- # to work-around any bugs, or to customize.
-
- if {[info exists env($enVarName)]} {
- lappend dirs $env($enVarName)
- }
-
- # 2. In the package script directory registered within
- # the configuration of the package itself.
-
- 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)
- #
- # Remaining locations are out of date (when relevant, they ought
- # to be covered by the $::auto_path seach above) and disabled.
- #
- # ../../library (From unix/arch directory in build hierarchy)
- # ../../foo1.0.1/library
- # (From unix directory in parallel build hierarchy)
- # ../../../foo1.0.1/library
- # (From unix/arch directory in parallel build hierarchy)
-
- set parentDir [file dirname [file dirname [info nameofexecutable]]]
- set grandParentDir [file dirname $parentDir]
- lappend dirs [file join $parentDir lib $basename$version]
- lappend dirs [file join $grandParentDir lib $basename$version]
- lappend dirs [file join $parentDir library]
- if {0} {
- lappend dirs [file join $grandParentDir library]
- lappend dirs [file join $grandParentDir $basename$patch library]
- lappend dirs [file join [file dirname $grandParentDir] \
- $basename$patch library]
- }
- }
- # uniquify $dirs in order
- array set seen {}
- foreach i $dirs {
- # Take note that the [file normalize] below has been noted to
- # cause difficulties for the freewrap utility. See Bug 1072136.
- # Until freewrap resolves the matter, one might work around the
- # problem by disabling that branch.
- if {[interp issafe]} {
- set norm $i
- } else {
- set norm [file normalize $i]
- }
- if {[info exists seen($norm)]} { continue }
- set seen($norm) ""
- lappend uniqdirs $i
- }
- 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 opts]} {
- return
- } else {
- append errors "$file: $msg\n"
- append errors [dict get $opts -errorinfo]\n
- }
- }
- }
- unset -nocomplain the_library
- set msg "Can't find a usable $initScript in the following directories: \n"
- append msg " $dirs\n\n"
- append msg "$errors\n\n"
- append msg "This probably means that $basename wasn't installed properly.\n"
- error $msg
-}
-
-
-# ----------------------------------------------------------------------
-# auto_mkindex
-# ----------------------------------------------------------------------
-# The following procedures are used to generate the tclIndex file
-# from Tcl source files. They use a special safe interpreter to
-# parse Tcl source files, writing out index entries as "proc"
-# commands are encountered. This implementation won't work in a
-# safe interpreter, since a safe interpreter can't create the
-# special parser and mess with its commands.
-
-if {[interp issafe]} {
- return ;# Stop sourcing the file here
-}
-
-# auto_mkindex --
-# Regenerate a tclIndex file from Tcl source files. Takes as argument
-# the name of the directory in which the tclIndex file is to be placed,
-# followed by any number of glob patterns to use in that directory to
-# locate all of the relevant files.
-#
-# Arguments:
-# dir - Name of the directory in which to create an index.
-# args - Any number of additional arguments giving the
-# names of files within dir. If no additional
-# are given auto_mkindex will look for *.tcl.
-
-proc auto_mkindex {dir args} {
- if {[interp issafe]} {
- error "can't generate index within safe interpreter"
- }
-
- set oldDir [pwd]
- cd $dir
- set dir [pwd]
-
- append index "# Tcl autoload index file, version 2.0\n"
- append index "# This file is generated by the \"auto_mkindex\" command\n"
- append index "# and sourced to set up indexing information for one or\n"
- append index "# more commands. Typically each line is a command that\n"
- append index "# sets an element in the auto_index array, where the\n"
- append index "# element name is the name of a command and the value is\n"
- append index "# a script that loads the command.\n\n"
- if {[llength $args] == 0} {
- set args *.tcl
- }
-
- auto_mkindex_parser::init
- foreach file [glob -- {*}$args] {
- if {[catch {auto_mkindex_parser::mkindex $file} msg opts] == 0} {
- append index $msg
- } else {
- cd $oldDir
- return -options $opts $msg
- }
- }
- auto_mkindex_parser::cleanup
-
- set fid [open "tclIndex" w]
- puts -nonewline $fid $index
- close $fid
- cd $oldDir
-}
-
-# Original version of auto_mkindex that just searches the source
-# code for "proc" at the beginning of the line.
-
-proc auto_mkindex_old {dir args} {
- set oldDir [pwd]
- cd $dir
- set dir [pwd]
- append index "# Tcl autoload index file, version 2.0\n"
- append index "# This file is generated by the \"auto_mkindex\" command\n"
- append index "# and sourced to set up indexing information for one or\n"
- append index "# more commands. Typically each line is a command that\n"
- append index "# sets an element in the auto_index array, where the\n"
- append index "# element name is the name of a command and the value is\n"
- append index "# a script that loads the command.\n\n"
- if {[llength $args] == 0} {
- set args *.tcl
- }
- foreach file [glob -- {*}$args] {
- set f ""
- set error [catch {
- set f [open $file]
- while {[gets $f line] >= 0} {
- if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} {
- set procName [lindex [auto_qualify $procName "::"] 0]
- append index "set [list auto_index($procName)]"
- append index " \[list source \[file join \$dir [list $file]\]\]\n"
- }
- }
- close $f
- } msg opts]
- if {$error} {
- catch {close $f}
- cd $oldDir
- return -options $opts $msg
- }
- }
- set f ""
- set error [catch {
- set f [open tclIndex w]
- puts -nonewline $f $index
- close $f
- cd $oldDir
- } msg opts]
- if {$error} {
- catch {close $f}
- cd $oldDir
- error $msg $info $code
- return -options $opts $msg
- }
-}
-
-# Create a safe interpreter that can be used to parse Tcl source files
-# generate a tclIndex file for autoloading. This interp contains
-# commands for things that need index entries. Each time a command
-# is executed, it writes an entry out to the index file.
-
-namespace eval auto_mkindex_parser {
- variable parser "" ;# parser used to build index
- variable index "" ;# maintains index as it is built
- variable scriptFile "" ;# name of file being processed
- variable contextStack "" ;# stack of namespace scopes
- variable imports "" ;# keeps track of all imported cmds
- variable initCommands ;# list of commands that create aliases
- if {![info exists initCommands]} {
- set initCommands [list]
- }
-
- proc init {} {
- variable parser
- variable initCommands
-
- if {![interp issafe]} {
- set parser [interp create -safe]
- $parser hide info
- $parser hide rename
- $parser hide proc
- $parser hide namespace
- $parser hide eval
- $parser hide puts
- $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.
- set contents [string map [list \$ \0] $contents]
-
- set index ""
- set contextStack ""
- set imports ""
-
- $parser eval $contents
-
- foreach name $imports {
- catch {$parser eval [list _%@namespace forget $name]}
- }
- return $index
-}
-
-# auto_mkindex_parser::hook command
-#
-# Registers a Tcl command to evaluate when initializing the
-# slave interpreter used by the mkindex parser.
-# The command is evaluated in the master interpreter, and can
-# use the variable auto_mkindex_parser::parser to get to the slave
-
-proc auto_mkindex_parser::hook {cmd} {
- variable initCommands
-
- lappend initCommands $cmd
-}
-
-# auto_mkindex_parser::slavehook command
-#
-# Registers a Tcl command to evaluate when initializing the
-# slave interpreter used by the mkindex parser.
-# The command is evaluated in the slave interpreter.
-
-proc auto_mkindex_parser::slavehook {cmd} {
- variable initCommands
-
- # The $parser variable is defined to be the name of the
- # slave interpreter when this command is used later.
-
- lappend initCommands "\$parser eval [list $cmd]"
-}
-
-# auto_mkindex_parser::command --
-#
-# Registers a new command with the "auto_mkindex_parser" interpreter
-# that parses Tcl files. These commands are fake versions of things
-# like the "proc" command. When you execute them, they simply write
-# out an entry to a "tclIndex" file for auto-loading.
-#
-# This procedure allows extensions to register their own commands
-# with the auto_mkindex facility. For example, a package like
-# [incr Tcl] might register a "class" command so that class definitions
-# could be added to a "tclIndex" file for auto-loading.
-#
-# Arguments:
-# name Name of command recognized in Tcl files.
-# arglist Argument list for command.
-# body Implementation of command to handle indexing.
-
-proc auto_mkindex_parser::command {name arglist body} {
- hook [list auto_mkindex_parser::commandInit $name $arglist $body]
-}
-
-# auto_mkindex_parser::commandInit --
-#
-# This does the actual work set up by auto_mkindex_parser::command
-# This is called when the interpreter used by the parser is created.
-#
-# Arguments:
-# name Name of command recognized in Tcl files.
-# arglist Argument list for command.
-# body Implementation of command to handle indexing.
-
-proc auto_mkindex_parser::commandInit {name arglist body} {
- variable parser
-
- set ns [namespace qualifiers $name]
- set tail [namespace tail $name]
- if {$ns eq ""} {
- set fakeName [namespace current]::_%@fake_$tail
- } else {
- set fakeName [namespace current]::[string map {:: _} _%@fake_$name]
- }
- proc $fakeName $arglist $body
-
- # YUK! Tcl won't let us alias fully qualified command names,
- # so we can't handle names like "::itcl::class". Instead,
- # we have to build procs with the fully qualified names, and
- # have the procs point to the aliases.
-
- if {[string match *::* $name]} {
- set exportCmd [list _%@namespace export [namespace tail $name]]
- $parser eval [list _%@namespace eval $ns $exportCmd]
-
- # The following proc definition does not work if you
- # want to tolerate space or something else diabolical
- # in the procedure name, (i.e., space in $alias)
- # The following does not work:
- # "_%@eval {$alias} \$args"
- # because $alias gets concat'ed to $args.
- # The following does not work because $cmd is somehow undefined
- # "set cmd {$alias} \; _%@eval {\$cmd} \$args"
- # A gold star to someone that can make test
- # autoMkindex-3.3 work properly
-
- set alias [namespace tail $fakeName]
- $parser invokehidden proc $name {args} "_%@eval {$alias} \$args"
- $parser alias $alias $fakeName
- } else {
- $parser alias $name $fakeName
- }
- return
-}
-
-# auto_mkindex_parser::fullname --
-# Used by commands like "proc" within the auto_mkindex parser.
-# Returns the qualified namespace name for the "name" argument.
-# If the "name" does not start with "::", elements are added from
-# the current namespace stack to produce a qualified name. Then,
-# the name is examined to see whether or not it should really be
-# qualified. If the name has more than the leading "::", it is
-# returned as a fully qualified name. Otherwise, it is returned
-# as a simple name. That way, the Tcl autoloader will recognize
-# it properly.
-#
-# Arguments:
-# name - Name that is being added to index.
-
-proc auto_mkindex_parser::fullname {name} {
- variable contextStack
-
- if {![string match ::* $name]} {
- foreach ns $contextStack {
- set name "${ns}::$name"
- if {[string match ::* $name]} {
- break
- }
- }
- }
-
- if {[namespace qualifiers $name] eq ""} {
- set name [namespace tail $name]
- } elseif {![string match ::* $name]} {
- set name "::$name"
- }
-
- # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse
- # that replacement.
- return [string map [list \0 \$] $name]
-}
-
-if {[llength $::auto_mkindex_parser::initCommands]} {
- return
-}
-
-# Register all of the procedures for the auto_mkindex parser that
-# will build the "tclIndex" file.
-
-# AUTO MKINDEX: proc name arglist body
-# Adds an entry to the auto index list for the given procedure name.
-
-auto_mkindex_parser::command proc {name args} {
- 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 {[namespace which -command tbcload::bcproc] eq ""} {
- auto_load tbcload::bcproc
- }
- load {} tbcload $auto_mkindex_parser::parser
-
- # AUTO MKINDEX: tbcload::bcproc name arglist body
- # Adds an entry to the auto index list for the given pre-compiled
- # procedure name.
-
- auto_mkindex_parser::commandInit tbcload::bcproc {name args} {
- 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 {$pattern ne "-force"} {
- lappend imports $pattern
- }
- }
- catch {$parser eval "_%@namespace import $args"}
- }
- }
-}
-
-return
diff --git a/library/history.tcl b/library/history.tcl
deleted file mode 100644
index 3a3f16a..0000000
--- a/library/history.tcl
+++ /dev/null
@@ -1,375 +0,0 @@
-# history.tcl --
-#
-# Implementation of the history command.
-#
-# RCS: @(#) $Id: history.tcl,v 1.7 2005/07/23 04:12:49 dgp 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] eq ""} {
- return ""
- }
-
- set i [incr history(nextid)]
- set history($i) $command
- set j [incr history(oldest)]
- unset -nocomplain 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 {$limit eq ""} {
- return $history(keep)
- } else {
- set oldold $history(oldest)
- set history(oldest) [expr {$history(nextid) - $limit}]
- for {} {$oldold <= $history(oldest)} {incr oldold} {
- unset -nocomplain 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 eq ""} {
- 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 map [list \n \n\t] [string trimright $history($i) \ \n]]
- append result $newline[format "%6d %s" $i $cmd]
- set newline \n
- }
- return $result
-}
-
-# tcl::HistRedo --
-#
-# Fetch the previous or specified event, execute it, and then
-# replace the current history item with that event.
-#
-# Parameters:
-# event (optional) index of history item to redo. Defaults to -1,
-# which means the previous event.
-#
-# Results:
-# Those of the command being redone.
-#
-# Side Effects:
-# Replaces the current history list item with the one being redone.
-
- proc tcl::HistRedo {{event -1}} {
- variable history
- if {$event eq ""} {
- 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
-}
diff --git a/library/init.tcl b/library/init.tcl
deleted file mode 100644
index 6b92c58..0000000
--- a/library/init.tcl
+++ /dev/null
@@ -1,832 +0,0 @@
-# init.tcl --
-#
-# Default system startup file for Tcl-based applications. Defines
-# "unknown" procedure and auto-load facilities.
-#
-# RCS: @(#) $Id: init.tcl,v 1.104.2.11 2008/12/21 20:59:01 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.
-# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-
-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.5.6
-
-# Compute the auto path to use in this interpreter.
-# The values on the path come from several locations:
-#
-# The environment variable TCLLIBPATH
-#
-# tcl_library, which is the directory containing this init.tcl script.
-# [tclInit] (Tcl_Init()) searches around for the directory containing this
-# init.tcl and defines tcl_library to that location before sourcing it.
-#
-# The parent directory of tcl_library. Adding the parent
-# means that packages in peer directories will be found automatically.
-#
-# Also add the directory ../lib relative to the directory where the
-# executable is located. This is meant to find binary packages for the
-# same architecture as the current executable.
-#
-# tcl_pkgPath, which is set by the platform-specific initialization routines
-# On UNIX it is compiled in
-# On Windows, it is not used
-
-if {![info exists auto_path]} {
- if {[info exists env(TCLLIBPATH)]} {
- set auto_path $env(TCLLIBPATH)
- } else {
- set auto_path ""
- }
-}
-namespace eval tcl {
- variable Dir
- foreach Dir [list $::tcl_library [file dirname $::tcl_library]] {
- if {$Dir ni $::auto_path} {
- lappend ::auto_path $Dir
- }
- }
- set Dir [file join [file dirname [file dirname \
- [info nameofexecutable]]] lib]
- if {$Dir ni $::auto_path} {
- lappend ::auto_path $Dir
- }
- catch {
- foreach Dir $::tcl_pkgPath {
- if {$Dir ni $::auto_path} {
- lappend ::auto_path $Dir
- }
- }
- }
-
- if {![interp issafe]} {
- variable Path [encoding dirs]
- set Dir [file join $::tcl_library encoding]
- if {$Dir ni $Path} {
- lappend Path $Dir
- encoding dirs $Path
- }
- }
-
- # TIP #255 min and max functions
- namespace eval mathfunc {
- proc min {args} {
- if {[llength $args] == 0} {
- return -code error \
- "too few arguments to math function \"min\""
- }
- set val Inf
- foreach arg $args {
- # This will handle forcing the numeric value without
- # ruining the internal type of a numeric object
- if {[catch {expr {double($arg)}} err]} {
- return -code error $err
- }
- if {$arg < $val} { set val $arg }
- }
- return $val
- }
- proc max {args} {
- if {[llength $args] == 0} {
- return -code error \
- "too few arguments to math function \"max\""
- }
- set val -Inf
- foreach arg $args {
- # This will handle forcing the numeric value without
- # ruining the internal type of a numeric object
- if {[catch {expr {double($arg)}} err]} {
- return -code error $err
- }
- if {$arg > $val} { set val $arg }
- }
- return $val
- }
- namespace export min max
- }
-}
-
-# Windows specific end of initialization
-
-if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
- namespace eval tcl {
- proc EnvTraceProc {lo n1 n2 op} {
- set x $::env($n2)
- set ::env($lo) $x
- set ::env([string toupper $lo]) $x
- }
- proc InitWinEnv {} {
- global env tcl_platform
- foreach p [array names env] {
- set u [string toupper $p]
- if {$u ne $p} {
- switch -- $u {
- COMSPEC -
- PATH {
- if {![info exists env($u)]} {
- set env($u) $env($p)
- }
- trace add variable env($p) write \
- [namespace code [list EnvTraceProc $p]]
- trace add variable env($u) write \
- [namespace code [list EnvTraceProc $p]]
- }
- }
- }
- }
- if {![info exists env(COMSPEC)]} {
- if {$tcl_platform(os) eq "Windows NT"} {
- set env(COMSPEC) cmd.exe
- } else {
- set env(COMSPEC) command.com
- }
- }
- }
- InitWinEnv
- }
-}
-
-# Setup the unknown package handler
-
-
-if {[interp issafe]} {
- package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
-} else {
- # Set up search for Tcl Modules (TIP #189).
- # and setup platform specific unknown package handlers
- if {$::tcl_platform(os) eq "Darwin"
- && $::tcl_platform(platform) eq "unix"} {
- package unknown {::tcl::tm::UnknownHandler \
- {::tcl::MacOSXPkgUnknown ::tclPkgUnknown}}
- } else {
- package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
- }
-
- # Set up the 'clock' ensemble
-
- namespace eval ::tcl::clock [list variable TclLibDir $::tcl_library]
-
- proc clock args {
- namespace eval ::tcl::clock [list namespace ensemble create -command \
- [uplevel 1 [list namespace origin [lindex [info level 0] 0]]] \
- -subcommands {
- add clicks format microseconds milliseconds scan seconds
- }]
-
- # Auto-loading stubs for 'clock.tcl'
-
- foreach cmd {add format scan} {
- proc ::tcl::clock::$cmd args {
- variable TclLibDir
- source -encoding utf-8 [file join $TclLibDir clock.tcl]
- return [uplevel 1 [info level 0]]
- }
- }
-
- return [uplevel 1 [info level 0]]
- }
-}
-
-# Conditionalize for presence of exec.
-
-if {[namespace which -command exec] eq ""} {
-
- # Some machines do not have exec. Also, on all
- # platforms, safe interpreters do not have exec.
-
- set auto_noexec 1
-}
-
-# Define a log command (which can be overwitten to log errors
-# differently, specially when stderr is not available)
-
-if {[namespace which -command tclLog] eq ""} {
- proc tclLog {string} {
- catch {puts stderr $string}
- }
-}
-
-# unknown --
-# This procedure is called when a Tcl command is invoked that doesn't
-# exist in the interpreter. It takes the following steps to make the
-# command available:
-#
-# 1. See if the 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 {
- variable ::tcl::UnknownPending
- global auto_noexec auto_noload env tcl_interactive
-
- # 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} {
- #return -code error "You need an {*}"
- set arglist [lrange $args 1 end]
- set ret [catch {uplevel 1 ::$cmd $arglist} result opts]
- dict unset opts -errorinfo
- dict incr opts -level
- return -options $opts $result
- }
-
- catch {set savedErrorInfo $::errorInfo}
- catch {set savedErrorCode $::errorCode}
- set name $cmd
- if {![info exists auto_noload]} {
- #
- # Make sure we're not trying to load the same proc twice.
- #
- if {[info exists UnknownPending($name)]} {
- return -code error "self-referential recursion\
- in \"unknown\" for command \"$name\"";
- }
- set UnknownPending($name) pending;
- set ret [catch {
- auto_load $name [uplevel 1 {::namespace current}]
- } msg opts]
- unset UnknownPending($name);
- if {$ret != 0} {
- dict append opts -errorinfo "\n (autoloading \"$name\")"
- return -options $opts $msg
- }
- if {![array size UnknownPending]} {
- unset UnknownPending
- }
- if {$msg} {
- if {[info exists savedErrorCode]} {
- set ::errorCode $savedErrorCode
- } else {
- unset -nocomplain ::errorCode
- }
- if {[info exists savedErrorInfo]} {
- set ::errorInfo $savedErrorInfo
- } else {
- unset -nocomplain ::errorInfo
- }
- set code [catch {uplevel 1 $args} msg opts]
- if {$code == 1} {
- #
- # Compute stack trace contribution from the [uplevel].
- # Note the dependence on how Tcl_AddErrorInfo, etc.
- # construct the stack trace.
- #
- set errorInfo [dict get $opts -errorinfo]
- set errorCode [dict get $opts -errorcode]
- set cinfo $args
- if {[string bytelength $cinfo] > 150} {
- set cinfo [string range $cinfo 0 150]
- while {[string bytelength $cinfo] > 150} {
- set cinfo [string range $cinfo 0 end-1]
- }
- append cinfo ...
- }
- append cinfo "\"\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.
- #
- dict unset opts -errorinfo
- dict incr opts -level
- return -options $opts $msg
- }
- #
- # Stack trace is nested, trim off just the contribution
- # from the extra "eval" of $args due to the "catch" above.
- #
- set 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 $einfo $expect $errorInfo]
- }
- return -code error -errorcode $errorCode \
- -errorinfo $einfo $msg
- } else {
- dict incr opts -level
- return -options $opts $msg
- }
- }
- }
-
- if {([info level] == 1) && ([info script] eq "") \
- && [info exists tcl_interactive] && $tcl_interactive} {
- if {![info exists auto_noexec]} {
- set new [auto_execok $name]
- if {$new ne ""} {
- set redir ""
- if {[namespace which -command console] eq ""} {
- set redir ">&@stdout <@stdin"
- }
- uplevel 1 [list ::catch \
- [concat exec $redir $new [lrange $args 1 end]] \
- ::tcl::UnknownResult ::tcl::UnknownOptions]
- dict incr ::tcl::UnknownOptions -level
- return -options $::tcl::UnknownOptions $::tcl::UnknownResult
- }
- }
- if {$name eq "!!"} {
- set newcmd [history event]
- } elseif {[regexp {^!(.+)$} $name -> event]} {
- set newcmd [history event $event]
- } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} {
- set newcmd [history event -1]
- catch {regsub -all -- $old $newcmd $new newcmd}
- }
- if {[info exists newcmd]} {
- tclLog $newcmd
- history change $newcmd 0
- uplevel 1 [list ::catch $newcmd \
- ::tcl::UnknownResult ::tcl::UnknownOptions]
- dict incr ::tcl::UnknownOptions -level
- return -options $::tcl::UnknownOptions $::tcl::UnknownResult
- }
-
- set ret [catch {set candidates [info commands $name*]} msg]
- if {$name eq "::"} {
- set name ""
- }
- if {$ret != 0} {
- dict append opts -errorinfo \
- "\n (expanding command prefix \"$name\" in unknown)"
- return -options $opts $msg
- }
- # Filter out bogus matches when $name contained
- # a glob-special char [Bug 946952]
- if {$name eq ""} {
- # Handle empty $name separately due to strangeness
- # in [string first] (See RFE 1243354)
- set cmds $candidates
- } else {
- set cmds [list]
- foreach x $candidates {
- if {[string first $name $x] == 0} {
- lappend cmds $x
- }
- }
- }
- if {[llength $cmds] == 1} {
- uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \
- ::tcl::UnknownResult ::tcl::UnknownOptions]
- dict incr ::tcl::UnknownOptions -level
- return -options $::tcl::UnknownOptions $::tcl::UnknownResult
- }
- if {[llength $cmds]} {
- return -code error "ambiguous command name \"$name\": [lsort $cmds]"
- }
- }
- return -code error "invalid command name \"$name\""
-}
-
-# auto_load --
-# Checks a collection of library directories to see if a procedure
-# is defined in one of them. If so, it sources the appropriate
-# library file to create the procedure. Returns 1 if it successfully
-# loaded the procedure, 0 otherwise.
-#
-# Arguments:
-# cmd - Name of the command to find and load.
-# namespace (optional) The namespace where the command is being used - must be
-# a canonical namespace as returned [namespace current]
-# for instance. If not given, namespace current is used.
-
-proc auto_load {cmd {namespace {}}} {
- global auto_index auto_path
-
- if {$namespace eq ""} {
- set namespace [uplevel 1 [list ::namespace current]]
- }
- set nameList [auto_qualify $cmd $namespace]
- # workaround non canonical auto_index entries that might be around
- # from older auto_mkindex versions
- lappend nameList $cmd
- foreach name $nameList {
- if {[info exists auto_index($name)]} {
- namespace eval :: $auto_index($name)
- # There's a couple of ways to look for a command of a given
- # name. One is to use
- # info commands $name
- # Unfortunately, if the name has glob-magic chars in it like *
- # or [], it may not match. For our purposes here, a better
- # route is to use
- # namespace which -command $name
- if {[namespace which -command $name] ne ""} {
- return 1
- }
- }
- }
- if {![info exists auto_path]} {
- return 0
- }
-
- if {![auto_load_index]} {
- return 0
- }
- foreach name $nameList {
- if {[info exists auto_index($name)]} {
- namespace eval :: $auto_index($name)
- if {[namespace which -command $name] ne ""} {
- return 1
- }
- }
- }
- return 0
-}
-
-# auto_load_index --
-# Loads the contents of tclIndex files on the auto_path directory
-# list. This is usually invoked within auto_load to load the index
-# of available commands. Returns 1 if the index is loaded, and 0 if
-# the index is already loaded and up to date.
-#
-# Arguments:
-# None.
-
-proc auto_load_index {} {
- variable ::tcl::auto_oldpath
- global auto_index auto_path
-
- if {[info exists auto_oldpath] && ($auto_oldpath eq $auto_path)} {
- return 0
- }
- set auto_oldpath $auto_path
-
- # Check if we are a safe interpreter. In that case, we support only
- # newer format tclIndex files.
-
- set issafe [interp issafe]
- for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
- set dir [lindex $auto_path $i]
- set f ""
- if {$issafe} {
- catch {source [file join $dir tclIndex]}
- } elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
- continue
- } else {
- set error [catch {
- set id [gets $f]
- if {$id eq "# Tcl autoload index file, version 2.0"} {
- eval [read $f]
- } elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} {
- while {[gets $f line] >= 0} {
- if {([string index $line 0] eq "#") \
- || ([llength $line] != 2)} {
- continue
- }
- set name [lindex $line 0]
- set auto_index($name) \
- "source [file join $dir [lindex $line 1]]"
- }
- } else {
- error "[file join $dir tclIndex] isn't a proper Tcl index file"
- }
- } msg opts]
- if {$f ne ""} {
- close $f
- }
- if {$error} {
- return -options $opts $msg
- }
- }
- }
- return 1
-}
-
-# auto_qualify --
-#
-# Compute a fully qualified names list for use in the auto_index array.
-# For historical reasons, commands in the global namespace do not have leading
-# :: in the index key. The list has two elements when the command name is
-# relative (no leading ::) and the namespace is not the global one. Otherwise
-# only one name is returned (and searched in the auto_index).
-#
-# Arguments -
-# cmd The command name. Can be any name accepted for command
-# invocations (Like "foo::::bar").
-# namespace The namespace where the command is being used - must be
-# a canonical namespace as returned by [namespace current]
-# for instance.
-
-proc auto_qualify {cmd namespace} {
-
- # count separators and clean them up
- # (making sure that foo:::::bar will be treated as foo::bar)
- set n [regsub -all {::+} $cmd :: cmd]
-
- # Ignore namespace if the name starts with ::
- # Handle special case of only leading ::
-
- # Before each return case we give an example of which category it is
- # with the following form :
- # ( inputCmd, inputNameSpace) -> output
-
- if {[string match ::* $cmd]} {
- if {$n > 1} {
- # ( ::foo::bar , * ) -> ::foo::bar
- return [list $cmd]
- } else {
- # ( ::global , * ) -> global
- return [list [string range $cmd 2 end]]
- }
- }
-
- # Potentially returning 2 elements to try :
- # (if the current namespace is not the global one)
-
- if {$n == 0} {
- if {$namespace eq "::"} {
- # ( nocolons , :: ) -> nocolons
- return [list $cmd]
- } else {
- # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
- return [list ${namespace}::$cmd $cmd]
- }
- } elseif {$namespace eq "::"} {
- # ( foo::bar , :: ) -> ::foo::bar
- return [list ::$cmd]
- } else {
- # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
- return [list ${namespace}::$cmd ::$cmd]
- }
-}
-
-# auto_import --
-#
-# Invoked during "namespace import" to make see if the imported commands
-# reside in an autoloaded library. If so, the commands are loaded so
-# that they will be available for the import links. If not, then this
-# procedure does nothing.
-#
-# Arguments -
-# pattern The pattern of commands being imported (like "foo::*")
-# a canonical namespace as returned by [namespace current]
-
-proc auto_import {pattern} {
- global auto_index
-
- # If no namespace is specified, this will be an error case
-
- if {![string match *::* $pattern]} {
- return
- }
-
- set ns [uplevel 1 [list ::namespace current]]
- set patternList [auto_qualify $pattern $ns]
-
- auto_load_index
-
- foreach pattern $patternList {
- foreach name [array names auto_index $pattern] {
- if {([namespace which -command $name] eq "")
- && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} {
- namespace eval :: $auto_index($name)
- }
- }
- }
-}
-
-# auto_execok --
-#
-# Returns string that indicates name of program to execute if
-# name corresponds to a shell builtin or an executable in the
-# Windows search path, or "" otherwise. Builds an associative
-# array auto_execs that caches information about previous checks,
-# for speed.
-#
-# Arguments:
-# name - Name of a command.
-
-if {$tcl_platform(platform) eq "windows"} {
-# Windows version.
-#
-# Note that 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 {$tcl_platform(os) eq "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 {$name in $shellBuiltins} {
- # When this is command.com for some reason on Win2K, Tcl won't
- # exec it unless the case is right, which this corrects. COMSPEC
- # may not point to a real file, so do the check.
- set cmd $env(COMSPEC)
- if {[file exists $cmd]} {
- set cmd [file attributes $cmd -shortname]
- }
- return [set auto_execs($name) [list $cmd /c $name]]
- }
-
- if {[llength [file split $name]] != 1} {
- foreach ext $execExtensions {
- set file ${name}${ext}
- if {[file exists $file] && ![file isdirectory $file]} {
- return [set auto_execs($name) [list $file]]
- }
- }
- return ""
- }
-
- set path "[file dirname [info nameof]];.;"
- if {[info exists env(WINDIR)]} {
- set windir $env(WINDIR)
- }
- if {[info exists windir]} {
- if {$tcl_platform(os) eq "Windows NT"} {
- append path "$windir/system32;"
- }
- append path "$windir/system;$windir;"
- }
-
- foreach var {PATH Path path} {
- if {[info exists env($var)]} {
- append path ";$env($var)"
- }
- }
-
- foreach dir [split $path {;}] {
- # Skip already checked directories
- if {[info exists checked($dir)] || ($dir eq {})} { 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 {$dir eq ""} {
- set dir .
- }
- set file [file join $dir $name]
- if {[file executable $file] && ![file isdirectory $file]} {
- set auto_execs($name) [list $file]
- return $auto_execs($name)
- }
- }
- return ""
-}
-
-}
-
-# ::tcl::CopyDirectory --
-#
-# This procedure is called by Tcl's core when attempts to call the
-# filesystem's copydirectory function fail. The semantics of the call
-# are that 'dest' does not yet exist, i.e. dest should become the exact
-# image of src. If dest does exist, we throw an error.
-#
-# Note that making changes to this procedure can change the results
-# of running Tcl's tests.
-#
-# Arguments:
-# action - "renaming" or "copying"
-# src - source directory
-# dest - destination directory
-proc tcl::CopyDirectory {action src dest} {
- set nsrc [file normalize $src]
- set ndest [file normalize $dest]
-
- if {$action eq "renaming"} {
- # Can't rename volumes. We could give a more precise
- # error message here, but that would break the test suite.
- if {$nsrc in [file volumes]} {
- return -code error "error $action \"$src\" to\
- \"$dest\": trying to rename a volume or move a directory\
- into itself"
- }
- }
- if {[file exists $dest]} {
- if {$nsrc eq $ndest} {
- return -code error "error $action \"$src\" to\
- \"$dest\": trying to rename a volume or move a directory\
- into itself"
- }
- if {$action eq "copying"} {
- # We used to throw an error here, but, looking more closely
- # at the core copy code in tclFCmd.c, if the destination
- # exists, then we should only call this function if -force
- # is true, which means we just want to over-write. So,
- # the following code is now commented out.
- #
- # return -code error "error $action \"$src\" to\
- # \"$dest\": file already exists"
- } else {
- # Depending on the platform, and on the current
- # working directory, the directories '.', '..'
- # can be returned in various combinations. Anyway,
- # if any other file is returned, we must signal an error.
- set existing [glob -nocomplain -directory $dest * .*]
- lappend existing {*}[glob -nocomplain -directory $dest \
- -type hidden * .*]
- foreach s $existing {
- if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
- return -code error "error $action \"$src\" to\
- \"$dest\": file already exists"
- }
- }
- }
- } else {
- if {[string first $nsrc $ndest] != -1} {
- set srclen [expr {[llength [file split $nsrc]] -1}]
- set ndest [lindex [file split $ndest] $srclen]
- if {$ndest eq [file tail $nsrc]} {
- return -code error "error $action \"$src\" to\
- \"$dest\": trying to rename a volume or move a directory\
- into itself"
- }
- }
- file mkdir $dest
- }
- # Have to be careful to capture both visible and hidden files.
- # We will also be more generous to the file system and not
- # assume the hidden and non-hidden lists are non-overlapping.
- #
- # On Unix 'hidden' files begin with '.'. On other platforms
- # or filesystems hidden files may have other interpretations.
- set filelist [concat [glob -nocomplain -directory $src *] \
- [glob -nocomplain -directory $src -types hidden *]]
-
- foreach s [lsort -unique $filelist] {
- if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
- file copy -force $s [file join $dest [file tail $s]]
- }
- }
- return
-}
diff --git a/library/license.terms b/library/license.terms
deleted file mode 100644
index f1dcaa5..0000000
--- a/library/license.terms
+++ /dev/null
@@ -1,40 +0,0 @@
-This software is copyrighted by the Regents of the University of
-California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
-Corporation and other parties. The following terms apply to all files
-associated with the software unless explicitly disclaimed in
-individual files.
-
-The authors hereby grant permission to use, copy, modify, distribute,
-and license this software and its documentation for any purpose, provided
-that existing copyright notices are retained in all copies and that this
-notice is included verbatim in any distributions. No written agreement,
-license, or royalty fee is required for any of the authorized uses.
-Modifications to this software may be copyrighted by their authors
-and need not follow the licensing terms described here, provided that
-the new terms are clearly indicated on the first page of each file where
-they apply.
-
-IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
-FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
-ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
-DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
-POSSIBILITY OF SUCH DAMAGE.
-
-THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
-INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
-FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
-IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
-NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
-MODIFICATIONS.
-
-GOVERNMENT USE: If you are acquiring this software on behalf of the
-U.S. government, the Government shall have only "Restricted Rights"
-in the software and related documentation as defined in the Federal
-Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
-are acquiring the software on behalf of the Department of Defense, the
-software shall be classified as "Commercial Computer Software" and the
-Government shall have only "Restricted Rights" as defined in Clause
-252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
-authors grant the U.S. Government and others acting in its behalf
-permission to use and distribute the software in accordance with the
-terms specified in this license.
diff --git a/library/opt/optparse.tcl b/library/opt/optparse.tcl
deleted file mode 100644
index 4622bde..0000000
--- a/library/opt/optparse.tcl
+++ /dev/null
@@ -1,1074 +0,0 @@
-# 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.10 2003/09/10 20:27:30 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.5
-
-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 lazy type determination
- proc OptGuessType {arg} {
- if { $arg == "true" || $arg == "false" } {
- return boolean
- }
- if {[string is integer -strict $arg]} {
- return int
- }
- if {[string is double -strict $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 {}
-}
diff --git a/library/opt/pkgIndex.tcl b/library/opt/pkgIndex.tcl
deleted file mode 100644
index c5d3635..0000000
--- a/library/opt/pkgIndex.tcl
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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.5 [list source [file join $dir optparse.tcl]]
diff --git a/library/parray.tcl b/library/parray.tcl
deleted file mode 100644
index e331d4d..0000000
--- a/library/parray.tcl
+++ /dev/null
@@ -1,30 +0,0 @@
-# parray:
-# Print the contents of a global array on stdout.
-#
-# RCS: @(#) $Id: parray.tcl,v 1.4 2005/06/03 10:02:23 dkf 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
- set names [lsort [array names array $pattern]]
- foreach name $names {
- if {[string length $name] > $maxl} {
- set maxl [string length $name]
- }
- }
- set maxl [expr {$maxl + [string length $a] + 2}]
- foreach name $names {
- set nameString [format %s(%s) $a $name]
- puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
- }
-}
diff --git a/library/safe.tcl b/library/safe.tcl
deleted file mode 100644
index 501a552..0000000
--- a/library/safe.tcl
+++ /dev/null
@@ -1,1035 +0,0 @@
-# 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.16.4.1 2008/06/25 16:42:05 andreas_kupries 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 {$access_path eq ""} {
- 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
- }
- # Extend the access list with the paths used to look for Tcl
- # Modules. We safe the virtual form separately as well, as
- # syncing it with the slave has to be defered until the
- # necessary commands are present for setup.
- foreach dir [::tcl::tm::list] {
- lappend access_path $dir
- Set [PathToken $i $slave] $dir
- lappend slave_auto_path "\$[PathToken $i]"
- lappend slave_tm_path "\$[PathToken $i]"
- incr i
- }
- Set [TmPathListName $slave] $slave_tm_path
- 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
-
- # Handling Tcl Modules, we need a restricted form of Glob.
- ::interp alias $slave glob {} [namespace current]::AliasGlob \
- $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 and tm.tcl into the slave, to get auto_load
- # and other procedures defined:
-
- 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)"
- }
-
- if {[catch {::interp eval $slave \
- {source [file join $tcl_library tm.tcl]}} msg]} {
- Log $slave "can't source tm.tcl ($msg)"
- error "can't source tm.tcl into slave $slave ($msg)"
- }
-
- # Sync the paths used to search for Tcl modules. This can be
- # done only now, after tm.tcl was loaded.
- ::interp eval $slave [list ::tcl::tm::add {*}[Set [TmPathListName $slave]]]
-
- 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 {{*}$hook $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 complete tm path list
- proc TmPathListName {slave} {
- return "[InterpStateName $slave](tm_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} {
- Toplevel set {*}$args
- }
- # lappend on toplevel vars
- proc Lappend {args} {
- Toplevel lappend {*}$args
- }
- # unset a var/token (currently just an global level eval)
- proc Unset {args} {
- 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 {[string match "*::*" $path] || [string match "*..*" $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]} {
- {*}$Log "$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"
- }
- }
-
- # AliasGlob is the target of the "glob" alias in safe interpreters.
-
- proc AliasGlob {slave args} {
- Log $slave "GLOB ! $args" NOTICE
- set cmd {}
- set at 0
-
- set dir {}
- set virtualdir {}
-
- while {$at < [llength $args]} {
- switch -glob -- [set opt [lindex $args $at]] {
- -nocomplain -
- -join { lappend cmd $opt ; incr at }
- -directory {
- lappend cmd $opt ; incr at
- set virtualdir [lindex $args $at]
-
- # get the real path from the virtual one.
- if {[catch {set dir [TranslatePath $slave $virtualdir]} msg]} {
- Log $slave $msg
- return -code error "permission denied"
- }
- # check that the path is in the access path of that slave
- if {[catch {DirInAccessPath $slave $dir} msg]} {
- Log $slave $msg
- return -code error "permission denied"
- }
- lappend cmd $dir ; incr at
- }
- pkgIndex.tcl {
- # Oops, this is globbing a subdirectory in regular
- # package search. That is not wanted. Abort,
- # handler does catch already (because glob was not
- # defined before). See package.tcl, lines 484ff in
- # tclPkgUnknown.
- error "unknown command glob"
- }
- -* {
- Log $slave "Safe base rejecting glob option '$opt'"
- error "Safe base rejecting glob option '$opt'"
- }
- default {
- lappend cmd $opt ; incr at
- }
- }
- }
-
- Log $slave "GLOB = $cmd" NOTICE
-
- if {[catch {::interp invokehidden $slave glob {*}$cmd} msg]} {
- Log $slave $msg
- return -code error "script error"
- }
-
- Log $slave "GLOB @ $msg" NOTICE
-
- # Translate path back to what the slave should see.
- set res {}
- foreach p $msg {
- regsub -- ^$dir $p $virtualdir p
- lappend res $p
- }
-
- Log $slave "GLOB @ $res" NOTICE
- return $res
- }
-
- # AliasSource is the target of the "source" alias in safe interpreters.
-
- proc AliasSource {slave args} {
-
- set argc [llength $args]
- # Extended for handling of Tcl Modules to allow not only
- # "source filename", but "source -encoding E filename" as
- # well.
- if {[lindex $args 0] eq "-encoding"} {
- incr argc -2
- set encoding [lrange $args 0 1]
- set at 2
- } else {
- set at 0
- set encoding {}
- }
- if {$argc != 1} {
- set msg "wrong # args: should be \"source ?-encoding E? fileName\""
- Log $slave "$msg ($args)"
- return -code error $msg
- }
- set file [lindex $args $at]
-
- # 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 {*}$encoding $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 {$target ne ""} {
- # 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 {$file eq ""} {
- # static package loading
- if {$package eq ""} {
- 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"
- }
- }
-
- proc DirInAccessPath {slave dir} {
- set access_path [GetAccessPath $slave]
-
- if {[file isfile $dir]} {
- error "\"$dir\": is a file"
- }
-
- # Normalize paths for comparison since lsearch knows nothing of
- # potential pathname anomalies.
- set norm_dir [file normalize $dir]
- foreach path $access_path {
- lappend norm_access_path [file normalize $path]
- }
-
- if {[lsearch -exact $norm_access_path $norm_dir] == -1} {
- error "\"$dir\": 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 [$command {*}$args]
- }
- 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 [::interp invokehidden $slave encoding {*}$args]
- }
-
- if {[string first $subcommand system] == 0} {
- 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
- }
-
-}
diff --git a/library/tclIndex b/library/tclIndex
deleted file mode 100644
index 010616f..0000000
--- a/library/tclIndex
+++ /dev/null
@@ -1,87 +0,0 @@
-# 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(pkg_mkIndex) [list source [file join $dir package.tcl]]
-set auto_index(tclPkgSetup) [list source [file join $dir package.tcl]]
-set auto_index(tclPkgUnknown) [list source [file join $dir package.tcl]]
-set auto_index(::tcl::MacOSXPkgUnknown) [list source [file join $dir package.tcl]]
-set auto_index(::pkg::create) [list source [file join $dir package.tcl]]
-set auto_index(parray) [list source [file join $dir parray.tcl]]
-set auto_index(::safe::InterpStatics) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::InterpNested) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpInit) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::CheckInterp) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpConfigure) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::InterpCreate) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::InterpSetConfig) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpFindInAccessPath) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpAddToAccessPath) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::InterpInit) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::AddSubDirs) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::setLogCmd) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::SyncAccessPath) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::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(::safe::AliasEncoding) [list source [file join $dir safe.tcl]]
-set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]]
-set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]]
-set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]]
-set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]]
-set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]]
-set auto_index(::tcl::tm::add) [list source [file join $dir tm.tcl]]
-set auto_index(::tcl::tm::remove) [list source [file join $dir tm.tcl]]
-set auto_index(::tcl::tm::list) [list source [file join $dir tm.tcl]]
-set auto_index(::tcl::tm::UnknownHandler) [list source [file join $dir tm.tcl]]
-set auto_index(::tcl::tm::roots) [list source [file join $dir tm.tcl]]
-set auto_index(::tcl::tm::path) [list source [file join $dir tm.tcl]]
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
deleted file mode 100644
index 3d3e89b..0000000
--- a/library/tcltest/tcltest.tcl
+++ /dev/null
@@ -1,3387 +0,0 @@
-# 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 31404 2008-09-25 05:41:59Z coke $
-
-package require Tcl 8.5 ;# -verbose line uses [info frame]
-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.3.0
-
- # 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|line)$} $level]} {
- # translate single characters abbreviations to expanded list
- set level [string map {p pass b body s skip t start e error l line} \
- [split $level {}]]
- }
- }
- set valid [list]
- foreach v $level {
- if {[regexp {^(pass|body|skip|start|error|line)$} $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', 'e' and 'l'.
- 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. Source file line
- information of failed tests is displayed if 'l' 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"
- if {[IsVerbose line]} {
- if {![catch {set testFrame [info frame -1]}] &&
- [dict get $testFrame type] eq "source"} {
- set testFile [dict get $testFrame file]
- set testLine [dict get $testFrame line]
- } else {
- set testFile [file normalize [uplevel 1 {info script}]]
- if {[file readable $testFile]} {
- set testFd [open $testFile r]
- set testLine [expr {[lsearch -regexp \
- [split [read $testFd] "\n"] \
- "^\[ \t\]*test [string map {. \\.} $name] "]+1}]
- close $testFd
- }
- }
- if {[info exists testLine]} {
- puts [outputChannel] "$testFile:$testLine: test failed:\
- $name [string trim $description]"
- }
- }
- puts [outputChannel] "==== $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} {
- #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 -types {b c f p s} \
- -nocomplain -- $match]]
- }
-
- # List files in $directory that match patterns to skip.
- set skipFileList [list]
- foreach skip [skipFiles] {
- set skipFileList [concat $skipFileList \
- [glob -directory $directory -types {b c f p s} \
- -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] {
- set skipDirs [concat $skipDirs [glob -directory $rootdir -types d \
- -nocomplain -- $pattern]]
- }
-
- # 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 -types d -nocomplain -- \
- $pattern] {
- 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
-}
-
-################################################################################
-# XXX partcl hacks - goal is to eventually remove these and run tcltest
-# natively. Any code in this section is NOT part of the original tcltest.tcl
-# library file but was specifically added for partcl;
-
-proc ::tcltest::outputChannel {} { return stdout }
-proc ::tcltest::errorChannel {} { return stderr }
-
-# Since I keep inadvertently committing them, leaving in the always-on
-# modifications for PASSED and SKIPPED; we can revert when we're faster.
-################################################################################
diff --git a/library/word.tcl b/library/word.tcl
deleted file mode 100644
index b8f7f7d..0000000
--- a/library/word.tcl
+++ /dev/null
@@ -1,146 +0,0 @@
-# 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.10 2007/12/13 15:26:03 dgp Exp $
-
-# The following variables are used to determine which characters are
-# interpreted as white space.
-
-if {$::tcl_platform(platform) eq "windows"} {
- # Windows style - any but a unicode space char
- 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}
-}
-
-# Arrange for caches of the real matcher REs to be kept, which enables the REs
-# themselves to be cached for greater performance (and somewhat greater
-# clarity too).
-
-namespace eval ::tcl {
- variable WordBreakRE
- array set WordBreakRE {}
-
- proc UpdateWordBreakREs args {
- # Ignores the arguments
- global tcl_wordchars tcl_nonwordchars
- variable WordBreakRE
-
- # To keep the RE strings short...
- set letter $tcl_wordchars
- set space $tcl_nonwordchars
-
- set WordBreakRE(after) "$letter$space|$space$letter"
- set WordBreakRE(before) "^.*($letter$space|$space$letter)"
- set WordBreakRE(end) "$space*$letter+$space"
- set WordBreakRE(next) "$letter*$space+$letter"
- set WordBreakRE(previous) "$space*($letter+)$space*\$"
- }
-
- # Initialize the cache
- UpdateWordBreakREs
- trace add variable ::tcl_wordchars write ::tcl::UpdateWordBreakREs
- trace add variable ::tcl_nonwordchars write ::tcl::UpdateWordBreakREs
-}
-
-# tcl_wordBreakAfter --
-#
-# This procedure returns the index of the first word boundary after the
-# starting point in the given string, or -1 if there are no more boundaries in
-# the given string. The index returned refers to the first character of the
-# pair that comprises a boundary.
-#
-# Arguments:
-# str - String to search.
-# start - Index into string specifying starting point.
-
-proc tcl_wordBreakAfter {str start} {
- variable ::tcl::WordBreakRE
- set result {-1 -1}
- regexp -indices -start $start $WordBreakRE(after) $str result
- return [lindex $result 1]
-}
-
-# tcl_wordBreakBefore --
-#
-# This procedure returns the index of the first word boundary before the
-# starting point in the given string, or -1 if there are no more boundaries in
-# the given string. The index returned refers to the second character of the
-# pair that comprises a boundary.
-#
-# Arguments:
-# str - String to search.
-# start - Index into string specifying starting point.
-
-proc tcl_wordBreakBefore {str start} {
- variable ::tcl::WordBreakRE
- set result {-1 -1}
- regexp -indices $WordBreakRE(before) [string range $str 0 $start] result
- return [lindex $result 1]
-}
-
-# tcl_endOfWord --
-#
-# This procedure returns the index of the first end-of-word location after a
-# starting index in the given string. An end-of-word location is defined to be
-# the first whitespace character following the first non-whitespace character
-# after the starting point. Returns -1 if there are no more words after the
-# starting point.
-#
-# Arguments:
-# str - String to search.
-# start - Index into string specifying starting point.
-
-proc tcl_endOfWord {str start} {
- variable ::tcl::WordBreakRE
- set result {-1 -1}
- regexp -indices -start $start $WordBreakRE(end) $str result
- return [lindex $result 1]
-}
-
-# tcl_startOfNextWord --
-#
-# This procedure returns the index of the first start-of-word location after a
-# starting index in the given string. A start-of-word location is defined to
-# be a non-whitespace character following a whitespace character. Returns -1
-# if there are no more start-of-word locations after the starting point.
-#
-# Arguments:
-# str - String to search.
-# start - Index into string specifying starting point.
-
-proc tcl_startOfNextWord {str start} {
- variable ::tcl::WordBreakRE
- set result {-1 -1}
- regexp -indices -start $start $WordBreakRE(next) $str result
- return [lindex $result 1]
-}
-
-# tcl_startOfPreviousWord --
-#
-# This procedure returns the index of the first start-of-word location before
-# a starting index in the given string.
-#
-# Arguments:
-# str - String to search.
-# start - Index into string specifying starting point.
-
-proc tcl_startOfPreviousWord {str start} {
- variable ::tcl::WordBreakRE
- set word {-1 -1}
- regexp -indices $WordBreakRE(previous) [string range $str 0 $start-1] \
- result word
- return [lindex $word 0]
-}
diff --git a/src/ARE/Actions.pm b/src/ARE/Actions.pm
deleted file mode 100644
index e4d420f..0000000
--- a/src/ARE/Actions.pm
+++ /dev/null
@@ -1,119 +0,0 @@
-use NQPHLL;
-
-class ARE::Actions is HLL::Actions {
-
- method TOP($/) {
- my $past := buildsub( $.ast );
- $past.node($/);
- make $past;
- }
-
- method nibbler($/) {
- my $past;
- if +$ > 1 {
- $past := PAST::Regex.new( :pasttype('alt'), :node($/) );
- for $ { $past.push($_.ast); }
- }
- else {
- $past := $[0].ast;
- }
- make $past;
- }
-
- method termish($/) {
- my $past := PAST::Regex.new( :pasttype('concat'), :node($/) );
- my $lastlit := 0;
- for $ {
- my $ast := $_.ast;
- if $ast {
- if $lastlit && $ast.pasttype eq 'literal'
- && !PAST::Node.ACCEPTS($ast[0]) {
- $lastlit[0] := $lastlit[0] ~ $ast[0];
- }
- else {
- $past.push($ast);
- $lastlit := $ast.pasttype eq 'literal'
- && !PAST::Node.ACCEPTS($ast[0])
- ?? $ast !! 0;
- }
- }
- }
- make $past;
- }
-
- method quantified_atom($/) {
- my $past := $.ast;
- if $ {
- my $qast := $[0].ast;
- $qast.unshift($past);
- $past := $qast;
- }
- make $past;
- }
-
- method atom($/) {
- my $past := $
- ?? $.ast
- !! PAST::Regex.new( ~$/, :pasttype, :node($/) );
- make $past;
- }
-
- method quantifier:sym<*>($/) {
- make PAST::Regex.new( :pasttype, :node($/) );
- }
- method quantifier:sym<+>($/) {
- make PAST::Regex.new( :pasttype, :min(1), :node($/) );
- }
- method quantifier:sym($/) {
- make PAST::Regex.new( :pasttype, :min(0), :max(1), :node($/) );
- }
-
- method metachar:sym<^>($/) {
- make PAST::Regex.new( :pasttype, :subtype('bos'), :node($/) );
- }
-
- method metachar:sym<$>($/) {
- make PAST::Regex.new( :pasttype, :subtype('eos'), :node($/) );
- }
-
- method metachar:sym<.>($/) {
- make PAST::Regex.new( :pasttype, :subtype<.>, :node($/) );
- }
-
- method metachar:sym($/) { make $.ast; }
-
- method metachar:sym<[>($/) {
- my $str := '';
- for $ {
- if $_[1] {
- my $a := pir::ord($_[0]);
- my $b := pir::ord(~$_[1][0]);
- while $a <= $b { $str := $str ~ pir::chr($a); $a++; }
- }
- else { $str := $str ~ $_[0]; }
- }
- my $past := PAST::Regex.new( $str, :pasttype, :node($/) );
- $past.negate( $ gt '' );
- make $past;
- }
-
- method backslash:sym($/) {
- make PAST::Regex.new( :pasttype, :subtype(~$), :node($/));
- }
-
- sub buildsub($rpast, $block = PAST::Block.new() ) {
- $rpast := PAST::Regex.new(
- PAST::Regex.new( :pasttype('scan') ),
- $rpast,
- PAST::Regex.new( :pasttype('pass') ),
- :pasttype('concat'),
- );
- unless $block.symbol('$¢') { $block.symbol('$¢', :scope); }
- unless $block.symbol('$/') { $block.symbol('$/', :scope); }
- $block.push($rpast);
- $block.blocktype('method');
- $block;
- }
-}
-
-# vim: expandtab shiftwidth=4 ft=perl6:
diff --git a/src/ARE/Compiler.pm b/src/ARE/Compiler.pm
deleted file mode 100644
index ba91182..0000000
--- a/src/ARE/Compiler.pm
+++ /dev/null
@@ -1,12 +0,0 @@
-use NQPHLL;
-
-class ARE::Compiler is HLL::Compiler {
- INIT {
- my $compiler := ARE::Compiler.new();
- $compiler.parsegrammar(ARE::Grammar);
- $compiler.parseactions(ARE::Actions);
- $compiler.language('ARE');
- }
-}
-
-# vim: expandtab shiftwidth=4 ft=perl6:
diff --git a/src/ARE/Grammar.pm b/src/ARE/Grammar.pm
deleted file mode 100644
index c13974e..0000000
--- a/src/ARE/Grammar.pm
+++ /dev/null
@@ -1,54 +0,0 @@
-use NQPHLL;
-
-grammar ARE::Grammar is HLL::Grammar {
- token TOP {
-
- [ $ || <.panic: 'Confused'> ]
- }
-
- token nibbler {
- [ '|' ]*
- }
-
- token termish {
- +
- }
-
- token quantified_atom {
- ?
- }
-
- token atom {
- [
- | <.barechar> [ <.barechar>+! > ]?
- |
- ]
- }
-
- token barechar { <-[\\\[*+?^$]> }
-
- proto token quantifier { <...> }
- token quantifier:sym<*> { }
- token quantifier:sym<+> { }
- token quantifier:sym { }
-
-
- proto token metachar { <...> }
- token metachar:sym<^> { }
- token metachar:sym<$> { }
- token metachar:sym<.> { }
- token metachar:sym { \\ }
-
-
- token metachar:sym<[> {
- '['
- $=['^'?]
- $=( [ \\ (.) | (<-[\]\\]>) ] [ '-' (.) ]? )*
- ']'
- }
-
- proto token backslash { <...> }
- token backslash:sym { $=[<[dswDSW]>] }
-}
-
-# vim: expandtab shiftwidth=4 ft=perl6:
diff --git a/src/FileGlob/Actions.pm b/src/FileGlob/Actions.pm
deleted file mode 100644
index 4f31556..0000000
--- a/src/FileGlob/Actions.pm
+++ /dev/null
@@ -1,16 +0,0 @@
-use NQPHLL;
-
-use src::StringGlob::Actions;
-
-class FileGlob::Actions is StringGlob::Actions {
-
- method metachar:sym<{>($/) {
- my $ast := PAST::Regex.new( :pasttype, :node($/) );
- for $ {
- $ast.push(PAST::Regex.new( ~$_, :pasttype, :node($/) ) );
- }
- make $ast;
- }
-}
-
-# vim: expandtab shiftwidth=4 ft=perl6:
diff --git a/src/FileGlob/Compiler.pm b/src/FileGlob/Compiler.pm
deleted file mode 100644
index 62b5956..0000000
--- a/src/FileGlob/Compiler.pm
+++ /dev/null
@@ -1,12 +0,0 @@
-use NQPHLL;
-
-class FileGlob::Compiler is HLL::Compiler {
- INIT {
- my $compiler := FileGlob::Compiler.new();
- $compiler.parsegrammar(FileGlob::Grammar);
- $compiler.parseactions(FileGlob::Actions);
- $compiler.language('FileGlob');
- }
-}
-
-# vim: expandtab shiftwidth=4 ft=perl6:
diff --git a/src/FileGlob/Grammar.pm b/src/FileGlob/Grammar.pm
deleted file mode 100644
index d881bf5..0000000
--- a/src/FileGlob/Grammar.pm
+++ /dev/null
@@ -1,17 +0,0 @@
-use NQPHLL;
-
-use src::StringGlob::Grammar;
-
-grammar FileGlob::Grammar is StringGlob::Grammar {
-
- # This is how globs do alternation
- token metachar:sym<{> {
- '{' ~ '}' [ +% ',' ]
- }
-
- token word { <-[,}]>+ }
-
- token barechar { <-[\\\[*+?{]> }
-}
-
-# vim: expandtab shiftwidth=4 ft=perl6:
diff --git a/src/Partcl.pm b/src/Partcl.pm
index 4fa74f4..183ce43 100644
--- a/src/Partcl.pm
+++ b/src/Partcl.pm
@@ -8,91 +8,10 @@ use src::Partcl::Grammar;
use src::Partcl::Actions;
use src::Partcl::Compiler;
use src::Partcl::Operators;
-use src::Partcl::commands::after;
-use src::Partcl::commands::append;
-use src::Partcl::commands::apply;
-use src::Partcl::commands::array;
-use src::Partcl::commands::binary;
-use src::Partcl::commands::break;
-use src::Partcl::commands::catch;
-use src::Partcl::commands::cd;
-use src::Partcl::commands::concat;
-use src::Partcl::commands::continue;
-use src::Partcl::commands::dict;
-use src::Partcl::commands::eof;
-use src::Partcl::commands::encoding;
-use src::Partcl::commands::error;
-use src::Partcl::commands::eval;
-use src::Partcl::commands::exit;
-use src::Partcl::commands::expr;
-use src::Partcl::commands::fileevent;
-use src::Partcl::commands::file;
-use src::Partcl::commands::flush;
-use src::Partcl::commands::foreach;
-use src::Partcl::commands::format;
-use src::Partcl::commands::for;
-use src::Partcl::commands::gets;
-use src::Partcl::commands::global;
-use src::Partcl::commands::glob;
-use src::Partcl::commands::if;
-use src::Partcl::commands::incr;
-use src::Partcl::commands::info;
-use src::Partcl::commands::interp;
-use src::Partcl::commands::join;
-use src::Partcl::commands::lappend;
-use src::Partcl::commands::lassign;
-use src::Partcl::commands::lindex;
-use src::Partcl::commands::linsert;
-use src::Partcl::commands::list;
-use src::Partcl::commands::llength;
-use src::Partcl::commands::lrange;
-use src::Partcl::commands::lrepeat;
-use src::Partcl::commands::lreplace;
-use src::Partcl::commands::lreverse;
-use src::Partcl::commands::lset;
-use src::Partcl::commands::lsort;
-use src::Partcl::commands::namespace;
-use src::Partcl::commands::package;
-use src::Partcl::commands::proc;
-use src::Partcl::commands::puts;
-use src::Partcl::commands::pwd;
-use src::Partcl::commands::regexp;
-use src::Partcl::commands::rename;
-use src::Partcl::commands::return;
-use src::Partcl::commands::set;
-use src::Partcl::commands::socket;
-use src::Partcl::commands::source;
-use src::Partcl::commands::split;
-use src::Partcl::commands::string;
-use src::Partcl::commands::subst;
-use src::Partcl::commands::switch;
-use src::Partcl::commands::time;
-use src::Partcl::commands::trace;
-use src::Partcl::commands::unset;
-use src::Partcl::commands::uplevel;
-use src::Partcl::commands::upvar;
-use src::Partcl::commands::variable;
-use src::Partcl::commands::vwait;
-use src::Partcl::commands::while;
-use src::TclArray;
-use src::TclLexPad;
-use src::TclList;
-use src::TclString;
-use src::ARE::Grammar;
-use src::ARE::Actions;
-use src::ARE::Compiler;
-use src::StringGlob::Grammar;
-use src::StringGlob::Actions;
-use src::StringGlob::Compiler;
-use src::FileGlob::Grammar;
-use src::FileGlob::Actions;
-use src::FileGlob::Compiler;
use src::init;
-use src::options;
sub MAIN(*@ARGS) {
- # XXX setup %LEXPAD?
Partcl::Compiler.new().command_line(@ARGS);
}
diff --git a/src/Partcl/Actions.pm b/src/Partcl/Actions.pm
index 83f984a..691e42a 100644
--- a/src/Partcl/Actions.pm
+++ b/src/Partcl/Actions.pm
@@ -5,60 +5,21 @@ class Partcl::Actions is HLL::Actions {
method TOP($/) { make $.ast; }
## TOP_eval and TOP_expr create a PAST::Block that uses the
- ## lexical scope given by the caller's %LEXPAD.
method TOP_eval($/) { make eval_block($.ast); }
method TOP_expr($/) { make eval_block($.ast); }
sub eval_block($past) {
## This is the runtime equivalent of
- ## register lexpad := DYNAMIC::<%LEXPAD>;
## The body of the code to be evaluated
- my $lexpad_init :=
- PAST::Var.new( :name, :scope, :isdecl,
- :viviself( PAST::Op.new(:pirop('find_dynamic_lex Ps'), '%LEXPAD'))
- );
-
- if ! pir::isnull(pir::find_dynamic_lex('@*PARTCL_COMPILER_NAMESPACE')) {
- PAST::Block.new( PAST::Stmts.new( $lexpad_init ), $past, :hll,
- :namespace(@*PARTCL_COMPILER_NAMESPACE)
- );
- } else {
- PAST::Block.new( PAST::Stmts.new( $lexpad_init ), $past, :hll);
- }
}
## TOP_proc creates a PAST::Block that initializes a
- ## new lexical scope in %LEXPAD.
method TOP_proc($/) { make lex_block($.ast); }
sub lex_block($past) {
## This is the runtime equivalent of
- ## register lexpad :=
- ## my %LEXPAD := TclLexPad.newpad(DYNAMIC::<%LEXPAD>);
- my $lexpad_init :=
- PAST::Var.new( :name, :scope, :isdecl,
- :viviself(
- PAST::Var.new( :name<%LEXPAD>, :scope, :isdecl,
- :viviself(
- PAST::Op.new(
- :pasttype, :name,
- PAST::Var.new( :name, :scope, :namespace<> ),
- PAST::Op.new(:pirop('find_dynamic_lex Ps'), '%LEXPAD')
- )
- )
- )
- )
- );
-
- if ! pir::isnull(pir::find_dynamic_lex('@*PARTCL_COMPILER_NAMESPACE')) {
- PAST::Block.new( PAST::Stmts.new( $lexpad_init ), $past, :hll,
- :namespace(@*PARTCL_COMPILER_NAMESPACE)
- );
- } else {
- PAST::Block.new( PAST::Stmts.new( $lexpad_init ), $past, :hll);
- }
}
method body($/) { make $