summaryrefslogtreecommitdiffstats
path: root/contrib
diff options
context:
space:
mode:
authorphk <phk@FreeBSD.org>1997-10-01 13:19:13 +0000
committerphk <phk@FreeBSD.org>1997-10-01 13:19:13 +0000
commit5b30c2fb530aac2933dce3197e33362c844d3039 (patch)
treebca582e352640f318b35228d0c250ddde3bd0e0b /contrib
parent30db38624722a51670556ef9b2dd7ccf4fb57387 (diff)
downloadFreeBSD-src-5b30c2fb530aac2933dce3197e33362c844d3039.zip
FreeBSD-src-5b30c2fb530aac2933dce3197e33362c844d3039.tar.gz
Upgrade to 8.0 release.
Diffstat (limited to 'contrib')
-rw-r--r--contrib/tcl/README71
-rw-r--r--contrib/tcl/changes193
-rw-r--r--contrib/tcl/doc/CrtInterp.36
-rw-r--r--contrib/tcl/doc/CrtObjCmd.311
-rw-r--r--contrib/tcl/doc/CrtSlave.326
-rw-r--r--contrib/tcl/doc/GetIndex.35
-rw-r--r--contrib/tcl/doc/Object.34
-rw-r--r--contrib/tcl/doc/RecEvalObj.355
-rw-r--r--contrib/tcl/doc/RecordEval.314
-rw-r--r--contrib/tcl/doc/WrongNumArgs.328
-rw-r--r--contrib/tcl/doc/bgerror.n7
-rw-r--r--contrib/tcl/doc/expr.n6
-rw-r--r--contrib/tcl/doc/history.n106
-rw-r--r--contrib/tcl/doc/http.n109
-rw-r--r--contrib/tcl/doc/interp.n62
-rw-r--r--contrib/tcl/doc/namespace.n290
-rw-r--r--contrib/tcl/doc/registry.n10
-rw-r--r--contrib/tcl/doc/rename.n16
-rw-r--r--contrib/tcl/doc/resource.n116
-rw-r--r--contrib/tcl/doc/safe.n529
-rw-r--r--contrib/tcl/doc/tclvars.n80
-rw-r--r--contrib/tcl/doc/uplevel.n20
-rw-r--r--contrib/tcl/doc/upvar.n20
-rw-r--r--contrib/tcl/doc/variable.n20
-rw-r--r--contrib/tcl/generic/tcl.h82
-rw-r--r--contrib/tcl/generic/tclAlloc.c456
-rw-r--r--contrib/tcl/generic/tclBasic.c526
-rw-r--r--contrib/tcl/generic/tclBinary.c20
-rw-r--r--contrib/tcl/generic/tclClock.c14
-rw-r--r--contrib/tcl/generic/tclCmdAH.c315
-rw-r--r--contrib/tcl/generic/tclCmdIL.c61
-rw-r--r--contrib/tcl/generic/tclCmdMZ.c99
-rw-r--r--contrib/tcl/generic/tclCompExpr.c99
-rw-r--r--contrib/tcl/generic/tclCompile.c1242
-rw-r--r--contrib/tcl/generic/tclCompile.h162
-rw-r--r--contrib/tcl/generic/tclEnv.c444
-rw-r--r--contrib/tcl/generic/tclEvent.c11
-rw-r--r--contrib/tcl/generic/tclExecute.c967
-rw-r--r--contrib/tcl/generic/tclFileName.c6
-rw-r--r--contrib/tcl/generic/tclHistory.c1081
-rw-r--r--contrib/tcl/generic/tclIO.c30
-rw-r--r--contrib/tcl/generic/tclIOCmd.c78
-rw-r--r--contrib/tcl/generic/tclIndexObj.c71
-rw-r--r--contrib/tcl/generic/tclInt.h131
-rw-r--r--contrib/tcl/generic/tclInterp.c269
-rw-r--r--contrib/tcl/generic/tclListObj.c12
-rw-r--r--contrib/tcl/generic/tclLoad.c6
-rw-r--r--contrib/tcl/generic/tclMain.c97
-rw-r--r--contrib/tcl/generic/tclMath.h27
-rw-r--r--contrib/tcl/generic/tclNamesp.c155
-rw-r--r--contrib/tcl/generic/tclObj.c122
-rw-r--r--contrib/tcl/generic/tclParse.c38
-rw-r--r--contrib/tcl/generic/tclProc.c43
-rw-r--r--contrib/tcl/generic/tclStringObj.c4
-rw-r--r--contrib/tcl/generic/tclTest.c124
-rw-r--r--contrib/tcl/generic/tclTimer.c241
-rw-r--r--contrib/tcl/generic/tclUtil.c320
-rw-r--r--contrib/tcl/generic/tclVar.c594
-rw-r--r--contrib/tcl/library/history.tcl369
-rw-r--r--contrib/tcl/library/http1.0/http.tcl10
-rw-r--r--contrib/tcl/library/http2.0/http.tcl460
-rw-r--r--contrib/tcl/library/http2.0/pkgIndex.tcl11
-rw-r--r--contrib/tcl/library/init.tcl106
-rw-r--r--contrib/tcl/library/opt0.1/optparse.tcl1067
-rw-r--r--contrib/tcl/library/opt0.1/pkgIndex.tcl7
-rw-r--r--contrib/tcl/library/safe.tcl710
-rw-r--r--contrib/tcl/library/tclIndex37
-rw-r--r--contrib/tcl/tests/all10
-rw-r--r--contrib/tcl/tests/basic.test39
-rw-r--r--contrib/tcl/tests/binary.test58
-rw-r--r--contrib/tcl/tests/cmdAH.test157
-rw-r--r--contrib/tcl/tests/cmdIL.test6
-rw-r--r--contrib/tcl/tests/compile.test44
-rw-r--r--contrib/tcl/tests/defs65
-rw-r--r--contrib/tcl/tests/env.test73
-rw-r--r--contrib/tcl/tests/error.test22
-rw-r--r--contrib/tcl/tests/eval.test4
-rw-r--r--contrib/tcl/tests/event.test145
-rw-r--r--contrib/tcl/tests/exec.test415
-rw-r--r--contrib/tcl/tests/execute.test3
-rw-r--r--contrib/tcl/tests/expr-old.test38
-rw-r--r--contrib/tcl/tests/expr.test25
-rw-r--r--contrib/tcl/tests/fCmd.test7
-rw-r--r--contrib/tcl/tests/fileName.test163
-rw-r--r--contrib/tcl/tests/for.test10
-rw-r--r--contrib/tcl/tests/foreach.test11
-rw-r--r--contrib/tcl/tests/format.test64
-rw-r--r--contrib/tcl/tests/history.test227
-rw-r--r--contrib/tcl/tests/http.test246
-rw-r--r--contrib/tcl/tests/httpold.test411
-rw-r--r--contrib/tcl/tests/if.test14
-rw-r--r--contrib/tcl/tests/incr.test8
-rw-r--r--contrib/tcl/tests/info.test15
-rw-r--r--contrib/tcl/tests/interp.test323
-rw-r--r--contrib/tcl/tests/io.test272
-rw-r--r--contrib/tcl/tests/ioCmd.test11
-rw-r--r--contrib/tcl/tests/misc.test10
-rw-r--r--contrib/tcl/tests/namespace.test42
-rw-r--r--contrib/tcl/tests/obj.test28
-rw-r--r--contrib/tcl/tests/opt.test236
-rw-r--r--contrib/tcl/tests/parse.test2
-rw-r--r--contrib/tcl/tests/pkg.test18
-rw-r--r--contrib/tcl/tests/proc-old.test6
-rw-r--r--contrib/tcl/tests/proc.test16
-rw-r--r--contrib/tcl/tests/pwd.test22
-rw-r--r--contrib/tcl/tests/registry.test19
-rw-r--r--contrib/tcl/tests/resource.test105
-rw-r--r--contrib/tcl/tests/safe.test595
-rw-r--r--contrib/tcl/tests/scan.test27
-rw-r--r--contrib/tcl/tests/set-old.test4
-rw-r--r--contrib/tcl/tests/socket.test101
-rw-r--r--contrib/tcl/tests/source.test4
-rw-r--r--contrib/tcl/tests/split.test15
-rw-r--r--contrib/tcl/tests/string.test7
-rw-r--r--contrib/tcl/tests/trace.test40
-rw-r--r--contrib/tcl/tests/unixFCmd.test25
-rw-r--r--contrib/tcl/tests/util.test80
-rw-r--r--contrib/tcl/tests/var.test49
-rw-r--r--contrib/tcl/tests/while.test6
-rw-r--r--contrib/tcl/tests/winFCmd.test83
-rw-r--r--contrib/tcl/tests/winPipe.test28
-rw-r--r--contrib/tcl/unix/Makefile.in37
-rwxr-xr-xcontrib/tcl/unix/configure246
-rwxr-xr-xcontrib/tcl/unix/configure.in19
-rwxr-xr-xcontrib/tcl/unix/mkLinks8
-rw-r--r--contrib/tcl/unix/tclConfig.sh.in5
-rw-r--r--contrib/tcl/unix/tclUnixFile.c16
-rw-r--r--contrib/tcl/unix/tclUnixInit.c9
-rw-r--r--contrib/tcl/unix/tclUnixNotfy.c4
-rw-r--r--contrib/tcl/unix/tclUnixPort.h9
-rw-r--r--contrib/tcl/unix/tclUnixSock.c27
131 files changed, 11501 insertions, 5861 deletions
diff --git a/contrib/tcl/README b/contrib/tcl/README
index 8c091b2..640f075 100644
--- a/contrib/tcl/README
+++ b/contrib/tcl/README
@@ -1,22 +1,21 @@
Tcl
-SCCS: @(#) README 1.45 97/06/25 11:02:14
+SCCS: @(#) README 1.49 97/08/14 08:47:31
1. Introduction
---------------
This directory and its descendants contain the sources and documentation
for Tcl, an embeddable scripting language. The information here
-corresponds to release 8.0b2, the second (and probably final) beta
-release for Tcl 8.0. Tcl 8.0 is a major new release that replaces the
-core of the interpreter with an on-the-fly bytecode compiler to improve
-execution speed. It also includes several other new features such as
-namespaces and binary I/O, plus many bug fixes. The compiler introduces
-a few incompatibilities that may affect existing Tcl scripts; the
-incompatibilities are relatively obscure but may require modifications
-to some old scripts before they can run with this version. The compiler
-introduces many new C-level APIs, but the old APIs are still supported.
-See below for more details.
+corresponds to release 8.0. Tcl 8.0 is a major new release that replaces
+the core of the interpreter with an on-the-fly bytecode compiler to
+improve execution speed. It also includes several other new features
+such as namespaces and binary I/O, plus many bug fixes. The compiler
+introduces a few incompatibilities that may affect existing Tcl scripts;
+the incompatibilities are relatively obscure but may require
+modifications to some old scripts before they can run with this version.
+The compiler introduces many new C-level APIs, but the old APIs are
+still supported. See below for more details.
2. Documentation
----------------
@@ -166,8 +165,9 @@ changes, there are several smaller changes and bug fixes. See the file
mechanism, implemented with the Tcl commands "interp hide", "interp
expose", "interp invokehidden", and "interp hidden" and the C APIs
Tcl_HideCommand and Tcl_ExposeCommand. There is now support for
- loadable security policies, including new library procedures such as
- tcl_safeCreateInterp.
+ safe packages and extension loading, including new library
+ procedures such as safe::interpCreate (see the manual entry safe.n
+ for details).
6. There is a new package "registry" available under Windows for
accessing the Windows registry.
@@ -224,9 +224,12 @@ scripts that worked under Tcl 7.6 and earlier releases:
are no longer supported; all of these features are now available on
all platforms via the "file" command.
- 5. Support for the variable tcl_precision is mostly removed; when
- real values are converted back to strings, the full 17 digits of
- precision are always used.
+ 5. The variable tcl_precision is now shared between interpreters
+ and defaults to 12 digits instead of 6; safe interpreters cannot
+ modify tcl_precision. The new object system in Tcl 8.0 causes
+ floating-to-string conversions (and the associated rounding) to
+ occur much less often than in Tcl 7.6, which can sometimes cause
+ behavioral changes.
6. The C APIs associated with the notifier have changed substantially.
@@ -270,7 +273,39 @@ in the directory "/pub/tcl". The archive also contains several FAQ
("frequently asked questions") documents that provide solutions to problems
that are commonly encountered by TCL newcomers.
-7. Support and bug fixes
+7. Mailing lists
+----------------
+
+A couple of Mailing List have been set up to discuss Macintosh or
+Windows related Tcl issues. In order to use these Mailing Lists you
+must have access to the internet. If you have access to the WWW the
+home pages for these mailing lists are located at the following URLs:
+
+ http://www.sunlabs.com/research/tcl/lists/mactcl-list.html
+
+ -and-
+
+ http://www.sunlabs.com/research/tcl/lists/wintcl-list.html
+
+The home pages contain information about the lists and an HTML archive
+of all the past messages on the list. To subscribe send a message to:
+
+ listserv@sunlabs.sun.com
+
+In the body of the message (the subject will be ignored) put:
+
+ subscribe mactcl Joe Blow
+
+Replacing Joe Blow with your real name, of course. (Use wintcl
+instead of mactcl if your interested in the Windows list.) If you
+would just like to receive more information about the list without
+subscribing put the line:
+
+ information mactcl
+
+in the body instead (or wintcl).
+
+8. Support and bug fixes
------------------------
We're very interested in receiving bug reports and suggestions for
@@ -304,7 +339,7 @@ In addition, Tcl support and training are available commercially from
NeoSoft (info@neosoft.com), Computerized Processes Unlimited
(gwl@cpu.com), and Data Kinetics (education@dkl.com).
-8. Tcl version numbers
+9. Tcl version numbers
----------------------
Each Tcl release is identified by two numbers separated by a dot, e.g.
diff --git a/contrib/tcl/changes b/contrib/tcl/changes
index 9390e86..c54526b 100644
--- a/contrib/tcl/changes
+++ b/contrib/tcl/changes
@@ -1,6 +1,6 @@
Recent user-visible changes to Tcl:
-SCCS: @(#) changes 1.251 97/06/30 08:48:28
+SCCS: @(#) changes 1.293 97/08/13 17:50:35
1. No more [command1] [command2] construct for grouping multiple
commands on a single command line.
@@ -2494,11 +2494,9 @@ following new library commands are provided:
policy mechanism.
tcl_safeDeleteInterp -- deletes a slave and deinitializes the
policy mechanism.
- tcl_safeAutoPath -- manages per slave path for package
- finding and auto-loading.
- tcl_safePolicyPath -- manages global search path for finding
- security policies.
Added a new file to the library, safeinit.tcl, to hold implementation. (JL)
+On 7/9/97, removed the policy loading mechanism from the Safe Base. Left
+only the Safe Base aliases dealing with auto-loading and source. (JL)
12/6/96 (new feature) Implemented Tcl_Finalize, an API that should be
called by a process when it is done using Tcl. This API runs all the exit
@@ -2934,8 +2932,8 @@ and to get the vector back later. (JL)
leave an object result instead of a string result. (JL)
5/14/97 (feature change) Improved the handling of the interpreter result.
-This is still either an object or a string, but the two values are now
-kept consistent unless some C code has set interp->result directly. See
+This is still either an object or a string, but the two values are now kept
+consistent unless some C code reads or writes interp->result directly. See
the SetResult man page for details. Removed the Tcl_ResetObjResult
procedure. (BL)
*** POTENTIAL INCOMPATIBILITY with Tcl 8.0a2 ***
@@ -3094,3 +3092,184 @@ Tcl_ExprObj. (BL)
*** POTENTIAL INCOMPATIBILITY with Tcl 8.0b1, but not with Tcl 7.6 ***
----------------- Released 8.0b2, 6/30/97 -----------------------
+
+7/1/97 (new feature) TCL_BUILD_SHARED flag set in tclConfig.sh
+when Tcl has been built with --enable-shared. A new tclLibObjs
+make target, echoing the list of the .o's needed to build a tcl
+library, is now provided. (DL)
+
+7/1/97 (feature change) compat/getcwd.c removed and changed the
+only place where getcwd is used so a new USEGETWD flag selects
+the use of the replacement "getwd". Adding this flag is recommended
+for Solaris (because getcwd on solaris uses a pipe to pwd(1)!).(DL)
+
+7/7/97 (feature change) The split command now supports binary data (i.e.,
+null characters in strings). (BL)
+
+7/7/97 (bug fix) string first returned the wrong result if the first
+argument string was empty. (BL)
+
+7/8/97 (bug fix) Fixed core dump in fcopy that could occur when a command
+callback was supplied and an error or eof condition caused no background
+activity. A refcount bug triggered a panic in Tcl_ListObjAppendElement. (BW)
+
+7/8/97 (bug fix) Relaxed the pattern matching on http_get so you do not
+need a trailing path component. You can now get away with just
+http_get sunscript.sun.com (BW)
+
+7/9/97 (bug fix) Creating anonymous interpreters no longer smashes existing
+commands with names similar to the generated name. Previously creating an
+anonymous interpreter could smash an existing command, now it skips until
+it finds a command name that isn't being used. (JL)
+
+7/9/97 (feature change) Removed the policy management mechanism from the
+Safe Base; left the aliases to source and load modules, and to do a limited
+form of the "file" command. See entry of 11/15/96. (JL)
+
+7/9/97 (bug fixes) Fixed various compilation-related bugs:
+ - Line numbers in errorInfo now are the same as those in Tcl7.6 unless
+there are compilation errors. Compilation error messages now include the
+entire command in error.
+ - Trailing ::s after namespace names weren't being ignored.
+ - Could not refer to an namespace variable with an empty name using a
+name of the form "n::". (BL)
+
+7/9/97 (bug fix) Fixed bug in Tcl_Export that prevented you from exporting
+from other than the current namespace. (BL)
+
+7/9/97 (bug fix) env.test was removing env var needed for proper finding
+of libraries in child process. (DL)
+
+7/10/97 (bug fixes/new feature) Cleanup in Tcl_MakeSafe. Less information
+is leaked to safe interps. Error message fixes for interp sub commands.
+Likewise changes in safealias.tcl; tcl_safeCreateInterp can now be called
+without argument to generate the slave name (like in interp create). (DL)
+
+7/10/97 (bug fixes) Bytecode compiler now generates more detailed
+command location information: subcommands as well as commands now have
+location information. This means command trace procedures now get the
+correct source string for each command in their command parameter. (BL)
+
+7/22/97 (bug fixes) Performance improvement in Safe interpreters
+handling. Added new mask value to (tclInt.h) Interp.flags record. (DL)
+
+7/22/97 (bug fix) Fixed panic in 'interp target {} foo'. This bug
+was present since Tcl 7.6. (JL)
+
+7/22/97 (bug fix) Fixed bug in compilation of procedures in namespaces: the
+procedure's namespace must be used to look up compile procedures, not the
+current namespace. (BL)
+
+7/22/97 (bug fix) Use of the -channel option of http_get was not setting
+the end of line translations mode on the channel, so copying binary data
+with the -channel option was corrupting the result on non-unix platforms. (BW)
+
+7/22/97 (bug fixes) file commands and ~user (seg fault and other
+improper returns). (DL)
+
+7/23/97 (feature change) Reenabled "vwait" in Safe Base. (JL)
+
+7/23/97 (bug fixes) Fixed two bugs involving read traces on array variables
+in procedures: trace procedures were sometimes not called, and reading
+nonexistant array elements didn't create undefined element variables that
+could later be defined by trace procedures. (BL)
+
+7/24/97 (bug fix) Windows memory allocation performance was
+superlinear in some cases. Made the Mac allocator generic and changed
+both the Mac and Windows platforms to use the new allocator instead of
+malloc and free. (SS)
+
+7/24/97 - 8/12/97 (bug fixes/change of features) Completely revamped safe
+sourcing/loading (see safe.n) to hide pathnames, use virtual
+paths tokens instead, improved security in several respects and made it
+more tunable. Multi level interp loading can work too now. Package auto
+loading now works in safe interps as long as the package directory is in
+the auto_path (no deep crawling allowed in safe interps). (DL)
+*** POTENTIAL INCOMPATIBILITY with previous alpha and beta releases ***
+
+7/24/97 (bug fixes) Made Tcl_SetVar* and Tcl_NewString* treat a NULL value
+as an empty string. (This fixes hairy crash case where you would crash
+because load command for other interps assumed presence of
+errorInfo...). (DL)
+
+7/28/97 (bug fix) Fixed pkg_mkIndex to understand namespaces. It will
+use the export list of a namespace and create auto_index entries for
+all export commands. Those names are in their fully qualified form in the
+auto_index. Therefore, I tweaked unknown to try both $cmd and ::$cmd.
+Also fixed pkg_mkIndex so you can have "package require" commands inside
+your packages. These commands are ignored, which is mostly ok except
+when you must load another package before loading yours because of
+linking dependencies. (BW)
+
+7/28/97 (bug fix) A variable created by the variable command now persists
+until the namespace is destroyed or the variable is unset. This is true even
+if the variable has not been initialized; these variables used to be
+destroyed if an error occurred when accessing them. In addition, the "info
+vars" command lists uninitialized namespace variables, while the "info
+exists" command returns 0 for them. (BL)
+
+7/29/97 (feature change) Changed the http package to use the ::http
+namespace. http_get renamed to http::geturl, http_config renamed to
+http::config, http_formatQuery renamed to http::formatQuery.
+It now provides the 2.0 version of the package.
+The 1.0 version is still available with the old names.
+*** POTENTIAL INCOMPATIBILITY with Tcl 8.0b2 but not with Tcl 7.6 ***
+
+7/29/97 (bug fix, new feature) Tcl_Main now uses Tcl objects internally to
+preserve NULLs in commands and command output. Added new API procedure
+Tcl_RecordAndEvalObj that resembles Tcl_RecordAndEval but takes an object
+containing a command. (BL)
+
+7/30/97 (bug fix) Tcl freed strings in the environ array even if it
+did not allocate them. (SS)
+
+7/30/97 (bug fix) If a procedure is renamed into a different namespace, it
+now executes in the context of that namespace. (BL)
+
+7/30/97 (bug fix) Prevent renaming of commands into and from namespaces as
+part of hiding them. (JL)
+
+7/31/97 (feature change) Moved the history command from C to tcl.
+This uses the ::history namespace. The "words" and "substitute" options
+are no longer supported. In addition, the "keep" option without a value
+returns the current keep limit. There is a new "clear" option.
+The unknown command now supports !! again. (BW)
+*** POTENTIAL INCOMPATIBILTY ***
+
+7/30/97 (bug fix) Made sure that a slave can not fool the master into
+hiding the wrong command. Made sure we don't crash in hiding + namespaces
+issues. (DL)
+
+8/4/97 (bug fix) Concat, eval, uplevel, and similar commands were
+incorrectly trimming trailing space characters from their arguments
+even when the space characters were preceded by a backslash. (JO)
+
+8/4/97 (bug fix) Removed the hard link between bgerror and tkerror.
+Only bgerror is supported in tcl core. Tk will still look for a
+tkerror but using regular tcl code for that feature. (DL)
+*** POTENTIAL INCOMPATIBILTY with code relying on the hard link ***
+
+8/6/97 (bug fix) Reduced size required for compiled bytecodes by using a
+more compact encoding for the command pc-to-source map. (BL)
+
+8/6/97 (new feature) Added support for additional compilation and execution
+statistics when Tcl is compiled with the TCL_COMPILE_STATS flag. (BL)
+
+8/7/97 (bug fix) Expressions not in {}s that have a comparison operator as
+the topmost operator must be compiled out-of-line (call the expr cmd at
+runtime) to properly support expr's two-level substitution semantics. An
+example is "set a 2; set b {$a}; puts [expr $b == 2]". (BL)
+
+8/11/97 (bug fix) The catch command would sometimes crash if a variable name
+was given and the bytecode evaluation stack was grown when executing the
+argument script. (BL)
+
+8/12/97 (feature change) Reinstated the variable tcl_precision to control
+the number of digits used when floating-point values are converted to
+strings, with default of 12 digits. However, had to make tcl_precision
+shared among all interpreters (except that safe interpreters can't
+modify it). This makes the Tcl 8.0 behavior almost identical to 7.6
+except that the default precision is 12 instead of 6. (JO)
+*** POTENTIAL INCOMPATIBILITY ***
+
+----------------- Released 8.0, 8/13/97 -----------------------
diff --git a/contrib/tcl/doc/CrtInterp.3 b/contrib/tcl/doc/CrtInterp.3
index b50d34e..bcca39d 100644
--- a/contrib/tcl/doc/CrtInterp.3
+++ b/contrib/tcl/doc/CrtInterp.3
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) CrtInterp.3 1.14 96/03/26 15:14:45
+'\" SCCS: @(#) CrtInterp.3 1.15 97/07/09 14:53:31
'\"
.so man.macros
.TH Tcl_CreateInterp 3 7.5 Tcl "Tcl Library Procedures"
@@ -100,8 +100,8 @@ When a new interpreter is created and used in a call to \fBTcl_Eval\fR,
\fBTcl_Release\fR should be wrapped around all uses of the interpreter.
Remember that it is unsafe to use the interpreter once \fBTcl_Release\fR
has been called. To ensure that the interpreter is properly deleted when
-it is no longer needed, call \fBTcl_InterpDeleted\fB to test if some other
-code already called \fBTcl_DeleteInterp\fB; if not, call
+it is no longer needed, call \fBTcl_InterpDeleted\fR to test if some other
+code already called \fBTcl_DeleteInterp\fR; if not, call
\fBTcl_DeleteInterp\fR before calling \fBTcl_Release\fB in your own code.
Do not call \fBTcl_DeleteInterp\fR on an interpreter for which
\fBTcl_InterpDeleted\fR returns nonzero.
diff --git a/contrib/tcl/doc/CrtObjCmd.3 b/contrib/tcl/doc/CrtObjCmd.3
index e510889..78fe6f8 100644
--- a/contrib/tcl/doc/CrtObjCmd.3
+++ b/contrib/tcl/doc/CrtObjCmd.3
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) @(#) CrtObjCmd.3 1.9 97/06/04 17:23:37
+'\" SCCS: @(#) @(#) CrtObjCmd.3 1.10 97/07/31 14:10:38
'\"
.so man.macros
.TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures"
@@ -54,7 +54,6 @@ The command must not have been deleted.
Pointer to structure containing various information about a
Tcl command.
.BE
-
.SH DESCRIPTION
.PP
\fBTcl_CreateObjCommand\fR defines a new command in \fIinterp\fR
@@ -130,8 +129,8 @@ Call \fBTcl_SetObjResult\fR if you want
to return something from the \fIobjv\fR array.
.PP
\fIDeleteProc\fR will be invoked when (if) \fIname\fR is deleted.
-This can occur through a call to \fBTcl_DeleteCommand\fR
-or \fBTcl_DeleteInterp\fR,
+This can occur through a call to \fBTcl_DeleteCommand\fR,
+\fBTcl_DeleteCommandFromToken\fR, or \fBTcl_DeleteInterp\fR,
or by replacing \fIname\fR in another call to \fBTcl_CreateObjCommand\fR.
\fIDeleteProc\fR is invoked before the command is deleted, and gives the
application an opportunity to release any structures associated
@@ -154,10 +153,10 @@ a built-in command, an application-specific command, or a Tcl procedure.
If \fIname\fR contains any \fB::\fR namespace qualifiers,
the command is deleted from the specified namespace.
.PP
-Given a token returned by \fBTcl_CreateObjCommand\fR
-when the command was created,
+Given a token returned by \fBTcl_CreateObjCommand\fR,
\fBTcl_DeleteCommandFromToken\fR deletes the command
from a command interpreter.
+It will delete a command even if that command has been renamed.
Once the call completes, attempts to invoke the command in
\fIinterp\fR will result in errors.
If the command corresponding to \fItoken\fR
diff --git a/contrib/tcl/doc/CrtSlave.3 b/contrib/tcl/doc/CrtSlave.3
index 3b3d7b8..fe18a55 100644
--- a/contrib/tcl/doc/CrtSlave.3
+++ b/contrib/tcl/doc/CrtSlave.3
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) CrtSlave.3 1.22 97/06/10 17:52:33
+'\" SCCS: @(#) CrtSlave.3 1.26 97/07/31 18:00:14
'\"
.so man.macros
.TH Tcl_CreateSlave 3 7.6 Tcl "Tcl Library Procedures"
@@ -107,7 +107,8 @@ called function.
.AP char *cmdName in
Name of an exposed command to hide or create.
.AP char *hiddenCmdName in
-Name of a hidden command to create or expose.
+Name under which a hidden command is stored and with which it can be
+exposed or invoked.
.VE
.BE
@@ -187,9 +188,11 @@ returns a pointer to a vector of Tcl_Obj structures instead of a vector of
strings.
.PP
\fBTcl_ExposeCommand\fR moves the command named \fIhiddenCmdName\fR from
-the set of hidden commands to the set of exposed commands, renaming it to
-\fIcmdName\fR. \fIHiddenCmdName\fR must be the name of an existing hidden
-command, or the operation will return \fBTCL_ERROR\fR and deposit an error
+the set of hidden commands to the set of exposed commands, putting
+it under the name
+\fIcmdName\fR.
+\fIHiddenCmdName\fR must be the name of an existing hidden
+command, or the operation will return \fBTCL_ERROR\fR and leave an error
message in the \fIresult\fR field in \fIinterp\fR.
If an exposed command named \fIcmdName\fR already exists,
the operation returns \fBTCL_ERROR\fR and leaves an error message in the
@@ -199,11 +202,18 @@ After executing this command, attempts to use \fIcmdName\fR in a call to
\fBTcl_Eval\fR or with the Tcl \fBeval\fR command will again succeed.
.PP
\fBTcl_HideCommand\fR moves the command named \fIcmdName\fR from the set of
-exposed commands to the set of hidden commands, renaming it to
-\fIhiddenCmdName\fR. \fICmdName\fR must be the name of an existing exposed
+exposed commands to the set of hidden commands, under the name
+\fIhiddenCmdName\fR.
+\fICmdName\fR must be the name of an existing exposed
command, or the operation will return \fBTCL_ERROR\fR and leave an error
message in the object result of \fIinterp\fR.
-If a hidden command named \fIhiddenCmdName\fR already
+Currently both \fIcmdName\fR and \fIhiddenCmdName\fR must not contain
+namespace qualifiers, or the operation will return \fBTCL_ERROR\fR and
+leave an error message in the object result of \fIinterp\fR.
+The \fICmdName\fR will be looked up in the global namespace, and not
+relative to the current namespace, even if the current namespace is not the
+global one.
+If a hidden command whose name is \fIhiddenCmdName\fR already
exists, the operation also returns \fBTCL_ERROR\fR and the \fIresult\fR
field in \fIinterp\fR contains an error message.
If the operation succeeds, it returns \fBTCL_OK\fR.
diff --git a/contrib/tcl/doc/GetIndex.3 b/contrib/tcl/doc/GetIndex.3
index 6678257..9ca7927 100644
--- a/contrib/tcl/doc/GetIndex.3
+++ b/contrib/tcl/doc/GetIndex.3
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) @(#) GetIndex.3 1.2 97/02/11 13:25:45
+'\" SCCS: @(#) @(#) GetIndex.3 1.3 97/07/30 16:21:05
'\"
.so man.macros
.TH Tcl_GetIndexFromObj 3 8.0 Tcl "Tcl Library Procedures"
@@ -70,5 +70,8 @@ the matching index immediately without having to redo the lookup
operation. Note: \fBTcl_GetIndexFromObj\fR assumes that the entries
in \fItablePtr\fR are static: they must not change between invocations.
+.SH "SEE ALSO"
+Tcl_WrongNumArgs
+
.SH KEYWORDS
index, object, table lookup
diff --git a/contrib/tcl/doc/Object.3 b/contrib/tcl/doc/Object.3
index e564de9..1fed7a6 100644
--- a/contrib/tcl/doc/Object.3
+++ b/contrib/tcl/doc/Object.3
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) @(#) Object.3 1.9 97/06/13 18:36:20
+'\" SCCS: @(#) @(#) Object.3 1.10 97/07/22 11:40:10
'\"
.so man.macros
.TH Tcl_Obj 3 8.0 Tcl "Tcl Library Procedures"
@@ -309,7 +309,7 @@ by calling \fBTcl_IsShared\fR.
If the object is shared they must copy the object
by using \fBTcl_DuplicateObj\fR;
this returns a new duplicate of the original object
-that has \fIrefCount\fR 1.
+that has \fIrefCount\fR 0.
If the object is not shared,
the command procedure "owns" the object and can safely modify it directly.
For example, the following code appears in the command procedure
diff --git a/contrib/tcl/doc/RecEvalObj.3 b/contrib/tcl/doc/RecEvalObj.3
new file mode 100644
index 0000000..7f3bdc9
--- /dev/null
+++ b/contrib/tcl/doc/RecEvalObj.3
@@ -0,0 +1,55 @@
+'\"
+'\" 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.
+'\"
+'\" SCCS: SCCS: @(#) RecEvalObj.3 1.1 97/07/29 18:31:21
+'\"
+.so man.macros
+.TH Tcl_RecordAndEvalObj 3 8.0 Tcl "Tcl Library Procedures"
+.BS
+.SH NAME
+Tcl_RecordAndEvalObj \- save command on history list before evaluating
+.SH SYNOPSIS
+.nf
+\fB#include <tcl.h>\fR
+.sp
+int
+\fBTcl_RecordAndEvalObj\fR(\fIinterp, cmdPtr, flags\fR)
+.SH ARGUMENTS
+.AS Tcl_Interp *interp;
+.AP Tcl_Interp *interp in
+Tcl interpreter in which to evaluate command.
+.AP Tcl_Obj *cmdPtr in
+Points to a Tcl object containing a command (or sequence of commands)
+to execute.
+.AP int flags in
+An OR'ed combination of flag bits. TCL_NO_EVAL means record the
+command but don't evaluate it. TCL_EVAL_GLOBAL means evaluate
+the command at global level instead of the current stack level.
+.BE
+
+.SH DESCRIPTION
+.PP
+\fBTcl_RecordAndEvalObj\fR is invoked to record a command as an event
+on the history list and then execute it using \fBTcl_EvalObj\fR
+(or \fBTcl_GlobalEvalObj\fR if the TCL_EVAL_GLOBAL bit is set
+in \fIflags\fR).
+It returns a completion code such as TCL_OK just like \fBTcl_EvalObj\fR,
+as well as a result object containing additional information
+(a result value or error message)
+that can be retrieved using \fBTcl_GetObjResult\fR.
+If you don't want the command recorded on the history list then
+you should invoke \fBTcl_EvalObj\fR instead of \fBTcl_RecordAndEvalObj\fR.
+Normally \fBTcl_RecordAndEvalObj\fR is only called with top-level
+commands typed by the user, since the purpose of history is to
+allow the user to re-issue recently-invoked commands.
+If the \fIflags\fR argument contains the TCL_NO_EVAL bit then
+the command is recorded without being evaluated.
+
+.SH "SEE ALSO"
+Tcl_EvalObj, Tcl_GetObjResult
+
+.SH KEYWORDS
+command, event, execute, history, interpreter, object, record
diff --git a/contrib/tcl/doc/RecordEval.3 b/contrib/tcl/doc/RecordEval.3
index 6e6fb27..17d353d 100644
--- a/contrib/tcl/doc/RecordEval.3
+++ b/contrib/tcl/doc/RecordEval.3
@@ -1,11 +1,11 @@
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
-'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 1994-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.
'\"
-'\" SCCS: @(#) RecordEval.3 1.17 96/08/26 12:59:47
+'\" SCCS: @(#) RecordEval.3 1.18 97/07/29 18:25:13
'\"
.so man.macros
.TH Tcl_RecordAndEval 3 7.4 Tcl "Tcl Library Procedures"
@@ -17,7 +17,7 @@ Tcl_RecordAndEval \- save command on history list before evaluating
\fB#include <tcl.h>\fR
.sp
int
-\fBTcl_RecordAndEval\fR(\fIinterp, cmd, eval\fR)
+\fBTcl_RecordAndEval\fR(\fIinterp, cmd, flags\fR)
.SH ARGUMENTS
.AS Tcl_Interp *interp;
.AP Tcl_Interp *interp in
@@ -44,6 +44,14 @@ commands typed by the user, since the purpose of history is to
allow the user to re-issue recently-invoked commands.
If the \fIflags\fR argument contains the TCL_NO_EVAL bit then
the command is recorded without being evaluated.
+.PP
+Note that \fBTcl_RecordAndEval\fR has been largely replaced by the
+object-based procedure \fBTcl_RecordAndEvalObj\fR.
+That object-based procedure records and optionally executes
+a command held in a Tcl object instead of a string.
+
+.SH "SEE ALSO"
+Tcl_RecordAndEvalObj
.SH KEYWORDS
command, event, execute, history, interpreter, record
diff --git a/contrib/tcl/doc/WrongNumArgs.3 b/contrib/tcl/doc/WrongNumArgs.3
index 528ebc8..61b68ce 100644
--- a/contrib/tcl/doc/WrongNumArgs.3
+++ b/contrib/tcl/doc/WrongNumArgs.3
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) @(#) WrongNumArgs.3 1.3 97/03/18 11:53:25
+'\" SCCS: @(#) @(#) WrongNumArgs.3 1.5 97/07/30 16:20:07
'\"
.so man.macros
.TH Tcl_WrongNumArgs 3 8.0 Tcl "Tcl Library Procedures"
@@ -30,7 +30,7 @@ Arguments to command that had the wrong number of arguments.
.AP char *message in
Additional error information to print after leading arguments
from \fIobjv\fR. This typically gives the acceptable syntax
-of the command.
+of the command. This argument may be NULL.
.BE
.SH DESCRIPTION
@@ -52,8 +52,28 @@ If \fIobjc\fR is 2, the result will be set to the following string:
.CS
wrong # args: should be "foo bar fileName count"
.CE
-\fIObjc\fR is usually 1, but may be 2 or more for commands like \fBstring\fR
-and the Tk widget commands, which use the first argument as a subcommand.
+\fIObjc\fR is usually 1, but may be 2 or more for commands like
+\fBstring\fR and the Tk widget commands, which use the first argument
+as a subcommand.
+.PP
+Some of the objects in the \fIobjv\fR array may be abbreviations for
+a subcommand. The command
+\fBTcl_GetIndexFromObj\fR will convert the abbreviated string object
+into an \fIindexObject\fR. If an error occurs in the parsing of the
+subcommand we would like to use the full subcommand name rather than
+the abbreviation. If the \fBTcl_WrongNumArgs\fR command finds any
+\fIindexObjects\fR in the \fIobjv\fR array it will use the full subcommand
+name in the error message instead of the abbreviated name that was
+origionally passed in. Using the above example, lets assume that
+\fIbar\fR is actually an abbreviation for \fIbarfly\fR and the object
+is now an indexObject becasue it was passed to
+\fBTcl_GetIndexFromObj\fR. In this case the error message would be:
+.CS
+wrong # args: should be "foo barfly fileName count"
+.CE
+
+.SH "SEE ALSO"
+Tcl_GetIndexFromObj
.SH KEYWORDS
command, error message, wrong number of arguments
diff --git a/contrib/tcl/doc/bgerror.n b/contrib/tcl/doc/bgerror.n
index 6875bcf..9f3e0c1 100644
--- a/contrib/tcl/doc/bgerror.n
+++ b/contrib/tcl/doc/bgerror.n
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) bgerror.n 1.3 96/03/25 20:10:12
+'\" SCCS: @(#) bgerror.n 1.5 97/08/04 17:49:35
'\"
.so man.macros
.TH bgerror n 7.5 Tcl "Tcl Built-In Commands"
@@ -58,8 +58,9 @@ However, if \fBbgerror\fR returns with a break exception, then
any remaining errors are skipped without calling \fBbgerror\fR.
.PP
Tcl has no default implementation for \fBbgerror\fR.
-However, in applications using Tk there will be a default
-\fBbgerror\fR procedure that posts a dialog box containing
+However, in applications using Tk there is a default
+\fBbgerror\fR procedure
+which posts a dialog box containing
the error message and offers the user a chance to see a stack
trace showing where the error occurred.
diff --git a/contrib/tcl/doc/expr.n b/contrib/tcl/doc/expr.n
index e7dda17..f4532cc 100644
--- a/contrib/tcl/doc/expr.n
+++ b/contrib/tcl/doc/expr.n
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) expr.n 1.25 97/04/29 10:11:52
+'\" SCCS: @(#) expr.n 1.27 97/08/12 11:31:30
'\"
.so man.macros
.TH expr n 8.0 Tcl "Tcl Built-In Commands"
@@ -285,6 +285,7 @@ operands could be arbitrary; it's better in these cases to use the
\fBstring compare\fR command instead.
.SH "PERFORMANCE CONSIDERATIONS"
+.VS
.PP
Enclose expressions in braces for the best speed and the smallest
storage requirements.
@@ -315,6 +316,7 @@ The most expensive code is required for
unbraced expressions that contain command substitutions.
These expressions must be implemented by generating new code
each time the expression is executed.
+.VE
.SH KEYWORDS
-arithmetic, boolean, compare, expression
+arithmetic, boolean, compare, expression, fuzzy comparison
diff --git a/contrib/tcl/doc/history.n b/contrib/tcl/doc/history.n
index a93e2fd..e58ea3a 100644
--- a/contrib/tcl/doc/history.n
+++ b/contrib/tcl/doc/history.n
@@ -1,11 +1,11 @@
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
-'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 1994-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.
'\"
-'\" SCCS: @(#) history.n 1.6 96/03/25 20:16:25
+'\" SCCS: @(#) history.n 1.11 97/08/07 16:44:49
'\"
.so man.macros
.TH history n "" Tcl "Tcl Built-In Commands"
@@ -29,7 +29,7 @@ A number: if positive, it refers to the event with
that number (all events are numbered starting at 1). If the number
is negative, it selects an event relative to the current event
(\fB\-1\fR refers to the previous event, \fB\-2\fR to the one before that, and
-so on).
+so on). Event \fB0\fP refers to the current event.
.IP [2]
A string: selects the most recent event that matches the string.
An event is considered to match the string either if the string is
@@ -57,10 +57,13 @@ substitution and wish to replace the current event (which invokes the
substitution) with the command created through substitution. The return
value is an empty string.
.TP
+\fBhistory clear\fR
+Erase the history list. The current keep limit is retained.
+The history event numbers are reset.
+.TP
\fBhistory event\fR ?\fIevent\fR?
Returns the value of the event given by \fIevent\fR. \fIEvent\fR
-defaults to \fB\-1\fR. This command causes history revision to occur:
-see below for details.
+defaults to \fB\-1\fR.
.TP
\fBhistory info \fR?\fIcount\fR?
Returns a formatted string (intended for humans to read) giving
@@ -68,10 +71,10 @@ the event number and contents for each of the events in the history
list except the current event. If \fIcount\fR is specified
then only the most recent \fIcount\fR events are returned.
.TP
-\fBhistory keep \fIcount\fR
+\fBhistory keep \fR?\fIcount\fR?
This command may be used to change the size of the history list to
\fIcount\fR events. Initially, 20 events are retained in the history
-list. This command returns an empty string.
+list. If \fIcount\fR is not specified, the current keep limit is returned.
.TP
\fBhistory nextid\fR
Returns the number of the next event to be recorded
@@ -82,87 +85,20 @@ event number in command-line prompts.
Re-executes the command indicated by \fIevent\fR and return its result.
\fIEvent\fR defaults to \fB\-1\fR. This command results in history
revision: see below for details.
-.TP
-\fBhistory substitute \fIold new \fR?\fIevent\fR?
-Retrieves the command given by \fIevent\fR
-(\fB\-1\fR by default), replace any occurrences of \fIold\fR by
-\fInew\fR in the command (only simple character equality is supported;
-no wild cards), execute the resulting command, and return the result
-of that execution. This command results in history
-revision: see below for details.
-.TP
-\fBhistory words \fIselector\fR ?\fIevent\fR?
-Retrieves from the command given by \fIevent\fR (\fB\-1\fR by default)
-the words given by \fIselector\fR, and return those words in a string
-separated by spaces. The \fBselector\fR argument has three forms.
-If it is a single number then it selects the word given by that
-number (\fB0\fR for the command name, \fB1\fR for its first argument,
-and so on). If it consists of two numbers separated by a dash,
-then it selects all the arguments between those two. Otherwise
-\fBselector\fR is treated as a pattern; all words matching that
-pattern (in the sense of \fBstring match\fR) are returned. In
-the numeric forms \fB$\fR may be used
-to select the last word of a command.
-For example, suppose the most recent command in the history list is
-.RS
-.CS
-\fBformat {%s is %d years old} Alice [expr $ageInMonths/12]\fR
-.CE
-Below are some history commands and the results they would produce:
-.DS
-.ta 4c
-.fi
-.UL Command " "
-.UL Result
-.nf
-
-\fBhistory words $ [expr $ageInMonths/12]\fR
-\fBhistory words 1-2 {%s is %d years old} Alice\fR
-\fBhistory words *a*o* {%s is %d years old} [expr $ageInMonths/12]\fR
-.DE
-\fBHistory words\fR results in history revision: see below for details.
-.RE
.SH "HISTORY REVISION"
.PP
-The history options \fBevent\fR, \fBredo\fR, \fBsubstitute\fR,
-and \fBwords\fR result in ``history revision''.
-When one of these options is invoked then the current event
+Pre-8.0 Tcl had a complex history revision mechanism.
+The current mechanism is more limited, and the old
+history operations \fBsubstitute\fP and \fBwords\fP have been removed.
+(As a consolation, the \fBclear\fP operation was added.)
+.PP
+The history option \fBredo\fR results in much simpler ``history revision''.
+When this option is invoked then the most recent event
is modified to eliminate the history command and replace it with
the result of the history command.
-For example, suppose that the most recent command in the history
-list is
-.CS
-\fBset a [expr $b+2]\fR
-.CE
-and suppose that the next command invoked is one of the ones on
-the left side of the table below. The command actually recorded in
-the history event will be the corresponding one on the right side
-of the table.
-.ne 1.5c
-.DS
-.ta 4c
-.fi
-.UL "Command Typed" " "
-.UL "Command Recorded"
-.nf
-
-\fBhistory redo set a [expr $b+2]\fR
-\fBhistory s a b set b [expr $b+2]\fR
-\fBset c [history w 2] set c [expr $b+2]\fR
-.DE
-History revision is needed because event specifiers like \fB\-1\fR
-are only valid at a particular time: once more events have been
-added to the history list a different event specifier would be
-needed.
-History revision occurs even when \fBhistory\fR is invoked
-indirectly from the current event (e.g. a user types a command
-that invokes a Tcl procedure that invokes \fBhistory\fR): the
-top-level command whose execution eventually resulted in a
-\fBhistory\fR command is replaced.
-If you wish to invoke commands like \fBhistory words\fR without
-history revision, you can use \fBhistory event\fR to save the
-current history event and then use \fBhistory change\fR to
-restore it later.
+If you want to redo an event without modifying history, then use
+the \fBevent\fP operation to retrieve some event,
+and the \fBadd\fP operation to add it to history and execute it.
.SH KEYWORDS
-event, history, record, revision
+event, history, record
diff --git a/contrib/tcl/doc/http.n b/contrib/tcl/doc/http.n
index 5a5b2d2..36227ce 100644
--- a/contrib/tcl/doc/http.n
+++ b/contrib/tcl/doc/http.n
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) http.n 1.10 97/06/24 17:15:09
+'\" SCCS: @(#) http.n 1.11 97/08/07 16:45:02
'\"
.so man.macros
.TH "Http" n 8.0 Tcl "Tcl Built-In Commands"
@@ -13,25 +13,25 @@
.SH NAME
Http \- Client-side implementation of the HTTP/1.0 protocol.
.SH SYNOPSIS
-\fBpackage require http ?1.0?\fP
+\fBpackage require http ?2.0?\fP
.sp
-\fBhttp_config \fI?options?\fR
+\fB::http::config \fI?options?\fR
.sp
-\fBhttp_get \fIurl ?options?\fR
+\fB::http::geturl \fIurl ?options?\fR
.sp
-\fBhttp_formatQuery \fIlist\fR
+\fB::http::formatQuery \fIlist\fR
.sp
-\fBhttp_reset \fItoken\fR
+\fB::http::reset \fItoken\fR
.sp
-\fBhttp_wait \fItoken\fR
+\fB::http::wait \fItoken\fR
.sp
-\fBhttp_status \fItoken\fR
+\fB::http::status \fItoken\fR
.sp
-\fBhttp_size \fItoken\fR
+\fB::http::size \fItoken\fR
.sp
-\fBhttp_code \fItoken\fR
+\fB::http::code \fItoken\fR
.sp
-\fBhttp_data \fItoken\fR
+\fB::http::data \fItoken\fR
.BE
.SH DESCRIPTION
@@ -43,26 +43,27 @@ firewalls. The package is compatible with the \fBSafesock\fR security
policy, so it can be used by untrusted applets to do URL fetching from
a restricted set of hosts.
.PP
-The \fBhttp_get\fR procedure does a HTTP transaction.
+The \fB::http::geturl\fR procedure does a HTTP transaction.
Its \fIoptions \fR determine whether a GET, POST, or HEAD transaction
is performed.
-The return value of \fBhttp_get\fR is a token for the transaction.
-The value is also the name of a global array that contains state
+The return value of \fB::http::geturl\fR is a token for the transaction.
+The value is also the name of an array in the ::http namespace
+ that contains state
information about the transaction. The elements of this array are
described in the STATE ARRAY section.
.PP
If the \fB-command\fP option is specified, then
the HTTP operation is done in the background.
-\fBhttp_get\fR returns immediately after generating the
+\fB::http::geturl\fR returns immediately after generating the
HTTP request and the callback is invoked
when the transaction completes. For this to work, the Tcl event loop
must be active. In Tk applications this is always true. For pure-Tcl
-applications, the caller can use \fBhttp_wait\fR after calling
-\fBhttp_get\fR to start the event loop.
+applications, the caller can use \fB::http::wait\fR after calling
+\fB::http::geturl\fR to start the event loop.
.SH COMMANDS
.TP
-\fBhttp_config\fP ?\fIoptions\fR?
-The \fBhttp_config\fR command is used to set and query the name of the
+\fB::http::config\fP ?\fIoptions\fR?
+The \fB::http::config\fR command is used to set and query the name of the
proxy server and port, and the User-Agent name used in the HTTP
requests. If no options are specified, then the current configuration
is returned. If a single argument is specified, then it should be one
@@ -86,7 +87,7 @@ The proxy port number.
.TP
\fB\-proxyfilter\fP \fIcommand\fP
The command is a callback that is made during
-\fBhttp_get\fR
+\fB::http::geturl\fR
to determine if a proxy is required for a given host. One argument, a
host name, is added to \fIcommand\fR when it is invoked. If a proxy
is required, the callback should return a two element list containing
@@ -97,20 +98,20 @@ non-empty.
.TP
\fB\-useragent\fP \fIstring\fP
The value of the User-Agent header in the HTTP request. The default
-is \fB"Tcl http client package 1.0."\fR
+is \fB"Tcl http client package 2.0."\fR
.RE
.TP
-\fBhttp_get\fP \fIurl\fP ?\fIoptions\fP?
-The \fBhttp_get \fR command is the main procedure in the package.
+\fB::http::geturl\fP \fIurl\fP ?\fIoptions\fP?
+The \fB::http::geturl \fR command is the main procedure in the package.
The \fB\-query\fR option causes a POST operation and
the \fB\-validate\fR option causes a HEAD operation;
-otherwise, a GET operation is performed. The \fBhttp_get\fR command
+otherwise, a GET operation is performed. The \fB::http::geturl\fR command
returns a \fItoken\fR value that can be used to get
information about the transaction. See the STATE ARRAY section for
-details. The \fBhttp_get\fR command blocks until the operation
+details. The \fB::http::geturl\fR command blocks until the operation
completes, unless the \fB\-command\fR option specifies a callback
that is invoked when the HTTP transaction completes.
-\fBhttp_get\fR takes several options:
+\fB::http::geturl\fR takes several options:
.RS
.TP
\fB\-blocksize\fP \fIsize\fP
@@ -127,9 +128,9 @@ Copy the URL contents to channel \fIname\fR instead of saving it in
.TP
\fB\-command\fP \fIcallback\fP
Invoke \fIcallback\fP after the HTTP transaction completes.
-This option causes \fBhttp_get\fP to return immediately.
+This option causes \fB::http::geturl\fP to return immediately.
The \fIcallback\fP gets an additional argument that is the \fItoken\fR returned
-from \fBhttp_get\fR. This token is the name of a global array that is
+from \fB::http::geturl\fR. This token is the name of an array that is
described in the STATE ARRAY section. Here is a template for the
callback:
.RS
@@ -145,7 +146,7 @@ proc httpCallback {token} {
Invoke \fIcallback\fP whenever HTTP data is available; if present, nothing
else will be done with the HTTP data. This procedure gets two additional
arguments: the socket for the HTTP data and the \fItoken\fR returned from
-\fBhttp_get\fR. The token is the name of a global array that is described
+\fB::http::geturl\fR. The token is the name of a global array that is described
in the STATE ARRAY section. The procedure is expected to return the number
of bytes read from the socket. Here is a template for the callback:
.RS
@@ -176,7 +177,7 @@ Pragma: no-cache
\fB\-progress\fP \fIcallback\fP
The \fIcallback\fR is made after each transfer of data from the URL.
The callback gets three additional arguments: the \fItoken\fR from
-\fBhttp_get\fR, the expected total size of the contents from the
+\fB::http::geturl\fR, the expected total size of the contents from the
\fBContent-Length\fR meta-data, and the current number of bytes
transferred so far. The expected total size may be unknown, in which
case zero is passed to the callback. Here is a template for the
@@ -190,60 +191,60 @@ proc httpProgress {token total current} {
.RE
.TP
\fB\-query\fP \fIquery\fP
-This flag causes \fBhttp_get\fR to do a POST request that passes the
+This flag causes \fB::http::geturl\fR to do a POST request that passes the
\fIquery\fR to the server. The \fIquery\fR must be a x-url-encoding
-formatted query. The \fBhttp_formatQuery\fR procedure can be used to
+formatted query. The \fB::http::formatQuery\fR procedure can be used to
do the formatting.
.TP
\fB\-timeout\fP \fImilliseconds\fP
-If \fImilliseconds\fR is non-zero, then \fBhttp_get\fR sets up a timeout
+If \fImilliseconds\fR is non-zero, then \fB::http::geturl\fR sets up a timeout
to occur after the specified number of milliseconds.
-A timeout results in a call to \fBhttp_reset\fP and to
+A timeout results in a call to \fB::http::reset\fP and to
the \fB-command\fP callback, if specified.
-The return value of \fBhttp_status\fP is \fBtimeout\fP
+The return value of \fB::http::status\fP is \fBtimeout\fP
after a timeout has occurred.
.TP
\fB\-validate\fP \fIboolean\fP
-If \fIboolean\fR is non-zero, then \fBhttp_get\fR does an HTTP HEAD
+If \fIboolean\fR is non-zero, then \fB::http::geturl\fR does an HTTP HEAD
request. This request returns meta information about the URL, but the
contents are not returned. The meta information is available in the
\fBstate(meta) \fR variable after the transaction. See the STATE
ARRAY section for details.
.RE
.TP
-\fBhttp_formatQuery\fP \fIkey value\fP ?\fIkey value\fP ...?
+\fB::http::formatQuery\fP \fIkey value\fP ?\fIkey value\fP ...?
This procedure does x-url-encoding of query data. It takes an even
number of arguments that are the keys and values of the query. It
encodes the keys and values, and generates one string that has the
proper & and = separators. The result is suitable for the
-\fB\-query\fR value passed to \fBhttp_get\fR.
+\fB\-query\fR value passed to \fB::http::geturl\fR.
.TP
-\fBhttp_reset\fP \fItoken\fP ?\fIwhy\fP?
+\fB::http::reset\fP \fItoken\fP ?\fIwhy\fP?
This command resets the HTTP transaction identified by \fItoken\fR, if
any. This sets the \fBstate(status)\fP value to \fIwhy\fP, which defaults to \fBreset\fR, and then calls the registered \fB\-command\fR callback.
.TP
-\fBhttp_wait\fP \fItoken\fP
+\fB::http::wait\fP \fItoken\fP
This is a convenience procedure that blocks and waits for the
transaction to complete. This only works in trusted code because it
uses \fBvwait\fR.
.TP
-\fBhttp_data\fP \fItoken\fP
+\fB::http::data\fP \fItoken\fP
This is a convenience procedure that returns the \fBbody\fP element
(i.e., the URL data) of the state array.
.TP
-\fBhttp_status\fP \fItoken\fP
+\fB::http::status\fP \fItoken\fP
This is a convenience procedure that returns the \fBstatus\fP element of
the state array.
.TP
-\fBhttp_code\fP \fItoken\fP
+\fB::http::code\fP \fItoken\fP
This is a convenience procedure that returns the \fBhttp\fP element of the
state array.
.TP
-\fBhttp_size\fP \fItoken\fP
+\fB::http::size\fP \fItoken\fP
This is a convenience procedure that returns the \fBcurrentsize\fP
element of the state array.
.SH "STATE ARRAY"
-The \fBhttp_get\fR procedure returns a \fItoken\fR that can be used to
+The \fB::http::geturl\fR procedure returns a \fItoken\fR that can be used to
get to the state of the HTTP transaction in the form of a Tcl array.
Use this construct to create an easy-to-use array variable:
.CS
@@ -254,11 +255,11 @@ The following elements of the array are supported:
.TP
\fBbody\fR
The contents of the URL. This will be empty if the \fB\-channel\fR
-option has been specified. This value is returned by the \fBhttp_data\fP command.
+option has been specified. This value is returned by the \fB::http::data\fP command.
.TP
\fBcurrentsize\fR
The current number of bytes fetched from the URL.
-This value is returned by the \fBhttp_size\fP command.
+This value is returned by the \fB::http::size\fP command.
.TP
\fBerror\fR
If defined, this is the error string seen when the HTTP transaction
@@ -266,7 +267,7 @@ was aborted.
.TP
\fBhttp\fR
The HTTP status reply from the server. This value
-is returned by the \fBhttp_code\fP command. The format of this value is:
+is returned by the \fB::http::code\fP command. The format of this value is:
.RS
.CS
\fIcode string\fP
@@ -297,7 +298,7 @@ The type of the URL contents. Examples include \fBtext/html\fR,
.TP
\fBContent-Length\fR
The advertised size of the contents. The actual size obtained by
-\fBhttp_get\fR is available as \fBstate(size)\fR.
+\fB::http::geturl\fR is available as \fBstate(size)\fR.
.TP
\fBLocation\fR
An alternate URL that contains the requested data.
@@ -320,12 +321,12 @@ The requested URL.
.SH EXAMPLE
.DS
# Copy a URL to a file and print meta-data
-proc Http_Copy { url file {chunk 4096} } {
+proc ::http::copy { url file {chunk 4096} } {
set out [open $file w]
- set token [http_get $url -channel $out -progress HttpProgress \\
+ set token [geturl $url -channel $out -progress ::http::Progress \\
-blocksize $chunk]
close $out
- # This ends the line started by HttpProgress
+ # This ends the line started by http::Progress
puts stderr ""
upvar #0 $token state
set max 0
@@ -336,7 +337,7 @@ proc Http_Copy { url file {chunk 4096} } {
if {[regexp -nocase ^location$ $name]} {
# Handle URL redirects
puts stderr "Location:$value"
- return [Http_Copy [string trim $value] $file $chunk]
+ return [copy [string trim $value] $file $chunk]
}
}
incr max
@@ -346,7 +347,7 @@ proc Http_Copy { url file {chunk 4096} } {
return $token
}
-proc HttpProgress {args} {
+proc ::http::Progress {args} {
puts -nonewline stderr . ; flush stderr
}
diff --git a/contrib/tcl/doc/interp.n b/contrib/tcl/doc/interp.n
index a7dda33..0236818 100644
--- a/contrib/tcl/doc/interp.n
+++ b/contrib/tcl/doc/interp.n
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) interp.n 1.29 97/03/06 17:41:39
+'\" SCCS: @(#) interp.n 1.35 97/07/31 18:04:06
'\"
.so man.macros
.TH interp n 7.6 Tcl "Tcl Built-In Commands"
@@ -169,18 +169,29 @@ exists in this master, \fB0\fR otherwise. If \fIpath\fR is omitted, the
invoking interpreter is used.
.VS BR
.TP
-\fBinterp \fBexpose \fIpath\fR \fIhiddenCmdName\fR ?\fIexposedCmdName\fR?
-Makes the hidden command \fIhiddenCmdName\fR exposed, potentially renaming
-it to \fIexposedCmdName\fR, in the interpreter denoted by \fIpath\fR.
+\fBinterp \fBexpose \fIpath\fR \fIhiddenName\fR ?\fIexposedCmdName\fR?
+Makes the hidden command \fIhiddenName\fR exposed, eventually bringing
+it back under a new \fIexposedCmdName\fR name (this name is currently
+accepted only if it is a valid global name space name without any ::),
+in the interpreter
+denoted by \fIpath\fR.
If an exposed command with the targetted name already exists, this command
fails.
Hidden commands are explained in more detail in HIDDEN COMMANDS, below.
.TP
\fBinterp \fBhide \fIpath\fR \fIexposedCmdName\fR ?\fIhiddenCmdName\fR?
-Makes the exposed command \fIexposedCmdName\fR hidden, potentially renaming
-it to \fIhiddenCmdName\fR, in the interpreter denoted by \fIpath\fR.
+Makes the exposed command \fIexposedCmdName\fR hidden, renaming
+it to the hidden command \fIhiddenCmdName\fR, or keeping the same name if
+\fIhiddenCmdName\fR is not given, in the interpreter denoted
+by \fIpath\fR.
If a hidden command with the targetted name already exists, this command
fails.
+Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can
+not contain namespace qualifiers, or an error is raised.
+Commands to be hidden by \fBinterp hide\fR are looked up in the global
+namespace even if the current namespace is not the global one. This
+prevents slaves from fooling a master interpreter into hiding the wrong
+command, by making the current namespace be different from the global one.
Hidden commands are explained in more detail in HIDDEN COMMANDS, below.
.TP
\fBinterp \fBhidden \fIpath\fR
@@ -291,25 +302,34 @@ such as the \fBerrorInfo\fR and \fBerrorCode\fR variables, if an
error occurs) is returned to the invoking interpreter.
.VS BR
.TP
-\fIslave \fBexpose \fIhiddenCmdName \fR?\fIexposedCmdName\fR?
-This command exposes the hidden command \fIhiddenCmdName\fR, potentially
-renaming it to \fIexposedCmdName\fR, in \fIslave\fR.
-If an exposed command with the targeted name already exists, this command
+\fIslave \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR?
+This command exposes the hidden command \fIhiddenName\fR, eventually bringing
+it back under a new \fIexposedCmdName\fR name (this name is currently
+accepted only if it is a valid global name space name without any ::),
+in \fIslave\fR.
+If an exposed command with the targetted name already exists, this command
fails.
For more details on hidden commands, see HIDDEN COMMANDS, below.
.TP
-\fIslave \fBhide \fIexposedCmdName \fR?\fIhiddenCmdName\fR?
-This command hides the exposed command \fIexposedCmdName\fR, potentially
-renaming it to \fIhiddenCmdName\fR, in \fIslave\fR.
-If a hidden command with the targeted name already exists, this command
+\fIslave \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR?
+This command hides the exposed command \fIexposedCmdName\fR, renaming it to
+the hidden command \fIhiddenCmdName\fR, or keeping the same name if the
+the argument is not given, in the \fIslave\fR interpreter.
+If a hidden command with the targetted name already exists, this command
fails.
+Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can
+not contain namespace qualifiers, or an error is raised.
+Commands to be hidden are looked up in the global
+namespace even if the current namespace is not the global one. This
+prevents slaves from fooling a master interpreter into hiding the wrong
+command, by making the current namespace be different from the global one.
For more details on hidden commands, see HIDDEN COMMANDS, below.
.TP
\fIslave \fBhidden\fR
Returns a list of the names of all hidden commands in \fIslave\fR.
.TP
-\fIslave \fBinvokehidden\fR ?\fB-global\fR \fIhiddenCmdName \fR?\fIarg ..\fR?
-This command invokes the hidden command \fIhiddenCmdName\fR with the
+\fIslave \fBinvokehidden\fR ?\fB-global\fR \fIhiddenName \fR?\fIarg ..\fR?
+This command invokes the hidden command \fIhiddenName\fR with the
supplied arguments, in \fIslave\fR. No substitutions or evaluations are
applied to the arguments.
If the \fB-global\fR flag is given, the command is invoked at the global
@@ -494,11 +514,19 @@ interpreter using \fBinterp expose\fR and \fBinterp hide\fR. The \fBinterp
expose\fR command moves a hidden command to the
set of exposed commands in the interpreter identified by \fIpath\fR,
potentially renaming the command in the process. If an exposed command by
-the targeted name already exists, the operation fails. Similarly,
+the targetted name already exists, the operation fails. Similarly,
\fBinterp hide\fR moves an exposed command to the set of hidden commands in
that interpreter. Safe interpreters are not allowed to move commands
between the set of hidden and exposed commands, in either themselves or
their descendants.
+.PP
+Currently, the names of hidden commands cannot contain namespace
+qualifiers, and you must first rename a command in a namespace to the
+global namespace before you can hide it.
+Commands to be hidden by \fBinterp hide\fR are looked up in the global
+namespace even if the current namespace is not the global one. This
+prevents slaves from fooling a master interpreter into hiding the wrong
+command, by making the current namespace be different from the global one.
.VE
.SH CREDITS
.PP
diff --git a/contrib/tcl/doc/namespace.n b/contrib/tcl/doc/namespace.n
index 4be685a..5bf787d 100644
--- a/contrib/tcl/doc/namespace.n
+++ b/contrib/tcl/doc/namespace.n
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) namespace.n 1.8 97/06/20 16:48:18
+'\" SCCS: @(#) namespace.n 1.9 97/08/13 17:08:25
'\"
.so man.macros
.TH namespace n 8.0 Tcl "Tcl Built-In Commands"
@@ -14,7 +14,7 @@
.SH NAME
namespace \- create and manipulate contexts for commands and variables
.SH SYNOPSIS
-\fBnamespace ?\fIsubcommand\fR? ?\fIarg ...\fR?
+\fBnamespace \fR?\fIoption\fR? ?\fIarg ...\fR?
.BE
.SH DESCRIPTION
@@ -23,38 +23,45 @@ The \fBnamespace\fR command lets you create, access, and destroy
separate contexts for commands and variables.
See the section \fBWHAT IS A NAMESPACE?\fR below
for a brief overview of namespaces.
-The legal \fIsubcommand\fR's are listed below.
-Note that you can abbreviate the names of subcommands.
+The legal \fIoption\fR's are listed below.
+Note that you can abbreviate the \fIoption\fR's.
.TP
-\fBnamespace children \fR?\fIname\fR? ?\fIpattern\fR?
+\fBnamespace children \fR?\fInamespace\fR? ?\fIpattern\fR?
Returns a list of all child namespaces that belong to the
-namespace \fIname\fR.
-If \fIname\fR is not specified,
+namespace \fInamespace\fR.
+If \fInamespace\fR is not specified,
then the children are returned for the current namespace.
-This command returns fully-qualified names which start with \fB::\fR.
+This command returns fully-qualified names,
+which start with \fB::\fR.
If the optional \fIpattern\fR is given,
then this command returns only the names that match the glob-style pattern.
The actual pattern used is determined as follows:
a pattern that starts with \fB::\fR is used directly,
-otherwise the namespace \fIname\fR
+otherwise the namespace \fInamespace\fR
(or the fully-qualified name of the current namespace)
is prepended onto the the pattern.
.TP
-\fBnamespace code \fIarg\fR
+\fBnamespace code \fIscript\fR
Captures the current namespace context for later execution
-of the script \fIarg\fR.
-It returns a new Tcl scoped command that can be evaluated later
-to execute \fIarg\fR in the current namespace.
-It is typically used to create callback scripts,
-where the \fIarg\fR argument is a list containing a script.
-The command it produces is equivalent to that produced by
-\fBlist namespace inscope [namespace current] $arg\fR
-If \fIarg\fR is itself a scoped command starting with
-\fBnamespace inscope\fR,
-the result is just \fIarg\fR.
-.br
-.sp
-Extensions like Tk normally execute callback scripts
+of the script \fIscript\fR.
+It returns a new script in which \fIscript\fR has been wrapped
+in a \fBnamespace code\fR command.
+The new script has two important properties.
+First, it can be evaluated in any namespace and will cause
+\fIscript\fR to be evaluated in the current namespace
+(the one where the \fBnamespace code\fR command was invoked).
+Second, additional arguments can be appended to the resulting script
+and they will be passed to \fIscript\fR as additional arguments.
+For example, suppose the command
+\fBset script [namespace code {foo bar}]\fR
+is invoked in namespace \fB::a::b\fR.
+Then \fBeval "$script x y"\fR
+can be executed in any namespace (assuming the value of
+\fBscript\fR has been passed in properly)
+and will have the same effect as the command
+\fBnamespace eval ::a::b {foo bar x y}\fR.
+This command is needed because
+extensions like Tk normally execute callback scripts
in the global namespace.
A scoped command captures a command together with its namespace context
in a way that allows it to be executed properly later.
@@ -67,19 +74,11 @@ The actual name of the global namespace is ``''
(i.e., an empty string),
but this command returns \fB::\fR for the global namespace
as a convenience to programmers.
-Tcl treats ``'' and \fB::\fR as synonyms
-for the name of the global namespace.
-This make it easier to manipulate namespace names
-and ensures that commands like
-\fBset [namespace current]::x\fR
-always work.
.TP
-\fBnamespace delete \fR?\fIname name ...\fR?
-Each namespace \fIname\fR is deleted
+\fBnamespace delete \fR?\fInamespace namespace ...\fR?
+Each namespace \fInamespace\fR is deleted
and all variables, procedures, and child namespaces
contained in the namespace are deleted.
-\fIname\fR may include a sequence of namespace qualifiers
-separated by \fB::\fRs.
If a procedure is currently executing inside the namespace,
the namespace will be kept alive until the procedure returns;
however, the namespace is marked to prevent other code from
@@ -87,42 +86,21 @@ looking it up by name.
If a namespace doesn't exist, this command returns an error.
If no namespace names are given, this command does nothing.
.TP
-\fBnamespace eval\fR \fIname arg\fR ?\fIarg ...\fR?
-Activates a namespace called \fIname\fR and evaluates some code
+\fBnamespace eval\fR \fInamespace arg\fR ?\fIarg ...\fR?
+Activates a namespace called \fInamespace\fR and evaluates some code
in that context.
If the namespace does not already exist, it is created.
-This command is normally used to define the
-commands and variables in a namespace.
If more than one \fIarg\fR argument is specified,
the arguments are concatenated together with a space between each one
-in the same fashion as the \fBconcat\fR command,
+in the same fashion as the \fBeval\fR command,
and the result is evaluated.
.br
.sp
-If a \fBnamespace eval\fR command creates a new namespace \fIname\fR,
-then \fIname\fR determines its parent namespace and
-the new namespace's position in the hierarchy of namespaces.
-If \fIname\fR includes a sequence of namespace qualifiers
-separated by \fB::\fRs,
-it is created as a child of the specified parent namespace;
-otherwise, the namespace is created as a child of the current namespace.
-If \fIname\fR has leading namespace qualifiers
+If \fInamespace\fR has leading namespace qualifiers
and any leading namespaces do not exist,
they are automatically created.
-.br
-.sp
-\fBnamespace eval\fR is another way (besides procedure calls)
-that the Tcl naming context can change.
-It adds a call frame to the stack to represent the namespace context.
-This means each \fBnamespace eval\fR command
-counts as another call level for \fBuplevel\fR and \fBupvar\fR commands.
-For example, \fBinfo level 1\fR will return a list
-describing a command that is either
-the outermost procedure call or the outermost \fBnamespace eval\fR command.
-Also, \fBuplevel #0\fR evaluates a script
-at top-level in the outermost namespace (the global namespace).
.TP
-\fBnamespace export \fR?\fB-clear\fR? ?\fIpattern pattern ...\fR?
+\fBnamespace export \fR?\-\fBclear\fR? ?\fIpattern pattern ...\fR?
Specifies which commands are exported from a namespace.
The exported commands are those that can be later imported
into another namespace using a \fBnamespace import\fR command.
@@ -136,15 +114,15 @@ but it may not include any namespace qualifiers.
That is, the pattern can only specify commands
in the current (exporting) namespace.
Each \fIpattern\fR is appended onto the namespace's list of export patterns.
-If the \fB-clear\fR flag is given,
+If the \-\fBclear\fR flag is given,
the namespace's export pattern list is reset to empty before any
\fIpattern\fR arguments are appended.
-If no \fIpattern\fRs are given and the \fB-clear\fR flag isn't given,
+If no \fIpattern\fRs are given and the \-\fBclear\fR flag isn't given,
this command returns the namespace's current export list.
.TP
\fBnamespace forget \fR?\fIpattern pattern ...\fR?
Removes previously imported commands from a namespace.
-Each \fIpattern\fR is a \fIqualified name\fR like
+Each \fIpattern\fR is a qualified name such as
\fBfoo::x\fR or \fBa::b::p*\fR.
Qualified names contain \fB::\fRs and qualify a name
with the name of one or more namespaces.
@@ -155,10 +133,10 @@ Glob characters may not appear in a namespace name.
This command first finds the matching exported commands.
It then checks whether any of those those commands
were previously imported by the current namespace.
-If so, this command deletes the corresponding imported command.
+If so, this command deletes the corresponding imported commands.
In effect, this un-does the action of a \fBnamespace import\fR command.
.TP
-\fBnamespace import \fR?\fB-force\fR? ?\fIpattern\fR \fIpattern ...\fR?
+\fBnamespace import \fR?\fB\-force\fR? ?\fIpattern\fR \fIpattern ...\fR?
Imports commands into a namespace.
Each \fIpattern\fR is a qualified name like
\fBfoo::x\fR or \fBa::p*\fR.
@@ -167,17 +145,24 @@ and may have glob-style special characters in the command name
at the end of the qualified name.
Glob characters may not appear in a namespace name.
All the commands that match a \fIpattern\fR string
-and which are exported from their namespace
+and which are currently exported from their namespace
are added to the current namespace.
This is done by creating a new command in the current namespace
that points to the exported command in its original namespace;
when the new imported command is called, it invokes the exported command.
This command normally returns an error
if an imported command conflicts with an existing command.
-However, if the \fB-force\fR option is given,
+However, if the \-\fBforce\fR option is given,
imported commands will silently replace existing commands.
+The \fBnamespace import\fR command has snapshot semantics:
+that is, only requested commands that are currently defined
+in the exporting namespace are imported.
+In other words, you can import only the commands that are in a namespace
+at the time when the \fBnamespace import\fR command is executed.
+If another command is defined and exported in this namespace later on,
+it will not be imported.
.TP
-\fBnamespace inscope\fR \fIname arg\fR ?\fIarg ...\fR?
+\fBnamespace inscope\fR \fInamespace arg\fR ?\fIarg ...\fR?
Executes a script in the context of a particular namespace.
This command is not expected to be used directly by programmers;
calls to it are generated implicitly when applications
@@ -195,9 +180,9 @@ is equivalent to
This \fBlappend\fR semantics is important because many callback scripts
are actually prefixes.
.TP
-\fBnamespace origin name\fR
+\fBnamespace origin \fIcommand\fR
Returns the fully-qualified name of the original command
-to which the imported command \fIname\fR refers.
+to which the imported command \fIcommand\fR refers.
When a command is imported into a namespace,
a new command is created in that namespace
that points to the actual command in the exporting namespace.
@@ -206,13 +191,13 @@ If a command is imported into a sequence of namespaces
just imports the command from the previous namespace,
this command returns the fully-qualified name of the original command
in the first namespace, \fIa\fR.
-If \fIname\fR does not refer to an imported command,
+If \fIcommand\fR does not refer to an imported command,
the command's own fully-qualified name is returned.
.TP
-\fBnamespace parent\fR ?\fIname\fR?
+\fBnamespace parent\fR ?\fInamespace\fR?
Returns the fully-qualified name of the parent namespace
-for namespace \fIname\fR.
-If \fIname\fR is not specified,
+for namespace \fInamespace\fR.
+If \fInamespace\fR is not specified,
the fully-qualified name of the current namespace's parent is returned.
.TP
\fBnamespace qualifiers\fR \fIstring\fR
@@ -236,7 +221,7 @@ This command is the complement of the \fBnamespace qualifiers\fR command.
It does not check whether the namespace names are, in fact,
the names of currently defined namespaces.
.TP
-\fBnamespace which\fR ?\fB-command\fR? ?\fB-variable\fR? \fIname\fR
+\fBnamespace which\fR ?\-\fBcommand\fR? ?\-\fBvariable\fR? \fIname\fR
Looks up \fIname\fR as either a command or variable
and returns its fully-qualified name.
For example, if \fIname\fR does not exist in the current namespace
@@ -274,7 +259,7 @@ the procedure \fBBump\fR.
The commands and variables in this namespace are separate from
other commands and variables in the same program.
If there is a command named \fBBump\fR in the global namespace,
-for example, it will not interfere with the command \fBBump\fR
+for example, it will be different from the command \fBBump\fR
in the \fBCounter\fR namespace.
.PP
Namespace variables resemble global variables in Tcl.
@@ -283,8 +268,8 @@ but can be accessed in a procedure via the \fBvariable\fR command,
as shown in the example above.
.PP
Namespaces are dynamic.
-You can add and delete commands and variables at any time.
-So you can build up the contents of a
+You can add and delete commands and variables at any time,
+so you can build up the contents of a
namespace over time using a series of \fBnamespace eval\fR commands.
For example, the following series of commands has the same effect
as the namespace definition shown above:
@@ -312,66 +297,37 @@ Namespaces can have other namespaces within them,
so they nest hierarchically.
A nested namespace is encapsulated inside its parent namespace
and can not interfere with other namespaces.
-If namespaces are used to represent packages,
-this feature lets one package contain its own copy of another package.
.SH "QUALIFIED NAMES"
-Procedures execute in the context of the namespace that contains them.
-So in the following namespace,
-.CS
-\fBnamespace eval Counter {
- namespace export Bump Reset
- variable num 0
-
- proc Bump {{by 1}} {
- variable num
- return [incr num $by]
- }
- proc Reset {} {
- variable num
- set num 0
- }
-}\fR
-.CE
-procedures like \fBBump\fR and \fBReset\fR execute in the context of
-namespace \fBCounter\fR.
.PP
-In this context, you can access the commands and variables that
-reside in the namespace using simple names.
-In the example above,
-we access the \fBnum\fR variable with the command \fBvariable num\fR.
-(We can't use \fBglobal num\fR since that would only
-look up \fBnum\fR in the global namespace.)
-We can access the \fBBump\fR and \fBReset\fR procedures in
-another procedure like this:
-.CS
-\fBnamespace eval Counter {
- namespace export Rebump
- proc Rebump {{by 1}} {
- Reset
- Bump $by
- }
-}\fR
-.CE
-This is the real benefit of namespaces.
-The commands and variables in a namespace fit together as a module.
+Each namespace has a textual name such as
+\fBhistory\fR or \fB::safe::interp\fR.
+Since namespaces may nest,
+qualified names are used to refer to
+commands, variables, and child namespaces contained inside namespaces.
+Qualified names are similar to the hierarchical path names for
+Unix files or Tk widgets,
+except that \fB::\fR is used as the separator
+instead of \fB/\fR or \fB.\fR.
+The topmost or global namespace has the name ``'' (i.e., an empty string),
+although \fB::\fR is a synonym.
+As an example, the name \fB::safe::interp::create\fR
+refers to the command \fBcreate\fR in the namespace \fBinterp\fR
+that is a child of of namespace \fB::safe\fR,
+which in turn is a child of the global namespace \fB::\fR.
.PP
If you want to access commands and variables from another namespace,
you must use some extra syntax.
Names must be qualified by the namespace that contains them.
-The \fB::\fR string acts as a separator
-between the various qualifiers in a name.
From the global namespace,
we might access the \fBCounter\fR procedures like this:
.CS
\fBCounter::Bump 5
-Counter::Reset
-Counter::Rebump 10\fR
+Counter::Reset\fR
.CE
We could access the current count like this:
.CS
-\fBputs "count = $Counter::num"
-set Counter::num 35\fR
+\fBputs "count = $Counter::num"\fR
.CE
When one namespace contains another, you may need more than one
qualifier to reach its elements.
@@ -381,23 +337,6 @@ from the global namespace like this:
.CS
\fBFoo::Counter::Bump 3\fR
.CE
-You can think of namespaces like directories in a file system.
-When you are sitting in a particular directory context,
-you can access files with simple names.
-But from another context, you must use a proper path name.
-A name like \fBFoo::Counter::Bump\fR
-is just like a file name \fBFoo/Counter/Bump\fR,
-except that we have used \fB::\fR instead of \fB/\fR as the separator.
-Just as the file system has a root directory \fB/\fR,
-all namespaces are rooted in the global namespace named \fB::\fR.
-So all names can be given with an absolute path that begins with \fB::\fR.
-For example, we can say:
-.CS
-\fB::Foo::Counter::Bump 3\fR
-.CE
-With this name, you can be sure that you'll get the \fBBump\fR procedure
-in the \fBCounter\fR namespace, in the \fBFoo\fR namespace, in the global
-namespace\-no matter what the current namespace context may be.
.PP
You can also use qualified names when you create and rename commands.
For example, you could add a procedure to the \fBFoo\fR
@@ -412,8 +351,9 @@ And you could move the same procedure to another namespace like this:
.PP
There are a few remaining points about qualified names
that we should cover.
-\fB::\fR is disallowed in both simple command and variable names except
-as a namespace separator.
+Namespaces have nonempty names except for the global namespace.
+\fB::\fR is disallowed in simple command, variable, and namespace names
+except as a namespace separator.
Extra \fB:\fRs in a qualified name are ignored;
that is, two or more \fB:\fRs are treated as a namespace separator.
A trailing \fB::\fR in a qualified variable or command name
@@ -471,27 +411,15 @@ You can use the \fBnamespace which\fR command to clear up any question
about name resolution.
For example, the command:
.CS
-\fBnamespace eval Foo::Debug {namespace which -variable traceLevel}\fR
+\fBnamespace eval Foo::Debug {namespace which \-variable traceLevel}\fR
.CE
returns \fB::traceLevel\fR.
On the other hand, the command,
.CS
-\fBnamespace eval Foo {namespace which -variable traceLevel}\fR
+\fBnamespace eval Foo {namespace which \-variable traceLevel}\fR
.CE
returns \fB::Foo::traceLevel\fR.
.PP
-Although Tcl always follows the
-``look in the current then in the global namespace''
-rule for variables and commands,
-there is a question of how to resolve a
-qualified name like \fBfoo::bar::cmd\fR.
-A relative name like this might resolve to either
-\fB[namespace current]::foo::bar::cmd\fR
-or to \fB::foo::bar::cmd\fR.
-If \fBcmd\fR does not appear in \fB[namespace current]::foo::bar\fR
-but does appear in \fB::foo::bar\fR,
-Tcl assumes it refers to the latter command.
-.PP
As mentioned above,
namespace names are looked up differently
than the names of variables and commands.
@@ -508,7 +436,7 @@ by the name resolution rule above,
you can access the element.
.PP
You can access a namespace variable
-within a procedure in the same namespace
+from a procedure in the same namespace
by using the \fBvariable\fR command.
Much like the \fBglobal\fR command,
this creates a local link to the namespace variable.
@@ -529,7 +457,7 @@ For example, suppose that all of the commands in a package
like BLT are contained in a namespace called \fBBlt\fR.
Then you might access these commands like this:
.CS
-\fBBlt::graph .g -background red
+\fBBlt::graph .g \-background red
Blt::table . .g 0,0\fR
.CE
If you use the \fBgraph\fR and \fBtable\fR commands frequently,
@@ -539,12 +467,16 @@ like this:
.CS
\fBnamespace import Blt::*\fR
.CE
-This adds all commands from the \fBBlt\fR namespace into the current
-namespace context, so you can write code like this:
+This adds all exported commands from the \fBBlt\fR namespace
+into the current namespace context, so you can write code like this:
.CS
-\fBgraph .g -background red
+\fBgraph .g \-background red
table . .g 0,0\fR
.CE
+The \fBnamespace import\fR command only imports commands
+from a namespace that that namespace exported
+with a \fBnamespace export\fR command.
+.PP
Importing \fIevery\fR command from a namespace is generally
a bad idea since you don't know what you will get.
It is better to import just the specific commands you need.
@@ -555,23 +487,15 @@ For example, the command
imports only the \fBgraph\fR and \fBtable\fR commands into the
current context.
.PP
-The \fBnamespace import\fR command has snapshot semantics:
-that is, only requested commands that are currently defined
-in the exporting namespace are imported.
-In other words, you can import only the commands that are in a namespace
-like \fBBlt\fR at the time when the \fBnamespace import\fR command is
-executed. If another command appears in this namespace later on, it
-will not be imported.
-.PP
If you try to import a command that already exists, you will get an
error. This prevents you from importing the same command from two
different packages. But from time to time (perhaps when debugging),
you may want to get around this restriction. You may want to
reissue the \fBnamespace import\fR command to pick up new commands
that have appeared in a namespace. In that case, you can use the
-\fB-force\fR option, and existing commands will be silently overwritten:
+\fB\-force\fR option, and existing commands will be silently overwritten:
.CS
-\fBnamespace import -force Blt::graph Blt::table\fR
+\fBnamespace import \-force Blt::graph Blt::table\fR
.CE
If for some reason, you want to stop using the imported commands,
you can remove them with an \fBnamespace forget\fR command, like this:
@@ -632,30 +556,6 @@ may be imported by other namespaces.
If a \fBnamespace import\fR command specifies a command
that is not exported, the command is not imported.
-.SH "SCOPED VALUES"
-.PP
-Extensions like Tk execute ordinary code fragments in the global
-namespace.
-A scoped command captures a script together with
-its namespace in a way that allows it to be executed properly later.
-It is needed, for example, to wrap up script
-when a Tk widget is used within a namespace.
-It is also needed for commands such as \fBafter\fR that
-execute a script at the global level at some future time.
-If a \fBafter\fR command is executed in a namespace,
-a \fBnamespace code\fR command is needed to ensure
-its script executes in the correct context:
-.CS
-\fBnamespace eval Foo {
- variable v 123
- proc report {msg} {
- puts "$msg"
- }
-
- after 2000 [namespace code {report "Hello World, v = $v"}]
-}\fR
-.CE
-
.SH "SEE ALSO"
variable(n)
diff --git a/contrib/tcl/doc/registry.n b/contrib/tcl/doc/registry.n
index 6e35f2d..52c2e4e 100644
--- a/contrib/tcl/doc/registry.n
+++ b/contrib/tcl/doc/registry.n
@@ -1,7 +1,10 @@
'\"
-'\" Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved.
+'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
-'\" SCCS: @(#) registry.n 1.3 97/06/23 14:41:04
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+'\" SCCS: @(#) registry.n 1.5 97/08/11 19:33:27
'\"
.so man.macros
.TH registry n 8.0 Tcl "Tcl Built-In Commands"
@@ -65,7 +68,8 @@ data, see SUPPORTED TYPES, below.
If \fIpattern\fR isn't specified, returns a list of names of all the
subkeys of \fIkeyName\fR. If \fIpattern\fR is specified, only those
names matching \fIpattern\fR are returned. Matching is determined
-using the same rules as for \fBstring\fR \fBmatch\fR.
+using the same rules as for \fBstring\fR \fBmatch\fR. If the
+specified \fIkeyName\fR does not exist, then an error is generated.
.TP
\fBregistry set \fIkeyName\fR ?\fIvalueName data \fR?\fItype\fR??
.
diff --git a/contrib/tcl/doc/rename.n b/contrib/tcl/doc/rename.n
index a3e185d..8962bd0 100644
--- a/contrib/tcl/doc/rename.n
+++ b/contrib/tcl/doc/rename.n
@@ -1,11 +1,11 @@
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
-'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 1994-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.
'\"
-'\" SCCS: @(#) rename.n 1.5 96/03/25 20:22:11
+'\" SCCS: @(#) rename.n 1.6 97/07/30 17:37:26
'\"
.so man.macros
.TH rename n "" Tcl "Tcl Built-In Commands"
@@ -20,9 +20,13 @@ rename \- Rename or delete a command
.SH DESCRIPTION
.PP
Rename the command that used to be called \fIoldName\fR so that it
-is now called \fInewName\fR. If \fInewName\fR is an empty string
-then \fIoldName\fR is deleted. The \fBrename\fR command
-returns an empty string as result.
+is now called \fInewName\fR.
+If \fInewName\fR is an empty string then \fIoldName\fR is deleted.
+\fIoldName\fR and \fInewName\fR may include namespace qualifiers
+(names of containing namespaces).
+If a command is renamed into a different namespace,
+future invocations of it will execute in the new namespace.
+The \fBrename\fR command returns an empty string as result.
.SH KEYWORDS
-command, delete, rename
+command, delete, namespace, rename
diff --git a/contrib/tcl/doc/resource.n b/contrib/tcl/doc/resource.n
new file mode 100644
index 0000000..1ccd50c
--- /dev/null
+++ b/contrib/tcl/doc/resource.n
@@ -0,0 +1,116 @@
+'\"
+'\" 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.
+'\" SCCS: @(#) resource.n 1.3 97/07/25 10:24:23
+'\"
+.so man.macros
+.TH resource n 8.0 Tcl "Tcl Built-In Commands"
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+resource \- Manipulate Macintosh resources
+.SH SYNOPSIS
+\fBresource \fIoption\fR ?\fIarg arg ...\fR?
+.BE
+
+.SH DESCRIPTION
+.PP
+The \fBresource\fR command provides some generic operations for
+dealing with Macintosh resources. This command is only supported on
+the Macintosh platform. Each Macintosh file consists of two
+\fIforks\fR: a \fIdata\fR fork and a \fIresource\fR fork. You use the
+normal open, puts, close, etc. commands to manipulate the data fork.
+You must use this command, however, to interact with the resource
+fork. \fIOption\fR indicates what resource command to perform. Any
+unique abbreviation for \fIoption\fR is acceptable. The valid options
+are:
+.TP
+\fBresource close \fIrsrcRef\fR
+Closes the given resource reference (obtained from \fBresource
+open\fR). Resources from that resource file will no longer be
+available.
+.TP
+\fBresource list \fIresourceType\fR ?\fIresourceRef\fR?
+List all of the resources ids of type \fIresourceType\fR (see RESOURCE
+TYPES below). If \fIresourceRef\fR is specified then the command will
+limit the search to that particular resource file. Otherwise, all
+resource files currently opened by the application will be searched.
+A Tcl list of either the resource name's or resource id's of the found
+resources will be returned. See the RESOURCE IDS section below for
+more details about what a resource id is.
+.TP
+\fBresource open \fIfileName\fR ?\fIpermissions\fR?
+Open the resource for the file \fIfileName\fR. Standard file
+permissions may also be specified (see the manual entry for \fBopen\fR
+for details). A resource reference (\fIresourceRef\fR) is returned
+that can be used by the other resource commands. An error can occur
+if the file doesn't exist or the file does not have a resource fork.
+However, if you open the file with write permissions the file and/or
+resource fork will be created instead of generating an error.
+.TP
+\fBresource read \fIresourceType\fR \fIresourceId\fR ?\fIresourceRef\fR?
+Read the entire resource of type \fIresourceType\fR (see RESOURCE
+TYPES below) and the name or id of \fIresourceId\fR (see RESOURCE IDS
+below) into memory and return the result. If \fIresourceRef\fR is
+specified we limit our search to that resource file, otherwise we
+search all open resource forks in the application. It is important to
+note that most Macintosh resource use a binary format and the data
+returned from this command may have embedded NULLs or other non-ASCII
+data.
+.TP
+\fBresource types ?\fIresourceRef\fR?
+This command returns a Tcl list of all resource types (see RESOURCE
+TYPES below) found in the resource file pointed to by
+\fIresourceRef\fR. If \fIresourceRef\fR is not specified it will
+return all the resource types found in every resource file currently
+opened by the application.
+.TP
+\fBresource write\fR ?\fIoptions\fR? \fIresourceType\fR \fIdata\fR
+This command will write the passed in \fIdata\fR as a new resource of
+type \fIresourceType\fR (see RESOURCE TYPES below). Several options
+are available that describe where and how the resource is stored.
+.RS
+.TP
+\fB\-id\fR \fIresourceId\fR
+If the \fB-id\fR option is given the id \fIresourceId\fR (see RESOURCE
+IDS below) is used for the new resource, otherwise a unique id will be
+generated that will not conflict with any existing resource. However,
+the id must be a number - to specify a name use the \fB\-name\fR option.
+.TP
+\fB\-name\fR \fIresourceName\fR
+If \fB-name\fR is specified the resource will be named
+\fIresourceName\fR, otherwise it will have the empty string as the
+name.
+.TP
+\fB\-file\fR \fIresourceRef\fR
+If the \fB-file\fR option is specified then the resource will be
+written in the file pointed to by \fIresourceRef\fR, otherwise the
+most resently open resource will be used.
+.RE
+
+.SH "RESOURCE TYPES"
+Resource types are defined as a four character string that is then
+mapped to an underlying id. For example, \fBTEXT\fR refers to the
+Macintosh resource type for text. The type \fBSTR#\fR is a list of
+counted strings. All Macintosh resources must be of some type. See
+Macintosh documentation for a more complete list of resource types
+that are commonly used.
+
+.SH "RESOURCE IDS"
+For this command the notion of a resource id actually refers to two
+ideas in Macintosh resources. Every place you can use a resource Id
+you can use either the resource name or a resource number. Names are
+always searched or returned in preference to numbers. For example,
+the \fBresource list\fR command will return names if they exist or
+numbers if the name is NULL.
+
+.SH "SEE ALSO"
+open
+
+.SH "PORTABILITY ISSUES"
+The resource command is only available on Macintosh.
+
+.SH KEYWORDS
+open, resource
diff --git a/contrib/tcl/doc/safe.n b/contrib/tcl/doc/safe.n
index acc50ed..03adf0f 100644
--- a/contrib/tcl/doc/safe.n
+++ b/contrib/tcl/doc/safe.n
@@ -4,300 +4,299 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) safe.n 1.10 97/03/24 09:21:12
+'\" SCCS: @(#) safe.n 1.3 97/08/13 12:44:45
'\"
.so man.macros
-.TH "Safe Tcl" n 7.7 Tcl "Tcl Built-In Commands"
+.TH "Safe Tcl" n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
-Safe Tcl \- A mechanism for managing security policies.
+Safe Base \- A mechanism for creating and manipulating safe interpreters.
.SH SYNOPSIS
-.nf
-\fBtcl_safeCreateInterp\fR \fIslave\fR
+.PP
+\fB::safe::interpCreate\fR ?\fIslave\fR? ?\fIoptions...\fR?
+.sp
+\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR?
.sp
-\fBtcl_safeInitInterp\fR \fIslave\fR
+\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR?
.sp
-\fBtcl_safeDeleteInterp\fR \fIslave\fR
+\fB::safe::interpDelete\fR \fIslave\fR
.sp
-\fIpolicy\fB_policyInit\fR \fIslave\fR
+\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR
.sp
-\fIpolicy\fB_policyFinalize\fR \fIslave\fR
-.fi
+\fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR
+.sp
+\fB::safe::setLogCmd\fR ?\fIcmd arg...\fR?
+.SH OPTIONS
+.PP
+?\fB\-accessPath\fR \fIpathList\fR? ?\fB\-noStatics\fR? ?\fB\-nestedLoadOk\fR? ?\fB\-deleteHook\fR \fIscript\fR?
.BE
.SH DESCRIPTION
+Safe Tcl is a mechanism for executing untrusted Tcl scripts
+safely and for providing mediated access by such scripts to
+potentially dangerous functionality.
.PP
-This manual entry describes \fBSafe Tcl\fR, a mechanism and collection of
-library procedures for managing security policies. \fBSafe Tcl\fR is used
-in \fBapplications\fR that want to provide a flexible, extensible safe
-hosting environment for untrusted guest scripts, \fBtclets\fR. It
-provides a mechanism to ensure that tclets cannot harm the hosting
-application, and a way to extend limited degrees of trust to such tclets,
-to allow them to have access to unsafe features.
+The Safe Base ensures that untrusted Tcl scripts cannot harm the
+hosting application.
+The Safe Base prevents integrity and privacy attacks. Untrusted Tcl
+scripts are prevented from corrupting the state of the hosting
+application or computer. Untrusted scripts are also prevented from
+disclosing information stored on the hosting computer or in the
+hosting application to any party.
.PP
-The content of this manual entry is of interest to four different
-audiences: authors of tclets will primarily be interested in the sections
-on the \fBSAFE BASE\fR and on \fBUSING SAFE TCL IN TCLETS\fR.
-Application authors will find relevant information in the section on
-\fBUSING SAFE TCL IN APPLICATIONS\fR. To create a new security
-policy, e.g. to enable tclets to have access to a new feature, read the
-section on \fBWRITING SECURITY POLICIES\fB. Finally, system administrators
-and people installing \fBSafe Tcl\fR will find useful information in the
-section on \fBINSTALLING SECURITY POLICIES\fR.
+The Safe Base allows a master interpreter to create safe, restricted
+interpreters that contain a set of predefined aliases for the \fBsource\fR,
+\fBload\fR, \fBfile\fR and \fBexit\fR commands and
+are able to use the auto-loading and package mechanisms.
.PP
-\fBSecurity policies\fR are collections of procedures, aliases, hidden
-commands and variable settings that together implement a controlled way for
-an application to allow a tclet to have restricted access to unsafe features.
-For a complete description of aliases, hidden commands and how to use
-multiple interpreters in an application, see the manual entry for the
-\fBinterp\fR command.
+No knowledge of the file system structure is leaked to the
+safe interpreter, because it has access only to a virtualized path
+containing tokens. When the safe interpreter requests to source a file, it
+uses the token in the virtual path as part of the file name to source; the
+master interpreter translates the token into a real directory name and
+executes the requested operation.
+Different levels of security can be selected by using the optional flags
+of the commands described below.
.PP
-Packaging collections of features into security policies has several
-advantages: First, it allows these collections to have names. This
-facilitates the formation of a common, agreed upon, understanding of what
-features are included in each policy. Second, it enables a reasoned
-approach to developing extensions that make restricted features available
-to untrusted tclets.
-Third, because the feature set is delineated clearly, a security policy can
-be subjected to analysis to determine what risks it exposes its user to.
+All commands provided in the master interpreter by the Safe Base reside in
+the \fBsafe\fR namespace.
+\fB::safe::interpCreate\fR creates a new safe interpreter with options,
+described in the section \fBOPTIONS\fR.
+The return value is the name of the new safe interpreter created.
+\fB::safe::interpInit\fR is similar to \fB::safe::interpCreate\fR except that
+it requires as its first argument the name of a safe interpreter that was
+previously created directly using the \fBinterp\fR command.
+\fB::safe::interpDelete\fR deletes the interpreter named by its argument.
+\fB::safe::interpConfigure\fR can be used to set or get options for the named
+safe interpreters; the options are described in the section \fBOPTIONS\fR.
.PP
-The \fBSafe Tcl\fR approach to safe execution of untrusted code is further
-discussed in \fBThe Safe\-Tcl Security Model\fR
-(http://www.sunlabs.com/people/john.ousterhout/SafeTcl.ps).
-This paper provides a detailed discussion of the underlying
-motivations and philosophy, and compares the \fBSafe Tcl\fR model with
-other current efforts.
-
-.SH "SAFE BASE"
-.PP
-This section describes the environment in which tclets start execution in
-an application using \fBSafe Tcl\fR. This environment is known as the
-\fBSafe Base\fR, as it provides the basis on which further security
-policies are built.
+A virtual path is maintained in the master interpreter for each safe
+interpreter created by \fB::safe::interpCreate\fR or initialized by
+\fB::safe::interpInit\fR.
+The path maps tokens accessible in the safe interpreter into real path
+names on the local file system.
+This prevents safe interpreters from gaining knowledge about the
+structure of the file system of the host on which the interpeter is
+executing.
+When a token is used in a safe interpreter in a request to source or
+load a file, the token is translated to a real path name and the file to be
+sourced or loaded is located on the file system.
+The safe interpreter never gains knowledge of the actual path name under
+which the file is stored on the file system.
+Commands are provided in the master interpreter to manipulate the virtual
+path for a safe interpreter.
+\fB::safe::interpConfigure\fR can be used to set a new path for a safe
+interpreter.
+\fB::safe::interpAddToAccessPath\fR adds a directory to the virtual path for
+the named safe interpreter and returns the token by which that directory
+will be accessible in the safe interpreter.
+\fB::safe::interpFindInAccessPath\fR finds the
+requested directory in the virtual path for the named safe interpreter and
+returns the token by which that directory can be accessed in the safe
+interpreter.
+If the path is not found, an error is raised.
.PP
-When a tclet starts execution in an environment using \fBSafe Tcl\fR,
-its interpreter will contain aliases for the following commands:
-.DS
-.ta 1.2i 2.4i 3.6i
-\fBexit file load source
-tclPkgUnknown\fR
-.DE
-The \fBexit\fR alias terminates the execution of the
-invoking slave.
-\fBFile\fR allows access to a subset of the sub\-commands of the full
-\fBfile\fR command.
-\fBload\fR and \fBsource\fR make extensions available to the tclet in a
-controlled manner.
-The \fBtclPkgUnknown\fR alias allows the application to interpose on
-\fBpackage require\fR invocations by the tclet.
+\fB::safe::setLogCommand\fR installs a script to be called when interesting
+life cycle events happen.
+This script will be called with one argument, a string describing the event.
+.SH ALIASES
.PP
-The following \fBTcl\fR commands are hidden in the Safe Base:
-.DS
-.ta 1.2i 2.4i 3.6i
-\fBcd exec exit fconfigure
-file glob load open
-pwd socket source vwait\fR
-.DE
+The following aliases are provided in a safe interpreter:
+.TP
+\fBsource\fB \fIfileName\fR
+The requested file, a Tcl source file, is sourced into the safe interpreter
+if it is found.
+The \fBsource\fR alias can only source files from directories in
+the virtual path for the safe interpreter. The \fBsource\fR alias requires
+the safe interpreter to
+use one of the token names in its virtual path to denote the directory in
+which the file to be sourced can be found.
+See the section on \fBSECURITY\fR for more discussion of restrictions on
+valid filenames.
+.TP
+\fBload\fR \fIfileName\fR
+The requested file, a shared object file, in dynamically loaded into the
+safe interpreter if it is found.
+The filename must contain a token name mentioned in the virtual path for
+the safe interpreter for it to be found successfully.
+Additionally, the shared object file must contain a safe entry point; see
+the manual page for the \fBload\fR command for more details.
+.TP
+\fBfile\fR ?\fIoptions\fR?
+The \fBfile\fR alias provides access to a safe subset of the subcommands of
+the \fBfile\fR command; it allows only \fBdirname\fR, \fBjoin\fR,
+\fBextension\fR, \fBroot\fR, \fBtail\fR, \fBpathname\fR and \fBsplit\fR
+subcommands. For more details on what these subcommands do see the manual
+page for the \fBfile\fR command.
+.TP
+\fBexit\fR
+The calling interpreter is deleted and its computation is stopped, but the
+Tcl process in which this interpreter exists is not terminated.
.PP
-A tclet can also request to load packages using \fBpackage require\fR.
-Please read the manual page on the \fBpackage\fR and \fBload\fR commands
-for a discussion of package loading and special restrictions on loading
-into safe interpreters.
+.SH COMMANDS
.PP
-Tclets can use auto-loading to obtain the definitions for procedures as
-needed. The auto-loading mechanism in the Safe Base supports tclIndex files
-generated by \fBauto_mkindex\fR Version 2 and later.
+The following commands are provided in the master interpreter:
+.TP
+\fB::safe::interpCreate\fR ?\fIslave\fR? ?\fIoptions...\fR?
+Creates a safe interpreter, installs the aliases described in the section
+\fBALIASES\fR and initializes the auto-loading and package mechanism as
+specified by the supplied \fBoptions\fR.
+See the \fBOPTIONS\fR section below for a description of the common
+optional arguments.
+If the \fIslave\fR argument is omitted, a name will be generated.
+\fB::safe::interpCreate\fR always returns the interpreter name.
+.TP
+\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR?
+This command is similar to \fBinterpCreate\fR except it that does not
+create the safe interpreter. \fIslave\fR must have been created by some
+other means, like \fB::interp create \-safe\fR.
+.TP
+\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR?
+If no \fIoptions\fR are given, returns the settings for all options for the
+named safe interpreter.
+If \fIoptions\fR are supplied, sets the options for the named safe
+interpreter. See the section on \fBOPTIONS\fR below.
+.TP
+\fB::safe::interpDelete\fR \fIslave\fR
+Deletes the safe interpreter and cleans up the corresponding
+master interpreter data structures.
+If a \fIdeletehook\fR script was specified for this interpreter it is
+evaluated before the interpreter is deleted, with the name of the
+interpreter as an additional argument.
+.TP
+\fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR
+This command finds and returns the token for the real directory
+\fIdirectory\fR in the safe interpreter's current virtual access path.
+It generates an error if the directory is not found.
+Example of use:
+.CS
+$slave eval [list set tk_library [::safe::interpFindInAccessPath $name $tk_library]]
+.CE
+.TP
+\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR
+This command adds \fIdirectory\fR to the virtual path maintained for the
+safe interpreter in the master, and returns the token that can be used in
+the safe interpreter to obtain access to files in that directory.
+If the directory is already in the virtual path, it only returns the token
+without adding the directory to the virtual path again.
+Example of use:
+.CS
+$slave eval [list set tk_library [::safe::interpAddToAccessPath $name $tk_library]]
+.CE
+.TP
+\fB::safe::setLogCmd\fR ?\fIcmd arg...\fR?
+This command installs a script that will be called when interesting
+lifecycle events occur for a safe interpreter.
+When called with no arguments, it returns the currently installed script.
+When called with one argument, an empty string, the currently installed
+script is removed and logging is turned off.
+The script will be invoked with one additional argument, a string
+describing the event of interest.
+The main purpose is to help in debugging safe interpreters.
+Using this facility you can get complete error messages while the safe
+interpreter gets only generic error messages.
+This prevents a safe interpreter from seeing messages about failures
+and other events that might contain sensitive information such as real
+directory names.
+.RS
+Example of use:
+.CS
+::safe::setLogCmd puts stderr
+.CE
+Below is the output of a sample session in which a safe interpreter
+attempted to source a file not found in its virtual access path.
+Note that the safe interpreter only received an error message saying that
+the file was not found:
+.CS
+NOTICE for slave interp10 : Created
+NOTICE for slave interp10 : Setting accessPath=(/foo/bar) staticsok=1 nestedok=0 deletehook=()
+NOTICE for slave interp10 : auto_path in interp10 has been set to {$p(:0:)}
+ERROR for slave interp10 : /foo/bar/init.tcl: no such file or directory
+.CE
+.RE
-.SH "USING SAFE TCL IN TCLETS"
-.PP
-Tclets start executing in the environment described in the previous
-section, on the \fBSAFE BASE\fR. If they need access to unsafe features,
-tclets can request to use a named security policy by invoking \fBpackage
-require\fR with the policy name. If the request is denied by the
-application's master interpreter, an error is returned.
-A tclet can \fBcatch\fR the error and request to use a different named
-policy, until a request is granted.
-.PP
-A tclet can only use one security policy during its lifetime. Once an
-invocation of \fBpackage require\fR to load a security policy succeeds,
-Safe Tcl prevents subsequent invocations of \fBpackage require\fR from
-succeeding if the requested package is a security policy. There is also no
-mechanism for a tclet to stop using a security policy, once it is loaded.
-Invocations of \fBpackage require\fR to load other packages unrelated to
-security policies will still succeed.
-.PP
-These restrictions are designed to prevent a tclet from composing security
-policies either concurrently or sequentially, in ways not supported or
-forseen by the authors of the policies. Allowing such composition would
-expose the application to unknown security risks, because a security policy
-that is safe in isolation is not necessarily safe when used in conjunction
-with other security policies.
-For example, a security policy that allows read\-only access to the local
-file system can not disclose private data belonging to the application if
-it does not have access to network communication commands such as
-\fBsocket\fR. However, when used in conjunction with another security
-policy that enables the \fBsocket\fR command, this policy is no longer
-safe.
+.SH OPTIONS
+The following options are common to
+\fB::safe::interpCreate\fR, \fB::safe::interpInit\fR,
+and \fB::safe::interpConfigure\fR.
+Any option name can be abbreviated to its minimal
+non-ambiguous name.
+Option names are not case sensitive.
+.TP
+\fB\-accessPath\fR ?\fIdirectoryList\fR?
+This option sets the list of directories from which the safe interpreter
+can \fBsource\fR and \fBload\fR files, and returns a list of tokens that
+will allow the safe interpreter access to these directories.
+If a value for \fBdirectoryList\fR is not given, or if it is given as the
+empty list, the safe interpreter will use the same directories than its
+master for auto-loading.
+See the section \fBSECURITY\fR below for more detail about virtual paths,
+tokens and access control.
+.TP
+\fB\-noStatics\fR
+This option specifies that the safe interpreter will not be allowed
+to load statically linked packages (like \fBload {} Tk\fR).
+The default is that safe interpreters are allowed to load statically linked
+packages.
+.TP
+\fB\-nestedLoadOk\fR
+This option specifies that the safe interpreter will be allowed
+to load packages into its own subinterpreters.
+The default is that safe interpreters are not allowed to load packages into
+their own subinterpreters.
+.TP
+\fB\-deleteHook\fR ?\fIscript\fR?
+If \fIscript\fR is given, it is evaluated in the master with the name of
+the safe interpreter as an additional argument just before deleting the
+safe interpreter.
+If no value is given for \fIscript\fR any currently installed deletion hook
+script for that safe interpreter is removed; it will no longer be called
+when the interpreter is deleted.
+There is no deletion hook script installed by default.
-.SH "USING SAFE TCL IN APPLICATIONS"
-.PP
-An application using Safe Tcl is usually structured as one or more unsafe
-interpreters in which trusted code belonging to the application is
-executed. Each such \fBmaster interpreter\fR controls one or more safe
-\fBslave interpreters\fR in which tclets are executed.
-Tclets communicate with their master interpreter via the aliases provided
-by the Safe Base and via additional mechanisms installed by each security
-policy.
-This section describes the procedures an application invokes to use Safe
-Tcl and to manage slave interpreters.
-.PP
-An application invokes \fBtcl_safeCreateInterp\fR \fIslave\fR to create a
-new slave interpreter; this new interpreter will contain the aliases
-provided by the Safe Base. A new command named \fBslave\fR is also created
-in the invoking interpreter, to allow the application to manipulate the new
-slave interpreter.
-.PP
-An application can use \fBtcl_safeInitInterp\fR \fIslave\fR to initialize
-an existing slave interpreter with the Safe-Tcl security policy mechanism.
-This procedure is useful when an application already has a safe slave
-interpreter created with \fBinterp create -safe\fR and wishes to enable it
-to use security policies.
-.PP
-An application should invoke \fBtcl_safeDeleteInterp\fR \fIslave\fR to
-delete an interpreter previously created by \fBtcl_safeCreateInterp\fR. This
-procedure terminates the execution of the tclet in the \fIslave\fR
-interpreter and cleans up associated state maintained by the Safe Tcl
-mechanism.
-.PP
-Security policies are installed on the file system of the system on which
-the application is executing. Security policies are found in the
-\fIpolicies\fR sub-directories of directories mentioned in the
-application's \fBauto_path\fR, and in sub-directories of these
-\fIpolicies\fR directories.
+.SH SECURITY
.PP
-Safe Tcl will invoke, on behalf of an application, additional procedures
-provided by individual security policies to manage the lifecycle of those
-policies. These additional procedures are described in the next section.
+The Safe Base does not attempt to completely prevent annoyance and
+denial of service attacks. These forms of attack prevent the
+application or user from temporarily using the computer to perform
+useful work, for example by consuming all available CPU time or
+all available screen real estate.
+These attacks, while agravating, are deemed to be of lesser importance
+in general than integrity and privacy attacks that the Safe Base
+is to prevent.
-.SH "WRITING SECURITY POLICIES"
+The commands available in a safe interpreter, in addition to
+the safe set as defined in \fBinterp\fR manual page, are mediated aliases
+for \fBsource\fR, \fBload\fR, \fBexit\fR, and a safe subset of \fBfile\fR.
+The safe interpreter can also auto-load code and it can request to load
+packages.
+Because some of these commands access the local file system, there is a
+potential for information leakage about its directory structure.
+To prevent this, commands which take file names as arguments in a safe
+interpreter use tokens instead of the real directory names.
+These tokens are translated to the real directory name while a request to,
+e.g., source a file is mediated by the master interpreter.
.PP
-Writing a security policy is a complex effort that should not be undertaken
-lightly. It involves careful design, exhaustive testing, public review and
-analysis and continuous debugging.
-In addition to considering what features a security policy should provide,
-the implementer has to constantly keep in mind the security risks to which
-an application using the policy may be exposed.
-Actively considering each feature to see if it can be used to compromise an
-application will help to minimize the chance of a security mishap later on.
+To further prevent potential information leakage from sensitive files that
+are accidentally included in the set of files that can be sourced by a safe
+interpreter, the \fBsource\fR alias is restricted so that it can only
+source files with names that have the extension \fB.tcl\fR, that contain
+only one dot and that are forteen characters long or shorter.
.PP
-A security policy is a Tcl script or a shared library that is loaded into
-an unsafe master interpreter.
-A security policy consists of two parts: a \fBmanagement\fR part, concerned
-with installing the policy into safe slaves and cleaning up after a slave
-is destroyed, and a \fBruntime\fR part, concerned with actually
-implementing the features of the policy.
-.PP
-The management part of a security policy consists of two Tcl procedures or
-commands, one for installing the security policy features into a safe
-slave, and the other for cleaning up any associated state when a slave is
-destroyed.
-The names of these procedures or commands are \fIpolicy\fB_policyInit\fR
-and \fIpolicy\fB_policyFinalize, where \fIpolicy\fR is the name of the
-policy as used by the slave interpreter in the \fBpackage require\fR
-invocation.
-.PP
-The policy initialization procedure \fIpolicy\fB_policyInit\fR called in
-the master interpreter with one argument, the name of the slave
-interpreter, when a slave requests to use the \fIpolicy\fR security policy.
-Error returns indicate that the slave was denied permission to use this
-policy; the error is propagated back to the slave interpreter. Successful
-return indicates that the policy is now available in the requesting slave.
-If it decides to allow the slave to use the requested policy,
-\fIpolicy\fB_policyInit\fR should install new aliases and command into the
-slave, initialize variables both in the master interpreter and in the
-slave, and do any other initialization work to make the policy features
-available in the slave.
-Policy initialization procedures may also perform other tasks, such as
-creating policy specific state data for the new slave using this policy.
-.PP
-Policy initialization procedures should be careful to leave a clean state
-in the slave interpreter if a failure occurs during initialization; the
-rule is that if an error is returned, no changes in any variables,
-procedures or aliases should be detectable in the slave.
-For example, if use of a security policy requires creation
-of a socket to a remote host at initialization time, and if that host is
-not accessible, all aliases created in the slave to use the policy
-should be removed. Otherwise, these aliases might open security holes when
-used in conjunction with another security policy subsequently requested by
-the slave. Without this, a malicious tclet could purposely cause a failure
-during initialization in one security policy and compose features provided
-by that policy in an unsafe manner with another security policy requested
-later.
-.PP
-When an application invokes \fBtcl_safeDeleteInterp\fR to delete a slave
-interpreter, the policy finalization procedure
-\fIpolicy\fB_policyFinalize\fR for the policy in use by the slave is called.
-It receives one argument, the name of the slave interpreter being deleted.
-This procedure should ensure that subsequently if a slave by the
-same name is re\-created, the new slave will be able to use this policy.
-It may also wish to remove any policy specific state data created by
-\fIpolicy\fB_policyInit\fR.
-.PP
-During initialization, a number of aliases may be created in the slave;
-when these aliases are invoke, they cause commands defined in the master to
-execute. The runtime part of a security policy consists of implementations
-of all the target commands that handle the invocation of aliases in the
-slave. Because these commands execute in a trusted interpreter, they have
-full access to all the capabilities of Tcl and any extensions loaded into
-the master interpreter.
-.PP
-A security policy must provide a \fBtclIndex\fR file in addition to files
-containing Tcl procedures and shared libraries implementing the policy.
-To generate a \fBtclIndex\fR file, use the Tcl command \fBauto_mkindex\fR
-which is described in the manual page for the Tcl library.
-
-.SH "INSTALLING SECURITY POLICIES"
-.PP
-Safe Tcl uses a platform dependent mechanism for obtaining the initial
-setting for the search path for finding security policies.
-On \fBUnix\fR, the environment variable \fBTCL_POLICY_PATH\fR is consulted.
-On \fBWin32\fR systems and on \fBMacOS\fR there is currently no mechanism
-provided to obtain the initial value; each application should provide its
-own mechanism for obtaining the initial search path. Such mechanisms will
-be provided shortly.
-.PP
-The search path is searched in reverse order of the order in which entries
-appear. Thus, if two or more policies by the same name occur in the path,
-the last policy by that name will be used by Safe Tcl.
-This enable system administrators to install system wide security policies
-in a centralized directory and then require users to include that directory
-as the last component in the search path. Doing so will ensure that system
-wide policies are used in preference of policies installed by individual
-users.
-.PP
-To install a policy, create a sub\-directory of one of the directories
-mentioned in the policy search path, and copy all the files comprising the
-policy into the new directory.
-Applications should be able, in most situations, to use the newly available
-policy immediately, without having to restart.
-If a security policy uses the same name as a regular package, a \fBpackage
-require\fR invocation in a slave interpreter will preferentially use the
-security policy over the regular package.
-However, if a security policy is installed after the first invocation of
-\fBpackage require\fR in an application, and a regular package exists by
-the same name, the security policy will not be available for use in that
-application. In this case you must restart the application for the policy
-to become available.
-
-.SH CREDITS
-.PP
-The security policy mechanism extends and expands on the Safe-Tcl prototype
-first implemented by Nathaniel Borenstein and Marshall Rose.
+The default value of the Tcl variable \fBauto_path\fR in a safe interpreter
+is a virtualized token list for the directories in the value of its
+master's \fBauto_path\fR variable and their immediate subdirectories.
+The first token in this list is also assigned to the Tcl varibale
+\fBtcl_library\fR in the safe interpreter.
+You can always specify a more
+restrictive path for which sub directories will never be searched by
+explicitly specifying your directory list with the \fB\-accessPath\fR flag
+instead of relying on this default mechanism.
.SH "SEE ALSO"
interp(n), library(n), load(n), package(n), source(n), unknown(n)
-
+
.SH KEYWORDS
-alias, auto\-loading, auto_mkindex, load, master interpreter, security
-policy, safe interpreter, slave interpreter, source
+alias, auto\-loading, auto_mkindex, load, master interpreter, safe
+interpreter, slave interpreter, source
diff --git a/contrib/tcl/doc/tclvars.n b/contrib/tcl/doc/tclvars.n
index 9270fcf..9a7fa6c 100644
--- a/contrib/tcl/doc/tclvars.n
+++ b/contrib/tcl/doc/tclvars.n
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) tclvars.n 1.30 97/05/02 13:06:45
+'\" SCCS: @(#) tclvars.n 1.33 97/08/13 17:50:20
'\"
.so man.macros
.TH tclvars n 8.0 Tcl "Tcl Built-In Commands"
@@ -44,6 +44,64 @@ PATH variable could be exported by the operating system as ``path'',
support many special cases. All other environment variables inherited by
Tcl are left unmodified.
.RE
+.RS
+On the Macintosh, the environment variable is constructed by Tcl as no
+global environment variable exists. The environment variables that
+are created for Tcl include:
+.TP
+\fBLOGIN\fR
+This holds the Chooser name of the Macintosh.
+.TP
+\fBUSER\fR
+This also holds the Chooser name of the Macintosh.
+.TP
+\fBSYS_FOLDER\fR
+The path to the system directory.
+.TP
+\fBAPPLE_M_FOLDER\fR
+The path to the Apple Menu directory.
+.TP
+\fBCP_FOLDER\fR
+The path to the control panels directory.
+.TP
+\fBDESK_FOLDER\fR
+The path to the desk top directory.
+.TP
+\fBEXT_FOLDER\fR
+The path to the system extensions directory.
+.TP
+\fBPREF_FOLDER\fR
+The path to the preferences directory.
+.TP
+\fBPRINT_MON_FOLDER\fR
+The path to the print monitor directory.
+.TP
+\fBSHARED_TRASH_FOLDER\fR
+The path to the network trash directory.
+.TP
+\fBTRASH_FOLDER\fR
+The path to the trash directory.
+.TP
+\fBSTART_UP_FOLDER\fR
+The path to the start up directory.
+.TP
+\fBPWD\fR
+The path to the application's default directory.
+.PP
+You can also create your own environment variables for the Macintosh.
+A file named \fITcl Environment Variables\fR may be placed in the
+preferences folder in the Mac system folder. Each line of this file
+should be of the form \fIVAR_NAME=var_data\fR.
+.PP
+The last alternative is to place environment variables in a 'STR#'
+resource named \fITcl Environment Variables\fR of the application. This
+is considered a little more ``Mac like'' than a Unix style Environment
+Variable file. Each entry in the 'STR#' resource has the same format
+as above. The source code file \fItclMacEnv.c\fR contains the
+implementation of the env mechanisms. This file contains many
+#define's that allow customization of the env mechanisms to fit your
+applications needs.
+.RE
.TP
\fBerrorCode\fR
After an error has occurred, this variable will be set to hold
@@ -213,15 +271,21 @@ general operating environment of the machine.
.TP
\fBtcl_precision\fR
.VS
-In Tcl versions before 8.0, this variable controlled the
-number of significant digits to include when converting floating-point
-values to strings.
-If the variable was not set then 6 digits were included.
+This variable controls the number of digits to generate
+when converting floating-point values to strings. It defaults
+to 12.
17 digits is ``perfect'' for IEEE floating-point in that it allows
double-precision values to be converted to strings and back to
-binary with no loss of precision.
-As of Tcl 8.0 this variable is ignored and all conversions use the
-full 17 digits.
+binary with no loss of information. However, using 17 digits prevents
+any rounding, which produces longer, less intuitive results. For example,
+\fBexpr 1.4\fR returns 1.3999999999999999 with \fBtcl_precision\fR
+set to 17, vs. 1.4 if \fBtcl_precision\fR is 12.
+.RS
+All interpreters in a process share a single \fBtcl_precision\fR value:
+changing it in one interpreter will affect all other interpreters as
+well. However, safe interpreters are not allowed to modify the
+variable.
+.RE
.VE
.TP
\fBtcl_rcFileName\fR
diff --git a/contrib/tcl/doc/uplevel.n b/contrib/tcl/doc/uplevel.n
index 574900e..0332ca1 100644
--- a/contrib/tcl/doc/uplevel.n
+++ b/contrib/tcl/doc/uplevel.n
@@ -1,11 +1,11 @@
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
-'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 1994-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.
'\"
-'\" SCCS: @(#) uplevel.n 1.7 96/03/25 20:26:46
+'\" SCCS: @(#) uplevel.n 1.8 97/08/13 13:41:36
'\"
.so man.macros
.TH uplevel n "" Tcl "Tcl Built-In Commands"
@@ -61,6 +61,20 @@ be used to obtain the level of the current procedure.
\fBUplevel\fR makes it possible to implement new control
constructs as Tcl procedures (for example, \fBuplevel\fR could
be used to implement the \fBwhile\fR construct as a Tcl procedure).
+.PP
+\fBnamespace eval\fR is another way (besides procedure calls)
+that the Tcl naming context can change.
+It adds a call frame to the stack to represent the namespace context.
+This means each \fBnamespace eval\fR command
+counts as another call level for \fBuplevel\fR and \fBupvar\fR commands.
+For example, \fBinfo level 1\fR will return a list
+describing a command that is either
+the outermost procedure call or the outermost \fBnamespace eval\fR command.
+Also, \fBuplevel #0\fR evaluates a script
+at top-level in the outermost namespace (the global namespace).
+
+.SH "SEE ALSO"
+namespace(n)
.SH KEYWORDS
-context, stack frame, variables
+context, level, namespace, stack frame, variables
diff --git a/contrib/tcl/doc/upvar.n b/contrib/tcl/doc/upvar.n
index e6e47ce..1920d37 100644
--- a/contrib/tcl/doc/upvar.n
+++ b/contrib/tcl/doc/upvar.n
@@ -1,11 +1,11 @@
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
-'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 1994-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.
'\"
-'\" SCCS: @(#) upvar.n 1.15 96/08/26 13:00:19
+'\" SCCS: @(#) upvar.n 1.16 97/08/13 13:43:34
'\"
.so man.macros
.TH upvar n "" Tcl "Tcl Built-In Commands"
@@ -57,6 +57,17 @@ Although \fBadd2\fR could have been implemented using \fBuplevel\fR
instead of \fBupvar\fR, \fBupvar\fR makes it simpler for \fBadd2\fR
to access the variable in the caller's procedure frame.
.PP
+\fBnamespace eval\fR is another way (besides procedure calls)
+that the Tcl naming context can change.
+It adds a call frame to the stack to represent the namespace context.
+This means each \fBnamespace eval\fR command
+counts as another call level for \fBuplevel\fR and \fBupvar\fR commands.
+For example, \fBinfo level 1\fR will return a list
+describing a command that is either
+the outermost procedure call or the outermost \fBnamespace eval\fR command.
+Also, \fBuplevel #0\fR evaluates a script
+at top-level in the outermost namespace (the global namespace).
+.PP
.VS
If an upvar variable is unset (e.g. \fBx\fR in \fBadd2\fR above), the
\fBunset\fR operation affects the variable it is linked to, not the
@@ -74,5 +85,8 @@ invoked). In particular, if the array is \fBenv\fR, then changes
made to \fImyVar\fR will not be passed to subprocesses correctly.
.VE
+.SH "SEE ALSO"
+namespace(n)
+
.SH KEYWORDS
-context, frame, global, level, procedure, variable
+context, frame, global, level, namespace, procedure, variable
diff --git a/contrib/tcl/doc/variable.n b/contrib/tcl/doc/variable.n
index 1475d47..186e40f 100644
--- a/contrib/tcl/doc/variable.n
+++ b/contrib/tcl/doc/variable.n
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) variable.n 1.2 97/05/18 15:20:28
+'\" SCCS: @(#) variable.n 1.4 97/08/13 16:57:57
'\"
.so man.macros
.TH variable n 8.0 Tcl "Tcl Built-In Commands"
@@ -25,9 +25,13 @@ within a namespace.
Each variable \fIname\fR is initialized with \fIvalue\fR.
The \fIvalue\fR for the last variable is optional.
.PP
-If a variable \fIname\fR does not exist,
-it is created and given the optional \fIvalue\fR.
-If it already exists, it is simply set to the optional \fIvalue\fR.
+If a variable \fIname\fR does not exist, it is created.
+In this case, if \fIvalue\fR is specified,
+it is assigned to the newly created variable.
+If no \fIvalue\fR is specified, the new variable is left undefined.
+If the variable already exists,
+it is set to \fIvalue\fR if \fIvalue\fR is specified
+or left unchanged if no \fIvalue\fR is given.
Normally, \fIname\fR is unqualified
(does not include the names of any containing namespaces),
and the variable is created in the current namespace.
@@ -51,14 +55,6 @@ and the initialization \fIvalue\fR should be left off.
After the variable has been declared,
elements within the array can be set using ordinary
\fBset\fR or \fBarray\fR commands.
-.PP
-It is generally best to provide a \fIvalue\fR to initialize each variable,
-or to initialize it immediately after the \fBvariable\fR command.
-This is because a namespace variable declared by a \fBvariable\fR command
-is not actually created until it is given a value.
-A declared but not yet initialized namespace variable
-will not appear in the output of an \fBinfo vars\fR command,
-for example.
.SH "SEE ALSO"
global(n), namespace(n)
diff --git a/contrib/tcl/generic/tcl.h b/contrib/tcl/generic/tcl.h
index 22331af..2d773da 100644
--- a/contrib/tcl/generic/tcl.h
+++ b/contrib/tcl/generic/tcl.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tcl.h 1.318 97/06/26 13:43:02
+ * SCCS: @(#) tcl.h 1.324 97/08/07 10:26:49
*/
#ifndef _TCL
@@ -37,11 +37,11 @@
#define TCL_MAJOR_VERSION 8
#define TCL_MINOR_VERSION 0
-#define TCL_RELEASE_LEVEL 1
-#define TCL_RELEASE_SERIAL 2
+#define TCL_RELEASE_LEVEL 2
+#define TCL_RELEASE_SERIAL 0
#define TCL_VERSION "8.0"
-#define TCL_PATCH_LEVEL "8.0b2"
+#define TCL_PATCH_LEVEL "8.0"
/*
* The following definitions set up the proper options for Windows
@@ -410,12 +410,25 @@ typedef struct Tcl_Obj {
* expression that is expensive to compute or has side effects.
*/
-#define Tcl_IncrRefCount(objPtr) \
- ++(objPtr)->refCount
-#define Tcl_DecrRefCount(objPtr) \
- if (--(objPtr)->refCount <= 0) TclFreeObj(objPtr)
-#define Tcl_IsShared(objPtr) \
- ((objPtr)->refCount > 1)
+EXTERN void Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
+EXTERN void Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
+EXTERN int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr));
+
+#ifdef TCL_MEM_DEBUG
+# define Tcl_IncrRefCount(objPtr) \
+ Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__)
+# define Tcl_DecrRefCount(objPtr) \
+ Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)
+# define Tcl_IsShared(objPtr) \
+ Tcl_DbIsShared(objPtr, __FILE__, __LINE__)
+#else
+# define Tcl_IncrRefCount(objPtr) \
+ ++(objPtr)->refCount
+# define Tcl_DecrRefCount(objPtr) \
+ if (--(objPtr)->refCount <= 0) TclFreeObj(objPtr)
+# define Tcl_IsShared(objPtr) \
+ ((objPtr)->refCount > 1)
+#endif
/*
* Macros and definitions that help to debug the use of Tcl objects.
@@ -511,17 +524,18 @@ typedef struct Tcl_CallFrame {
} Tcl_CallFrame;
/*
- * Information about commands that is returned by Tcl_GetCmdInfo and passed
- * to Tcl_SetCmdInfo. objProc is an objc/objv object-based command procedure
- * while proc is a traditional Tcl argc/argv string-based procedure.
- * Tcl_CreateObjCommand and Tcl_CreateCommand ensure that both objProc and
- * proc are non-NULL and can be called to execute the command. However,
- * it may be faster to call one instead of the other. The member
- * isNativeObjectProc is set to 1 if an object-based procedure was
- * registered by Tcl_CreateObjCommand, and to 0 if a string-based procedure
- * was registered by Tcl_CreateCommand. The other procedure is typically set
- * to a compatibility wrapper that does string-to-object or object-to-string
- * argument conversions then calls the other procedure.
+ * Information about commands that is returned by Tcl_GetCommandInfo and
+ * passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based
+ * command procedure while proc is a traditional Tcl argc/argv
+ * string-based procedure. Tcl_CreateObjCommand and Tcl_CreateCommand
+ * ensure that both objProc and proc are non-NULL and can be called to
+ * execute the command. However, it may be faster to call one instead of
+ * the other. The member isNativeObjectProc is set to 1 if an
+ * object-based procedure was registered by Tcl_CreateObjCommand, and to
+ * 0 if a string-based procedure was registered by Tcl_CreateCommand.
+ * The other procedure is typically set to a compatibility wrapper that
+ * does string-to-object or object-to-string argument conversions then
+ * calls the other procedure.
*/
typedef struct Tcl_CmdInfo {
@@ -985,7 +999,7 @@ EXTERN int Tcl_AsyncInvoke _ANSI_ARGS_((Tcl_Interp *interp,
EXTERN void Tcl_AsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async));
EXTERN int Tcl_AsyncReady _ANSI_ARGS_((void));
EXTERN void Tcl_BackgroundError _ANSI_ARGS_((Tcl_Interp *interp));
-EXTERN char Tcl_Backslash _ANSI_ARGS_((char *src,
+EXTERN char Tcl_Backslash _ANSI_ARGS_((CONST char *src,
int *readPtr));
EXTERN int Tcl_BadChannelOption _ANSI_ARGS_((Tcl_Interp *interp,
char *optionName, char *optionList));
@@ -1003,9 +1017,9 @@ EXTERN int Tcl_CommandComplete _ANSI_ARGS_((char *cmd));
EXTERN char * Tcl_Concat _ANSI_ARGS_((int argc, char **argv));
EXTERN Tcl_Obj * Tcl_ConcatObj _ANSI_ARGS_((int objc,
Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_ConvertCountedElement _ANSI_ARGS_((char *src,
+EXTERN int Tcl_ConvertCountedElement _ANSI_ARGS_((CONST char *src,
int length, char *dst, int flags));
-EXTERN int Tcl_ConvertElement _ANSI_ARGS_((char *src,
+EXTERN int Tcl_ConvertElement _ANSI_ARGS_((CONST char *src,
char *dst, int flags));
EXTERN int Tcl_ConvertToType _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_ObjType *typePtr));
@@ -1059,6 +1073,12 @@ EXTERN int Tcl_DbCkfree _ANSI_ARGS_((char *ptr,
char *file, int line));
EXTERN char * Tcl_DbCkrealloc _ANSI_ARGS_((char *ptr,
unsigned int size, char *file, int line));
+EXTERN void Tcl_DbDecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr,
+ char *file, int line));
+EXTERN void Tcl_DbIncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr,
+ char *file, int line));
+EXTERN int Tcl_DbIsShared _ANSI_ARGS_((Tcl_Obj *objPtr,
+ char *file, int line));
EXTERN Tcl_Obj * Tcl_DbNewBooleanObj _ANSI_ARGS_((int boolValue,
char *file, int line));
EXTERN Tcl_Obj * Tcl_DbNewDoubleObj _ANSI_ARGS_((double doubleValue,
@@ -1109,9 +1129,9 @@ EXTERN int Tcl_DoOneEvent _ANSI_ARGS_((int flags));
EXTERN void Tcl_DoWhenIdle _ANSI_ARGS_((Tcl_IdleProc *proc,
ClientData clientData));
EXTERN char * Tcl_DStringAppend _ANSI_ARGS_((Tcl_DString *dsPtr,
- char *string, int length));
+ CONST char *string, int length));
EXTERN char * Tcl_DStringAppendElement _ANSI_ARGS_((
- Tcl_DString *dsPtr, char *string));
+ Tcl_DString *dsPtr, CONST char *string));
EXTERN void Tcl_DStringEndSublist _ANSI_ARGS_((Tcl_DString *dsPtr));
EXTERN void Tcl_DStringFree _ANSI_ARGS_((Tcl_DString *dsPtr));
EXTERN void Tcl_DStringGetResult _ANSI_ARGS_((Tcl_Interp *interp,
@@ -1137,7 +1157,7 @@ EXTERN int Tcl_EvalObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
EXTERN void Tcl_Exit _ANSI_ARGS_((int status));
EXTERN int Tcl_ExposeCommand _ANSI_ARGS_((Tcl_Interp *interp,
- char *hiddenCmdName, char *cmdName));
+ char *hiddenCmdToken, char *cmdName));
EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp *interp,
char *string, int *ptr));
EXTERN int Tcl_ExprBooleanObj _ANSI_ARGS_((Tcl_Interp *interp,
@@ -1245,7 +1265,7 @@ EXTERN int Tcl_GlobalEvalObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
EXTERN char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable *tablePtr));
EXTERN int Tcl_HideCommand _ANSI_ARGS_((Tcl_Interp *interp,
- char *cmdName, char *hiddenCmdName));
+ char *cmdName, char *hiddenCmdToken));
EXTERN int Tcl_Init _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN void Tcl_InitHashTable _ANSI_ARGS_((Tcl_HashTable *tablePtr,
int keyType));
@@ -1326,6 +1346,8 @@ EXTERN int Tcl_Read _ANSI_ARGS_((Tcl_Channel chan,
EXTERN void Tcl_ReapDetachedProcs _ANSI_ARGS_((void));
EXTERN int Tcl_RecordAndEval _ANSI_ARGS_((Tcl_Interp *interp,
char *cmd, int flags));
+EXTERN int Tcl_RecordAndEvalObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *cmdPtr, int flags));
EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp *interp,
char *string));
EXTERN int Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp *interp,
@@ -1342,9 +1364,9 @@ EXTERN void Tcl_Release _ANSI_ARGS_((ClientData clientData));
EXTERN void Tcl_RestartIdleTimer _ANSI_ARGS_((void));
EXTERN void Tcl_ResetResult _ANSI_ARGS_((Tcl_Interp *interp));
#define Tcl_Return Tcl_SetResult
-EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_((char *string,
+EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_((CONST char *string,
int length, int *flagPtr));
-EXTERN int Tcl_ScanElement _ANSI_ARGS_((char *string,
+EXTERN int Tcl_ScanElement _ANSI_ARGS_((CONST char *string,
int *flagPtr));
EXTERN int Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan,
int offset, int mode));
diff --git a/contrib/tcl/generic/tclAlloc.c b/contrib/tcl/generic/tclAlloc.c
new file mode 100644
index 0000000..cf07036
--- /dev/null
+++ b/contrib/tcl/generic/tclAlloc.c
@@ -0,0 +1,456 @@
+/*
+ * tclAlloc.c --
+ *
+ * This is a very fast storage allocator. It allocates blocks of a
+ * small number of different sizes, and keeps free lists of each size.
+ * Blocks that don't exactly fit are passed up to the next larger size.
+ * Blocks over a certain size are directly allocated from the system.
+ *
+ * Copyright (c) 1983 Regents of the University of California.
+ * Copyright (c) 1996-1997 Sun Microsystems, Inc.
+ *
+ * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclAlloc.c 1.4 97/08/11 18:45:38
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+
+#ifdef TCL_DEBUG
+# define DEBUG
+/* #define MSTATS */
+# define RCHECK
+#endif
+
+typedef unsigned long caddr_t;
+
+/*
+ * The overhead on a block is at least 4 bytes. When free, this space
+ * contains a pointer to the next free block, and the bottom two bits must
+ * be zero. When in use, the first byte is set to MAGIC, and the second
+ * byte is the size index. The remaining bytes are for alignment.
+ * If range checking is enabled then a second word holds the size of the
+ * requested block, less 1, rounded up to a multiple of sizeof(RMAGIC).
+ * The order of elements is critical: ov_magic must overlay the low order
+ * bits of ov_next, and ov_magic can not be a valid ov_next bit pattern.
+ */
+
+union overhead {
+ union overhead *ov_next; /* when free */
+ struct {
+ unsigned char ovu_magic0; /* magic number */
+ unsigned char ovu_index; /* bucket # */
+ unsigned char ovu_unused; /* unused */
+ unsigned char ovu_magic1; /* other magic number */
+#ifdef RCHECK
+ unsigned short ovu_rmagic; /* range magic number */
+ unsigned long ovu_size; /* actual block size */
+#endif
+ } ovu;
+#define ov_magic0 ovu.ovu_magic0
+#define ov_magic1 ovu.ovu_magic1
+#define ov_index ovu.ovu_index
+#define ov_rmagic ovu.ovu_rmagic
+#define ov_size ovu.ovu_size
+};
+
+
+#define MAGIC 0xef /* magic # on accounting info */
+#define RMAGIC 0x5555 /* magic # on range info */
+
+#ifdef RCHECK
+#define RSLOP sizeof (unsigned short)
+#else
+#define RSLOP 0
+#endif
+
+#define OVERHEAD (sizeof(union overhead) + RSLOP)
+
+/*
+ * nextf[i] is the pointer to the next free block of size 2^(i+3). The
+ * smallest allocatable block is 8 bytes. The overhead information
+ * precedes the data area returned to the user.
+ */
+
+#define NBUCKETS 13
+#define MAXMALLOC (1<<(NBUCKETS+2))
+static union overhead *nextf[NBUCKETS];
+
+#ifdef MSTATS
+
+/*
+ * nmalloc[i] is the difference between the number of mallocs and frees
+ * for a given block size.
+ */
+
+static unsigned int nmalloc[NBUCKETS+1];
+#include <stdio.h>
+#endif
+
+#if defined(DEBUG) || defined(RCHECK)
+#define ASSERT(p) if (!(p)) panic(# p)
+#define RANGE_ASSERT(p) if (!(p)) panic(# p)
+#else
+#define ASSERT(p)
+#define RANGE_ASSERT(p)
+#endif
+
+/*
+ * Prototypes for functions used only in this file.
+ */
+
+static void MoreCore _ANSI_ARGS_((int bucket));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpAlloc --
+ *
+ * Allocate more memory.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TclpAlloc(
+ unsigned int nbytes) /* Number of bytes to allocate. */
+{
+ register union overhead *op;
+ register long bucket;
+ register unsigned amt;
+
+ /*
+ * First the simple case: we simple allocate big blocks directly
+ */
+ if (nbytes + OVERHEAD >= MAXMALLOC) {
+ op = (union overhead *)TclpSysAlloc(nbytes+OVERHEAD, 0);
+ if (op == NULL) {
+ return NULL;
+ }
+ op->ov_magic0 = op->ov_magic1 = MAGIC;
+ op->ov_index = 0xff;
+#ifdef MSTATS
+ nmalloc[NBUCKETS]++;
+#endif
+#ifdef RCHECK
+ /*
+ * Record allocated size of block and
+ * bound space with magic numbers.
+ */
+ op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1);
+ op->ov_rmagic = RMAGIC;
+ *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
+#endif
+ return (void *)(op+1);
+ }
+ /*
+ * Convert amount of memory requested into closest block size
+ * stored in hash buckets which satisfies request.
+ * Account for space used per block for accounting.
+ */
+#ifndef RCHECK
+ amt = 8; /* size of first bucket */
+ bucket = 0;
+#else
+ amt = 16; /* size of first bucket */
+ bucket = 1;
+#endif
+ while (nbytes + OVERHEAD > amt) {
+ amt <<= 1;
+ if (amt == 0) {
+ return (NULL);
+ }
+ bucket++;
+ }
+ ASSERT( bucket < NBUCKETS );
+
+ /*
+ * If nothing in hash bucket right now,
+ * request more memory from the system.
+ */
+ if ((op = nextf[bucket]) == NULL) {
+ MoreCore(bucket);
+ if ((op = nextf[bucket]) == NULL) {
+ return (NULL);
+ }
+ }
+ /*
+ * Remove from linked list
+ */
+ nextf[bucket] = op->ov_next;
+ op->ov_magic0 = op->ov_magic1 = MAGIC;
+ op->ov_index = (unsigned char) bucket;
+#ifdef MSTATS
+ nmalloc[bucket]++;
+#endif
+#ifdef RCHECK
+ /*
+ * Record allocated size of block and
+ * bound space with magic numbers.
+ */
+ op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1);
+ op->ov_rmagic = RMAGIC;
+ *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
+#endif
+ return ((char *)(op + 1));
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MoreCore --
+ *
+ * Allocate more memory to the indicated bucket.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Attempts to get more memory from the system.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+MoreCore(
+ int bucket) /* What bucket to allocat to. */
+{
+ register union overhead *op;
+ register long sz; /* size of desired block */
+ long amt; /* amount to allocate */
+ int nblks; /* how many blocks we get */
+
+ /*
+ * sbrk_size <= 0 only for big, FLUFFY, requests (about
+ * 2^30 bytes on a VAX, I think) or for a negative arg.
+ */
+ sz = 1 << (bucket + 3);
+ ASSERT(sz > 0);
+
+ amt = MAXMALLOC;
+ nblks = amt / sz;
+ ASSERT(nblks*sz == amt);
+
+ op = (union overhead *)TclpSysAlloc(amt, 1);
+ /* no more room! */
+ if (op == NULL) {
+ return;
+ }
+
+ /*
+ * Add new memory allocated to that on
+ * free list for this hash bucket.
+ */
+ nextf[bucket] = op;
+ while (--nblks > 0) {
+ op->ov_next = (union overhead *)((caddr_t)op + sz);
+ op = (union overhead *)((caddr_t)op + sz);
+ }
+ op->ov_next = (union overhead *)NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFree --
+ *
+ * Free memory.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpFree(
+ char *cp) /* Pointer to memory to free. */
+{
+ register long size;
+ register union overhead *op;
+
+ if (cp == NULL) {
+ return;
+ }
+
+ op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
+
+ ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */
+ ASSERT(op->ov_magic1 == MAGIC);
+ if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) {
+ return;
+ }
+
+ RANGE_ASSERT(op->ov_rmagic == RMAGIC);
+ RANGE_ASSERT(*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) == RMAGIC);
+ size = op->ov_index;
+ if ( size == 0xff ) {
+#ifdef MSTATS
+ nmalloc[NBUCKETS]--;
+#endif
+ TclpSysFree(op);
+ return;
+ }
+ ASSERT(size < NBUCKETS);
+ op->ov_next = nextf[size]; /* also clobbers ov_magic */
+ nextf[size] = op;
+#ifdef MSTATS
+ nmalloc[size]--;
+#endif
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpRealloc --
+ *
+ * Reallocate memory.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TclpRealloc(
+ char *cp, /* Pointer to alloced block. */
+ unsigned int nbytes) /* New size of memory. */
+{
+ int i;
+ union overhead *op;
+ int expensive;
+ unsigned long maxsize;
+
+ if (cp == NULL) {
+ return (TclpAlloc(nbytes));
+ }
+
+ op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
+
+ ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */
+ ASSERT(op->ov_magic1 == MAGIC);
+ if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) {
+ return NULL;
+ }
+
+ RANGE_ASSERT(op->ov_rmagic == RMAGIC);
+ RANGE_ASSERT(*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) == RMAGIC);
+ i = op->ov_index;
+
+ /*
+ * If the block isn't in a bin, just realloc it.
+ */
+
+ if (i == 0xff) {
+ op = (union overhead *) TclpSysRealloc(op, nbytes+OVERHEAD);
+ if (op == NULL) {
+ return NULL;
+ }
+#ifdef MSTATS
+ nmalloc[NBUCKETS]++;
+#endif
+#ifdef RCHECK
+ /*
+ * Record allocated size of block and update magic number bounds.
+ */
+
+ op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1);
+ *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
+#endif
+ return (char *)(op+1);
+ }
+ maxsize = 1 << (i+3);
+ expensive = 0;
+ if ( nbytes + OVERHEAD > maxsize ) {
+ expensive = 1;
+ } else if ( i > 0 && nbytes + OVERHEAD < (maxsize/2) ) {
+ expensive = 1;
+ }
+
+ if (expensive) {
+ void *newp;
+
+ newp = TclpAlloc(nbytes);
+ if ( newp == NULL ) {
+ return NULL;
+ }
+ maxsize -= OVERHEAD;
+ if ( maxsize < nbytes )
+ nbytes = maxsize;
+ memcpy((VOID *) newp, (VOID *) cp, (size_t) nbytes);
+ TclpFree(cp);
+ return newp;
+ }
+
+ /*
+ * Ok, we don't have to copy, it fits as-is
+ */
+#ifdef RCHECK
+ op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1);
+ *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
+#endif
+ return(cp);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * mstats --
+ *
+ * Prints two lines of numbers, one showing the length of the
+ * free list for each size category, the second showing the
+ * number of mallocs - frees for each size category.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef MSTATS
+void
+mstats(
+ char *s) /* Where to write info. */
+{
+ register int i, j;
+ register union overhead *p;
+ int totfree = 0,
+ totused = 0;
+
+ fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s);
+ for (i = 0; i < NBUCKETS; i++) {
+ for (j = 0, p = nextf[i]; p; p = p->ov_next, j++)
+ fprintf(stderr, " %d", j);
+ totfree += j * (1 << (i + 3));
+ }
+ fprintf(stderr, "\nused:\t");
+ for (i = 0; i < NBUCKETS; i++) {
+ fprintf(stderr, " %d", nmalloc[i]);
+ totused += nmalloc[i] * (1 << (i + 3));
+ }
+ fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n",
+ totused, totfree);
+ fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n",
+ MAXMALLOC, nmalloc[NBUCKETS]);
+}
+#endif
diff --git a/contrib/tcl/generic/tclBasic.c b/contrib/tcl/generic/tclBasic.c
index c043dd4..952292f 100644
--- a/contrib/tcl/generic/tclBasic.c
+++ b/contrib/tcl/generic/tclBasic.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclBasic.c 1.280 97/05/20 19:09:26
+ * SCCS: @(#) tclBasic.c 1.305 97/08/13 10:34:43
*/
#include "tclInt.h"
@@ -89,12 +89,10 @@ static CmdInfo builtInCmds[] = {
TclCompileForCmd, 1},
{"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd,
TclCompileForeachCmd, 1},
- {"format", Tcl_FormatCmd, (Tcl_ObjCmdProc *) NULL,
+ {"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd,
(CompileProc *) NULL, 1},
{"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd,
(CompileProc *) NULL, 1},
- {"history", Tcl_HistoryCmd, (Tcl_ObjCmdProc *) NULL,
- (CompileProc *) NULL, 1},
{"if", Tcl_IfCmd, (Tcl_ObjCmdProc *) NULL,
TclCompileIfCmd, 1},
{"incr", Tcl_IncrCmd, (Tcl_ObjCmdProc *) NULL,
@@ -143,7 +141,7 @@ static CmdInfo builtInCmds[] = {
(CompileProc *) NULL, 1},
{"set", Tcl_SetCmd, (Tcl_ObjCmdProc *) NULL,
TclCompileSetCmd, 1},
- {"split", Tcl_SplitCmd, (Tcl_ObjCmdProc *) NULL,
+ {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd,
(CompileProc *) NULL, 1},
{"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd,
(CompileProc *) NULL, 1},
@@ -169,15 +167,15 @@ static CmdInfo builtInCmds[] = {
*/
#ifndef TCL_GENERIC_ONLY
- {"after", Tcl_AfterCmd, (Tcl_ObjCmdProc *) NULL,
+ {"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd,
(CompileProc *) NULL, 1},
- {"cd", Tcl_CdCmd, (Tcl_ObjCmdProc *) NULL,
+ {"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd,
(CompileProc *) NULL, 0},
- {"close", Tcl_CloseCmd, (Tcl_ObjCmdProc *) NULL,
+ {"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd,
(CompileProc *) NULL, 1},
- {"eof", Tcl_EofCmd, (Tcl_ObjCmdProc *) NULL,
+ {"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd,
(CompileProc *) NULL, 1},
- {"fblocked", Tcl_FblockedCmd, (Tcl_ObjCmdProc *) NULL,
+ {"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd,
(CompileProc *) NULL, 1},
{"fconfigure", Tcl_FconfigureCmd, (Tcl_ObjCmdProc *) NULL,
(CompileProc *) NULL, 0},
@@ -210,7 +208,7 @@ static CmdInfo builtInCmds[] = {
{"update", Tcl_UpdateCmd, (Tcl_ObjCmdProc *) NULL,
(CompileProc *) NULL, 1},
{"vwait", Tcl_VwaitCmd, (Tcl_ObjCmdProc *) NULL,
- (CompileProc *) NULL, 0},
+ (CompileProc *) NULL, 1},
#ifdef MAC_TCL
{"beep", (Tcl_CmdProc *) NULL, Tcl_BeepObjCmd,
@@ -272,6 +270,7 @@ Tcl_CreateInterp()
*/
if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) {
+ /*NOTREACHED*/
panic("Tcl_CallFrame and CallFrame are not the same size");
}
@@ -298,14 +297,6 @@ Tcl_CreateInterp()
iPtr->returnCode = TCL_OK;
iPtr->errorInfo = NULL;
iPtr->errorCode = NULL;
- iPtr->numEvents = 0;
- iPtr->events = NULL;
- iPtr->curEvent = 0;
- iPtr->curEventNum = 0;
- iPtr->revPtr = NULL;
- iPtr->historyFirst = NULL;
- iPtr->revDisables = 1;
- iPtr->evalFirst = iPtr->evalLast = NULL;
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
iPtr->appendUsed = 0;
@@ -399,18 +390,45 @@ Tcl_CreateInterp()
}
}
+ /*
+ * Initialize/Create "errorInfo" and "errorCode" global vars
+ * (because some part of the C code assume they exists
+ * and we can get a seg fault otherwise (in multiple
+ * interps loading of extensions for instance) --dl)
+ */
+ /*
+ * We can't assume that because we initialize
+ * the variables here, they won't be unset later.
+ * so we had 2 choices:
+ * + Check every place where a GetVar of those is used
+ * and the NULL result is not checked (like in tclLoad.c)
+ * + Make SetVar,... NULL friendly
+ * We choosed the second option because :
+ * + It is easy and low cost to check for NULL pointer before
+ * calling strlen()
+ * + It can be helpfull to other people using those API
+ * + Passing a NULL value to those closest 'meaning' is empty string
+ * (specially with the new objects where 0 bytes strings are ok)
+ * So the following init is commented out: -- dl
+ */
+ /*
+ (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, "",
+ TCL_GLOBAL_ONLY);
+ (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, "NONE",
+ TCL_GLOBAL_ONLY);
+ */
+
#ifndef TCL_GENERIC_ONLY
TclSetupEnv((Tcl_Interp *) iPtr);
#endif
/*
- * Do Safe-Tcl init stuff
+ * Do Multiple/Safe Interps Tcl init stuff
*/
-
(void) TclInterpInit((Tcl_Interp *)iPtr);
/*
- * Set up variables such as tcl_library and tcl_precision.
+ * Set up variables such as tcl_version.
*/
TclPlatformInit((Tcl_Interp *)iPtr);
@@ -418,6 +436,9 @@ Tcl_CreateInterp()
TCL_GLOBAL_ONLY);
Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION,
TCL_GLOBAL_ONLY);
+ Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL,
+ TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ TclPrecTraceProc, (ClientData) NULL);
/*
* Compute the byte order of this machine.
@@ -425,7 +446,7 @@ Tcl_CreateInterp()
order.s = 1;
Tcl_SetVar2((Tcl_Interp *) iPtr, "tcl_platform", "byteOrder",
- (order.c[0] == 1) ? "litteEndian" : "bigEndian",
+ (order.c[0] == 1) ? "littleEndian" : "bigEndian",
TCL_GLOBAL_ONLY);
/*
@@ -818,20 +839,6 @@ DeleteInterpProc(interp)
ckfree(iPtr->errorCode);
iPtr->errorCode = NULL;
}
- if (iPtr->events != NULL) {
- for (i = 0; i < iPtr->numEvents; i++) {
- ckfree(iPtr->events[i].command);
- }
- ckfree((char *) iPtr->events);
- iPtr->events = NULL;
- }
- while (iPtr->revPtr != NULL) {
- HistoryRev *nextPtr = iPtr->revPtr->nextPtr;
-
- ckfree(iPtr->revPtr->newBytes);
- ckfree((char *) iPtr->revPtr);
- iPtr->revPtr = nextPtr;
- }
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
iPtr->appendResult = NULL;
@@ -964,10 +971,6 @@ HiddenCmdsDeleteProc(clientData, interp)
Command *cmdPtr;
hiddenCmdTblPtr = (Tcl_HashTable *) clientData;
- hPtr = Tcl_FindHashEntry(hiddenCmdTblPtr, "tkerror");
- if (hPtr != NULL) {
- Tcl_DeleteHashEntry(hPtr);
- }
for (hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch)) {
@@ -1023,7 +1026,18 @@ HiddenCmdsDeleteProc(clientData, interp)
if (cmdPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(cmdPtr->hPtr);
}
- ckfree((char *) cmdPtr);
+
+ /*
+ * Now free the Command structure, unless there is another reference
+ * to it from a CmdName Tcl object in some ByteCode code
+ * sequence. In that case, delay the cleanup until all references
+ * are either discarded (when a ByteCode is freed) or replaced by a
+ * new reference (when a cached CmdName Command reference is found
+ * to be invalid and TclExecuteByteCode looks up the command in the
+ * command hashtable).
+ */
+
+ TclCleanupCommand(cmdPtr);
}
Tcl_DeleteHashTable(hiddenCmdTblPtr);
ckfree((char *) hiddenCmdTblPtr);
@@ -1042,24 +1056,24 @@ HiddenCmdsDeleteProc(clientData, interp)
* if an error occurs.
*
* Side effects:
- * Moves a command from the command table to the hidden command
- * table.
+ * Removes a command from the command table and create an entry
+ * into the hidden command table under the specified token name.
*
*----------------------------------------------------------------------
*/
int
-Tcl_HideCommand(interp, cmdName, hiddenCmdName)
+Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
Tcl_Interp *interp; /* Interpreter in which to hide command. */
- char *cmdName; /* Name of hidden command. */
- char *hiddenCmdName; /* Name of to-be-hidden command. */
+ char *cmdName; /* Name of command to hide. */
+ char *hiddenCmdToken; /* Token name of the to-be-hidden command. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Command cmd;
Command *cmdPtr;
Tcl_HashTable *hTblPtr;
- Tcl_HashEntry *hPtr, *tkErrorHPtr;
- int isBgerror, new;
+ Tcl_HashEntry *hPtr;
+ int new;
if (iPtr->flags & DELETED) {
@@ -1071,38 +1085,57 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdName)
return TCL_ERROR;
}
- if (strstr(hiddenCmdName, "::") != NULL) {
+ /*
+ * Disallow hiding of commands that are currently in a namespace or
+ * renaming (as part of hiding) into a namespace.
+ *
+ * (because the current implementation with a single global table
+ * and the needed uniqueness of names cause problems with namespaces)
+ *
+ * we don't need to check for "::" in cmdName because the real check is
+ * on the nsPtr below.
+ *
+ * hiddenCmdToken is just a string which is not interpreted in any way.
+ * It may contain :: but the string is not interpreted as a namespace
+ * qualifier command name. Thus, hiding foo::bar to foo::bar and then
+ * trying to expose or invoke ::foo::bar will NOT work; but if the
+ * application always uses the same strings it will get consistent
+ * behaviour.
+ *
+ * But as we currently limit ourselves to the global namespace only
+ * for the source, in order to avoid potential confusion,
+ * lets prevent "::" in the token too. --dl
+ */
+
+ if (strstr(hiddenCmdToken, "::") != NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "hidden command names can't have namespace qualifiers",
- (char *) NULL);
+ "cannot use namespace qualifiers as hidden command",
+ "token (rename)", (char *) NULL);
return TCL_ERROR;
}
/*
* Find the command to hide. An error is returned if cmdName can't
- * be found.
+ * be found. Look up the command only from the global namespace.
+ * Full path of the command must be given if using namespaces.
*/
cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
- /*flags*/ TCL_LEAVE_ERR_MSG);
+ /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY);
if (cmd == (Tcl_Command) NULL) {
return TCL_ERROR;
}
cmdPtr = (Command *) cmd;
/*
- * If this command is the "bgerror" command in the global namespace,
- * make note of it now. We'll need to know this later so that we can
- * handle its "tkerror" twin below.
+ * Check that the command is really in global namespace
*/
-
- isBgerror = 0;
- if (cmdPtr->hPtr != NULL) {
- char *tail = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
- if ((*tail == 'b') && (strcmp(tail, "bgerror") == 0)
- && (cmdPtr->nsPtr == iPtr->globalNsPtr)) {
- isBgerror = 1;
- }
+
+ if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "can only hide global namespace commands",
+ " (use rename then hide)", (char *) NULL);
+ return TCL_ERROR;
}
/*
@@ -1121,19 +1154,26 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdName)
/*
* It is an error to move an exposed command to a hidden command with
- * hiddenCmdName if a hidden command with the name hiddenCmdName already
+ * hiddenCmdToken if a hidden command with the name hiddenCmdToken already
* exists.
*/
- hPtr = Tcl_CreateHashEntry(hTblPtr, hiddenCmdName, &new);
+ hPtr = Tcl_CreateHashEntry(hTblPtr, hiddenCmdToken, &new);
if (!new) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "hidden command named \"", hiddenCmdName, "\" already exists",
+ "hidden command named \"", hiddenCmdToken, "\" already exists",
(char *) NULL);
return TCL_ERROR;
}
/*
+ * Nb : This code is currently 'like' a rename to a specialy set apart
+ * name table. Changes here and in TclRenameCommand must
+ * be kept in synch untill the common parts are actually
+ * factorized out.
+ */
+
+ /*
* Remove the hash entry for the command from the interpreter command
* table. This is like deleting the command, so bump its command epoch;
* this invalidates any cached references that point to the command.
@@ -1146,28 +1186,8 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdName)
}
/*
- * If we are creating a hidden command named "bgerror", share the
- * command data structure with another command named "tkerror". This
- * code should eventually be removed.
- */
-
- if (isBgerror) {
- tkErrorHPtr = Tcl_CreateHashEntry(hTblPtr, "tkerror", &new);
- if (!new) {
- panic("Tcl_HideCommand: hiding bgerror while tkerror is already hidden!");
- }
- Tcl_SetHashValue(tkErrorHPtr, (ClientData) cmdPtr);
- tkErrorHPtr = Tcl_FindHashEntry(&(iPtr->globalNsPtr->cmdTable),
- "tkerror");
- if (tkErrorHPtr != (Tcl_HashEntry *) NULL) {
- Tcl_DeleteHashEntry(tkErrorHPtr);
- }
- }
-
- /*
- * Now link the hash table entry with the command structure. Keep the
- * containing namespace the same. After all, the command really
- * "belongs" to that namespace.
+ * Now link the hash table entry with the command structure.
+ * We ensured above that the nsPtr was right.
*/
cmdPtr->hPtr = hPtr;
@@ -1207,19 +1227,18 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdName)
*/
int
-Tcl_ExposeCommand(interp, hiddenCmdName, cmdName)
+Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
Tcl_Interp *interp; /* Interpreter in which to make command
* callable. */
- char *hiddenCmdName; /* Name of hidden command. */
+ char *hiddenCmdToken; /* Name of hidden command. */
char *cmdName; /* Name of to-be-exposed command. */
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr;
- Namespace *nsPtr, *dummy1, *dummy2;
- Tcl_HashEntry *hPtr, *tkErrorHPtr;
+ Namespace *nsPtr;
+ Tcl_HashEntry *hPtr;
Tcl_HashTable *hTblPtr;
- char *tail;
- int new, result;
+ int new;
if (iPtr->flags & DELETED) {
/*
@@ -1231,6 +1250,20 @@ Tcl_ExposeCommand(interp, hiddenCmdName, cmdName)
}
/*
+ * Check that we have a regular name for the command
+ * (that the user is not trying to do an expose and a rename
+ * (to another namespace) at the same time)
+ */
+
+ if (strstr(cmdName, "::") != NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "can not expose to a namespace ",
+ "(use expose to toplevel, then rename)",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
* Find the hash table for the hidden commands; error out if there
* is none.
*/
@@ -1239,7 +1272,7 @@ Tcl_ExposeCommand(interp, hiddenCmdName, cmdName)
NULL);
if (hTblPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "unknown hidden command \"", hiddenCmdName,
+ "unknown hidden command \"", hiddenCmdToken,
"\"", (char *) NULL);
return TCL_ERROR;
}
@@ -1248,45 +1281,42 @@ Tcl_ExposeCommand(interp, hiddenCmdName, cmdName)
* Get the command from the hidden command table:
*/
- hPtr = Tcl_FindHashEntry(hTblPtr, hiddenCmdName);
+ hPtr = Tcl_FindHashEntry(hTblPtr, hiddenCmdToken);
if (hPtr == (Tcl_HashEntry *) NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "unknown hidden command \"", hiddenCmdName,
+ "unknown hidden command \"", hiddenCmdToken,
"\"", (char *) NULL);
return TCL_ERROR;
}
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
+
/*
- * Normally, the command will go right back into its containing
- * namespace. But if the exposed command name has "::" namespace
- * qualifiers, it is being moved to another context.
+ * Check that we have a true global namespace
+ * command (enforced by Tcl_HideCommand() but let's double
+ * check. (If it was not, we would not really know how to
+ * handle it).
*/
-
- if (strstr(cmdName, "::") != NULL) {
- result = TclGetNamespaceForQualName(interp, cmdName,
- iPtr->globalNsPtr,
- (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
- &nsPtr, &dummy1, &dummy2, &tail);
- if (result != TCL_OK) {
- return result;
- }
- if ((nsPtr == NULL) || (tail == NULL)) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad command name \"", cmdName, "\"", (char *) NULL);
- return TCL_ERROR;
- }
- } else {
- nsPtr = cmdPtr->nsPtr;
- tail = cmdName;
+ if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
+ /*
+ * This case is theoritically impossible,
+ * we might rather panic() than 'nicely' erroring out ?
+ */
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "trying to expose a non global command name space command",
+ (char *) NULL);
+ return TCL_ERROR;
}
+
+ /* This is the global table */
+ nsPtr = cmdPtr->nsPtr;
/*
* It is an error to overwrite an existing exposed command as a result
* of exposing a previously hidden command.
*/
- hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
+ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new);
if (!new) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"exposed command \"", cmdName,
@@ -1305,35 +1335,22 @@ Tcl_ExposeCommand(interp, hiddenCmdName, cmdName)
}
/*
- * If we are creating a command named "bgerror", share the command
- * data structure with another command named "tkerror". This code
- * should eventually be removed.
- */
-
- if ((*tail == 'b') && (strcmp(tail, "bgerror") == 0)
- && (nsPtr == iPtr->globalNsPtr)) {
- tkErrorHPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
- "tkerror", &new);
- if (!new) {
- panic("Tcl_ExposeCommand: exposing bgerror while tkerror is already exposed!");
- }
- Tcl_SetHashValue(tkErrorHPtr, (ClientData) cmdPtr);
- tkErrorHPtr = Tcl_FindHashEntry(hTblPtr, "tkerror");
- if (tkErrorHPtr != NULL) {
- Tcl_DeleteHashEntry(tkErrorHPtr);
- }
- }
-
- /*
* Now link the hash table entry with the command structure.
* This is like creating a new command, so deal with any shadowing
* of commands in the global namespace.
*/
cmdPtr->hPtr = hPtr;
- cmdPtr->nsPtr = nsPtr;
+
Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
- TclResetShadowedCmdRefs(interp, cmdPtr);
+
+ /*
+ * Not needed as we are only in the global namespace
+ * (but would be needed again if we supported namespace command hiding)
+ *
+ * TclResetShadowedCmdRefs(interp, cmdPtr);
+ */
+
/*
* If the command being exposed has a compile procedure, increment
@@ -1421,18 +1438,6 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
tail = cmdName;
}
- /*
- * The code below was added in 11/95 to preserve backwards compatibility
- * when "tkerror" was renamed "bgerror": if anyone attempts to define
- * "tkerror" as a command, it is actually created as "bgerror". This
- * code should eventually be removed.
- */
-
- if ((*tail == 't') && (strcmp(tail, "tkerror") == 0)
- && (nsPtr == iPtr->globalNsPtr)) {
- tail = "bgerror";
- }
-
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
if (!new) {
/*
@@ -1469,23 +1474,6 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
cmdPtr->importRefPtr = NULL;
/*
- * The code below provides more backwards compatibility for the
- * renaming of "tkerror" to "bgerror". Like the code above, this
- * code should eventually become unnecessary.
- */
-
- if ((*tail == 'b') && (strcmp(tail, "bgerror") == 0)
- && (nsPtr == iPtr->globalNsPtr)) {
- /*
- * We're currently creating the "bgerror" command; create
- * a "tkerror" command that shares the same Command structure.
- */
-
- hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, "tkerror", &new);
- Tcl_SetHashValue(hPtr, cmdPtr);
- }
-
- /*
* We just created a command, so in its namespace and all of its parent
* namespaces, it may shadow global commands with the same name. If any
* shadowed commands are found, invalidate all cached command references
@@ -1574,18 +1562,6 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
tail = cmdName;
}
- /*
- * The code below was added in 11/95 to preserve backwards compatibility
- * when "tkerror" was renamed "bgerror": if anyone attempts to define
- * "tkerror" as a command, it is actually created as "bgerror". This
- * code should eventually be removed.
- */
-
- if ((*tail == 't') && (strcmp(tail, "tkerror") == 0)
- && (nsPtr == iPtr->globalNsPtr)) {
- tail = "bgerror";
- }
-
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
if (!new) {
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
@@ -1601,7 +1577,7 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
cmdPtr->objClientData = clientData;
cmdPtr->deleteProc = deleteProc;
cmdPtr->deleteData = clientData;
- goto checkForBgerror;
+ return (Tcl_Command) cmdPtr;
}
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
@@ -1632,23 +1608,6 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
cmdPtr->deleted = 0;
cmdPtr->importRefPtr = NULL;
- /*
- * The code below provides more backwards compatibility for the
- * renaming of "tkerror" to "bgerror". Like the code above, this
- * code should eventually become unnecessary.
- */
-
- checkForBgerror:
- if ((*tail == 'b') && (strcmp(tail, "bgerror") == 0)
- && (nsPtr == iPtr->globalNsPtr)) {
- /*
- * We're currently creating the "bgerror" command; create
- * a "tkerror" command that shares the same Command structure.
- */
-
- hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, "tkerror", &new);
- Tcl_SetHashValue(hPtr, cmdPtr);
- }
return (Tcl_Command) cmdPtr;
}
@@ -1830,7 +1789,8 @@ TclInvokeObjectCommand(clientData, interp, argc, argv)
* Called to give an existing Tcl command a different name. Both the
* old command name and the new command name can have "::" namespace
* qualifiers. If the new command has a different namespace context,
- * the command is automatically moved to that namespace.
+ * the command will be moved to that namespace and will execute in
+ * the context of that new namespace.
*
* If the new command name is NULL or the null string, the command is
* deleted.
@@ -1852,12 +1812,12 @@ TclRenameCommand(interp, oldName, newName)
char *newName; /* New command name. */
{
Interp *iPtr = (Interp *) interp;
- char *cmdTail, *newTail;
+ char *newTail;
Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2;
Tcl_Command cmd;
Command *cmdPtr;
Tcl_HashEntry *hPtr, *oldHPtr;
- int new, isSrcBgerror, isDestBgerror, result;
+ int new, result;
/*
* Find the existing command. An error is returned if cmdName can't
@@ -1869,11 +1829,10 @@ TclRenameCommand(interp, oldName, newName)
cmdPtr = (Command *) cmd;
if (cmdPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ",
- ((newName == NULL) || (*newName == '\0'))? "delete":"rename",
+ ((newName == NULL)||(*newName == '\0'))? "delete":"rename",
" \"", oldName, "\": command doesn't exist", (char *) NULL);
return TCL_ERROR;
}
- cmdTail = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
cmdNsPtr = cmdPtr->nsPtr;
/*
@@ -1912,35 +1871,17 @@ TclRenameCommand(interp, oldName, newName)
return TCL_ERROR;
}
+
/*
- * The code below was added in 11/95 to preserve backwards compatibility
- * when "tkerror" was renamed "bgerror": we guarantee that the hash
- * table entries for both commands refer to a single shared Command
- * structure. This code should eventually become unnecessary.
+ * Warning: any changes done in the code here are likely
+ * to be needed in Tcl_HideCommand() code too.
+ * (until the common parts are extracted out) --dl
*/
- if ((*cmdTail == 't') && (strcmp(cmdTail, "tkerror") == 0)
- && (cmdNsPtr == iPtr->globalNsPtr)) {
- cmdTail = "bgerror";
- }
- isSrcBgerror = ((*cmdTail == 'b') && (strcmp(cmdTail, "bgerror") == 0)
- && (cmdNsPtr == iPtr->globalNsPtr));
-
- if ((*newTail == 't') && (strcmp(newTail, "tkerror") == 0)
- && (newNsPtr == iPtr->globalNsPtr)) {
- newTail = "bgerror";
- }
- isDestBgerror = ((*newTail == 'b') && (strcmp(newTail, "bgerror") == 0)
- && (newNsPtr == iPtr->globalNsPtr));
-
/*
- * Put the command in the new namespace, so we can check for an alias
+ * Put the command in the new namespace so we can check for an alias
* loop. Since we are adding a new command to a namespace, we must
* handle any shadowing of the global commands that this might create.
- * Note that the renamed command has a different hashtable pointer than
- * it used to have. This allows the command caching code in tclExecute.c
- * to recognize that a command pointer it has cached for this command is
- * now invalid.
*/
oldHPtr = cmdPtr->hPtr;
@@ -1951,8 +1892,8 @@ TclRenameCommand(interp, oldName, newName)
TclResetShadowedCmdRefs(interp, cmdPtr);
/*
- * Everything is in place so we can check for an alias loop. If we
- * detect one, put everything back the way it was and report the error.
+ * Now check for an alias loop. If we detect one, put everything back
+ * the way it was and report the error.
*/
result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr);
@@ -1983,32 +1924,6 @@ TclRenameCommand(interp, oldName, newName)
iPtr->compileEpoch++;
}
- /*
- * The code below provides more backwards compatibility for the
- * "tkerror" => "bgerror" renaming. As with the other compatibility
- * code above, it should eventually be removed.
- */
-
- if (isSrcBgerror) {
- /*
- * The source command is "bgerror": delete the hash table entry for
- * "tkerror" if it exists.
- */
-
- hPtr = Tcl_FindHashEntry(&cmdNsPtr->cmdTable, "tkerror");
- if (hPtr != NULL) {
- Tcl_DeleteHashEntry(hPtr);
- }
- }
- if (isDestBgerror) {
- /*
- * The destination command is "bgerror"; create a "tkerror"
- * command that shares the same Command structure.
- */
-
- hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, "tkerror", &new);
- Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
- }
return TCL_OK;
}
@@ -2283,15 +2198,8 @@ Tcl_DeleteCommandFromToken(interp, cmd)
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = (Command *) cmd;
- char *cmdName;
- int isBgerror;
ImportRef *refPtr, *nextRefPtr;
Tcl_Command importCmd;
- Tcl_HashEntry *tkErrorHPtr;
-
- cmdName = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
- isBgerror = ((*cmdName == 'b') && (strcmp(cmdName, "bgerror") == 0)
- && (cmdPtr->nsPtr == iPtr->globalNsPtr));
/*
* The code here is tricky. We can't delete the hash table entry
@@ -2360,29 +2268,6 @@ Tcl_DeleteCommandFromToken(interp, cmd)
}
/*
- * The code below provides more backwards compatibility for the
- * renaming of "tkerror" to "bgerror". Like the code above, this
- * code should eventually become unnecessary.
- */
-
- if (isBgerror) {
- /*
- * When the "bgerror" command is deleted, delete "tkerror"
- * as well. It shared the same Command structure as "bgerror",
- * so all we have to do is throw away the hash table entry.
- * NOTE: we have to be careful since tkerror may already have
- * been deleted before bgerror.
- */
-
- tkErrorHPtr = Tcl_FindHashEntry(cmdPtr->hPtr->tablePtr,
- "tkerror");
-
- if (tkErrorHPtr != (Tcl_HashEntry *) NULL) {
- Tcl_DeleteHashEntry(tkErrorHPtr);
- }
- }
-
- /*
* Don't use hPtr to delete the hash entry here, because it's
* possible that the deletion callback renamed the command.
* Instead, use cmdPtr->hptr, and make sure that no-one else
@@ -2588,6 +2473,19 @@ Tcl_EvalObj(interp, objPtr)
}
/*
+ * On the Mac, we will never reach the default recursion limit before blowing
+ * the stack. So we need to do a check here.
+ */
+
+ if (TclpCheckStackSpace() == 0) {
+ /*NOTREACHED*/
+ iPtr->numLevels--;
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
+ return TCL_ERROR;
+ }
+
+ /*
* If the interpreter has been deleted, return an error.
*/
@@ -2641,16 +2539,6 @@ Tcl_EvalObj(interp, objPtr)
iPtr->evalFlags = 0;
/*
- * Save information for the history module, if needed.
- * BTL: setting these NULL disables history revisions.
- */
-
- if (flags & TCL_RECORD_BOUNDS) {
- iPtr->evalFirst = NULL;
- iPtr->evalLast = NULL;
- }
-
- /*
* Execute the commands. If the code was compiled from an empty string,
* don't bother executing the code.
*/
@@ -2723,25 +2611,6 @@ Tcl_EvalObj(interp, objPtr)
int length;
/*
- * Compute the line number where the error occurred.
- * BTL: no line # information yet.
- */
-
- iPtr->errorLine = 1;
-#ifdef NOT_YET
- for (p = cmd; p != cmdStart; p++) {
- if (*p == '\n') {
- iPtr->errorLine++;
- }
- }
- for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) {
- if (*p == '\n') {
- iPtr->errorLine++;
- }
- }
-#endif
-
- /*
* Figure out how much of the command to print in the error
* message (up to a certain number of characters, or up to
* the first new-line).
@@ -2813,7 +2682,6 @@ Tcl_ExprLong(interp, string, ptr)
if (length > 0) {
exprPtr = Tcl_NewStringObj(string, length);
Tcl_IncrRefCount(exprPtr);
-
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
@@ -2868,7 +2736,6 @@ Tcl_ExprDouble(interp, string, ptr)
if (length > 0) {
exprPtr = Tcl_NewStringObj(string, length);
Tcl_IncrRefCount(exprPtr);
-
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
@@ -2923,7 +2790,6 @@ Tcl_ExprBoolean(interp, string, ptr)
if (length > 0) {
exprPtr = Tcl_NewStringObj(string, length);
Tcl_IncrRefCount(exprPtr);
-
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
@@ -3312,7 +3178,7 @@ TclObjInvoke(interp, objc, objv, flags)
hTblPtr = (Tcl_HashTable *)
Tcl_GetAssocData(interp, "tclHiddenCmds", NULL);
if (hTblPtr == (Tcl_HashTable *) NULL) {
- badHiddenCmdName:
+ badhiddenCmdToken:
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"invalid hidden command name \"", cmdName, "\"",
@@ -3326,7 +3192,7 @@ TclObjInvoke(interp, objc, objv, flags)
*/
if (hPtr == NULL) {
- goto badHiddenCmdName;
+ goto badhiddenCmdToken;
}
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
} else {
@@ -3462,7 +3328,7 @@ Tcl_ExprString(interp, string)
if (length > 0) {
TclNewObj(exprPtr);
TclInitStringRep(exprPtr, string, length);
- Tcl_DecrRefCount(exprPtr);
+ Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
@@ -3554,7 +3420,7 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr)
Interp dummy;
Tcl_Obj *saveObjPtr;
char *string;
- int result = TCL_OK;
+ int result;
int i;
/*
@@ -3920,12 +3786,14 @@ Tcl_AddObjErrorInfo(interp, message, length)
* Now append "message" to the end of errorInfo.
*/
- messagePtr = Tcl_NewStringObj(message, length);
- Tcl_IncrRefCount(messagePtr);
- Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, messagePtr,
- (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
- Tcl_DecrRefCount(messagePtr); /* free msg object appended above */
-
+ if (length != 0) {
+ messagePtr = Tcl_NewStringObj(message, length);
+ Tcl_IncrRefCount(messagePtr);
+ Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, messagePtr,
+ (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
+ Tcl_DecrRefCount(messagePtr); /* free msg object appended above */
+ }
+
Tcl_DecrRefCount(namePtr); /* free the name object */
}
diff --git a/contrib/tcl/generic/tclBinary.c b/contrib/tcl/generic/tclBinary.c
index 28190cc..c20d03d 100644
--- a/contrib/tcl/generic/tclBinary.c
+++ b/contrib/tcl/generic/tclBinary.c
@@ -9,9 +9,10 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclBinary.c 1.16 97/05/19 10:29:18
+ * SCCS: @(#) tclBinary.c 1.20 97/08/11 18:43:09
*/
+#include <math.h>
#include "tclInt.h"
#include "tclPort.h"
@@ -275,9 +276,11 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
count = 1;
}
if (length >= count) {
- memcpy(cursor, str, (size_t) count);
+ memcpy((VOID *) cursor, (VOID *) str,
+ (size_t) count);
} else {
- memcpy(cursor, str, (size_t) length);
+ memcpy((VOID *) cursor, (VOID *) str,
+ (size_t) length);
memset(cursor+length, pad,
(size_t) (count - length));
}
@@ -877,12 +880,13 @@ FormatNumber(interp, type, src, cursorPtr)
* to the valid range for float.
*/
- if (dvalue > FLT_MAX) {
- *((float *)(*cursorPtr)) = FLT_MAX;
- } else if (dvalue < FLT_MIN) {
- *((float *)(*cursorPtr)) = FLT_MIN;
+ if (fabs(dvalue) > (double)FLT_MAX) {
+ *((float *)(*cursorPtr))
+ = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
+ } else if (fabs(dvalue) < (double)FLT_MIN) {
+ *((float *)(*cursorPtr)) = (float) 0.0;
} else {
- *((float *)(*cursorPtr)) = (float)dvalue;
+ *((float *)(*cursorPtr)) = (float) dvalue;
}
(*cursorPtr) += sizeof(float);
}
diff --git a/contrib/tcl/generic/tclClock.c b/contrib/tcl/generic/tclClock.c
index c6cb924..bf45583 100644
--- a/contrib/tcl/generic/tclClock.c
+++ b/contrib/tcl/generic/tclClock.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclClock.c 1.36 97/06/02 10:14:17
+ * SCCS: @(#) tclClock.c 1.37 97/07/29 10:29:58
*/
#include "tcl.h"
@@ -79,7 +79,7 @@ Tcl_ClockObjCmd (client, interp, objc, objv)
switch (index) {
case 0: /* clicks */
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "clicks");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_SetLongObj(resultPtr, (long) TclpGetClicks());
@@ -87,8 +87,8 @@ Tcl_ClockObjCmd (client, interp, objc, objv)
case 1: /* format */
if ((objc < 3) || (objc > 7)) {
wrongFmtArgs:
- Tcl_WrongNumArgs(interp, 1, objv,
- "format clockval ?-format string? ?-gmt boolean?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "clockval ?-format string? ?-gmt boolean?");
return TCL_ERROR;
}
@@ -126,8 +126,8 @@ Tcl_ClockObjCmd (client, interp, objc, objv)
case 2: /* scan */
if ((objc < 3) || (objc > 7)) {
wrongScanArgs:
- Tcl_WrongNumArgs(interp, 1, objv,
- "scan dateString ?-base clockValue? ?-gmt boolean?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "dateString ?-base clockValue? ?-gmt boolean?");
return TCL_ERROR;
}
@@ -184,7 +184,7 @@ Tcl_ClockObjCmd (client, interp, objc, objv)
return TCL_OK;
case 3: /* seconds */
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "seconds");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_SetLongObj(resultPtr, (long) TclpGetSeconds());
diff --git a/contrib/tcl/generic/tclCmdAH.c b/contrib/tcl/generic/tclCmdAH.c
index 46384c9..79968d3 100644
--- a/contrib/tcl/generic/tclCmdAH.c
+++ b/contrib/tcl/generic/tclCmdAH.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCmdAH.c 1.146 97/06/26 13:45:20
+ * SCCS: @(#) tclCmdAH.c 1.156 97/08/12 18:10:15
*/
#include "tclInt.h"
@@ -92,6 +92,7 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv)
char *string, *arg;
int argLen, caseObjc;
Tcl_Obj *CONST *caseObjv;
+ Tcl_Obj *armPtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -187,11 +188,12 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv)
match:
if (body != -1) {
+ armPtr = caseObjv[body-1];
result = Tcl_EvalObj(interp, caseObjv[body]);
if (result == TCL_ERROR) {
char msg[100];
- arg = Tcl_GetStringFromObj(caseObjv[body-1], &argLen);
+ arg = Tcl_GetStringFromObj(armPtr, &argLen);
sprintf(msg, "\n (\"%.*s\" arm line %d)", argLen, arg,
interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
@@ -231,6 +233,7 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
+ Tcl_Obj *varNamePtr = NULL;
int result;
if ((objc != 2) && (objc != 3)) {
@@ -244,10 +247,15 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
* stack rendering objv invalid.
*/
+ if (objc == 3) {
+ varNamePtr = objv[2];
+ }
+
result = Tcl_EvalObj(interp, objv[1]);
+
if (objc == 3) {
- if (Tcl_ObjSetVar2(interp, objv[2], NULL, Tcl_GetObjResult(interp),
- TCL_PARSE_PART1) == NULL) {
+ if (Tcl_ObjSetVar2(interp, varNamePtr, NULL,
+ Tcl_GetObjResult(interp), TCL_PARSE_PART1) == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"couldn't save command result in variable", -1);
@@ -270,7 +278,7 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
- * Tcl_CdCmd --
+ * Tcl_CdObjCmd --
*
* This procedure is invoked to process the "cd" Tcl command.
* See the user documentation for details on what it does.
@@ -286,24 +294,24 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
/* ARGSUSED */
int
-Tcl_CdCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_CdObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *dirName;
+ int dirLength;
Tcl_DString buffer;
int result;
- if (argc > 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " dirName\"", (char *) NULL);
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dirName");
return TCL_ERROR;
}
- if (argc == 2) {
- dirName = argv[1];
+ if (objc == 2) {
+ dirName = Tcl_GetStringFromObj(objv[1], &dirLength);
} else {
dirName = "~";
}
@@ -482,7 +490,7 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv)
objPtr = Tcl_ConcatObj(objc-1, objv+1);
result = Tcl_EvalObj(interp, objPtr);
- TclDecrRefCount(objPtr); /* we're done with the object */
+ Tcl_DecrRefCount(objPtr); /* we're done with the object */
}
if (result == TCL_ERROR) {
char msg[60];
@@ -612,7 +620,7 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv)
* Free allocated resources.
*/
- TclDecrRefCount(objPtr);
+ Tcl_DecrRefCount(objPtr);
return result;
}
@@ -790,8 +798,8 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME,
}
/*
- * Return the last component, unless it is the only component, and it
- * is the root of an absolute path.
+ * Return the last component, unless it is the only component,
+ * and it is the root of an absolute path.
*/
if (pargc > 0) {
@@ -826,10 +834,10 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME,
errorString = "extension name";
goto not3Args;
}
- extension = TclGetExtension(Tcl_GetStringFromObj(objv[2], &length));
+ extension = TclGetExtension(Tcl_GetStringFromObj(objv[2],&length));
if (extension != NULL) {
- Tcl_SetStringObj(resultPtr, extension, (int) strlen(extension));
+ Tcl_SetStringObj(resultPtr, extension, (int)strlen(extension));
}
goto done;
case FILE_PATHTYPE:
@@ -878,7 +886,8 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME,
pargv[i - 2] = Tcl_GetStringFromObj(objv[i], &length);
}
Tcl_JoinPath(objc - 2, pargv, &buffer);
- Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer), buffer.length);
+ Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer),
+ buffer.length);
ckfree((char *) pargv);
Tcl_DStringFree(&buffer);
goto done;
@@ -930,7 +939,11 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME,
case FILE_NATIVENAME:
fileName = Tcl_TranslateFileName(interp,
Tcl_GetStringFromObj(objv[2], &length), &buffer);
- Tcl_SetStringObj(resultPtr, fileName, -1);
+ if (fileName == NULL) {
+ result = TCL_ERROR ;
+ } else {
+ Tcl_SetStringObj(resultPtr, fileName, -1);
+ }
goto done;
}
@@ -950,8 +963,16 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME,
}
mode = R_OK;
checkAccess:
- Tcl_SetBooleanObj(resultPtr, !((fileName == NULL)
- || (access(fileName, mode) == -1)));
+ /*
+ * The result might have been set within Tcl_TranslateFileName
+ * (like no such user "blah" for file exists ~blah)
+ * but we don't want to flag an error in that case.
+ */
+ if (fileName == NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
+ } else {
+ Tcl_SetBooleanObj(resultPtr, (access(fileName, mode) != -1));
+ }
goto done;
case FILE_WRITABLE:
if (objc != 3) {
@@ -1237,7 +1258,8 @@ StoreStatData(interp, varName, statPtr)
return TCL_ERROR;
}
if (Tcl_SetVar2(interp, varName, "type",
- GetTypeFromMode((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) == NULL) {
+ GetTypeFromMode((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG)
+ == NULL) {
return TCL_ERROR;
}
return TCL_OK;
@@ -1343,7 +1365,7 @@ Tcl_ForCmd(dummy, interp, argc, argv)
if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
if (result == TCL_ERROR) {
char msg[60];
- sprintf(msg, "\n (\"for\" body line %d)", interp->errorLine);
+ sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine);
Tcl_AddErrorInfo(interp, msg);
}
break;
@@ -1398,13 +1420,24 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
int v; /* v selects a loop variable */
int numLists; /* Count of value lists */
Tcl_Obj *bodyPtr;
-
-#define STATIC_SIZE 4
- int indexArray[STATIC_SIZE]; /* Array of value list indices */
- int varcListArray[STATIC_SIZE]; /* # loop variables per list */
- Tcl_Obj **varvListArray[STATIC_SIZE]; /* Array of variable name lists */
- int argcListArray[STATIC_SIZE]; /* Array of value list sizes */
- Tcl_Obj **argvListArray[STATIC_SIZE]; /* Array of value lists */
+
+ /*
+ * We copy the argument object pointers into a local array to avoid
+ * the problem that "objv" might become invalid. It is a pointer into
+ * the evaluation stack and that stack might be grown and reallocated
+ * if the loop body requires a large amount of stack space.
+ */
+
+#define NUM_ARGS 9
+ Tcl_Obj *(argObjStorage[NUM_ARGS]);
+ Tcl_Obj **argObjv = argObjStorage;
+
+#define STATIC_LIST_SIZE 4
+ int indexArray[STATIC_LIST_SIZE]; /* Array of value list indices */
+ int varcListArray[STATIC_LIST_SIZE]; /* # loop variables per list */
+ Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; /* Array of var name lists */
+ int argcListArray[STATIC_LIST_SIZE]; /* Array of value list sizes */
+ Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; /* Array of value lists */
int *index = indexArray;
int *varcList = varcListArray;
@@ -1419,6 +1452,18 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
}
/*
+ * Create the object argument array "argObjv". Make sure argObjv is
+ * large enough to hold the objc arguments.
+ */
+
+ if (objc > NUM_ARGS) {
+ argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *));
+ }
+ for (i = 0; i < objc; i++) {
+ argObjv[i] = objv[i];
+ }
+
+ /*
* Manage numList parallel value lists.
* argvList[i] is a value list counted by argcList[i]
* varvList[i] is the list of variables associated with the value list
@@ -1427,7 +1472,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
*/
numLists = (objc-2)/2;
- if (numLists > STATIC_SIZE) {
+ if (numLists > STATIC_LIST_SIZE) {
index = (int *) ckalloc(numLists * sizeof(int));
varcList = (int *) ckalloc(numLists * sizeof(int));
varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
@@ -1449,7 +1494,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
maxj = 0;
for (i = 0; i < numLists; i++) {
- result = Tcl_ListObjGetElements(interp, objv[1+i*2],
+ result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
&varcList[i], &varvList[i]);
if (result != TCL_OK) {
goto done;
@@ -1461,7 +1506,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
goto done;
}
- result = Tcl_ListObjGetElements(interp, objv[2+i*2],
+ result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
&argcList[i], &argvList[i]);
if (result != TCL_OK) {
goto done;
@@ -1481,9 +1526,30 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
* If some value lists run out of values, set loop vars to ""
*/
- bodyPtr = objv[objc-1];
+ bodyPtr = argObjv[objc-1];
for (j = 0; j < maxj; j++) {
for (i = 0; i < numLists; i++) {
+ /*
+ * If a variable or value list object has been converted to
+ * another kind of Tcl object, convert it back to a list object
+ * and refetch the pointer to its element array.
+ */
+
+ if (argObjv[1+i*2]->typePtr != &tclListType) {
+ result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
+ &varcList[i], &varvList[i]);
+ if (result != TCL_OK) {
+ panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i);
+ }
+ }
+ if (argObjv[2+i*2]->typePtr != &tclListType) {
+ result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
+ &argcList[i], &argvList[i]);
+ if (result != TCL_OK) {
+ panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
+ }
+ }
+
for (v = 0; v < varcList[i]; v++) {
int k = index[i]++;
Tcl_Obj *valuePtr, *varValuePtr;
@@ -1536,21 +1602,25 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
}
done:
- if (numLists > STATIC_SIZE) {
+ if (numLists > STATIC_LIST_SIZE) {
ckfree((char *) index);
ckfree((char *) varcList);
ckfree((char *) argcList);
ckfree((char *) varvList);
ckfree((char *) argvList);
}
+ if (argObjv != argObjStorage) {
+ ckfree((char *) argObjv);
+ }
return result;
-#undef STATIC_SIZE
+#undef STATIC_LIST_SIZE
+#undef NUM_ARGS
}
/*
*----------------------------------------------------------------------
*
- * Tcl_FormatCmd --
+ * Tcl_FormatObjCmd --
*
* This procedure is invoked to process the "format" Tcl command.
* See the user documentation for details on what it does.
@@ -1566,14 +1636,16 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
/* ARGSUSED */
int
-Tcl_FormatCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_FormatObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register char *format; /* Used to read characters from the format
* string. */
+ int formatLen; /* The length of the format string */
+ char *endPtr; /* Points to the last char in format array */
char newFormat[40]; /* A new format specifier is generated here. */
int width; /* Field width from field specifier, or 0 if
* no width given. */
@@ -1595,17 +1667,19 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
# define INT_VALUE 0
# define PTR_VALUE 1
# define DOUBLE_VALUE 2
- char *dst = interp->result; /* Where result is stored. Starts off at
- * interp->resultSpace, but may get dynamically
- * re-allocated if this isn't enough. */
- int dstSize = 0; /* Number of non-null characters currently
- * stored at dst. */
- int dstSpace = TCL_RESULT_SIZE;
- /* Total amount of storage space available
- * in dst (not including null terminator. */
+# define MAX_FLOAT_SIZE 320
+
+ Tcl_Obj *resultPtr; /* Where result is stored finally. */
+ char staticBuf[MAX_FLOAT_SIZE];
+ /* A static buffer to copy the format results
+ * into */
+ char *dst = staticBuf; /* The buffer that sprintf writes into each
+ * time the format processes a specifier */
+ int dstSize = MAX_FLOAT_SIZE;
+ /* The size of the dst buffer */
int noPercent; /* Special case for speed: indicates there's
- * no field specifier, just a string to copy. */
- int argIndex; /* Index of argument to substitute next. */
+ * no field specifier, just a string to copy.*/
+ int objIndex; /* Index of argument to substitute next. */
int gotXpg = 0; /* Non-zero means that an XPG3 %n$-style
* specifier has been seen. */
int gotSequential = 0; /* Non-zero means that a regular sequential
@@ -1620,20 +1694,25 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
* 1. this procedure can't trust its arguments.
* 2. we must be able to provide a large enough result area to hold
* whatever's generated. This is hard to estimate.
- * 2. there's no way to move the arguments from argv to the call
+ * 2. there's no way to move the arguments from objv to the call
* to sprintf in a reasonable way. This is particularly nasty
* because some of the arguments may be two-word values (doubles).
* So, what happens here is to scan the format string one % group
* at a time, making many individual calls to sprintf.
*/
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " formatString ?arg arg ...?\"", (char *) NULL);
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "formatString ?arg arg ...?");
return TCL_ERROR;
}
- argIndex = 2;
- for (format = argv[1]; *format != 0; ) {
+
+ format = Tcl_GetStringFromObj(objv[1], &formatLen);
+ endPtr = format + formatLen;
+ resultPtr = Tcl_NewObj();
+ objIndex = 2;
+
+ while (format < endPtr) {
register char *newPtr = newFormat;
width = precision = noPercent = useShort = 0;
@@ -1642,17 +1721,12 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
/*
* Get rid of any characters before the next field specifier.
*/
-
if (*format != '%') {
- register char *p;
-
- ptrValue = p = format;
- while ((*format != '%') && (*format != 0)) {
- *p = *format;
- p++;
+ ptrValue = format;
+ while ((*format != '%') && (format < endPtr)) {
format++;
}
- size = p - ptrValue;
+ size = format - ptrValue;
noPercent = 1;
goto doField;
}
@@ -1670,7 +1744,6 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
* will be needed to store the result, and substitute for
* "*" size specifiers.
*/
-
*newPtr = '%';
newPtr++;
format++;
@@ -1692,8 +1765,8 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
if (gotSequential) {
goto mixedXPG;
}
- argIndex = tmp+1;
- if ((argIndex < 2) || (argIndex >= argc)) {
+ objIndex = tmp+1;
+ if ((objIndex < 2) || (objIndex >= objc)) {
goto badIndex;
}
goto xpgCheckDone;
@@ -1716,13 +1789,14 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
width = strtoul(format, &end, 10);
format = end;
} else if (*format == '*') {
- if (argIndex >= argc) {
+ if (objIndex >= objc) {
goto badIndex;
}
- if (Tcl_GetInt(interp, argv[argIndex], &width) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[objIndex],
+ &width) != TCL_OK) {
goto fmtError;
}
- argIndex++;
+ objIndex++;
format++;
}
if (width > 100000) {
@@ -1751,13 +1825,14 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
precision = strtoul(format, &end, 10);
format = end;
} else if (*format == '*') {
- if (argIndex >= argc) {
+ if (objIndex >= objc) {
goto badIndex;
}
- if (Tcl_GetInt(interp, argv[argIndex], &precision) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[objIndex],
+ &precision) != TCL_OK) {
goto fmtError;
}
- argIndex++;
+ objIndex++;
format++;
}
if (precision != 0) {
@@ -1777,7 +1852,7 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
*newPtr = *format;
newPtr++;
*newPtr = 0;
- if (argIndex >= argc) {
+ if (objIndex >= objc) {
goto badIndex;
}
switch (*format) {
@@ -1788,20 +1863,19 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
case 'u':
case 'x':
case 'X':
- if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue)
- != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[objIndex],
+ (int *) &intValue) != TCL_OK) {
goto fmtError;
}
whichValue = INT_VALUE;
size = 40 + precision;
break;
case 's':
- ptrValue = argv[argIndex];
- size = strlen(argv[argIndex]);
+ ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size);
break;
case 'c':
- if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue)
- != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[objIndex],
+ (int *) &intValue) != TCL_OK) {
goto fmtError;
}
whichValue = INT_VALUE;
@@ -1812,12 +1886,12 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
case 'f':
case 'g':
case 'G':
- if (Tcl_GetDouble(interp, argv[argIndex], &doubleValue)
- != TCL_OK) {
+ if (Tcl_GetDoubleFromObj(interp, objv[objIndex],
+ &doubleValue) != TCL_OK) {
goto fmtError;
}
whichValue = DOUBLE_VALUE;
- size = 320;
+ size = MAX_FLOAT_SIZE;
if (precision > 10) {
size += precision;
}
@@ -1829,14 +1903,13 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
goto fmtError;
default:
{
- char buf[80];
-
+ char buf[40];
sprintf(buf, "bad field specifier \"%c\"", *format);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
goto fmtError;
}
}
- argIndex++;
+ objIndex++;
format++;
/*
@@ -1848,62 +1921,56 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
if (width > size) {
size = width;
}
- if ((dstSize + size) > dstSpace) {
- char *newDst;
- int newSpace;
-
- newSpace = 2*(dstSize + size);
- newDst = (char *) ckalloc((unsigned) newSpace+1);
- if (dstSize != 0) {
- memcpy((VOID *) newDst, (VOID *) dst, (size_t) dstSize);
- }
- if (dstSpace != TCL_RESULT_SIZE) {
- ckfree(dst);
- }
- dst = newDst;
- dstSpace = newSpace;
- }
if (noPercent) {
- memcpy((VOID *) (dst+dstSize), (VOID *) ptrValue, (size_t) size);
- dstSize += size;
- dst[dstSize] = 0;
+ Tcl_AppendToObj(resultPtr, ptrValue, size);
} else {
+ if (size > dstSize) {
+ if (dst != staticBuf) {
+ ckfree(dst);
+ }
+ dst = (char *) ckalloc((unsigned) (size + 1));
+ dstSize = size;
+ }
+
if (whichValue == DOUBLE_VALUE) {
- sprintf(dst+dstSize, newFormat, doubleValue);
+ sprintf(dst, newFormat, doubleValue);
} else if (whichValue == INT_VALUE) {
if (useShort) {
- sprintf(dst+dstSize, newFormat, (short) intValue);
+ sprintf(dst, newFormat, (short) intValue);
} else {
- sprintf(dst+dstSize, newFormat, intValue);
+ sprintf(dst, newFormat, intValue);
}
} else {
- sprintf(dst+dstSize, newFormat, ptrValue);
+ sprintf(dst, newFormat, ptrValue);
}
- dstSize += strlen(dst+dstSize);
+ Tcl_AppendToObj(resultPtr, dst, -1);
}
}
- if (dstSpace != TCL_RESULT_SIZE) {
- Tcl_SetResult(interp, dst, TCL_DYNAMIC);
- } else {
- Tcl_SetResult(interp, dst, TCL_STATIC);
+ Tcl_SetObjResult(interp, resultPtr);
+ if(dst != staticBuf) {
+ ckfree(dst);
}
return TCL_OK;
mixedXPG:
- interp->result = "cannot mix \"%\" and \"%n$\" conversion specifiers";
+ Tcl_SetResult(interp,
+ "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC);
goto fmtError;
badIndex:
if (gotXpg) {
- interp->result = "\"%n$\" argument index out of range";
+ Tcl_SetResult(interp,
+ "\"%n$\" argument index out of range", TCL_STATIC);
} else {
- interp->result = "not enough arguments for all format specifiers";
+ Tcl_SetResult(interp,
+ "not enough arguments for all format specifiers", TCL_STATIC);
}
fmtError:
- if (dstSpace != TCL_RESULT_SIZE) {
- ckfree(dst);
+ if(dst != staticBuf) {
+ ckfree(dst);
}
+ Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
}
diff --git a/contrib/tcl/generic/tclCmdIL.c b/contrib/tcl/generic/tclCmdIL.c
index 18342f3..6503d35 100644
--- a/contrib/tcl/generic/tclCmdIL.c
+++ b/contrib/tcl/generic/tclCmdIL.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCmdIL.c 1.163 97/06/13 18:16:52
+ * SCCS: @(#) tclCmdIL.c 1.168 97/07/29 12:52:40
*/
#include "tclInt.h"
@@ -55,7 +55,7 @@ typedef struct SortInfo {
Tcl_DString compareCmd; /* The Tcl comparison command when sortMode
* is SORTMODE_COMMAND. Pre-initialized to
* hold base of command.*/
- long index; /* If the -index option was specified, this
+ int index; /* If the -index option was specified, this
* holds the index of the list element
* to extract for comparison. If -index
* wasn't specified, this is -1. */
@@ -472,7 +472,7 @@ InfoArgsCmd(dummy, interp, objc, objv)
Tcl_Obj *listObjPtr;
if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "args procname");
+ Tcl_WrongNumArgs(interp, 2, objv, "procname");
return TCL_ERROR;
}
@@ -532,7 +532,7 @@ InfoBodyCmd(dummy, interp, objc, objv)
Proc *procPtr;
if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "body procname");
+ Tcl_WrongNumArgs(interp, 2, objv, "procname");
return TCL_ERROR;
}
@@ -578,7 +578,7 @@ InfoCmdCountCmd(dummy, interp, objc, objv)
Interp *iPtr = (Interp *) interp;
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "cmdcount");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -659,7 +659,7 @@ InfoCommandsCmd(dummy, interp, objc, objv)
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
}
} else {
- Tcl_WrongNumArgs(interp, 1, objv, "commands ?pattern?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
@@ -749,7 +749,7 @@ InfoCompleteCmd(dummy, interp, objc, objv)
char *command;
if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "complete command");
+ Tcl_WrongNumArgs(interp, 2, objv, "command");
return TCL_ERROR;
}
@@ -797,7 +797,7 @@ InfoDefaultCmd(dummy, interp, objc, objv)
Tcl_Obj *valueObjPtr;
if (objc != 5) {
- Tcl_WrongNumArgs(interp, 1, objv, "default procname arg varname");
+ Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname");
return TCL_ERROR;
}
@@ -877,7 +877,7 @@ InfoExistsCmd(dummy, interp, objc, objv)
Var *varPtr, *arrayPtr;
if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "exists varName");
+ Tcl_WrongNumArgs(interp, 2, objv, "varName");
return TCL_ERROR;
}
@@ -933,7 +933,7 @@ InfoGlobalsCmd(dummy, interp, objc, objv)
} else if (objc == 3) {
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
} else {
- Tcl_WrongNumArgs(interp, 1, objv, "globals ?pattern?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
@@ -988,7 +988,7 @@ InfoHostnameCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "hostname");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -1065,7 +1065,7 @@ InfoLevelCmd(dummy, interp, objc, objv)
return TCL_OK;
}
- Tcl_WrongNumArgs(interp, 1, objv, "level ?number?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?number?");
return TCL_ERROR;
}
@@ -1100,7 +1100,7 @@ InfoLibraryCmd(dummy, interp, objc, objv)
char *libDirName;
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "library");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -1146,7 +1146,7 @@ InfoLoadedCmd(dummy, interp, objc, objv)
int result;
if ((objc != 2) && (objc != 3)) {
- Tcl_WrongNumArgs(interp, 1, objv, "loaded ?interp?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?interp?");
return TCL_ERROR;
}
@@ -1201,7 +1201,7 @@ InfoLocalsCmd(dummy, interp, objc, objv)
} else if (objc == 3) {
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
} else {
- Tcl_WrongNumArgs(interp, 1, objv, "locals ?pattern?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
@@ -1280,7 +1280,7 @@ InfoNameOfExecutableCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "nameofexecutable");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -1321,7 +1321,7 @@ InfoPatchLevelCmd(dummy, interp, objc, objv)
char *patchlevel;
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "patchlevel");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -1374,7 +1374,7 @@ InfoProcsCmd(dummy, interp, objc, objv)
} else if (objc == 3) {
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
} else {
- Tcl_WrongNumArgs(interp, 1, objv, "procs ?pattern?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
@@ -1430,7 +1430,7 @@ InfoScriptCmd(dummy, interp, objc, objv)
{
Interp *iPtr = (Interp *) interp;
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "script");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -1469,7 +1469,7 @@ InfoSharedlibCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "sharedlibextension");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -1509,7 +1509,7 @@ InfoTclVersionCmd(dummy, interp, objc, objv)
char *version;
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "tclversion");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -1597,7 +1597,7 @@ InfoVarsCmd(dummy, interp, objc, objv)
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
}
} else {
- Tcl_WrongNumArgs(interp, 1, objv, "vars ?pattern?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
@@ -1624,7 +1624,8 @@ InfoVarsCmd(dummy, interp, objc, objv)
entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
while (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (!TclIsVarUndefined(varPtr)) {
+ if (!TclIsVarUndefined(varPtr)
+ || (varPtr->flags & VAR_NAMESPACE_VAR)) {
varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(varName, simplePattern)) {
@@ -1654,7 +1655,8 @@ InfoVarsCmd(dummy, interp, objc, objv)
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
while (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (!TclIsVarUndefined(varPtr)) {
+ if (!TclIsVarUndefined(varPtr)
+ || (varPtr->flags & VAR_NAMESPACE_VAR)) {
varName = Tcl_GetHashKey(&globalNsPtr->varTable,
entryPtr);
if ((simplePattern == NULL)
@@ -2426,14 +2428,9 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv)
-1);
return TCL_ERROR;
}
- if (Tcl_GetLongFromObj(interp, objv[i+1], &sortInfo.index)
+ if (TclGetIntForIndex(interp, objv[i+1], -2, &sortInfo.index)
!= TCL_OK) {
- if (strcmp("end", Tcl_GetStringFromObj(objv[i+1], &dummy))
- == 0) {
- sortInfo.index = -2;
- } else {
- return TCL_ERROR;
- }
+ return TCL_ERROR;
}
cmdPtr = objv[i+1];
i++;
@@ -2675,7 +2672,7 @@ SortCompare(objPtr1, objPtr2, infoPtr)
if (objPtr == NULL) {
objPtr = objPtr1;
missingElement:
- sprintf(buffer, "%ld", infoPtr->index);
+ sprintf(buffer, "%d", infoPtr->index);
Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
"element ", buffer, " missing from sublist \"",
Tcl_GetStringFromObj(objPtr, (int *) NULL),
diff --git a/contrib/tcl/generic/tclCmdMZ.c b/contrib/tcl/generic/tclCmdMZ.c
index ec1f737..9ab2c82 100644
--- a/contrib/tcl/generic/tclCmdMZ.c
+++ b/contrib/tcl/generic/tclCmdMZ.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCmdMZ.c 1.99 97/05/19 17:37:17
+ * SCCS: @(#) tclCmdMZ.c 1.102 97/08/13 10:06:58
*/
#include "tclInt.h"
@@ -953,7 +953,7 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
- * Tcl_SplitCmd --
+ * Tcl_SplitObjCmd --
*
* This procedure is invoked to process the "split" Tcl command.
* See the user documentation for details on what it does.
@@ -969,60 +969,63 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv)
/* ARGSUSED */
int
-Tcl_SplitCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_SplitObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *splitChars;
register char *p, *p2;
- char *elementStart;
+ char *splitChars, *string, *elementStart;
+ int splitCharLen, stringLen, i, j;
+ Tcl_Obj *listPtr;
- if (argc == 2) {
+ if (objc == 2) {
splitChars = " \n\t\r";
- } else if (argc == 3) {
- splitChars = argv[2];
+ splitCharLen = 4;
+ } else if (objc == 3) {
+ splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
} else {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " string ?splitChars?\"", (char *) NULL);
+ Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
return TCL_ERROR;
}
+ string = Tcl_GetStringFromObj(objv[1], &stringLen);
+ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+
/*
* Handle the special case of splitting on every character.
*/
- if (*splitChars == 0) {
- char string[2];
- string[1] = 0;
- for (p = argv[1]; *p != 0; p++) {
- string[0] = *p;
- Tcl_AppendElement(interp, string);
+ if (splitCharLen == 0) {
+ for (i = 0, p = string; i < stringLen; i++, p++) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(p, 1));
}
- return TCL_OK;
- }
-
- /*
- * Normal case: split on any of a given set of characters.
- * Discard instances of the split characters.
- */
+ } else {
+ /*
+ * Normal case: split on any of a given set of characters.
+ * Discard instances of the split characters.
+ */
- for (p = elementStart = argv[1]; *p != 0; p++) {
- char c = *p;
- for (p2 = splitChars; *p2 != 0; p2++) {
- if (*p2 == c) {
- *p = 0;
- Tcl_AppendElement(interp, elementStart);
- *p = c;
- elementStart = p+1;
- break;
+ for (i = 0, p = elementStart = string; i < stringLen; i++, p++) {
+ for (j = 0, p2 = splitChars; j < splitCharLen; j++, p2++) {
+ if (*p2 == *p) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(elementStart, (p-elementStart)));
+ elementStart = p+1;
+ break;
+ }
}
}
+ if (p != string) {
+ int remainingChars = stringLen - (elementStart-string);
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(elementStart, remainingChars));
+ }
}
- if (p != argv[1]) {
- Tcl_AppendElement(interp, elementStart);
- }
+
+ Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
@@ -1132,15 +1135,17 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
+ match = -1;
string1 = Tcl_GetStringFromObj(objv[2], &length1);
string2 = Tcl_GetStringFromObj(objv[3], &length2);
- match = -1;
- end = string2 + length2 - length1 + 1;
- for (p = string2; p < end; p++) {
- if (memcmp(string1, p, (unsigned) length1) == 0) {
- match = p - string2;
- if (first) {
- break;
+ if (length1 > 0) {
+ end = string2 + length2 - length1 + 1;
+ for (p = string2; p < end; p++) {
+ if (memcmp(string1, p, (unsigned) length1) == 0) {
+ match = p - string2;
+ if (first) {
+ break;
+ }
}
}
}
@@ -2066,7 +2071,7 @@ TraceVarProc(clientData, interp, name1, name2, flags)
oldObjResultPtr = iPtr->objResultPtr;
iPtr->objResultPtr = saveObjPtr; /* was incremented above */
- TclDecrRefCount(oldObjResultPtr);
+ Tcl_DecrRefCount(oldObjResultPtr);
Tcl_DecrRefCount(dummy.objResultPtr);
dummy.objResultPtr = NULL;
diff --git a/contrib/tcl/generic/tclCompExpr.c b/contrib/tcl/generic/tclCompExpr.c
index 4113879..74b12c1 100644
--- a/contrib/tcl/generic/tclCompExpr.c
+++ b/contrib/tcl/generic/tclCompExpr.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCompExpr.c 1.30 97/06/13 18:17:20
+ * SCCS: @(#) tclCompExpr.c 1.31 97/08/07 10:14:07
*/
#include "tclInt.h"
@@ -69,7 +69,14 @@ typedef struct ExprInfo {
* primary to a number if possible. */
int exprIsJustVarRef; /* Set 1 if the expr consists of just a
* variable reference as in the expression
- * of "if $b then...". Otherwise 0. Used
+ * of "if $b then...". Otherwise 0. If 1 the
+ * expr is compiled out-of-line in order to
+ * implement expr's 2 level substitution
+ * semantics properly. */
+ int exprIsComparison; /* Set 1 if the top-level operator in the
+ * expr is a comparison. Otherwise 0. If 1,
+ * because the operands might be strings,
+ * the expr is compiled out-of-line in order
* to implement expr's 2 level substitution
* semantics properly. */
} ExprInfo;
@@ -242,6 +249,11 @@ static int GetToken _ANSI_ARGS_((Tcl_Interp *interp,
* Otherwise it is set 0. This is used to implement Tcl's two level
* expression substitution semantics properly.
*
+ * envPtr->exprIsComparison is set 1 if the top-level operator in the
+ * expr is a comparison. Otherwise it is set 0. If 1, because the
+ * operands might be strings, the expr is compiled out-of-line in order
+ * to implement expr's 2 level substitution semantics properly.
+ *
* Side effects:
* Adds instructions to envPtr to evaluate the expression at runtime.
*
@@ -307,6 +319,7 @@ TclCompileExpr(interp, string, lastChar, flags, envPtr)
info.lastChar = lastChar;
info.hasOperators = 0;
info.exprIsJustVarRef = 1; /* will be set 0 if anything else is seen */
+ info.exprIsComparison = 0; /* set 1 if topmost operator is <,==,etc. */
/*
* Get the first token then compile an expression.
@@ -343,6 +356,7 @@ TclCompileExpr(interp, string, lastChar, flags, envPtr)
envPtr->termOffset = (info.next - string);
envPtr->maxStackDepth = maxDepth;
envPtr->exprIsJustVarRef = info.exprIsJustVarRef;
+ envPtr->exprIsComparison = info.exprIsComparison;
return result;
}
@@ -424,6 +438,7 @@ CompileCondExpr(interp, infoPtr, flags, envPtr)
infoPtr->hasOperators = 0;
infoPtr->exprIsJustVarRef = 0;
+ infoPtr->exprIsComparison = 0;
result = CompileCondExpr(interp, infoPtr, flags, envPtr);
if (result != TCL_OK) {
goto done;
@@ -495,6 +510,12 @@ CompileCondExpr(interp, infoPtr, flags, envPtr)
TclFixupForwardJump(envPtr, &jumpAroundThenFixup, jumpDist, 127);
infoPtr->hasOperators = 1;
+
+ /*
+ * A comparison is not the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 0;
}
done:
@@ -658,7 +679,12 @@ CompileLorExpr(interp, infoPtr, flags, envPtr)
TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), jumpDist, 127);
}
+ /*
+ * We get here only if one or more ||'s appear as top-level operators.
+ */
+
done:
+ infoPtr->exprIsComparison = 0;
TclFreeJumpFixupArray(&jumpFixupArray);
envPtr->maxStackDepth = maxDepth;
return result;
@@ -817,10 +843,16 @@ CompileLandExpr(interp, infoPtr, flags, envPtr)
fixupIndex = (j - 1); /* process closest jump first */
currCodeOffset = TclCurrCodeOffset();
jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset);
- TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), jumpDist, 127);
+ TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]),
+ jumpDist, 127);
}
+ /*
+ * We get here only if one or more &&'s appear as top-level operators.
+ */
+
done:
+ infoPtr->exprIsComparison = 0;
TclFreeJumpFixupArray(&jumpFixupArray);
envPtr->maxStackDepth = maxDepth;
return result;
@@ -883,6 +915,12 @@ CompileBitOrExpr(interp, infoPtr, flags, envPtr)
maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
TclEmitOpcode(INST_BITOR, envPtr);
+
+ /*
+ * A comparison is not the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 0;
}
done:
@@ -947,6 +985,12 @@ CompileBitXorExpr(interp, infoPtr, flags, envPtr)
maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
TclEmitOpcode(INST_BITXOR, envPtr);
+
+ /*
+ * A comparison is not the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 0;
}
done:
@@ -1011,6 +1055,12 @@ CompileBitAndExpr(interp, infoPtr, flags, envPtr)
maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
TclEmitOpcode(INST_BITAND, envPtr);
+
+ /*
+ * A comparison is not the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 0;
}
done:
@@ -1082,6 +1132,12 @@ CompileEqualityExpr(interp, infoPtr, flags, envPtr)
}
op = infoPtr->token;
+
+ /*
+ * A comparison _is_ the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 1;
}
done:
@@ -1162,6 +1218,12 @@ CompileRelationalExpr(interp, infoPtr, flags, envPtr)
}
op = infoPtr->token;
+
+ /*
+ * A comparison _is_ the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 1;
}
done:
@@ -1233,6 +1295,12 @@ CompileShiftExpr(interp, infoPtr, flags, envPtr)
}
op = infoPtr->token;
+
+ /*
+ * A comparison is not the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 0;
}
done:
@@ -1304,6 +1372,12 @@ CompileAddExpr(interp, infoPtr, flags, envPtr)
}
op = infoPtr->token;
+
+ /*
+ * A comparison is not the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 0;
}
done:
@@ -1377,6 +1451,12 @@ CompileMultiplyExpr(interp, infoPtr, flags, envPtr)
}
op = infoPtr->token;
+
+ /*
+ * A comparison is not the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 0;
}
done:
@@ -1449,6 +1529,12 @@ CompileUnaryExpr(interp, infoPtr, flags, envPtr)
TclEmitOpcode(INST_LNOT, envPtr);
break;
}
+
+ /*
+ * A comparison is not the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 0;
} else { /* must be a primaryExpr */
result = CompilePrimaryExpr(interp, infoPtr, flags, envPtr);
if (result != TCL_OK) {
@@ -1583,6 +1669,7 @@ CompilePrimaryExpr(interp, infoPtr, flags, envPtr)
if (result != TCL_OK) {
goto done;
}
+ infoPtr->exprIsComparison = 0;
result = CompileCondExpr(interp, infoPtr, flags, envPtr);
if (result != TCL_OK) {
goto done;
@@ -1722,6 +1809,7 @@ CompileMathFuncCall(interp, infoPtr, flags, envPtr)
if (mathFuncPtr->numArgs > 0) {
for (i = 0; ; i++) {
+ infoPtr->exprIsComparison = 0;
result = CompileCondExpr(interp, infoPtr, flags, envPtr);
if (result != TCL_OK) {
goto done;
@@ -1785,7 +1873,12 @@ CompileMathFuncCall(interp, infoPtr, flags, envPtr)
TclEmitInstUInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr);
}
+ /*
+ * A comparison is not the top-level operator in this expression.
+ */
+
done:
+ infoPtr->exprIsComparison = 0;
envPtr->maxStackDepth = maxDepth;
return result;
diff --git a/contrib/tcl/generic/tclCompile.c b/contrib/tcl/generic/tclCompile.c
index e8aa99c..d4fad0c 100644
--- a/contrib/tcl/generic/tclCompile.c
+++ b/contrib/tcl/generic/tclCompile.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCompile.c 1.61 97/06/23 18:43:46
+ * SCCS: @(#) tclCompile.c 1.76 97/08/12 13:35:43
*/
#include "tclInt.h"
@@ -29,11 +29,26 @@ int tclTraceCompile = 0;
static int traceInitialized = 0;
/*
- * Count of the number of compilations.
+ * Count of the number of compilations and various other compilation-
+ * related statistics.
*/
#ifdef TCL_COMPILE_STATS
long tclNumCompilations = 0;
+double tclTotalSourceBytes = 0.0;
+double tclTotalCodeBytes = 0.0;
+
+double tclTotalInstBytes = 0.0;
+double tclTotalObjBytes = 0.0;
+double tclTotalExceptBytes = 0.0;
+double tclTotalAuxBytes = 0.0;
+double tclTotalCmdMapBytes = 0.0;
+
+double tclCurrentSourceBytes = 0.0;
+double tclCurrentCodeBytes = 0.0;
+
+int tclSourceCount[32];
+int tclByteCodeCount[32];
#endif /* TCL_COMPILE_STATS */
/*
@@ -365,6 +380,9 @@ static int CreateExceptionRange _ANSI_ARGS_((
static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr));
static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData));
+static unsigned char * EncodeCmdLocMap _ANSI_ARGS_((
+ CompileEnv *envPtr, ByteCode *codePtr,
+ unsigned char *startPtr));
static void EnterCmdExtentData _ANSI_ARGS_((
CompileEnv *envPtr, int cmdNumber,
int numSrcChars, int numCodeBytes));
@@ -377,6 +395,8 @@ static void FreeForeachInfo _ANSI_ARGS_((
static void FreeByteCodeInternalRep _ANSI_ARGS_((
Tcl_Obj *objPtr));
static void FreeArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr));
+static int GetCmdLocEncodingSize _ANSI_ARGS_((
+ CompileEnv *envPtr));
static void InitArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr));
static int LookupCompiledLocal _ANSI_ARGS_((
char *name, int nameChars, int createIfNew,
@@ -421,12 +441,11 @@ TclPrintByteCodeObj(interp, objPtr)
Tcl_Obj *objPtr; /* The bytecode object to disassemble. */
{
ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
- Proc *procPtr;
- CmdLocation *mapPtr;
- ExceptionRange *excRangeArrayPtr;
- unsigned char *codeStart, *codeLimit, *pc, *start;
- int numCmds, numRanges, cmd, maxChars, i;
- char *source;
+ unsigned char *codeStart, *codeLimit, *pc;
+ unsigned char *codeDeltaNext, *codeLengthNext;
+ unsigned char *srcDeltaNext, *srcLengthNext;
+ int codeOffset, codeLen, srcOffset, srcLen;
+ int numCmds, numObjs, delta, objBytes, i;
if (codePtr->refCount <= 0) {
return; /* already freed */
@@ -434,28 +453,60 @@ TclPrintByteCodeObj(interp, objPtr)
codeStart = codePtr->codeStart;
codeLimit = (codeStart + codePtr->numCodeBytes);
- source = codePtr->source;
- procPtr = codePtr->procPtr;
- numCmds = codePtr->numCommands;
- numRanges = codePtr->numExcRanges;
- mapPtr = codePtr->cmdMapPtr;
- excRangeArrayPtr = codePtr->excRangeArrayPtr;
-
- fprintf(stdout, "\nByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x, interp epoch %u\n",
+ numCmds = codePtr->numCommands;
+ numObjs = codePtr->numObjects;
+
+ objBytes = (numObjs * sizeof(Tcl_Obj));
+ for (i = 0; i < numObjs; i++) {
+ Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i];
+ if (litObjPtr->bytes != NULL) {
+ objBytes += litObjPtr->length;
+ }
+ }
+
+ /*
+ * Print header lines describing the ByteCode.
+ */
+
+ fprintf(stdout, "\nByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n",
(unsigned int) codePtr, codePtr->refCount,
codePtr->compileEpoch, (unsigned int) codePtr->iPtr,
codePtr->iPtr->compileEpoch);
- if (procPtr != NULL) {
+ fprintf(stdout, " Source ");
+ TclPrintSource(stdout, codePtr->source,
+ TclMin(codePtr->numSrcChars, 70));
+ fprintf(stdout, "\n Cmds %d, chars %d, inst %d, objs %u, aux %d, stk depth %u, code/src %.2f\n",
+ numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs,
+ codePtr->numAuxDataItems, codePtr->maxStackDepth,
+ (codePtr->numSrcChars?
+ ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0));
+ fprintf(stdout, " Code %d = %d(header)+%d(inst)+%d(objs)+%d(exc)+%d(aux)+%d(cmd map)\n",
+ codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes,
+ objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)),
+ (codePtr->numAuxDataItems * sizeof(AuxData)),
+ codePtr->numCmdLocBytes);
+
+ /*
+ * If the ByteCode is the compiled body of a Tcl procedure, print
+ * information about that procedure. Note that we don't know the
+ * procedure's name since ByteCode's can be shared among procedures.
+ */
+
+ if (codePtr->procPtr != NULL) {
+ Proc *procPtr = codePtr->procPtr;
int numCompiledLocals = procPtr->numCompiledLocals;
fprintf(stdout,
- " Proc 0x%x, ref ct=%d, %d args, %d compiled locals\n",
+ " Proc 0x%x, ref ct %d, args %d, compiled locals %d\n",
(unsigned int) procPtr, procPtr->refCount, procPtr->numArgs,
numCompiledLocals);
if (numCompiledLocals > 0) {
CompiledLocal *localPtr = procPtr->firstLocalPtr;
for (i = 0; i < numCompiledLocals; i++) {
- fprintf(stdout, " %d: frame index=%d, flags=0x%x%s%s",
- i, localPtr->frameIndex, localPtr->flags,
+ fprintf(stdout, " %d: slot %d%s%s%s%s%s",
+ i, localPtr->frameIndex,
+ ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""),
+ ((localPtr->flags & VAR_ARRAY)? ", array" : ""),
+ ((localPtr->flags & VAR_LINK)? ", link" : ""),
(localPtr->isArg? ", arg" : ""),
(localPtr->isTemp? ", temp" : ""));
if (localPtr->isTemp) {
@@ -467,21 +518,43 @@ TclPrintByteCodeObj(interp, objPtr)
}
}
}
- fprintf(stdout, " Source: ");
- TclPrintSource(stdout, source, TclMin(codePtr->numSrcChars, 70));
- fprintf(stdout, "\n Chars=%d, bytes=%u, objs=%u, stk depth=%u, exc depth=%d, aux items=%d\n",
- codePtr->numSrcChars, codePtr->numCodeBytes,
- codePtr->numObjects, codePtr->maxStackDepth,
- codePtr->maxExcRangeDepth, codePtr->numAuxDataItems);
/*
+ * Print the ExceptionRange array.
+ */
+
+ if (codePtr->numExcRanges > 0) {
+ fprintf(stdout, " Exception ranges %d, depth %d:\n",
+ codePtr->numExcRanges, codePtr->maxExcRangeDepth);
+ for (i = 0; i < codePtr->numExcRanges; i++) {
+ ExceptionRange *rangePtr = &(codePtr->excRangeArrayPtr[i]);
+ fprintf(stdout, " %d: level %d, %s, pc %d-%d, ",
+ i, rangePtr->nestingLevel,
+ ((rangePtr->type == LOOP_EXCEPTION_RANGE)? "loop":"catch"),
+ rangePtr->codeOffset,
+ (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
+ switch (rangePtr->type) {
+ case LOOP_EXCEPTION_RANGE:
+ fprintf(stdout, "continue %d, break %d\n",
+ rangePtr->continueOffset, rangePtr->breakOffset);
+ break;
+ case CATCH_EXCEPTION_RANGE:
+ fprintf(stdout, "catch %d\n", rangePtr->catchOffset);
+ break;
+ default:
+ panic("TclPrintSource: unrecognized ExceptionRange type %d\n",
+ rangePtr->type);
+ }
+ }
+ }
+
+ /*
* If there were no commands (e.g., an expression or an empty string
- * was compiled), just print all instructions.
+ * was compiled), just print all instructions and return.
*/
if (numCmds == 0) {
- start = codeStart;
- pc = start;
+ pc = codeStart;
while (pc < codeLimit) {
fprintf(stdout, " ");
pc += TclPrintInstruction(codePtr, pc);
@@ -490,68 +563,128 @@ TclPrintByteCodeObj(interp, objPtr)
}
/*
- * Print table giving the source and object locations for each command.
+ * Print table showing the code offset, source offset, and source
+ * length for each command. These are encoded as a sequence of bytes.
*/
- fprintf(stdout, " Commands=%d\n", numCmds);
+ fprintf(stdout, " Commands %d:", numCmds);
+ codeDeltaNext = codePtr->codeDeltaStart;
+ codeLengthNext = codePtr->codeLengthStart;
+ srcDeltaNext = codePtr->srcDeltaStart;
+ srcLengthNext = codePtr->srcLengthStart;
+ codeOffset = srcOffset = 0;
for (i = 0; i < numCmds; i++) {
- fprintf(stdout, " %d: source=%d-%d, code=%d-%d\n",
- (i+1), mapPtr[i].srcOffset,
- (mapPtr[i].srcOffset + mapPtr[i].numSrcChars - 1),
- mapPtr[i].codeOffset,
- (mapPtr[i].codeOffset + mapPtr[i].numCodeBytes - 1));
- }
-
- /*
- * Print the ExceptionRange array.
- */
+ if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
+ codeDeltaNext++;
+ delta = TclGetInt4AtPtr(codeDeltaNext);
+ codeDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(codeDeltaNext);
+ codeDeltaNext++;
+ }
+ codeOffset += delta;
- fprintf(stdout, " Exception ranges=%d\n", numRanges);
- for (i = 0; i < numRanges; i++) {
- ExceptionRange *rangePtr = &(excRangeArrayPtr[i]);
- fprintf(stdout, " %d: level=%d, type=%s, pc range=%d-%d, ",
- i, rangePtr->nestingLevel,
- ((rangePtr->type == LOOP_EXCEPTION_RANGE)? "loop" : "catch"),
- rangePtr->codeOffset,
- (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
- switch (rangePtr->type) {
- case LOOP_EXCEPTION_RANGE:
- fprintf(stdout, "continue=%d, break=%d\n",
- rangePtr->continueOffset, rangePtr->breakOffset);
- break;
- case CATCH_EXCEPTION_RANGE:
- fprintf(stdout, "catch=%d\n", rangePtr->catchOffset);
- break;
- default:
- fprintf(stdout, "unrecognized ExceptionRange type %d\n",
- rangePtr->type);
+ if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
+ codeLengthNext++;
+ codeLen = TclGetInt4AtPtr(codeLengthNext);
+ codeLengthNext += 4;
+ } else {
+ codeLen = TclGetInt1AtPtr(codeLengthNext);
+ codeLengthNext++;
+ }
+
+ if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
+ srcDeltaNext++;
+ delta = TclGetInt4AtPtr(srcDeltaNext);
+ srcDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(srcDeltaNext);
+ srcDeltaNext++;
+ }
+ srcOffset += delta;
+
+ if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
+ srcLengthNext++;
+ srcLen = TclGetInt4AtPtr(srcLengthNext);
+ srcLengthNext += 4;
+ } else {
+ srcLen = TclGetInt1AtPtr(srcLengthNext);
+ srcLengthNext++;
}
+
+ fprintf(stdout, "%s%4d: pc %d-%d, source %d-%d",
+ ((i % 2)? " " : "\n "),
+ (i+1), codeOffset, (codeOffset + codeLen - 1),
+ srcOffset, (srcOffset + srcLen - 1));
+ }
+ if ((numCmds > 0) && ((numCmds % 2) != 0)) {
+ fprintf(stdout, "\n");
}
/*
* Print each instruction. If the instruction corresponds to the start
- * of a command, print the command's source.
+ * of a command, print the command's source. Note that we don't need
+ * the code length here.
*/
- start = codeStart;
- cmd = 0;
- pc = start;
- while (pc < codeLimit) {
- int pcOffset = (pc - start);
- while ((cmd < numCmds) && (pcOffset >= mapPtr[cmd].codeOffset)) {
- /*
- * The start of the command with index cmd.
- */
-
- maxChars = TclMin(mapPtr[cmd].numSrcChars, 70);
- fprintf(stdout, " Command %d: ", (cmd+1));
- TclPrintSource(stdout, (source + mapPtr[cmd].srcOffset),
- maxChars);
- fprintf(stdout, "\n");
- cmd++;
+ codeDeltaNext = codePtr->codeDeltaStart;
+ srcDeltaNext = codePtr->srcDeltaStart;
+ srcLengthNext = codePtr->srcLengthStart;
+ codeOffset = srcOffset = 0;
+ pc = codeStart;
+ for (i = 0; i < numCmds; i++) {
+ if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
+ codeDeltaNext++;
+ delta = TclGetInt4AtPtr(codeDeltaNext);
+ codeDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(codeDeltaNext);
+ codeDeltaNext++;
+ }
+ codeOffset += delta;
+
+ if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
+ srcDeltaNext++;
+ delta = TclGetInt4AtPtr(srcDeltaNext);
+ srcDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(srcDeltaNext);
+ srcDeltaNext++;
+ }
+ srcOffset += delta;
+
+ if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
+ srcLengthNext++;
+ srcLen = TclGetInt4AtPtr(srcLengthNext);
+ srcLengthNext += 4;
+ } else {
+ srcLen = TclGetInt1AtPtr(srcLengthNext);
+ srcLengthNext++;
+ }
+
+ /*
+ * Print instructions before command i.
+ */
+
+ while ((pc-codeStart) < codeOffset) {
+ fprintf(stdout, " ");
+ pc += TclPrintInstruction(codePtr, pc);
+ }
+
+ fprintf(stdout, " Command %d: ", (i+1));
+ TclPrintSource(stdout, (codePtr->source + srcOffset),
+ TclMin(srcLen, 70));
+ fprintf(stdout, "\n");
+ }
+ if (pc < codeLimit) {
+ /*
+ * Print instructions after the last command.
+ */
+
+ while (pc < codeLimit) {
+ fprintf(stdout, " ");
+ pc += TclPrintInstruction(codePtr, pc);
}
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
}
}
@@ -590,7 +723,7 @@ TclPrintInstruction(codePtr, pc)
for (i = 0; i < instDesc->numOperands; i++) {
switch (instDesc->opTypes[i]) {
case OPERAND_INT1:
- opnd = TclGetInt1AtPc(pc+1+i);
+ opnd = TclGetInt1AtPtr(pc+1+i);
if ((i == 0) && ((opCode == INST_JUMP1)
|| (opCode == INST_JUMP_TRUE1)
|| (opCode == INST_JUMP_FALSE1))) {
@@ -600,7 +733,7 @@ TclPrintInstruction(codePtr, pc)
}
break;
case OPERAND_INT4:
- opnd = TclGetInt4AtPc(pc+1+i);
+ opnd = TclGetInt4AtPtr(pc+1+i);
if ((i == 0) && ((opCode == INST_JUMP4)
|| (opCode == INST_JUMP_TRUE4)
|| (opCode == INST_JUMP_FALSE4))) {
@@ -610,7 +743,7 @@ TclPrintInstruction(codePtr, pc)
}
break;
case OPERAND_UINT1:
- opnd = TclGetUInt1AtPc(pc+1+i);
+ opnd = TclGetUInt1AtPtr(pc+1+i);
if ((i == 0) && (opCode == INST_PUSH1)) {
elemPtr = codePtr->objArrayPtr[opnd];
string = Tcl_GetStringFromObj(elemPtr, &elemLen);
@@ -642,7 +775,7 @@ TclPrintInstruction(codePtr, pc)
}
break;
case OPERAND_UINT4:
- opnd = TclGetUInt4AtPc(pc+1+i);
+ opnd = TclGetUInt4AtPtr(pc+1+i);
if (opCode == INST_PUSH4) {
elemPtr = codePtr->objArrayPtr[opnd];
string = Tcl_GetStringFromObj(elemPtr, &elemLen);
@@ -812,6 +945,11 @@ TclCleanupByteCode(codePtr)
register Tcl_Obj *elemPtr;
register int i;
+#ifdef TCL_COMPILE_STATS
+ tclCurrentSourceBytes -= (double) codePtr->numSrcChars;
+ tclCurrentCodeBytes -= (double) codePtr->totalSize;
+#endif /* TCL_COMPILE_STATS */
+
/*
* A single heap object holds the ByteCode structure and its code,
* object, command location, and auxiliary data arrays. This means we
@@ -864,50 +1002,54 @@ DupByteCodeInternalRep(srcPtr, copyPtr)
{
ByteCode *codePtr = (ByteCode *) srcPtr->internalRep.otherValuePtr;
register ByteCode *dupPtr;
- int codeBytes = codePtr->numCodeBytes;
- int numObjects = codePtr->numObjects;
- int numAuxDataItems = codePtr->numAuxDataItems;
register AuxData *srcAuxDataPtr, *dupAuxDataPtr;
- size_t objArrayBytes, rangeArrayBytes, cmdLocBytes, auxDataBytes;
+ size_t objArrayBytes, exceptArrayBytes, cmdLocBytes, auxDataBytes;
register size_t size;
register char *p;
- int i;
+ int codeBytes, numObjects, i;
/*
* Allocate a single heap object to hold the copied ByteCode structure
* and its code, object, command location, and auxiliary data arrays.
*/
- objArrayBytes = numObjects * sizeof(Tcl_Obj *);
- rangeArrayBytes = (codePtr->numExcRanges * sizeof(ExceptionRange));
- cmdLocBytes = codePtr->numCommands * sizeof(CmdLocation);
- auxDataBytes = numAuxDataItems * sizeof(AuxData);
-
- size = TCL_ALIGN(sizeof(ByteCode));
- size += TCL_ALIGN(codeBytes);
- size += TCL_ALIGN(objArrayBytes);
- size += TCL_ALIGN(rangeArrayBytes);
- size += TCL_ALIGN(cmdLocBytes);
- size += TCL_ALIGN(auxDataBytes);
+ codeBytes = codePtr->numCodeBytes;
+ numObjects = codePtr->numObjects;
+ objArrayBytes = (numObjects * sizeof(Tcl_Obj *));
+ exceptArrayBytes = (codePtr->numExcRanges * sizeof(ExceptionRange));
+ auxDataBytes = (codePtr->numAuxDataItems * sizeof(AuxData));
+ cmdLocBytes = codePtr->numCmdLocBytes;
+
+ size = sizeof(ByteCode);
+ size += TCL_ALIGN(codeBytes); /* align object array */
+ size += TCL_ALIGN(objArrayBytes); /* align exception range array */
+ size += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
+ size += auxDataBytes;
+ size += cmdLocBytes;
p = (char *) ckalloc(size);
dupPtr = (ByteCode *) p;
memcpy((VOID *) dupPtr, (VOID *) codePtr, size);
- p += TCL_ALIGN(sizeof(ByteCode));
+ p += sizeof(ByteCode);
dupPtr->codeStart = (unsigned char *) p;
- p += TCL_ALIGN(codeBytes);
+ p += TCL_ALIGN(codeBytes); /* object array is aligned */
dupPtr->objArrayPtr = (Tcl_Obj **) p;
- p += TCL_ALIGN(objArrayBytes);
+ p += TCL_ALIGN(objArrayBytes); /* exception range array is aligned */
dupPtr->excRangeArrayPtr = (ExceptionRange *) p;
- p += TCL_ALIGN(rangeArrayBytes);
- dupPtr->cmdMapPtr = (CmdLocation *) p;
-
- p += TCL_ALIGN(cmdLocBytes);
+ p += TCL_ALIGN(exceptArrayBytes); /* AuxData array is aligned */
dupPtr->auxDataArrayPtr = (AuxData *) p;
+
+ p += auxDataBytes;
+ dupPtr->codeDeltaStart = ((unsigned char *) dupPtr) +
+ (codePtr->codeDeltaStart - (unsigned char *) codePtr);
+ dupPtr->srcDeltaStart = ((unsigned char *) dupPtr) +
+ (codePtr->srcDeltaStart - (unsigned char *) codePtr);
+ dupPtr->srcLengthStart = ((unsigned char *) dupPtr) +
+ (codePtr->srcLengthStart - (unsigned char *) codePtr);
/*
* Increment the ref counts for objects in the object array since we are
@@ -924,7 +1066,7 @@ DupByteCodeInternalRep(srcPtr, copyPtr)
srcAuxDataPtr = codePtr->auxDataArrayPtr;
dupAuxDataPtr = dupPtr->auxDataArrayPtr;
- for (i = 0; i < numAuxDataItems; i++) {
+ for (i = 0; i < codePtr->numAuxDataItems; i++) {
if (srcAuxDataPtr->dupProc != NULL) {
dupAuxDataPtr->clientData =
srcAuxDataPtr->dupProc(srcAuxDataPtr->clientData);
@@ -937,6 +1079,11 @@ DupByteCodeInternalRep(srcPtr, copyPtr)
copyPtr->internalRep.otherValuePtr = (VOID *) dupPtr;
copyPtr->typePtr = &tclByteCodeType;
+
+#ifdef TCL_COMPILE_STATS
+ tclCurrentSourceBytes += (double) codePtr->numSrcChars;
+ tclCurrentCodeBytes += (double) codePtr->totalSize;
+#endif /* TCL_COMPILE_STATS */
}
/*
@@ -984,10 +1131,6 @@ SetByteCodeFromAny(interp, objPtr)
traceInitialized = 1;
}
-#ifdef TCL_COMPILE_STATS
- tclNumCompilations++;
-#endif /* TCL_COMPILE_STATS */
-
string = Tcl_GetStringFromObj(objPtr, &length);
TclInitCompileEnv(interp, &compEnv, string);
result = TclCompileString(interp, string, string+length,
@@ -1105,6 +1248,7 @@ TclInitCompileEnv(interp, envPtr, string)
envPtr->wordIsSimple = 0;
envPtr->numSimpleWordChars = 0;
envPtr->exprIsJustVarRef = 0;
+ envPtr->exprIsComparison = 0;
envPtr->termOffset = 0;
envPtr->codeStart = envPtr->staticCodeSpace;
@@ -1204,67 +1348,121 @@ TclFreeCompileEnv(envPtr)
void
TclInitByteCodeObj(objPtr, envPtr)
- Tcl_Obj *objPtr; /* Points object that should be
- * initialized, and whose string rep
- * contains the source code. */
+ Tcl_Obj *objPtr; /* Points object that should be
+ * initialized, and whose string rep
+ * contains the source code. */
register CompileEnv *envPtr; /* Points to the CompileEnv structure from
* which to create a ByteCode structure. */
{
register ByteCode *codePtr;
- size_t codeBytes, objArrayBytes, rangeArrayBytes, cmdLocBytes;
+ size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
size_t auxDataArrayBytes;
- register size_t size;
- register char *p;
+ register size_t size, objBytes, totalSize;
+ register unsigned char *p;
+ unsigned char *nextPtr;
+ int srcLen = envPtr->termOffset;
+ int numObjects, i;
+#ifdef TCL_COMPILE_STATS
+ int srcLenLog2, sizeLog2;
+#endif /*TCL_COMPILE_STATS*/
+
+ codeBytes = (envPtr->codeNext - envPtr->codeStart);
+ numObjects = envPtr->objArrayNext;
+ objArrayBytes = (envPtr->objArrayNext * sizeof(Tcl_Obj *));
+ exceptArrayBytes = (envPtr->excRangeArrayNext * sizeof(ExceptionRange));
+ auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData));
+ cmdLocBytes = GetCmdLocEncodingSize(envPtr);
+
+ size = sizeof(ByteCode);
+ size += TCL_ALIGN(codeBytes); /* align object array */
+ size += TCL_ALIGN(objArrayBytes); /* align exception range array */
+ size += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
+ size += auxDataArrayBytes;
+ size += cmdLocBytes;
+
+ /*
+ * Compute the total number of bytes needed for this bytecode
+ * including the storage for the Tcl objects in its object array.
+ */
+
+ objBytes = (numObjects * sizeof(Tcl_Obj));
+ for (i = 0; i < numObjects; i++) {
+ Tcl_Obj *litObjPtr = envPtr->objArrayPtr[i];
+ if (litObjPtr->bytes != NULL) {
+ objBytes += litObjPtr->length;
+ }
+ }
+ totalSize = (size + objBytes);
- codeBytes = envPtr->codeNext - envPtr->codeStart;
- objArrayBytes = envPtr->objArrayNext * sizeof(Tcl_Obj *);
- rangeArrayBytes = (envPtr->excRangeArrayNext * sizeof(ExceptionRange));
- cmdLocBytes = envPtr->numCommands * sizeof(CmdLocation);
- auxDataArrayBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
+#ifdef TCL_COMPILE_STATS
+ tclNumCompilations++;
+ tclTotalSourceBytes += (double) srcLen;
+ tclTotalCodeBytes += (double) totalSize;
- size = TCL_ALIGN(sizeof(ByteCode));
- size += TCL_ALIGN(codeBytes);
- size += TCL_ALIGN(objArrayBytes);
- size += TCL_ALIGN(rangeArrayBytes);
- size += TCL_ALIGN(cmdLocBytes);
- size += TCL_ALIGN(auxDataArrayBytes);
+ tclTotalInstBytes += (double) codeBytes;
+ tclTotalObjBytes += (double) objBytes;
+ tclTotalExceptBytes += exceptArrayBytes;
+ tclTotalAuxBytes += (double) auxDataArrayBytes;
+ tclTotalCmdMapBytes += (double) cmdLocBytes;
+
+ tclCurrentSourceBytes += (double) srcLen;
+ tclCurrentCodeBytes += (double) totalSize;
+
+ srcLenLog2 = TclLog2(srcLen);
+ sizeLog2 = TclLog2((int) totalSize);
+ if ((srcLenLog2 > 31) || (sizeLog2 > 31)) {
+ panic("TclInitByteCodeObj: bad source or code sizes\n");
+ }
+ tclSourceCount[srcLenLog2]++;
+ tclByteCodeCount[sizeLog2]++;
+#endif /* TCL_COMPILE_STATS */
- p = (char *) ckalloc(size);
+ p = (unsigned char *) ckalloc(size);
codePtr = (ByteCode *) p;
codePtr->iPtr = envPtr->iPtr;
codePtr->compileEpoch = envPtr->iPtr->compileEpoch;
codePtr->refCount = 1;
codePtr->source = envPtr->source;
codePtr->procPtr = envPtr->procPtr;
+ codePtr->totalSize = totalSize;
codePtr->numCommands = envPtr->numCommands;
- codePtr->numSrcChars = envPtr->termOffset;
+ codePtr->numSrcChars = srcLen;
codePtr->numCodeBytes = codeBytes;
- codePtr->numObjects = envPtr->objArrayNext;
+ codePtr->numObjects = numObjects;
codePtr->numExcRanges = envPtr->excRangeArrayNext;
codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
+ codePtr->numCmdLocBytes = cmdLocBytes;
codePtr->maxExcRangeDepth = envPtr->maxExcRangeDepth;
codePtr->maxStackDepth = envPtr->maxStackDepth;
- p += TCL_ALIGN(sizeof(ByteCode));
- codePtr->codeStart = (unsigned char *) p;
+ p += sizeof(ByteCode);
+ codePtr->codeStart = p;
memcpy((VOID *) p, (VOID *) envPtr->codeStart, codeBytes);
- p += TCL_ALIGN(codeBytes);
+ p += TCL_ALIGN(codeBytes); /* align object array */
codePtr->objArrayPtr = (Tcl_Obj **) p;
memcpy((VOID *) p, (VOID *) envPtr->objArrayPtr, objArrayBytes);
-
- p += TCL_ALIGN(objArrayBytes);
- codePtr->excRangeArrayPtr = (ExceptionRange *) p;
- memcpy((VOID *) p, (VOID *) envPtr->excRangeArrayPtr, rangeArrayBytes);
-
- p += TCL_ALIGN(rangeArrayBytes);
- codePtr->cmdMapPtr = (CmdLocation *) p;
- memcpy((VOID *) p, (VOID *) envPtr->cmdMapPtr, cmdLocBytes);
- p += TCL_ALIGN(cmdLocBytes);
- codePtr->auxDataArrayPtr = (AuxData *) p;
- memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr, auxDataArrayBytes);
+ p += TCL_ALIGN(objArrayBytes); /* align exception range array */
+ if (exceptArrayBytes > 0) {
+ codePtr->excRangeArrayPtr = (ExceptionRange *) p;
+ memcpy((VOID *) p, (VOID *) envPtr->excRangeArrayPtr,
+ exceptArrayBytes);
+ }
+
+ p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
+ if (auxDataArrayBytes > 0) {
+ codePtr->auxDataArrayPtr = (AuxData *) p;
+ memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr,
+ auxDataArrayBytes);
+ }
+ p += auxDataArrayBytes;
+ nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
+ if (((size_t)(nextPtr - p)) != cmdLocBytes) {
+ panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes);
+ }
+
/*
* Free the old internal rep then convert the object to a
* bytecode object by making its internal rep point to the just
@@ -1282,6 +1480,204 @@ TclInitByteCodeObj(objPtr, envPtr)
/*
*----------------------------------------------------------------------
*
+ * GetCmdLocEncodingSize --
+ *
+ * Computes the total number of bytes needed to encode the command
+ * location information for some compiled code.
+ *
+ * Results:
+ * The byte count needed to encode the compiled location information.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetCmdLocEncodingSize(envPtr)
+ CompileEnv *envPtr; /* Points to compilation environment
+ * structure containing the CmdLocation
+ * structure to encode. */
+{
+ register CmdLocation *mapPtr = envPtr->cmdMapPtr;
+ int numCmds = envPtr->numCommands;
+ int codeDelta, codeLen, srcDelta, srcLen;
+ int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext;
+ /* The offsets in their respective byte
+ * sequences where the next encoded offset
+ * or length should go. */
+ int prevCodeOffset, prevSrcOffset, i;
+
+ codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0;
+ prevCodeOffset = prevSrcOffset = 0;
+ for (i = 0; i < numCmds; i++) {
+ codeDelta = (mapPtr[i].codeOffset - prevCodeOffset);
+ if (codeDelta < 0) {
+ panic("GetCmdLocEncodingSize: bad code offset");
+ } else if (codeDelta <= 127) {
+ codeDeltaNext++;
+ } else {
+ codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */
+ }
+ prevCodeOffset = mapPtr[i].codeOffset;
+
+ codeLen = mapPtr[i].numCodeBytes;
+ if (codeLen < 0) {
+ panic("GetCmdLocEncodingSize: bad code length");
+ } else if (codeLen <= 127) {
+ codeLengthNext++;
+ } else {
+ codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
+ }
+
+ srcDelta = (mapPtr[i].srcOffset - prevSrcOffset);
+ if ((-127 <= srcDelta) && (srcDelta <= 127)) {
+ srcDeltaNext++;
+ } else {
+ srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */
+ }
+ prevSrcOffset = mapPtr[i].srcOffset;
+
+ srcLen = mapPtr[i].numSrcChars;
+ if (srcLen < 0) {
+ panic("GetCmdLocEncodingSize: bad source length");
+ } else if (srcLen <= 127) {
+ srcLengthNext++;
+ } else {
+ srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
+ }
+ }
+
+ return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * EncodeCmdLocMap --
+ *
+ * Encode the command location information for some compiled code into
+ * a ByteCode structure. The encoded command location map is stored as
+ * three adjacent byte sequences.
+ *
+ * Results:
+ * Pointer to the first byte after the encoded command location
+ * information.
+ *
+ * Side effects:
+ * The encoded information is stored into the block of memory headed
+ * by codePtr. Also records pointers to the start of the four byte
+ * sequences in fields in codePtr's ByteCode header structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static unsigned char *
+EncodeCmdLocMap(envPtr, codePtr, startPtr)
+ CompileEnv *envPtr; /* Points to compilation environment
+ * structure containing the CmdLocation
+ * structure to encode. */
+ ByteCode *codePtr; /* ByteCode in which to encode envPtr's
+ * command location information. */
+ unsigned char *startPtr; /* Points to the first byte in codePtr's
+ * memory block where the location
+ * information is to be stored. */
+{
+ register CmdLocation *mapPtr = envPtr->cmdMapPtr;
+ int numCmds = envPtr->numCommands;
+ register unsigned char *p = startPtr;
+ int codeDelta, codeLen, srcDelta, srcLen, prevOffset;
+ register int i;
+
+ /*
+ * Encode the code offset for each command as a sequence of deltas.
+ */
+
+ codePtr->codeDeltaStart = p;
+ prevOffset = 0;
+ for (i = 0; i < numCmds; i++) {
+ codeDelta = (mapPtr[i].codeOffset - prevOffset);
+ if (codeDelta < 0) {
+ panic("EncodeCmdLocMap: bad code offset");
+ } else if (codeDelta <= 127) {
+ TclStoreInt1AtPtr(codeDelta, p);
+ p++;
+ } else {
+ TclStoreInt1AtPtr(0xFF, p);
+ p++;
+ TclStoreInt4AtPtr(codeDelta, p);
+ p += 4;
+ }
+ prevOffset = mapPtr[i].codeOffset;
+ }
+
+ /*
+ * Encode the code length for each command.
+ */
+
+ codePtr->codeLengthStart = p;
+ for (i = 0; i < numCmds; i++) {
+ codeLen = mapPtr[i].numCodeBytes;
+ if (codeLen < 0) {
+ panic("EncodeCmdLocMap: bad code length");
+ } else if (codeLen <= 127) {
+ TclStoreInt1AtPtr(codeLen, p);
+ p++;
+ } else {
+ TclStoreInt1AtPtr(0xFF, p);
+ p++;
+ TclStoreInt4AtPtr(codeLen, p);
+ p += 4;
+ }
+ }
+
+ /*
+ * Encode the source offset for each command as a sequence of deltas.
+ */
+
+ codePtr->srcDeltaStart = p;
+ prevOffset = 0;
+ for (i = 0; i < numCmds; i++) {
+ srcDelta = (mapPtr[i].srcOffset - prevOffset);
+ if ((-127 <= srcDelta) && (srcDelta <= 127)) {
+ TclStoreInt1AtPtr(srcDelta, p);
+ p++;
+ } else {
+ TclStoreInt1AtPtr(0xFF, p);
+ p++;
+ TclStoreInt4AtPtr(srcDelta, p);
+ p += 4;
+ }
+ prevOffset = mapPtr[i].srcOffset;
+ }
+
+ /*
+ * Encode the source length for each command.
+ */
+
+ codePtr->srcLengthStart = p;
+ for (i = 0; i < numCmds; i++) {
+ srcLen = mapPtr[i].numSrcChars;
+ if (srcLen < 0) {
+ panic("EncodeCmdLocMap: bad source length");
+ } else if (srcLen <= 127) {
+ TclStoreInt1AtPtr(srcLen, p);
+ p++;
+ } else {
+ TclStoreInt1AtPtr(0xFF, p);
+ p++;
+ TclStoreInt4AtPtr(srcLen, p);
+ p += 4;
+ }
+ }
+
+ return p;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileString --
*
* Compile a Tcl script in a null-terminated binary string.
@@ -1308,8 +1704,8 @@ int
TclCompileString(interp, string, lastChar, flags, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
int flags; /* Flags to control compilation (same as
* passed to Tcl_Eval). */
CompileEnv *envPtr; /* Holds resulting instructions. */
@@ -1326,7 +1722,7 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
char *cmdSrcStart = NULL; /* Points to first non-blank char in each
* command. Initialized to avoid compiler
* warning. */
- int cmdIndex = -1; /* The index of the current command in the
+ int cmdIndex; /* The index of the current command in the
* compilation environment's command
* location table. Initialized to avoid
* compiler warning. */
@@ -1379,7 +1775,7 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
if (src[1] == '\n') {
src += 2;
} else {
- break; /* no longer white space */
+ break;
}
} else {
src++;
@@ -1418,7 +1814,7 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
type = CHAR_TYPE(src, lastChar);
if ((type == TCL_COMMAND_END)
&& ((c != ']') || (flags & TCL_BRACKET_TERM))) {
- continue; /* ignore empty command; restart outer cmd loop */
+ continue; /* empty command; restart outer cmd loop */
}
/*
@@ -1449,45 +1845,42 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
* of compilation procedures. If a word other than the first is
* simple and represents an integer whose formatted representation
* is the same as the word, just push an integer object. Also record
- * starting source and object information for the command if we are
- * at the top level (i.e. we were called directly from
- * SetByteCodeFromAny and are not compiling a substring enclosed in
- * square brackets).
+ * starting source and object information for the command.
*/
cmdSrcStart = src;
cmdCodeOffset = (envPtr->codeNext - envPtr->codeStart);
cmdWords = 0;
- if (!(flags & TCL_BRACKET_TERM)) {
- envPtr->numCommands++;
- cmdIndex = (envPtr->numCommands - 1);
- EnterCmdStartData(envPtr, cmdIndex,
- (cmdSrcStart - envPtr->source), cmdCodeOffset);
+
+ envPtr->numCommands++;
+ cmdIndex = (envPtr->numCommands - 1);
+ EnterCmdStartData(envPtr, cmdIndex,
+ (cmdSrcStart - envPtr->source), cmdCodeOffset);
- if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
- /*
- * Display a line summarizing the top level command we
- * are about to compile.
- */
-
- char *p = cmdSrcStart;
- int numChars;
- char *ellipsis = "";
-
- while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)
- || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) {
- p++;
- }
- numChars = (p - cmdSrcStart);
- if (numChars > 60) {
- numChars = 60;
- ellipsis = " ...";
- } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) {
- ellipsis = " ...";
- }
- fprintf(stdout, "Compiling: %.*s%s\n",
- numChars, cmdSrcStart, ellipsis);
+ if ((!(flags & TCL_BRACKET_TERM))
+ && (tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
+ /*
+ * Display a line summarizing the top level command we are about
+ * to compile.
+ */
+
+ char *p = cmdSrcStart;
+ int numChars, complete;
+
+ while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)
+ || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) {
+ p++;
+ }
+ numChars = (p - cmdSrcStart);
+ complete = 1;
+ if (numChars > 60) {
+ numChars = 60;
+ complete = 0;
+ } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) {
+ complete = 0;
}
+ fprintf(stdout, "Compiling: %.*s%s\n",
+ numChars, cmdSrcStart, (complete? "" : " ..."));
}
while ((type != TCL_COMMAND_END)
@@ -1502,7 +1895,7 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
if (src[1] == '\n') {
src += 2;
} else {
- break; /* no longer white space */
+ break;
}
} else {
src++;
@@ -1520,9 +1913,9 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
* avoid an extra procedure call.
*/
- envPtr->pushSimpleWords = 0; /* we will handle simple words */
+ envPtr->pushSimpleWords = 0;
if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- src++; /* advance over the " or { */
+ src++;
if (type == TCL_QUOTE) {
result = TclCompileQuotes(interp, src, lastChar,
'"', flags, envPtr);
@@ -1590,18 +1983,29 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
* traces). Look up the first word in the interpreter's
* hashtable of commands. If a compilation procedure is
* found, let it compile the command after resetting
- * error logging information.
+ * error logging information. Note that if we are
+ * compiling a procedure, we must look up the command
+ * in the procedure's namespace and not the current
+ * namespace.
*/
+ Namespace *cmdNsPtr;
+
+ if (envPtr->procPtr != NULL) {
+ cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
+ } else {
+ cmdNsPtr = NULL;
+ }
+
cmdPtr = NULL;
cmd = Tcl_FindCommand(interp, src,
- (Tcl_Namespace *) NULL, /*flags*/ 0);
+ (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
if (cmd != (Tcl_Command) NULL) {
cmdPtr = (Command *) cmd;
}
if ((cmdPtr != NULL) && (cmdPtr->compileProc != NULL)) {
char *firstArg = termPtr;
- src[numChars] = savedChar; /* restore chr */
+ src[numChars] = savedChar;
iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS
| ERROR_CODE_SET);
result = (*(cmdPtr->compileProc))(interp,
@@ -1609,9 +2013,9 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
if (result == TCL_OK) {
src = (firstArg + envPtr->termOffset);
maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- goto finishCommand; /* done with command */
+ goto finishCommand;
} else if (result == TCL_OUT_LINE_COMPILE) {
- result = TCL_OK; /* reset result */
+ result = TCL_OK;
src[numChars] = '\0';
} else {
src = firstArg;
@@ -1652,8 +2056,9 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
resPtr->refNsCmdEpoch = nsPtr->cmdRefEpoch;
resPtr->cmdEpoch = cmdPtr->cmdEpoch;
resPtr->refCount = 1;
- objPtr->internalRep.otherValuePtr =
- (VOID *) resPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 =
+ (VOID *) resPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
cmdPtr->refCount++;
}
@@ -1671,7 +2076,8 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
char buf[40];
if (TclLooksLikeInt(src)) {
- if (TclGetLong(interp, src, &n) == TCL_OK) {
+ int code = TclGetLong(interp, src, &n);
+ if (code == TCL_OK) {
TclFormatInt(buf, n);
if (strcmp(src, buf) == 0) {
isCompilableInt = 1;
@@ -1684,6 +2090,8 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
objPtr->internalRep.longValue = n;
objPtr->typePtr = &tclIntType;
}
+ } else {
+ Tcl_ResetResult(interp);
}
}
if (!isCompilableInt) {
@@ -1691,7 +2099,7 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
}
}
- src[numChars] = savedChar; /* restore the saved char */
+ src[numChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth = TclMax((cmdWords + 1), maxDepth);
} else { /* not a simple word */
@@ -1709,13 +2117,6 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
* was found for the command we called it and skipped this.
*/
-#ifdef TCL_COMPILE_DEBUG
- if ((cmdWords < 0) || (cmdWords > 10000)) {
- fprintf(stderr, "\nTclCompileString: bad cmdWords value %d\n",
- cmdWords);
- panic("TclCompileString: bad cmdWords value %d");
- }
-#endif /*TCL_COMPILE_DEBUG*/
if (cmdWords > 0) {
if (cmdWords <= 255) {
TclEmitInstUInt1(INST_INVOKE_STK1, cmdWords, envPtr);
@@ -1726,18 +2127,13 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
/*
* Update the compilation environment structure. Record
- * source/object information for the command if we are at the top
- * level (i.e. we we called directly from SetByteCodeFromAny and are
- * not compiling a substring enclosed in square brackets).
+ * source/object information for the command.
*/
finishCommand:
- if (!(flags & TCL_BRACKET_TERM)) {
- int cmdSrcChars = (src - cmdSrcStart);
- cmdCodeBytes =
- (envPtr->codeNext - envPtr->codeStart - cmdCodeOffset);
- EnterCmdExtentData(envPtr, cmdIndex, cmdSrcChars, cmdCodeBytes);
- }
+ cmdCodeBytes = envPtr->codeNext - envPtr->codeStart - cmdCodeOffset;
+ EnterCmdExtentData(envPtr, cmdIndex, src-cmdSrcStart, cmdCodeBytes);
+
isFirstCmd = 0;
envPtr->termOffset = (src - string);
c = *src;
@@ -1754,7 +2150,7 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0,
/*inHeap*/ 0, envPtr);
TclEmitPush(objIndex, envPtr);
- maxDepth = 1; /* we pushed 1 word for the empty string */
+ maxDepth = 1;
}
} else {
/*
@@ -1762,8 +2158,8 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
* where the error occurred.
*/
- int numChars;
register char *p;
+ int numChars;
char buf[200];
iPtr->errorLine = 1;
@@ -1780,14 +2176,22 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
/*
* Figure out how much of the command to print (up to a certain
- * number of characters, or up to the first newline).
+ * number of characters, or up to the end of the command).
*/
- numChars = (src - cmdSrcStart);
+ p = cmdSrcStart;
+ while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)
+ || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) {
+ p++;
+ }
+ numChars = (p - cmdSrcStart);
if (numChars > 150) {
numChars = 150;
ellipsis = " ...";
+ } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) {
+ ellipsis = " ...";
}
+
sprintf(buf, "\n while compiling\n\"%.*s%s\"",
numChars, cmdSrcStart, ellipsis);
Tcl_AddObjErrorInfo(interp, buf, -1);
@@ -1902,7 +2306,7 @@ CompileWord(interp, string, lastChar, flags, envPtr)
*/
if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- src++; /* advance over the " or { */
+ src++;
if (type == TCL_QUOTE) {
result = TclCompileQuotes(interp, src, lastChar, '"', flags,
envPtr);
@@ -2080,7 +2484,7 @@ CompileMultipartWord(interp, string, lastChar, flags, envPtr)
if (src[1] == '\n') {
src += numRead;
type = TCL_SPACE; /* force word end */
- break; /* exit loop: \newline is word separator */
+ break;
}
src += numRead;
} else {
@@ -2131,7 +2535,7 @@ CompileMultipartWord(interp, string, lastChar, flags, envPtr)
if (*p == '\\') {
*dst = Tcl_Backslash(p, &numRead);
if (p[1] == '\n') {
- break; /* end of word */
+ break;
}
p += numRead;
dst++;
@@ -2146,7 +2550,7 @@ CompileMultipartWord(interp, string, lastChar, flags, envPtr)
objIndex = TclObjIndexForString(start, numChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
}
- start[numChars] = savedChar; /* restore the saved char */
+ start[numChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth = TclMax((numParts + 1), maxDepth);
} else if (type == TCL_DOLLAR) {
@@ -2167,7 +2571,7 @@ CompileMultipartWord(interp, string, lastChar, flags, envPtr)
(flags | TCL_BRACKET_TERM), envPtr);
termPtr = (src + envPtr->termOffset);
if (*termPtr == ']') {
- termPtr++; /* advance over the ']'. */
+ termPtr++;
} else if (*termPtr == '\0') {
/*
* Missing ] at end of nested command.
@@ -2327,7 +2731,7 @@ TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr)
(flags | TCL_BRACKET_TERM), envPtr);
termPtr = (src + envPtr->termOffset);
if (*termPtr == ']') {
- termPtr++; /* advance over the ']'. */
+ termPtr++;
}
src = termPtr;
if (result != TCL_OK) {
@@ -2384,7 +2788,7 @@ TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr)
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
result = TCL_ERROR;
} else {
- src++; /* advance over termChar */
+ src++;
}
envPtr->wordIsSimple = 1;
envPtr->numSimpleWordChars = (src - string - 1);
@@ -2425,7 +2829,7 @@ TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr)
objIndex = TclObjIndexForString(start, numChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
}
- start[numChars] = savedChar; /* restore the saved char */
+ start[numChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth = TclMax((numParts + 1), maxDepth);
}
@@ -2445,7 +2849,7 @@ TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr)
result = TCL_ERROR;
goto done;
} else {
- src++; /* advance over termChar */
+ src++;
}
if (numParts == 0) {
@@ -2577,8 +2981,7 @@ CompileBraces(interp, string, lastChar, flags, envPtr)
--level;
if (level == 0) {
src++;
- last = (src - 2); /* i.e. point just before
- * terminating } */
+ last = (src - 2); /* point just before terminating } */
break;
}
} else if (c == '\\') {
@@ -2645,7 +3048,7 @@ CompileBraces(interp, string, lastChar, flags, envPtr)
objIndex = TclObjIndexForString(string, numChars, /*allocStrRep*/ 1,
/*inHeap*/ 0, envPtr);
}
- string[numChars] = savedChar; /* restore the saved char */
+ string[numChars] = savedChar;
TclEmitPush(objIndex, envPtr);
done:
@@ -2755,7 +3158,7 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
char *p;
- src++; /* advance over the '{'. */
+ src++;
name = src;
c = *src;
while (c != '}') {
@@ -2788,9 +3191,9 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
if (c == ':') {
if (*(src+1) == ':') {
nameHasNsSeparators = 1;
- src += 2; /* skip over the initial :: */
+ src += 2;
while (*src == ':') {
- src++; /* skip over a subsequent : */
+ src++;
}
c = *src;
} else {
@@ -2826,11 +3229,11 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
if (!isArrayRef) { /* scalar reference */
if ((envPtr->procPtr == NULL) || nameHasNsSeparators) {
- savedChar = name[nameChars]; /* save char just after name */
+ savedChar = name[nameChars];
name[nameChars] = '\0';
objIndex = TclObjIndexForString(name, nameChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar; /* restore the saved char */
+ name[nameChars] = savedChar;
TclEmitPush(objIndex, envPtr);
TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
maxDepth = 1;
@@ -2846,11 +3249,11 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
}
maxDepth = 0;
} else {
- savedChar = name[nameChars]; /* save char after name */
+ savedChar = name[nameChars];
name[nameChars] = '\0';
objIndex = TclObjIndexForString(name, nameChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar; /* restore the saved char */
+ name[nameChars] = savedChar;
TclEmitPush(objIndex, envPtr);
TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
maxDepth = 1;
@@ -2858,11 +3261,11 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
}
} else { /* array reference */
if ((envPtr->procPtr == NULL) || nameHasNsSeparators) {
- savedChar = name[nameChars]; /* save char after name */
+ savedChar = name[nameChars];
name[nameChars] = '\0';
objIndex = TclObjIndexForString(name, nameChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar; /* restore the saved char */
+ name[nameChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth = 1;
} else {
@@ -2870,11 +3273,11 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
/*createIfNew*/ 0, /*flagsIfCreated*/ 0,
envPtr->procPtr);
if (localIndex < 0) {
- savedChar = name[nameChars]; /* save char after name */
+ savedChar = name[nameChars];
name[nameChars] = '\0';
objIndex = TclObjIndexForString(name, nameChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar; /* restore the saved char */
+ name[nameChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth = 1;
}
@@ -2885,11 +3288,11 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
* just as is done for quoted strings.
*/
- src++; /* advance over the '(' */
+ src++;
envPtr->pushSimpleWords = 1;
result = TclCompileQuotes(interp, src, lastChar, ')', flags,
envPtr);
- src += envPtr->termOffset; /* advance beyond the terminating ) */
+ src += envPtr->termOffset;
if (result != TCL_OK) {
char msg[200];
sprintf(msg, "\n (parsing index for array \"%.*s\")",
@@ -3122,7 +3525,7 @@ TclCompileCatchCmd(interp, string, lastChar, flags, envPtr)
if (*p == '(') {
if (*lastChar == ')') { /* we have an array element */
result = TCL_OUT_LINE_COMPILE;
- goto done; /* only scalar loop vars for now */
+ goto done;
}
}
p++;
@@ -3165,11 +3568,11 @@ TclCompileCatchCmd(interp, string, lastChar, flags, envPtr)
bodyStart = argInfo.startArray[0];
bodyEnd = argInfo.endArray[0];
- savedChar = *(bodyEnd+1); /* save char after body */
+ savedChar = *(bodyEnd+1);
*(bodyEnd+1) = '\0';
result = CompileCmdWordInline(interp, bodyStart, (bodyEnd+1),
flags, envPtr);
- *(bodyEnd+1) = savedChar; /* restore the saved char */
+ *(bodyEnd+1) = savedChar;
if (result != TCL_OK) {
if (result == TCL_ERROR) {
@@ -3199,7 +3602,7 @@ TclCompileCatchCmd(interp, string, lastChar, flags, envPtr)
TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr);
}
}
- TclEmitOpcode(INST_POP, envPtr); /* pop the result */
+ TclEmitOpcode(INST_POP, envPtr);
objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, /*inHeap*/ 0,
envPtr);
@@ -3224,14 +3627,7 @@ TclCompileCatchCmd(interp, string, lastChar, flags, envPtr)
* catch's error target.
*/
-#ifdef TCL_COMPILE_DEBUG
- if (envPtr->excRangeArrayPtr[range].type != CATCH_EXCEPTION_RANGE) {
- panic("TclCompileCatchCmd: bad body ExceptionRange type %d\n",
- envPtr->excRangeArrayPtr[range].type);
- }
-#endif /*TCL_COMPILE_DEBUG*/
envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset();
-
if (localIndex != -1) {
TclEmitOpcode(INST_PUSH_RESULT, envPtr);
if (localIndex <= 255) {
@@ -3239,7 +3635,7 @@ TclCompileCatchCmd(interp, string, lastChar, flags, envPtr)
} else {
TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr);
}
- TclEmitOpcode(INST_POP, envPtr); /* pop the result */
+ TclEmitOpcode(INST_POP, envPtr);
}
TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
@@ -3405,6 +3801,7 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
char c;
int savePushSimpleWords = envPtr->pushSimpleWords;
int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;
+ int saveExprIsComparison = envPtr->exprIsComparison;
/*
* Scan the words of the command and record the start and finish of
@@ -3458,10 +3855,10 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
* Simple case: a single argument word in {}'s.
*/
- *wordEnd = '\0'; /* temporarily replace the '}' by a null */
+ *wordEnd = '\0';
result = TclCompileExpr(interp, (wordStart + 1), wordEnd,
flags, envPtr);
- *wordEnd = '}'; /* restore the '}' */
+ *wordEnd = '}';
envPtr->termOffset = (wordEnd + 1) - string;
envPtr->pushSimpleWords = savePushSimpleWords;
@@ -3529,7 +3926,7 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
envPtr->excRangeDepth++;
envPtr->maxExcRangeDepth =
- TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
+ TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr);
TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr);
@@ -3539,23 +3936,36 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
savedChar = *(last + 1);
- *(last + 1) = '\0'; /* replace term. char with null */
+ *(last + 1) = '\0';
result = TclCompileExpr(interp, first, last + 1, flags, envPtr);
- *(last + 1) = savedChar; /* restore the saved char */
+ *(last + 1) = savedChar;
maxDepth = envPtr->maxStackDepth;
envPtr->excRangeArrayPtr[range].numCodeBytes =
- TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
+ TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
- if ((envPtr->exprIsJustVarRef) || (result != TCL_OK)) {
+ if ((result != TCL_OK) || (envPtr->exprIsJustVarRef)
+ || (envPtr->exprIsComparison)) {
/*
- * We must call the expr command at runtime since the expression
- * consisted of just a single variable reference (and a second
- * round of substitutions might be needed) or there was a
- * compilation error. Delete the inline code by backing up the
- * code pc and catch index. Note that if there was a compilation
- * error, we can't report the error yet since the expression
- * might be valid after the second round of substitutions.
+ * We must call the expr command at runtime. Either there was a
+ * compilation error or the inline code might fail to give the
+ * correct 2 level substitution semantics.
+ *
+ * The latter can happen if the expression consisted of just a
+ * single variable reference or if the top-level operator in the
+ * expr is a comparison (which might operate on strings). In the
+ * latter case, the expression's code might execute (apparently)
+ * successfully but produce the wrong result. We depend on its
+ * execution failing if a second level of substitutions is
+ * required. This causes the "catch" code we generate around the
+ * inline code to back off to a call on the expr command at
+ * runtime, and this always gives the right 2 level substitution
+ * semantics.
+ *
+ * We delete the inline code by backing up the code pc and catch
+ * index. Note that if there was a compilation error, we can't
+ * report the error yet since the expression might be valid
+ * after the second round of substitutions.
*/
envPtr->codeNext = (envPtr->codeStart + startCodeOffset);
@@ -3579,10 +3989,10 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
wordStart = argInfo.startArray[i];
wordEnd = argInfo.endArray[i];
savedChar = *(wordEnd + 1);
- *(wordEnd + 1) = '\0'; /* replace term. char with null */
+ *(wordEnd + 1) = '\0';
envPtr->pushSimpleWords = 1;
result = CompileWord(interp, wordStart, wordEnd+1, flags, envPtr);
- *(wordEnd + 1) = savedChar; /* restore the saved char */
+ *(wordEnd + 1) = savedChar;
if (result != TCL_OK) {
break;
}
@@ -3620,13 +4030,6 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
* target since it, being after the jump, also moved down.
*/
-#ifdef TCL_COMPILE_DEBUG
- if (envPtr->excRangeArrayPtr[range].type != CATCH_EXCEPTION_RANGE) {
- panic("TclCompileExprCmd: bad body ExceptionRange type %d\n",
- envPtr->excRangeArrayPtr[range].type);
- }
-#endif /* TCL_COMPILE_DEBUG */
-
envPtr->excRangeArrayPtr[range].catchOffset += 3;
}
}
@@ -3643,6 +4046,7 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
}
envPtr->pushSimpleWords = savePushSimpleWords;
envPtr->exprIsJustVarRef = saveExprIsJustVarRef;
+ envPtr->exprIsComparison = saveExprIsComparison;
envPtr->maxStackDepth = maxDepth;
FreeArgInfo(&argInfo);
return result;
@@ -3849,13 +4253,6 @@ TclCompileForCmd(interp, string, lastChar, flags, envPtr)
jumpBackOffset = TclCurrCodeOffset();
jumpBackDist = (jumpBackOffset - testCodeOffset);
-#ifdef TCL_COMPILE_DEBUG
- if (jumpBackDist > MAX_JUMP_DIST) {
- fprintf(stderr, "\nTclCompileForCmd: bad distance %u for unconditional jump\n",
- jumpBackDist);
- panic("TclCompileForCmd: bad distance for unconditional jump");
- }
-#endif /*TCL_COMPILE_DEBUG*/
if (jumpBackDist > 120) {
TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
} else {
@@ -3878,12 +4275,6 @@ TclCompileForCmd(interp, string, lastChar, flags, envPtr)
* record since it also moved down.
*/
-#ifdef TCL_COMPILE_DEBUG
- if (envPtr->excRangeArrayPtr[range1].type != LOOP_EXCEPTION_RANGE) {
- panic("TclCompileForCmd: bad body ExceptionRange type %d\n",
- envPtr->excRangeArrayPtr[range1].type);
- }
-#endif /* TCL_COMPILE_DEBUG */
envPtr->excRangeArrayPtr[range1].codeOffset += 3;
envPtr->excRangeArrayPtr[range1].continueOffset += 3;
envPtr->excRangeArrayPtr[range2].codeOffset += 3;
@@ -3911,12 +4302,6 @@ TclCompileForCmd(interp, string, lastChar, flags, envPtr)
* is the loop's break target.
*/
-#ifdef TCL_COMPILE_DEBUG
- if (envPtr->excRangeArrayPtr[range1].type != LOOP_EXCEPTION_RANGE) {
- panic("TclCompileForCmd: bad body ExceptionRange type %d\n",
- envPtr->excRangeArrayPtr[range1].type);
- }
-#endif /* TCL_COMPILE_DEBUG */
envPtr->excRangeArrayPtr[range1].breakOffset =
envPtr->excRangeArrayPtr[range2].breakOffset = TclCurrCodeOffset();
@@ -3928,7 +4313,7 @@ TclCompileForCmd(interp, string, lastChar, flags, envPtr)
envPtr);
TclEmitPush(objIndex, envPtr);
if (maxDepth == 0) {
- maxDepth = 1; /* since we just pushed one object */
+ maxDepth = 1;
}
done:
@@ -4104,11 +4489,11 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
* NOTE: THIS NEEDS TO BE CONVERTED TO AN OBJECT LIST.
*/
- savedChar = *(varListEnd+1); /* save char after var list */
+ savedChar = *(varListEnd+1);
*(varListEnd+1) = '\0';
result = Tcl_SplitList(interp, varListStart,
&varcList[i], &varvList[i]);
- *(varListEnd+1) = savedChar; /* restore the saved char */
+ *(varListEnd+1) = savedChar;
if (result != TCL_OK) {
goto done;
}
@@ -4135,7 +4520,7 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
q--;
if (*q == ')') { /* we have an array element */
result = TCL_OUT_LINE_COMPILE;
- goto done; /* only scalar loop vars for now */
+ goto done;
}
}
p++;
@@ -4224,7 +4609,7 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
} else {
TclEmitInstUInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
}
- TclEmitOpcode(INST_POP, envPtr); /* no longer need list on the stk */
+ TclEmitOpcode(INST_POP, envPtr);
}
/*
@@ -4257,12 +4642,12 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
bodyStart = argInfo.startArray[numWords - 1];
bodyEnd = argInfo.endArray[numWords - 1];
- savedChar = *(bodyEnd+1); /* save char after body */
+ savedChar = *(bodyEnd+1);
*(bodyEnd+1) = '\0';
envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
result = CompileCmdWordInline(interp, bodyStart, bodyEnd+1, flags,
envPtr);
- *(bodyEnd+1) = savedChar; /* restore the saved char */
+ *(bodyEnd+1) = savedChar;
if (result != TCL_OK) {
if (result == TCL_ERROR) {
char msg[60];
@@ -4293,12 +4678,6 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
jumpBackOffset = TclCurrCodeOffset();
jumpBackDist =
(jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset);
-#ifdef TCL_COMPILE_DEBUG
- if (jumpBackDist > MAX_JUMP_DIST) {
- fprintf(stderr, "\nTclCompileForeachCmd: bad distance %u for unconditional jump\n", jumpBackDist);
- panic("TclCompileForeachCmd: bad distance for unconditional jump");
- }
-#endif /*TCL_COMPILE_DEBUG*/
if (jumpBackDist > 120) {
TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
} else {
@@ -4318,12 +4697,6 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
* Update the loop body's starting PC offset since it moved down.
*/
-#ifdef TCL_COMPILE_DEBUG
- if (envPtr->excRangeArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
- panic("TclCompileForeachCmd: bad body ExceptionRange type %d\n",
- envPtr->excRangeArrayPtr[range].type);
- }
-#endif /*TCL_COMPILE_DEBUG*/
envPtr->excRangeArrayPtr[range].codeOffset += 3;
/*
@@ -4349,12 +4722,6 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
* break target.
*/
-#ifdef TCL_COMPILE_DEBUG
- if (envPtr->excRangeArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
- panic("TclCompileForeachCmd: bad body ExceptionRange type %d\n",
- envPtr->excRangeArrayPtr[range].type);
- }
-#endif /*TCL_COMPILE_DEBUG*/
envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset();
/*
@@ -4365,7 +4732,7 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
envPtr);
TclEmitPush(objIndex, envPtr);
if (maxDepth == 0) {
- maxDepth = 1; /* since we just pushed one object */
+ maxDepth = 1;
}
done:
@@ -4541,7 +4908,7 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
* a script to execute if the expression is true.
*/
- AdvanceToNextWord(src, envPtr); /* make sure there is a next word */
+ AdvanceToNextWord(src, envPtr);
src += envPtr->termOffset;
type = CHAR_TYPE(src, lastChar);
if (type == TCL_COMMAND_END) {
@@ -4557,7 +4924,7 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
*/
testSrcStart = src;
- envPtr->pushSimpleWords = 1; /* process words normally */
+ envPtr->pushSimpleWords = 1;
result = CompileExprWord(interp, src, lastChar, flags, envPtr);
if (result != TCL_OK) {
if (result == TCL_ERROR) {
@@ -4602,7 +4969,7 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
if ((*src == 't') && (strncmp(src, "then", 4) == 0)) {
type = CHAR_TYPE(src+4, lastChar);
if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
- src += 4; /* skip over the "then" */
+ src += 4;
AdvanceToNextWord(src, envPtr);
src += envPtr->termOffset;
type = CHAR_TYPE(src, lastChar);
@@ -4623,7 +4990,10 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr);
if (result != TCL_OK) {
if (result == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp, "\n (\"if\" body script)", -1);
+ char msg[60];
+ sprintf(msg, "\n (\"if\" then script line %d)",
+ interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
}
goto done;
}
@@ -4676,7 +5046,7 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
&& ((*src == 'e') && (strncmp(src, "elseif", 6) == 0))) {
type = CHAR_TYPE(src+6, lastChar);
if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
- src += 6; /* skip over the "elseif" */
+ src += 6;
AdvanceToNextWord(src, envPtr);
src += envPtr->termOffset;
type = CHAR_TYPE(src, lastChar);
@@ -4690,7 +5060,7 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
continue; /* continue the "expr then body" loop */
}
}
- break; /* exit the loop */
+ break;
} /* end of the "expr then body" loop */
/*
@@ -4702,7 +5072,7 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
if ((*src == 'e') && (strncmp(src, "else", 4) == 0)) {
type = CHAR_TYPE(src+4, lastChar);
if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
- src += 4; /* skip over the "else" */
+ src += 4;
AdvanceToNextWord(src, envPtr);
src += envPtr->termOffset;
type = CHAR_TYPE(src, lastChar);
@@ -4723,7 +5093,10 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr);
if (result != TCL_OK) {
if (result == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp, "\n (\"if\" else script)", -1);
+ char msg[60];
+ sprintf(msg, "\n (\"if\" else script line %d)",
+ interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
}
goto done;
}
@@ -4780,13 +5153,13 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
ifFalsePc = (envPtr->codeStart + jumpFalseFixupArray.fixup[jumpIndex].codeOffset);
opCode = *ifFalsePc;
if (opCode == INST_JUMP_FALSE1) {
- jumpFalseDist = TclGetInt1AtPc(ifFalsePc + 1);
+ jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
jumpFalseDist += 3;
- TclUpdateInt1AtPc(jumpFalseDist, (ifFalsePc + 1));
+ TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
} else if (opCode == INST_JUMP_FALSE4) {
- jumpFalseDist = TclGetInt4AtPc(ifFalsePc + 1);
+ jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
jumpFalseDist += 3;
- TclUpdateInt4AtPc(jumpFalseDist, (ifFalsePc + 1));
+ TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
} else {
panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump");
}
@@ -4886,7 +5259,7 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
* an optional "elName". Otherwise, if not simple, just push the name.
*/
- AdvanceToNextWord(src, envPtr); /* make sure there is a next word */
+ AdvanceToNextWord(src, envPtr);
src += envPtr->termOffset;
type = CHAR_TYPE(src, lastChar);
if (type == TCL_COMMAND_END) {
@@ -4898,7 +5271,7 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
goto done;
}
- envPtr->pushSimpleWords = 0; /* we will process the varName */
+ envPtr->pushSimpleWords = 0;
result = CompileWord(interp, src, lastChar, flags, envPtr);
if (result != TCL_OK) {
goto done;
@@ -4908,7 +5281,7 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
name = src;
nameChars = envPtr->numSimpleWordChars;
if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- name++; /* advance over the " or { */
+ name++;
}
elName = NULL;
elNameChars = 0;
@@ -4955,11 +5328,11 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
if (simpleVarName) {
if (procPtr == NULL) {
- savedChar = name[nameChars]; /* save char after name */
+ savedChar = name[nameChars];
name[nameChars] = '\0';
objIndex = TclObjIndexForString(name, nameChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar; /* restore the saved char */
+ name[nameChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth = 1;
} else {
@@ -4970,11 +5343,11 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
if (localIndex > 255) { /* we'll push the name */
localIndex = -1;
}
- savedChar = name[nameChars]; /* save char after name */
+ savedChar = name[nameChars];
name[nameChars] = '\0';
objIndex = TclObjIndexForString(name, nameChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar; /* restore the saved char */
+ name[nameChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth = 1;
} else {
@@ -4988,12 +5361,12 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
* substitutions on it, just as is done for quoted strings.
*/
- savedChar = elName[elNameChars]; /* save char after elName */
+ savedChar = elName[elNameChars];
elName[elNameChars] = '\0';
envPtr->pushSimpleWords = 1;
result = TclCompileQuotes(interp, elName, elName+elNameChars,
0, flags, envPtr);
- elName[elNameChars] = savedChar; /* restore the saved char */
+ elName[elNameChars] = savedChar;
if (result != TCL_OK) {
char msg[200];
sprintf(msg, "\n (parsing index for array \"%.*s\")",
@@ -5011,17 +5384,17 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
if (incrementGiven) {
type = CHAR_TYPE(src, lastChar);
- envPtr->pushSimpleWords = 0; /* we will handle simple words */
+ envPtr->pushSimpleWords = 0;
result = CompileWord(interp, src, lastChar, flags, envPtr);
if (result != TCL_OK) {
if (result == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp,
- "\n (reading increment)", -1);
+ "\n (increment expression)", -1);
}
goto done;
}
if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- src++; /* advance over the " or { */
+ src++;
}
if (envPtr->wordIsSimple) {
/*
@@ -5040,7 +5413,8 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
src[numChars] = '\0';
if (TclLooksLikeInt(src)) {
- if (TclGetLong(interp, src, &n) == TCL_OK) {
+ int code = TclGetLong(interp, src, &n);
+ if (code == TCL_OK) {
if ((-127 <= n) && (n <= 127)) {
isCompilableInt = 1;
isImmIncrValue = 1;
@@ -5062,6 +5436,8 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
maxDepth += 1;
}
}
+ } else {
+ Tcl_ResetResult(interp);
}
}
if (!isCompilableInt) {
@@ -5070,7 +5446,7 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
TclEmitPush(objIndex, envPtr);
maxDepth += 1;
}
- src[numChars] = savedChar; /* restore the saved char */
+ src[numChars] = savedChar;
} else {
maxDepth += envPtr->maxStackDepth;
}
@@ -5088,10 +5464,6 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
* Now emit instructions to increment the variable.
*/
- if ((localIndex >= 0) && (localIndex > 255)) {
- panic("TclCompileIncrCmd: bad localIndex %d\n", localIndex);
- return TCL_ERROR;
- }
if (simpleVarName) {
if (elName == NULL) { /* scalar */
if (localIndex >= 0) {
@@ -5146,7 +5518,7 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
src += envPtr->termOffset;
type = CHAR_TYPE(src, lastChar);
if (type != TCL_COMMAND_END) {
- goto badArgs; /* too many arguments */
+ goto badArgs;
}
}
@@ -5263,7 +5635,7 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
* runtime.
*/
- envPtr->pushSimpleWords = 0; /* we will process the varName */
+ envPtr->pushSimpleWords = 0;
result = CompileWord(interp, wordStart, argInfo.endArray[0] + 1,
flags, envPtr);
if (result != TCL_OK) {
@@ -5344,11 +5716,11 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
*/
if ((procPtr == NULL) || nameHasNsSeparators) {
- savedChar = name[nameChars]; /* save char after name */
+ savedChar = name[nameChars];
name[nameChars] = '\0';
objIndex = TclObjIndexForString(name, nameChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar; /* restore the saved char */
+ name[nameChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth = 1;
} else {
@@ -5360,11 +5732,11 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
if (localIndex >= 0) {
maxDepth = 0;
} else {
- savedChar = name[nameChars]; /* save char after name */
+ savedChar = name[nameChars];
name[nameChars] = '\0';
objIndex = TclObjIndexForString(name, nameChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar; /* restore the saved char */
+ name[nameChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth = 1;
}
@@ -5377,12 +5749,12 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
*/
if (elName != NULL) {
- savedChar = elName[elNameChars]; /* save char after elName */
+ savedChar = elName[elNameChars];
elName[elNameChars] = '\0';
envPtr->pushSimpleWords = 1;
result = TclCompileQuotes(interp, elName, elName+elNameChars,
0, flags, envPtr);
- elName[elNameChars] = savedChar; /* restore the saved char */
+ elName[elNameChars] = savedChar;
if (result != TCL_OK) {
char msg[200];
sprintf(msg, "\n (parsing index for array \"%.*s\")",
@@ -5425,13 +5797,14 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
p = wordStart;
if ((*wordStart == '"') || (*wordStart == '{')) {
- p++; /* advance over the " or { */
+ p++;
}
savedChar = p[envPtr->numSimpleWordChars];
p[envPtr->numSimpleWordChars] = '\0';
isCompilableInt = 0;
if (TclLooksLikeInt(p)) {
- if (TclGetLong(interp, p, &n) == TCL_OK) {
+ int code = TclGetLong(interp, p, &n);
+ if (code == TCL_OK) {
TclFormatInt(buf, n);
if (strcmp(p, buf) == 0) {
isCompilableInt = 1;
@@ -5444,6 +5817,8 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
objPtr->internalRep.longValue = n;
objPtr->typePtr = &tclIntType;
}
+ } else {
+ Tcl_ResetResult(interp);
}
}
if (!isCompilableInt) {
@@ -5451,7 +5826,7 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
envPtr->numSimpleWordChars, /*allocStrRep*/ 1,
/*inHeap*/ 0, envPtr);
}
- p[envPtr->numSimpleWordChars] = savedChar; /* restore char */
+ p[envPtr->numSimpleWordChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth += 1;
}
@@ -5575,7 +5950,7 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset();
- AdvanceToNextWord(src, envPtr); /* make sure there is a next word */
+ AdvanceToNextWord(src, envPtr);
src += envPtr->termOffset;
type = CHAR_TYPE(src, lastChar);
if (type == TCL_COMMAND_END) {
@@ -5605,7 +5980,7 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
* Compile the next word: the test expression.
*/
- envPtr->pushSimpleWords = 1; /* process words normally */
+ envPtr->pushSimpleWords = 1;
result = CompileExprWord(interp, src, lastChar, flags, envPtr);
if (result != TCL_OK) {
if (result == TCL_ERROR) {
@@ -5630,7 +6005,7 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
* starting PC offset and byte length in the its ExceptionRange record.
*/
- AdvanceToNextWord(src, envPtr); /* make sure there is a next word */
+ AdvanceToNextWord(src, envPtr);
src += envPtr->termOffset;
type = CHAR_TYPE(src, lastChar);
if (type == TCL_COMMAND_END) {
@@ -5670,12 +6045,6 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
jumpBackOffset = TclCurrCodeOffset();
jumpBackDist =
(jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset);
-#ifdef TCL_COMPILE_DEBUG
- if (jumpBackDist > MAX_JUMP_DIST) {
- fprintf(stderr, "\nTclCompileWhileCmd: bad distance %u for unconditional jump\n", jumpBackDist);
- panic("TclCompileWhileCmd: bad distance for unconditional jump");
- }
-#endif /*TCL_COMPILE_DEBUG*/
if (jumpBackDist > 120) {
TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
} else {
@@ -5695,12 +6064,6 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
* Update the loop body's starting PC offset since it moved down.
*/
-#ifdef TCL_COMPILE_DEBUG
- if (envPtr->excRangeArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
- panic("TclCompileWhileCmd: bad body ExceptionRange type %d\n",
- envPtr->excRangeArrayPtr[range].type);
- }
-#endif /* TCL_COMPILE_DEBUG */
envPtr->excRangeArrayPtr[range].codeOffset += 3;
/*
@@ -5726,12 +6089,6 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
* break target.
*/
-#ifdef TCL_COMPILE_DEBUG
- if (envPtr->excRangeArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
- panic("TclCompileWhileCmd: bad body ExceptionRange type %d\n",
- envPtr->excRangeArrayPtr[range].type);
- }
-#endif /* TCL_COMPILE_DEBUG */
envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset();
/*
@@ -5742,7 +6099,7 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
envPtr);
TclEmitPush(objIndex, envPtr);
if (maxDepth == 0) {
- maxDepth = 1; /* since we just pushed one object */
+ maxDepth = 1;
}
/*
@@ -5755,7 +6112,7 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
src += envPtr->termOffset;
type = CHAR_TYPE(src, lastChar);
if (type != TCL_COMMAND_END) {
- goto badArgs; /* too many arguments */
+ goto badArgs;
}
}
@@ -5827,6 +6184,7 @@ CompileExprWord(interp, string, lastChar, flags, envPtr)
char c;
int savePushSimpleWords = envPtr->pushSimpleWords;
int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;
+ int saveExprIsComparison = envPtr->exprIsComparison;
int numChars, result;
/*
@@ -5872,7 +6230,7 @@ CompileExprWord(interp, string, lastChar, flags, envPtr)
first = src+1;
src = TclWordEnd(src, lastChar, nestedCmd, NULL);
- if (*src == 0) { /* word doesn't end properly. */
+ if (*src == 0) {
goto badArgs;
}
if (*src != '}') {
@@ -5882,12 +6240,12 @@ CompileExprWord(interp, string, lastChar, flags, envPtr)
numChars = (last - first + 1);
savedChar = first[numChars];
- first[numChars] = '\0'; /* replace term. char with null */
+ first[numChars] = '\0';
result = TclCompileExpr(interp, first, first+numChars,
flags, envPtr);
- first[numChars] = savedChar; /* restore the saved char */
+ first[numChars] = savedChar;
- src++; /* advance src after terminating '}' */
+ src++;
maxDepth = envPtr->maxStackDepth;
} else {
/*
@@ -5945,24 +6303,36 @@ CompileExprWord(interp, string, lastChar, flags, envPtr)
envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
numChars = (last - first + 1);
savedChar = first[numChars];
- first[numChars] = '\0'; /* replace term. char with null */
+ first[numChars] = '\0';
result = TclCompileExpr(interp, first, first + numChars,
flags, envPtr);
- first[numChars] = savedChar; /* restore the saved char */
+ first[numChars] = savedChar;
envPtr->excRangeArrayPtr[range].numCodeBytes =
TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
- if ((envPtr->exprIsJustVarRef) || (result != TCL_OK)) {
+ if ((result != TCL_OK) || (envPtr->exprIsJustVarRef)
+ || (envPtr->exprIsComparison)) {
/*
- * We must call the expr command at runtime since the
- * expression consisted of just a single variable reference
- * (and a second round of substitutions might be needed) or
- * there was a compilation error. Delete the inline code by
- * backing up the code pc and catch index. Note that if
- * there was a compilation error, we can't report the error
- * yet since the expression might be valid after the second
- * round of substitutions.
+ * We must call the expr command at runtime. Either there
+ * was a compilation error or the inline code might fail to
+ * give the correct 2 level substitution semantics.
+ *
+ * The latter can happen if the expression consisted of just
+ * a single variable reference or if the top-level operator
+ * in the expr is a comparison (which might operate on
+ * strings). In the latter case, the expression's code might
+ * execute (apparently) successfully but produce the wrong
+ * result. We depend on its execution failing if a second
+ * level of substitutions is required. This causes the
+ * "catch" code we generate around the inline code to back
+ * off to a call on the expr command at runtime, and this
+ * always gives the right 2 level substitution semantics.
+ *
+ * We delete the inline code by backing up the code pc and
+ * catch index. Note that if there was a compilation error,
+ * we can't report the error yet since the expression might
+ * be valid after the second round of substitutions.
*/
envPtr->codeNext = (envPtr->codeStart + startCodeOffset);
@@ -6001,13 +6371,6 @@ CompileExprWord(interp, string, lastChar, flags, envPtr)
* target since it, being after the jump, also moved down.
*/
-#ifdef TCL_COMPILE_DEBUG
- if (envPtr->excRangeArrayPtr[range].type != CATCH_EXCEPTION_RANGE) {
- panic("CompileExprWord: bad body ExceptionRange type %d\n",
- envPtr->excRangeArrayPtr[range].type);
- }
-#endif /* TCL_COMPILE_DEBUG */
-
envPtr->excRangeArrayPtr[range].catchOffset += 3;
}
}
@@ -6018,6 +6381,7 @@ CompileExprWord(interp, string, lastChar, flags, envPtr)
envPtr->maxStackDepth = maxDepth;
envPtr->pushSimpleWords = savePushSimpleWords;
envPtr->exprIsJustVarRef = saveExprIsJustVarRef;
+ envPtr->exprIsComparison = saveExprIsComparison;
return result;
}
@@ -6079,8 +6443,8 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
type = CHAR_TYPE(src, lastChar);
if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- src++; /* advance over the " or { */
- envPtr->pushSimpleWords = 0; /* we process a simple word below */
+ src++;
+ envPtr->pushSimpleWords = 0;
if (type == TCL_QUOTE) {
result = TclCompileQuotes(interp, src, lastChar,
'"', flags, envPtr);
@@ -6132,7 +6496,7 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
*closeCharPos = '\0';
result = TclCompileString(interp, src, closeCharPos,
(flags & ~TCL_BRACKET_TERM), envPtr);
- *closeCharPos = savedChar; /* restore the saved char */
+ *closeCharPos = savedChar;
if (result != TCL_OK) {
goto done;
}
@@ -6168,7 +6532,7 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
Tcl_Command cmd;
Command *cmdPtr = NULL;
- int wasCompiled = 0; /* set 1 if word has compile proc. */
+ int wasCompiled = 0;
savedChar = *p;
*p = '\0';
@@ -6179,7 +6543,7 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
cmdPtr = (Command *) cmd;
}
if (cmdPtr != NULL && cmdPtr->compileProc != NULL) {
- *p = savedChar; /* restore the saved char */
+ *p = savedChar;
src = p;
iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS
| ERROR_CODE_SET);
@@ -6194,7 +6558,7 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
if (!wasCompiled) {
objIndex = TclObjIndexForString(src, p-src,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- *p = savedChar; /* restore the saved char */
+ *p = savedChar;
TclEmitPush(objIndex, envPtr);
TclEmitInstUInt1(INST_INVOKE_STK1, 1, envPtr);
src = p;
@@ -6205,7 +6569,7 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
* Push the word and call eval at runtime.
*/
- envPtr->pushSimpleWords = 1; /* process words normally */
+ envPtr->pushSimpleWords = 1;
result = CompileWord(interp, src, lastChar, flags, envPtr);
if (result != TCL_OK) {
goto done;
@@ -6312,7 +6676,7 @@ LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr)
localPtr->flags = flagsIfCreated;
localPtr->defValuePtr = NULL;
if (name != NULL) {
- strncpy(localPtr->name, name, (unsigned) nameChars);
+ memcpy((VOID *) localPtr->name, (VOID *) name, (size_t) nameChars);
}
localPtr->name[nameChars] = '\0';
procPtr->numCompiledLocals++;
@@ -6387,12 +6751,12 @@ AdvanceToNextWord(string, envPtr)
char
Tcl_Backslash(src, readPtr)
- char *src; /* Points to the backslash character of
+ CONST char *src; /* Points to the backslash character of
* a backslash sequence. */
int *readPtr; /* Fill in with number of characters read
* from src, unless NULL. */
{
- register char *p = src+1;
+ CONST char *p = src + 1;
char result;
int count;
@@ -6547,7 +6911,7 @@ TclObjIndexForString(string, length, allocStrRep, inHeap, envPtr)
if (!new) { /* already in object table and array */
objIndex = (int) Tcl_GetHashValue(hPtr);
if (inHeap) {
- ckfree(string); /* since we own the string */
+ ckfree(string);
}
return objIndex;
}
@@ -6562,17 +6926,18 @@ TclObjIndexForString(string, length, allocStrRep, inHeap, envPtr)
if (allocStrRep) {
if (inHeap) { /* use input string for obj's string rep */
objPtr->bytes = string;
- } else { /* must allocate string rep */
+ } else {
if (length > 0) {
objPtr->bytes = ckalloc((unsigned) length + 1);
- memcpy(objPtr->bytes, string, (size_t) length);
+ memcpy((VOID *) objPtr->bytes, (VOID *) string,
+ (size_t) length);
objPtr->bytes[length] = '\0';
}
}
objPtr->length = length;
} else { /* leave the string rep NULL */
if (inHeap) {
- ckfree(string); /* since we own the string */
+ ckfree(string);
}
}
@@ -6581,7 +6946,7 @@ TclObjIndexForString(string, length, allocStrRep, inHeap, envPtr)
}
objIndex = envPtr->objArrayNext;
envPtr->objArrayPtr[objIndex] = objPtr;
- Tcl_IncrRefCount(objPtr); /* since obj array now has a reference */
+ Tcl_IncrRefCount(objPtr);
envPtr->objArrayNext++;
if (hPtr) {
@@ -6754,10 +7119,16 @@ EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
envPtr->mallocedCmdMap = 1;
}
+ if (cmdIndex > 0) {
+ if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) {
+ panic("EnterCmdStartData: cmd map table not sorted by code offset");
+ }
+ }
+
cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
+ cmdLocPtr->codeOffset = codeOffset;
cmdLocPtr->srcOffset = srcOffset;
cmdLocPtr->numSrcChars = -1;
- cmdLocPtr->codeOffset = codeOffset;
cmdLocPtr->numCodeBytes = -1;
}
@@ -6766,7 +7137,7 @@ EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
*
* EnterCmdExtentData --
*
- * Registers the source and bytecode length of a command. This
+ * Registers the source and bytecode length for a command. This
* information is used at runtime to map between instruction pc and
* source locations.
*
@@ -6895,7 +7266,7 @@ CollectArgInfo(interp, string, lastChar, flags, argInfoPtr)
} else if (*src == '"') {
wordStart = src;
src = TclWordEnd(src, lastChar, nestedCmd, NULL);
- if (src == lastChar) { /* word doesn't end properly. */
+ if (src == lastChar) {
badStringTermination:
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
@@ -6905,9 +7276,9 @@ CollectArgInfo(interp, string, lastChar, flags, argInfoPtr)
prev = (src-1);
if (*src == '"') {
wordEnd = src;
- src++; /* skip over terminating '"' */
+ src++;
} else if ((*src == ';') && (*prev == '"')) {
- scanningArgs = 0; /* found a terminating ';' */
+ scanningArgs = 0;
wordEnd = prev;
} else {
goto badStringTermination;
@@ -6915,7 +7286,7 @@ CollectArgInfo(interp, string, lastChar, flags, argInfoPtr)
} else if (*src == '{') {
wordStart = src;
src = TclWordEnd(src, lastChar, nestedCmd, NULL);
- if (src == lastChar) { /* word doesn't end properly. */
+ if (src == lastChar) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"missing close-brace", -1);
@@ -6924,9 +7295,9 @@ CollectArgInfo(interp, string, lastChar, flags, argInfoPtr)
prev = (src-1);
if (*src == '}') {
wordEnd = src;
- src++; /* skip over terminating '}' */
+ src++;
} else if ((*src == ';') && (*prev == '}')) {
- scanningArgs = 0; /* found a terminating ';' */
+ scanningArgs = 0;
wordEnd = prev;
} else {
Tcl_ResetResult(interp);
@@ -6938,17 +7309,17 @@ CollectArgInfo(interp, string, lastChar, flags, argInfoPtr)
wordStart = src;
src = TclWordEnd(src, lastChar, nestedCmd, NULL);
prev = (src-1);
- if (src == lastChar) { /* word doesn't end properly. */
+ if (src == lastChar) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"missing close-bracket or close-brace", -1);
return TCL_ERROR;
} else if (*src == ';') {
- scanningArgs = 0; /* found a terminating ';' */
+ scanningArgs = 0;
wordEnd = prev;
} else {
wordEnd = src;
- src++; /* advance to char after word */
+ src++;
if ((src == lastChar) || (*src == '\n')
|| ((*src == ']') && nestedCmd)) {
scanningArgs = 0;
@@ -7378,13 +7749,6 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
int firstCmd, lastCmd, firstRange, lastRange, k;
unsigned int numBytes;
-#ifdef TCL_COMPILE_DEBUG
- if (jumpDist > MAX_JUMP_DIST) {
- fprintf(stderr, "\nTclFixupForwardJump: bad jump distance %u\n", jumpDist);
- panic("TclFixupForwardJump: bad jump distance");
- }
-#endif /*TCL_COMPILE_DEBUG*/
-
if (jumpDist <= distThreshold) {
jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
switch (jumpFixupPtr->jumpType) {
@@ -7398,7 +7762,7 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc);
break;
}
- return 0; /* no need to grow the jump */
+ return 0;
}
/*
diff --git a/contrib/tcl/generic/tclCompile.h b/contrib/tcl/generic/tclCompile.h
index 65bbe42..6dc3f03 100644
--- a/contrib/tcl/generic/tclCompile.h
+++ b/contrib/tcl/generic/tclCompile.h
@@ -6,7 +6,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCompile.h 1.33 97/05/02 13:12:43
+ * SCCS: @(#) tclCompile.h 1.37 97/08/07 19:11:50
*/
#ifndef _TCLCOMPILATION
@@ -55,11 +55,29 @@ extern int tclTraceCompile;
extern int tclTraceExec;
/*
- * The number of bytecode compilations.
+ * The number of bytecode compilations and various other compilation-related
+ * statistics. The tclByteCodeCount and tclSourceCount arrays are used to
+ * hold the count of ByteCodes and sources whose sizes fall into various
+ * binary decades; e.g., tclByteCodeCount[5] is a count of the ByteCodes
+ * with size larger than 2**4 and less than or equal to 2**5.
*/
#ifdef TCL_COMPILE_STATS
extern long tclNumCompilations;
+extern double tclTotalSourceBytes;
+extern double tclTotalCodeBytes;
+
+extern double tclTotalInstBytes;
+extern double tclTotalObjBytes;
+extern double tclTotalExceptBytes;
+extern double tclTotalAuxBytes;
+extern double tclTotalCmdMapBytes;
+
+extern double tclCurrentSourceBytes;
+extern double tclCurrentCodeBytes;
+
+extern int tclSourceCount[32];
+extern int tclByteCodeCount[32];
#endif /* TCL_COMPILE_STATS */
/*
@@ -115,15 +133,17 @@ typedef struct ExceptionRange {
/*
* Structure used to map between instruction pc and source locations. It
- * defines for each compiled Tcl command the starting and ending offsets for
- * its source and code.
+ * defines for each compiled Tcl command its code's starting offset and
+ * its source's starting offset and length. Note that the code offset
+ * increases monotonically: that is, the table is sorted in code offset
+ * order. The source offset is not monotonic.
*/
typedef struct CmdLocation {
+ int codeOffset; /* Offset of first byte of command code. */
+ int numCodeBytes; /* Number of bytes for command's code. */
int srcOffset; /* Offset of first char of the command. */
int numSrcChars; /* Number of command source chars. */
- int codeOffset; /* Offset of first byte of command code. */
- int numCodeBytes; /* Number of code bytes for command code. */
} CmdLocation;
/*
@@ -222,6 +242,12 @@ typedef struct CompileEnv {
* of "if $b then...". Otherwise 0. Used
* to implement expr's 2 level substitution
* semantics properly. */
+ int exprIsComparison; /* Set 1 if the top-level operator in the
+ * expression last compiled is a comparison.
+ * Otherwise 0. If 1, since the operands
+ * might be strings, the expr is compiled
+ * out-of-line to implement expr's 2 level
+ * substitution semantics properly. */
int termOffset; /* Offset of character just after the last
* one compiled. Set by compilation
* procedures before returning. */
@@ -307,12 +333,17 @@ typedef struct ByteCode {
* pointer is also not owned by the ByteCode
* and must not be freed by it. Used for
* debugging. */
+ size_t totalSize; /* Total number of bytes required for this
+ * ByteCode structure including the storage
+ * for Tcl objects in its object array. */
int numCommands; /* Number of commands compiled. */
int numSrcChars; /* Number of source chars compiled. */
int numCodeBytes; /* Number of code bytes. */
int numObjects; /* Number of Tcl objects in object array. */
int numExcRanges; /* Number of ExceptionRange array elems. */
int numAuxDataItems; /* Number of AuxData items. */
+ int numCmdLocBytes; /* Number of bytes needed for encoded
+ * command location information. */
int maxExcRangeDepth; /* Maximum nesting level of ExceptionRanges;
* -1 if no ranges were compiled. */
int maxStackDepth; /* Maximum number of stack elements needed
@@ -326,13 +357,43 @@ typedef struct ByteCode {
/* Points to the start of the ExceptionRange
* array. This is just after the last
* object in the object array. */
- CmdLocation *cmdMapPtr; /* Points to pc <-> source map: an array of
- * numCommands CmdLocation structures. This
- * is just after the last entry in the
- * ExceptionRange array. */
AuxData *auxDataArrayPtr; /* Points to the start of the auxiliary data
* array. This is just after the last entry
- * in the CmdLocation array. */
+ * in the ExceptionRange array. */
+ unsigned char *codeDeltaStart;
+ /* Points to the first of a sequence of
+ * bytes that encode the change in the
+ * starting offset of each command's code.
+ * If -127<=delta<=127, it is encoded as 1
+ * byte, otherwise 0xFF (128) appears and
+ * the delta is encoded by the next 4 bytes.
+ * Code deltas are always positive. This
+ * sequence is just after the last entry in
+ * the AuxData array. */
+ unsigned char *codeLengthStart;
+ /* Points to the first of a sequence of
+ * bytes that encode the length of each
+ * command's code. The encoding is the same
+ * as for code deltas. Code lengths are
+ * always positive. This sequence is just
+ * after the last entry in the code delta
+ * sequence. */
+ unsigned char *srcDeltaStart;
+ /* Points to the first of a sequence of
+ * bytes that encode the change in the
+ * starting offset of each command's source.
+ * The encoding is the same as for code
+ * deltas. Source deltas can be negative.
+ * This sequence is just after the last byte
+ * in the code length sequence. */
+ unsigned char *srcLengthStart;
+ /* Points to the first of a sequence of
+ * bytes that encode the length of each
+ * command's source. The encoding is the
+ * same as for code deltas. Source lengths
+ * are always positive. This sequence is
+ * just after the last byte in the source
+ * delta sequence. */
} ByteCode;
/*
@@ -709,14 +770,15 @@ EXTERN int TclFixupForwardJump _ANSI_ARGS_((
EXTERN void TclFreeCompileEnv _ANSI_ARGS_((CompileEnv *envPtr));
EXTERN void TclFreeJumpFixupArray _ANSI_ARGS_((
JumpFixupArray *fixupArrayPtr));
-EXTERN int TclGetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
- ByteCode* codePtr));
EXTERN void TclInitByteCodeObj _ANSI_ARGS_((Tcl_Obj *objPtr,
CompileEnv *envPtr));
EXTERN void TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp,
CompileEnv *envPtr, char *string));
EXTERN void TclInitJumpFixupArray _ANSI_ARGS_((
JumpFixupArray *fixupArrayPtr));
+#ifdef TCL_COMPILE_STATS
+EXTERN int TclLog2 _ANSI_ARGS_((int value));
+#endif /*TCL_COMPILE_STATS*/
EXTERN int TclObjIndexForString _ANSI_ARGS_((char *start,
int length, int allocStrRep, int inHeap,
CompileEnv *envPtr));
@@ -826,7 +888,7 @@ EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile,
/*
* Macro to push a Tcl object onto the Tcl evaluation stack. It emits the
* object's one or four byte array index into the CompileEnv's code
- * array. These support, respectively, a maximum of 256 (2^8) and 2^32
+ * array. These support, respectively, a maximum of 256 (2**8) and 2**32
* objects in a CompileEnv. The ANSI C "prototype" for this macro is:
*
* EXTERN void TclEmitPush _ANSI_ARGS_((int objIndex, CompileEnv *envPtr));
@@ -840,22 +902,22 @@ EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile,
}
/*
- * Macros to update a (signed or unsigned) integer starting at a bytecode
- * pc. The two variants depend on the number of bytes. The ANSI C
- * "prototypes" for these macros are:
+ * Macros to update a (signed or unsigned) integer starting at a pointer.
+ * The two variants depend on the number of bytes. The ANSI C "prototypes"
+ * for these macros are:
*
- * EXTERN void TclUpdateInt1AtPc _ANSI_ARGS_((int i, unsigned char *pc));
- * EXTERN void TclUpdateInt4AtPc _ANSI_ARGS_((int i, unsigned char *pc));
+ * EXTERN void TclStoreInt1AtPtr _ANSI_ARGS_((int i, unsigned char *p));
+ * EXTERN void TclStoreInt4AtPtr _ANSI_ARGS_((int i, unsigned char *p));
*/
-#define TclUpdateInt1AtPc(i, pc) \
- *(pc) = (unsigned char) ((unsigned int) (i))
+#define TclStoreInt1AtPtr(i, p) \
+ *(p) = (unsigned char) ((unsigned int) (i))
-#define TclUpdateInt4AtPc(i, pc) \
- *(pc) = (unsigned char) ((unsigned int) (i) >> 24); \
- *(pc+1) = (unsigned char) ((unsigned int) (i) >> 16); \
- *(pc+2) = (unsigned char) ((unsigned int) (i) >> 8); \
- *(pc+3) = (unsigned char) ((unsigned int) (i) )
+#define TclStoreInt4AtPtr(i, p) \
+ *(p) = (unsigned char) ((unsigned int) (i) >> 24); \
+ *(p+1) = (unsigned char) ((unsigned int) (i) >> 16); \
+ *(p+2) = (unsigned char) ((unsigned int) (i) >> 8); \
+ *(p+3) = (unsigned char) ((unsigned int) (i) )
/*
* Macros to update instructions at a particular pc with a new op code
@@ -870,54 +932,54 @@ EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile,
#define TclUpdateInstInt1AtPc(op, i, pc) \
*(pc) = (unsigned char) (op); \
- TclUpdateInt1AtPc((i), ((pc)+1))
+ TclStoreInt1AtPtr((i), ((pc)+1))
#define TclUpdateInstInt4AtPc(op, i, pc) \
*(pc) = (unsigned char) (op); \
- TclUpdateInt4AtPc((i), ((pc)+1))
+ TclStoreInt4AtPtr((i), ((pc)+1))
/*
* Macros to get a signed integer (GET_INT{1,2}) or an unsigned int
- * (GET_UINT{1,2}) from a code pc pointer. There are two variants for each
- * return type that depend on the number of bytes fetched from the code
- * sequence. The ANSI C "prototypes" for these macros are:
+ * (GET_UINT{1,2}) from a pointer. There are two variants for each
+ * return type that depend on the number of bytes fetched.
+ * The ANSI C "prototypes" for these macros are:
*
- * EXTERN int TclGetInt1AtPc _ANSI_ARGS_((unsigned char *pc));
- * EXTERN int TclGetInt4AtPc _ANSI_ARGS_((unsigned char *pc));
- * EXTERN unsigned int TclGetUInt1AtPc _ANSI_ARGS_((unsigned char *pc));
- * EXTERN unsigned int TclGetUInt4AtPc _ANSI_ARGS_((unsigned char *pc));
+ * EXTERN int TclGetInt1AtPtr _ANSI_ARGS_((unsigned char *p));
+ * EXTERN int TclGetInt4AtPtr _ANSI_ARGS_((unsigned char *p));
+ * EXTERN unsigned int TclGetUInt1AtPtr _ANSI_ARGS_((unsigned char *p));
+ * EXTERN unsigned int TclGetUInt4AtPtr _ANSI_ARGS_((unsigned char *p));
*/
/*
- * The TclGetInt1AtPc macro is tricky because we want to do sign
+ * The TclGetInt1AtPtr macro is tricky because we want to do sign
* extension on the 1-byte value. Unfortunately the "char" type isn't
* signed on all platforms so sign-extension doesn't always happen
- * automatically. Sometimes we can explicitly declare the pointer to be
+ * automatically. Sometimes we can explicitly declare the pointer to be
* signed, but other times we have to explicitly sign-extend the value
* in software.
*/
#ifndef __CHAR_UNSIGNED__
-# define TclGetInt1AtPc(pc) ((int) *((char *) pc))
+# define TclGetInt1AtPtr(p) ((int) *((char *) p))
#else
# ifdef HAVE_SIGNED_CHAR
-# define TclGetInt1AtPc(pc) ((int) *((signed char *) pc))
+# define TclGetInt1AtPtr(p) ((int) *((signed char *) p))
# else
-# define TclGetInt1AtPc(pc) (((int) *((char *) pc)) \
- | ((*(pc) & 0200) ? (-256) : 0))
+# define TclGetInt1AtPtr(p) (((int) *((char *) p)) \
+ | ((*(p) & 0200) ? (-256) : 0))
# endif
#endif
-#define TclGetInt4AtPc(pc) (((int) TclGetInt1AtPc(pc) << 24) | \
- (*((pc)+1) << 16) | \
- (*((pc)+2) << 8) | \
- (*((pc)+3)))
+#define TclGetInt4AtPtr(p) (((int) TclGetInt1AtPtr(p) << 24) | \
+ (*((p)+1) << 16) | \
+ (*((p)+2) << 8) | \
+ (*((p)+3)))
-#define TclGetUInt1AtPc(pc) ((unsigned int) *(pc))
-#define TclGetUInt4AtPc(pc) ((unsigned int) (*(pc) << 24) | \
- (*((pc)+1) << 16) | \
- (*((pc)+2) << 8) | \
- (*((pc)+3)))
+#define TclGetUInt1AtPtr(p) ((unsigned int) *(p))
+#define TclGetUInt4AtPtr(p) ((unsigned int) (*(p) << 24) | \
+ (*((p)+1) << 16) | \
+ (*((p)+2) << 8) | \
+ (*((p)+3)))
/*
* Macros used to compute the minimum and maximum of two integers.
diff --git a/contrib/tcl/generic/tclEnv.c b/contrib/tcl/generic/tclEnv.c
index f619769..8027f5e 100644
--- a/contrib/tcl/generic/tclEnv.c
+++ b/contrib/tcl/generic/tclEnv.c
@@ -2,7 +2,9 @@
* tclEnv.c --
*
* Tcl support for environment variables, including a setenv
- * procedure.
+ * procedure. This file contains the generic portion of the
+ * environment module. It is primarily responsible for keeping
+ * the "env" arrays in sync with the system environment variables.
*
* Copyright (c) 1991-1994 The Regents of the University of California.
* Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -10,21 +12,11 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclEnv.c 1.43 97/05/21 17:10:56
+ * SCCS: @(#) tclEnv.c 1.49 97/08/11 20:22:40
*/
-/*
- * The putenv and setenv definitions below cause any system prototypes for
- * those procedures to be ignored so that there won't be a clash when the
- * versions in this file are compiled.
- */
-
-#define putenv ignore_putenv
-#define setenv ignore_setenv
#include "tclInt.h"
#include "tclPort.h"
-#undef putenv
-#undef setenv
/*
* The structure below is used to keep track of all of the interpereters
@@ -44,25 +36,30 @@ static EnvInterp *firstInterpPtr = NULL;
/* First in list of all managed interpreters,
* or NULL if none. */
-static int environSize = 0; /* Non-zero means that the all of the
- * environ-related information is malloc-ed
- * and the environ array itself has this
- * many total entries allocated to it (not
- * all may be in use at once). Zero means
- * that the environment array is in its
- * original static state. */
+static int cacheSize = 0; /* Number of env strings in environCache. */
+static char **environCache = NULL;
+ /* Array containing all of the environment
+ * strings that Tcl has allocated. */
+
+#ifndef USE_PUTENV
+static int environSize = 0; /* Non-zero means that the environ array was
+ * malloced and has this many total entries
+ * allocated to it (not all may be in use at
+ * once). Zero means that the environment
+ * array is in its original static state. */
+#endif
/*
* Declarations for local procedures defined in this file:
*/
-static void EnvExitProc _ANSI_ARGS_((ClientData clientData));
-static void EnvInit _ANSI_ARGS_((void));
static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, char *name1, char *name2,
int flags));
static int FindVariable _ANSI_ARGS_((CONST char *name,
int *lengthPtr));
+static void ReplaceString _ANSI_ARGS_((CONST char *oldStr,
+ char *newStr));
void TclSetEnv _ANSI_ARGS_((CONST char *name,
CONST char *value));
void TclUnsetEnv _ANSI_ARGS_((CONST char *name));
@@ -100,14 +97,11 @@ TclSetupEnv(interp)
Tcl_DString ds;
int i, sz;
- /*
- * First, initialize our environment-related information, if
- * necessary.
- */
-
- if (environSize == 0) {
- EnvInit();
+#ifdef MAC_TCL
+ if (environ == NULL) {
+ environSize = TclMacCreateEnv();
}
+#endif
/*
* Next, initialize the DString we are going to use for copying
@@ -170,97 +164,6 @@ TclSetupEnv(interp)
/*
*----------------------------------------------------------------------
*
- * FindVariable --
- *
- * Locate the entry in environ for a given name.
- *
- * Results:
- * The return value is the index in environ of an entry with the
- * name "name", or -1 if there is no such entry. The integer at
- * *lengthPtr is filled in with the length of name (if a matching
- * entry is found) or the length of the environ array (if no matching
- * entry is found).
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-FindVariable(name, lengthPtr)
- CONST char *name; /* Name of desired environment variable. */
- int *lengthPtr; /* Used to return length of name (for
- * successful searches) or number of non-NULL
- * entries in environ (for unsuccessful
- * searches). */
-{
- int i;
- register CONST char *p1, *p2;
-
- for (i = 0, p1 = environ[i]; p1 != NULL; i++, p1 = environ[i]) {
- for (p2 = name; *p2 == *p1; p1++, p2++) {
- /* NULL loop body. */
- }
- if ((*p1 == '=') && (*p2 == '\0')) {
- *lengthPtr = p2-name;
- return i;
- }
- }
- *lengthPtr = i;
- return -1;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclGetEnv --
- *
- * Get an environment variable or return NULL if the variable
- * doesn't exist. This procedure is intended to be a
- * stand-in for the UNIX "getenv" procedure so that applications
- * using that procedure will interface properly to Tcl. To make
- * it a stand-in, the Makefile must define "TclGetEnv" to "getenv".
- *
- * Results:
- * ptr to value on success, NULL if error.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-TclGetEnv(name)
- char *name; /* Name of desired environment variable. */
-{
- int i;
- size_t len, nameLen;
- char *equal;
-
- nameLen = strlen(name);
- for (i = 0; environ[i] != NULL; i++) {
- equal = strchr(environ[i], '=');
- if (equal == NULL) {
- continue;
- }
- len = (size_t) (equal - environ[i]);
- if ((len == nameLen) && (strncmp(name, environ[i], len) == 0)) {
- /*
- * The caller of this function should regard this
- * as static memory.
- */
- return &environ[i][len+1];
- }
- }
-
- return NULL;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclSetEnv --
*
* Set an environment variable, replacing an existing value
@@ -287,12 +190,14 @@ TclSetEnv(name, value)
CONST char *value; /* New value for variable. */
{
int index, length, nameLength;
- char *p;
+ char *p, *oldValue;
EnvInterp *eiPtr;
- if (environSize == 0) {
- EnvInit();
+#ifdef MAC_TCL
+ if (environ == NULL) {
+ environSize = TclMacCreateEnv();
}
+#endif
/*
* Figure out where the entry is going to go. If the name doesn't
@@ -302,6 +207,7 @@ TclSetEnv(name, value)
index = FindVariable(name, &length);
if (index == -1) {
+#ifndef USE_PUTENV
if ((length+2) > environSize) {
char **newEnviron;
@@ -309,12 +215,16 @@ TclSetEnv(name, value)
((length+5) * sizeof(char *)));
memcpy((VOID *) newEnviron, (VOID *) environ,
length*sizeof(char *));
- ckfree((char *) environ);
+ if (environSize != 0) {
+ ckfree((char *) environ);
+ }
environ = newEnviron;
environSize = length+5;
}
index = length;
environ[index+1] = NULL;
+#endif
+ oldValue = NULL;
nameLength = strlen(name);
} else {
/*
@@ -328,35 +238,44 @@ TclSetEnv(name, value)
if (strcmp(value, environ[index]+length+1) == 0) {
return;
}
- ckfree(environ[index]);
+ oldValue = environ[index];
nameLength = length;
}
+
+
+ /*
+ * Update all of the interpreters.
+ */
+
+ for (eiPtr= firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) {
+ (void) Tcl_SetVar2(eiPtr->interp, "env", (char *) name,
+ (char *) value, TCL_GLOBAL_ONLY);
+ }
/*
- * Create a new entry and enter it into the table.
+ * Create a new entry.
*/
p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2));
- environ[index] = p;
strcpy(p, name);
- p += nameLength;
- *p = '=';
- strcpy(p+1, value);
+ p[nameLength] = '=';
+ strcpy(p+nameLength+1, value);
/*
- * Update all of the interpreters.
+ * Update the system environment.
*/
- for (eiPtr= firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) {
- (void) Tcl_SetVar2(eiPtr->interp, "env", (char *) name,
- p+1, TCL_GLOBAL_ONLY);
- }
+#ifdef USE_PUTENV
+ putenv(p);
+#else
+ environ[index] = p;
+#endif
/*
- * Update the system environment.
+ * Replace the old value with the new value in the cache.
*/
- TclSetSystemEnv(name, value);
+ ReplaceString(oldValue, p);
}
/*
@@ -408,7 +327,7 @@ Tcl_PutEnv(string)
return 0;
}
name = (char *) ckalloc((unsigned) nameLength+1);
- memcpy(name, string, (size_t) nameLength);
+ memcpy((VOID *) name, (VOID *) string, (size_t) nameLength);
name[nameLength] = 0;
TclSetEnv(name, value+1);
ckfree(name);
@@ -439,29 +358,63 @@ void
TclUnsetEnv(name)
CONST char *name; /* Name of variable to remove. */
{
- int index, dummy;
- char **envPtr;
EnvInterp *eiPtr;
+ char *oldValue;
+ int length, index;
+#ifdef USE_PUTENV
+ char *string;
+#else
+ char **envPtr;
+#endif
- if (environSize == 0) {
- EnvInit();
+#ifdef MAC_TCL
+ if (environ == NULL) {
+ environSize = TclMacCreateEnv();
}
+#endif
+
+ index = FindVariable(name, &length);
/*
- * Update the environ array.
+ * First make sure that the environment variable exists to avoid
+ * doing needless work and to avoid recursion on the unset.
*/
-
- index = FindVariable(name, &dummy);
+
if (index == -1) {
return;
}
- ckfree(environ[index]);
+ /*
+ * Remember the old value so we can free it if Tcl created the string.
+ */
+
+ oldValue = environ[index];
+
+ /*
+ * Update the system environment. This must be done before we
+ * update the interpreters or we will recurse.
+ */
+
+#ifdef USE_PUTENV
+ string = ckalloc(length+2);
+ memcpy((VOID *) string, (VOID *) name, (size_t) length);
+ string[length] = '=';
+ string[length+1] = '\0';
+ putenv(string);
+ ckfree(string);
+#else
for (envPtr = environ+index+1; ; envPtr++) {
envPtr[-1] = *envPtr;
if (*envPtr == NULL) {
break;
- }
+ }
}
+#endif
+
+ /*
+ * Replace the old value in the cache.
+ */
+
+ ReplaceString(oldValue, NULL);
/*
* Update all of the interpreters.
@@ -471,12 +424,43 @@ TclUnsetEnv(name)
(void) Tcl_UnsetVar2(eiPtr->interp, "env", (char *) name,
TCL_GLOBAL_ONLY);
}
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetEnv --
+ *
+ * Retrieve the value of an environment variable.
+ *
+ * Results:
+ * Returns a pointer to a static string in the environment,
+ * or NULL if the value was not found.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- /*
- * Update the system environment.
- */
+char *
+TclGetEnv(name)
+ CONST char *name; /* Name of variable to find. */
+{
+ int length, index;
+
+#ifdef MAC_TCL
+ if (environ == NULL) {
+ environSize = TclMacCreateEnv();
+ }
+#endif
- TclSetSystemEnv(name, NULL);
+ index = FindVariable(name, &length);
+ if ((index != -1) && (*(environ[index]+length) == '=')) {
+ return environ[index]+length+1;
+ } else {
+ return NULL;
+ }
}
/*
@@ -560,91 +544,151 @@ EnvTraceProc(clientData, interp, name1, name2, flags)
/*
*----------------------------------------------------------------------
*
- * EnvInit --
+ * ReplaceString --
*
- * This procedure is called to initialize our management
- * of the environ array.
+ * Replace one string with another in the environment variable
+ * cache. The cache keeps track of all of the environment
+ * variables that Tcl has modified so they can be freed later.
*
* Results:
* None.
*
* Side effects:
- * Environ gets copied to malloc-ed storage, so that in
- * the future we don't have to worry about which entries
- * are malloc-ed and which are static.
+ * May free the old string.
*
*----------------------------------------------------------------------
*/
static void
-EnvInit()
+ReplaceString(oldStr, newStr)
+ CONST char *oldStr; /* Old environment string. */
+ char *newStr; /* New environment string. */
{
-#ifdef MAC_TCL
- environSize = TclMacCreateEnv();
-#else
- char **newEnviron, **oldEnviron;
- int i, length;
+ int i;
+ char **newCache;
- oldEnviron = environ;
- if (environSize != 0) {
- return;
- }
- for (length = 0; environ[length] != NULL; length++) {
- /* Empty loop body. */
+ /*
+ * Check to see if the old value was allocated by Tcl. If so,
+ * it needs to be deallocated to avoid memory leaks. Note that this
+ * algorithm is O(n), not O(1). This will result in n-squared behavior
+ * if lots of environment changes are being made.
+ */
+
+ for (i = 0; i < cacheSize; i++) {
+ if ((environCache[i] == oldStr) || (environCache[i] == NULL)) {
+ break;
+ }
}
- environSize = length+5;
- newEnviron = (char **) ckalloc((unsigned)
- (environSize * sizeof(char *)));
- for (i = 0; i < length; i++) {
- newEnviron[i] = (char *) ckalloc((unsigned) (strlen(environ[i]) + 1));
- strcpy(newEnviron[i], environ[i]);
+ if (i < cacheSize) {
+ /*
+ * Replace or delete the old value.
+ */
+
+ if (environCache[i]) {
+ ckfree(environCache[i]);
+ }
+
+ if (newStr) {
+ environCache[i] = newStr;
+ } else {
+ for (; i < cacheSize-1; i++) {
+ environCache[i] = environCache[i+1];
+ }
+ environCache[cacheSize-1] = NULL;
+ }
+ } else {
+ /*
+ * We need to grow the cache in order to hold the new string.
+ */
+
+ newCache = (char **) ckalloc((cacheSize + 5) * sizeof(char *));
+ if (environCache) {
+ memcpy((VOID *) newCache, (VOID *) environCache,
+ (size_t) (cacheSize * sizeof(char*)));
+ ckfree((char *) environCache);
+ }
+ environCache = newCache;
+ environCache[cacheSize] = (char *) newStr;
+ environCache[cacheSize+1] = NULL;
+ cacheSize += 5;
}
- newEnviron[length] = NULL;
- environ = newEnviron;
- Tcl_CreateExitHandler(EnvExitProc, (ClientData) oldEnviron);
-#endif
}
/*
*----------------------------------------------------------------------
*
- * EnvExitProc --
+ * FindVariable --
*
- * This procedure is called just before the process exits. It
- * frees the memory associated with environment variables.
+ * Locate the entry in environ for a given name.
*
* Results:
- * None.
+ * The return value is the index in environ of an entry with the
+ * name "name", or -1 if there is no such entry. The integer at
+ * *lengthPtr is filled in with the length of name (if a matching
+ * entry is found) or the length of the environ array (if no matching
+ * entry is found).
*
* Side effects:
- * Memory is freed.
+ * None.
*
*----------------------------------------------------------------------
*/
-static void
-EnvExitProc(clientData)
- ClientData clientData; /* Old environment pointer -- restore this. */
+static int
+FindVariable(name, lengthPtr)
+ CONST char *name; /* Name of desired environment variable. */
+ int *lengthPtr; /* Used to return length of name (for
+ * successful searches) or number of non-NULL
+ * entries in environ (for unsuccessful
+ * searches). */
{
- char **p;
- EnvInterp *eiPtr, *nextPtr;
+ int i;
+ register CONST char *p1, *p2;
- for (p = environ; *p != NULL; p++) {
- ckfree(*p);
+ for (i = 0, p1 = environ[i]; p1 != NULL; i++, p1 = environ[i]) {
+ for (p2 = name; *p2 == *p1; p1++, p2++) {
+ /* NULL loop body. */
+ }
+ if ((*p1 == '=') && (*p2 == '\0')) {
+ *lengthPtr = p2-name;
+ return i;
+ }
}
- ckfree((char *) environ);
+ *lengthPtr = i;
+ return -1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFinalizeEnvironment --
+ *
+ * This function releases any storage allocated by this module
+ * that isn't still in use by the global environment. Any
+ * strings that are still in the environment will be leaked.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May deallocate storage.
+ *
+ *----------------------------------------------------------------------
+ */
+void
+TclFinalizeEnvironment()
+{
/*
- * Note that we need to reset the environ global so the Borland C run-time
- * doesn't choke on exit.
+ * For now we just deallocate the cache array and none of the environment
+ * strings. This may leak more memory that strictly necessary, since some
+ * of the strings may no longer be in the environment. However,
+ * determining which ones are ok to delete is n-squared, and is pretty
+ * unlikely, so we don't bother.
*/
- environ = (char **) clientData;
- environSize = 0;
-
- for (eiPtr = firstInterpPtr; eiPtr != NULL; eiPtr = nextPtr) {
- nextPtr = eiPtr->nextPtr;
- ckfree((char *) eiPtr);
+ if (environCache) {
+ ckfree((char *) environCache);
+ environCache = NULL;
}
- firstInterpPtr = NULL;
}
diff --git a/contrib/tcl/generic/tclEvent.c b/contrib/tcl/generic/tclEvent.c
index a503df7..4672982 100644
--- a/contrib/tcl/generic/tclEvent.c
+++ b/contrib/tcl/generic/tclEvent.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclEvent.c 1.152 97/05/21 07:06:19
+ * SCCS: @(#) tclEvent.c 1.153 97/08/11 20:22:31
*/
#include "tclInt.h"
@@ -516,6 +516,10 @@ Tcl_Finalize()
{
ExitHandler *exitPtr;
+ /*
+ * Invoke exit handler first.
+ */
+
tclInExit = 1;
for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
/*
@@ -530,11 +534,12 @@ Tcl_Finalize()
}
/*
- * Uninitialize everything associated with the compile and execute
- * environment. This *must* be done at the latest possible time.
+ * Now finalize the Tcl execution environment. Note that this must be done
+ * after the exit handlers, because there are order dependencies.
*/
TclFinalizeCompExecEnv();
+ TclFinalizeEnvironment();
firstExitPtr = NULL;
tclInExit = 0;
}
diff --git a/contrib/tcl/generic/tclExecute.c b/contrib/tcl/generic/tclExecute.c
index 111cf4b..4c12437 100644
--- a/contrib/tcl/generic/tclExecute.c
+++ b/contrib/tcl/generic/tclExecute.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclExecute.c 1.81 97/06/26 13:50:03
+ * SCCS: @(#) tclExecute.c 1.95 97/08/12 17:06:49
*/
#include "tclInt.h"
@@ -21,7 +21,7 @@
# include <float.h>
#endif
#ifndef TCL_NO_MATH
-#include <math.h>
+#include "tclMath.h"
#endif
/*
@@ -119,8 +119,8 @@ static char *resultStrings[] = {
*/
#ifdef TCL_COMPILE_STATS
-static int instructionCount[256];
static long numExecutions = 0;
+static int instructionCount[256];
#endif /* TCL_COMPILE_STATS */
/*
@@ -283,18 +283,27 @@ static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
#endif /* TCL_COMPILE_STATS */
static void FreeCmdNameInternalRep _ANSI_ARGS_((
Tcl_Obj *objPtr));
+static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
+ ByteCode* codePtr, int *lengthPtr));
static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr));
static void IllegalExprOperandType _ANSI_ARGS_((
Tcl_Interp *interp, unsigned int opCode,
Tcl_Obj *opndPtr));
static void InitByteCodeExecution _ANSI_ARGS_((
Tcl_Interp *interp));
+static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
#ifdef TCL_COMPILE_DEBUG
static char * StringForResultCode _ANSI_ARGS_((int result));
#endif /* TCL_COMPILE_DEBUG */
static void UpdateStringOfCmdName _ANSI_ARGS_((Tcl_Obj *objPtr));
+#ifdef TCL_COMPILE_DEBUG
+static void ValidatePcAndStackTop _ANSI_ARGS_((
+ ByteCode *codePtr, unsigned char *pc,
+ int stackTop, int stackLowerBound,
+ int stackUpperBound));
+#endif /* TCL_COMPILE_DEBUG */
/*
* Table describing the built-in math functions. Entries in this table are
@@ -388,6 +397,9 @@ InitByteCodeExecution(interp)
#ifdef TCL_COMPILE_STATS
(VOID *) memset(instructionCount, 0, sizeof(instructionCount));
+ (VOID *) memset(tclByteCodeCount, 0, sizeof(tclByteCodeCount));
+ (VOID *) memset(tclSourceCount, 0, sizeof(tclSourceCount));
+
Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd,
(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
#endif /* TCL_COMPILE_STATS */
@@ -607,24 +619,7 @@ TclExecuteByteCode(interp, codePtr)
*/
if (tclTraceExec >= 2) {
- Proc *procPtr = codePtr->procPtr;
- fprintf(stdout, "\nExecuting ByteCode 0x%x, ref ct %u, epoch %u, cmds %u, interp 0x%x, interp epoch %u\n",
- (unsigned int) codePtr, codePtr->refCount,
- codePtr->compileEpoch, codePtr->numCommands,
- (unsigned int) codePtr->iPtr, codePtr->iPtr->compileEpoch);
- if (procPtr != NULL) {
- fprintf(stdout,
- " Proc 0x%x, ref ct=%d, %d args, %d compiled locals\n",
- (unsigned int) procPtr, procPtr->refCount,
- procPtr->numArgs, procPtr->numCompiledLocals);
- }
- fprintf(stdout, " Source: ");
- TclPrintSource(stdout, codePtr->source, 70);
- fprintf(stdout, "\n");
- fprintf(stdout, " Chars=%d, bytes=%u, objs=%u, stk depth=%u, exc depth=%d, aux items=%d\n",
- codePtr->numSrcChars, codePtr->numCodeBytes,
- codePtr->numObjects, codePtr->maxStackDepth,
- codePtr->maxExcRangeDepth, codePtr->numAuxDataItems);
+ PrintByteCodeInfo(codePtr);
#ifdef TCL_COMPILE_STATS
fprintf(stdout, " Starting stack top=%d, system objects=%ld\n",
eePtr->stackTop, (tclObjsAlloced - tclObjsFreed));
@@ -671,44 +666,10 @@ TclExecuteByteCode(interp, codePtr)
*/
for (;;) {
- opCode = *pc;
-
#ifdef TCL_COMPILE_DEBUG
- if (((unsigned int) pc < (unsigned int) codePtr->codeStart)
- || ((unsigned int) pc > (unsigned int) (codePtr->codeStart + codePtr->numCodeBytes))) {
- fprintf(stderr,
- "\nTclExecuteByteCode: bad instruction pc 0x%x\n",
- (unsigned int) pc);
- panic("TclExecuteByteCode execution failure: bad pc");
- }
- if ((unsigned int) opCode > LAST_INST_OPCODE) {
- fprintf(stderr,
- "\nTclExecuteByteCode: bad opcode %d at pc %u\n",
- (unsigned int) opCode,
- (unsigned int)(pc - codePtr->codeStart));
- panic("TclExecuteByteCode execution failure: bad opcode");
- }
- if ((stackTop < initStackTop) || (stackTop > eePtr->stackEnd)) {
- int cmdIndex = TclGetSrcInfoForPc(pc, codePtr);
- fprintf(stderr,
- "\nTclExecuteByteCode: bad stack top %d at pc %u",
- stackTop, (unsigned int)(pc - codePtr->codeStart));
- if (cmdIndex != -1) {
- CmdLocation *locPtr = &(codePtr->cmdMapPtr[cmdIndex]);
- char *ellipsis = "";
- int numChars = locPtr->numSrcChars;
- if (numChars > 100) {
- numChars = 100;
- ellipsis = "...";
- }
- fprintf(stderr, "\n executing %.*s%s\n", numChars,
- (codePtr->source + locPtr->srcOffset), ellipsis);
- } else {
- fprintf(stderr, "\n");
- }
- panic("TclExecuteByteCode execution failure: bad stack top");
- }
-#else /* not TCL_COMPILE_DEBUG - print generic trace if so requested */
+ ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop,
+ eePtr->stackEnd);
+#else /* not TCL_COMPILE_DEBUG */
if (traceInstructions) {
#ifdef TCL_COMPILE_STATS
fprintf(stdout, "%d: %d,%ld ", iPtr->numLevels, stackTop,
@@ -721,10 +682,11 @@ TclExecuteByteCode(interp, codePtr)
}
#endif /* TCL_COMPILE_DEBUG */
+ opCode = *pc;
#ifdef TCL_COMPILE_STATS
instructionCount[opCode]++;
#endif /* TCL_COMPILE_STATS */
-
+
switch (opCode) {
case INST_DONE:
/*
@@ -733,7 +695,7 @@ TclExecuteByteCode(interp, codePtr)
*/
valuePtr = POP_OBJECT();
Tcl_SetObjResult(interp, valuePtr);
- TclDecrRefCount(valuePtr); /* done with valuePtr */
+ TclDecrRefCount(valuePtr);
if (stackTop != initStackTop) {
fprintf(stderr, "\nTclExecuteByteCode: done instruction at pc %u: stack top %d != entry stack top %d\n",
(unsigned int)(pc - codePtr->codeStart),
@@ -748,16 +710,16 @@ TclExecuteByteCode(interp, codePtr)
goto done;
case INST_PUSH1:
- valuePtr = objArrayPtr[TclGetUInt1AtPc(pc+1)];
+ valuePtr = objArrayPtr[TclGetUInt1AtPtr(pc+1)];
PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("push1 %u => ", TclGetUInt1AtPc(pc+1)),
+ TRACE_WITH_OBJ(("push1 %u => ", TclGetUInt1AtPtr(pc+1)),
valuePtr);
ADJUST_PC(2);
case INST_PUSH4:
- valuePtr = objArrayPtr[TclGetUInt4AtPc(pc+1)];
+ valuePtr = objArrayPtr[TclGetUInt4AtPtr(pc+1)];
PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("push4 %u => ", TclGetUInt4AtPc(pc+1)),
+ TRACE_WITH_OBJ(("push4 %u => ", TclGetUInt4AtPtr(pc+1)),
valuePtr);
ADJUST_PC(5);
@@ -774,7 +736,7 @@ TclExecuteByteCode(interp, codePtr)
ADJUST_PC(1);
case INST_CONCAT1:
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
{
Tcl_Obj *concatObjPtr;
int totalLen = 0;
@@ -828,12 +790,12 @@ TclExecuteByteCode(interp, codePtr)
}
case INST_INVOKE_STK4:
- opnd = TclGetUInt4AtPc(pc+1);
+ opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doInvocation;
case INST_INVOKE_STK1:
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doInvocation:
@@ -926,16 +888,12 @@ TclExecuteByteCode(interp, codePtr)
for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
tracePtr = tracePtr->nextPtr) {
if (iPtr->numLevels <= tracePtr->level) {
- int cmdIndex = TclGetSrcInfoForPc(pc, codePtr);
- if (cmdIndex != -1) {
- CmdLocation *locPtr =
- &(codePtr->cmdMapPtr[cmdIndex]);
- char *command =
- (codePtr->source + locPtr->srcOffset);
- int numChars = locPtr->numSrcChars;
+ int numChars;
+ char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
+ if (cmd != NULL) {
DECACHE_STACK_INFO();
CallTraceProcedure(interp, tracePtr, cmdPtr,
- command, numChars, objc, objv);
+ cmd, numChars, objc, objv);
CACHE_STACK_INFO();
}
}
@@ -1083,41 +1041,12 @@ TclExecuteByteCode(interp, codePtr)
case TCL_ERROR:
/*
- * The invoked command returned an error. Record
- * information about what was being executed when the
- * error occurred, then look for an enclosing catch
- * exception range, if any.
+ * The invoked command returned an error. Look for an
+ * enclosing catch exception range, if any.
*/
TRACE_WITH_OBJ(("%s %u => ... after \"%.20s\", TCL_ERROR ",
opName[opCode], objc, cmdNameBuf),
Tcl_GetObjResult(interp));
- if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
- char buf[200];
- int cmdIndex = TclGetSrcInfoForPc(pc, codePtr);
- if (cmdIndex != -1) {
- CmdLocation *locPtr =
- &(codePtr->cmdMapPtr[cmdIndex]);
- char *ellipsis = "";
- int numChars = locPtr->numSrcChars;
- if (numChars > 150) {
- numChars = 150;
- ellipsis = "...";
- }
- if (!(iPtr->flags & ERR_IN_PROGRESS)) {
- sprintf(buf, "\n while executing\n\"%.*s%s\"",
- numChars,
- (codePtr->source + locPtr->srcOffset),
- ellipsis);
- } else {
- sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
- numChars,
- (codePtr->source + locPtr->srcOffset),
- ellipsis);
- }
- Tcl_AddObjErrorInfo(interp, buf, -1);
- iPtr->flags |= ERR_ALREADY_LOGGED;
- }
- }
goto checkForCatch;
case TCL_RETURN:
@@ -1151,7 +1080,7 @@ TclExecuteByteCode(interp, codePtr)
PUSH_OBJECT(Tcl_GetObjResult(interp));
TRACE_WITH_OBJ(("evalStk \"%.30s\" => ", O2S(objPtr)),
Tcl_GetObjResult(interp));
- TclDecrRefCount(objPtr); /* done with popped object */
+ TclDecrRefCount(objPtr);
ADJUST_PC(1);
} else if ((result == TCL_BREAK) || (result == TCL_CONTINUE)) {
/*
@@ -1172,7 +1101,7 @@ TclExecuteByteCode(interp, codePtr)
if (rangePtr == NULL) {
TRACE(("evalStk \"%.30s\" => no encl. loop or catch, returning %s\n",
O2S(objPtr), StringForResultCode(result)));
- Tcl_DecrRefCount(objPtr); /* done with popped obj */
+ Tcl_DecrRefCount(objPtr);
goto abnormalReturn; /* no catch exists to check */
}
switch (rangePtr->type) {
@@ -1182,7 +1111,7 @@ TclExecuteByteCode(interp, codePtr)
} else if (rangePtr->continueOffset == -1) {
TRACE(("evalStk \"%.30s\" => %s, loop w/o continue, checking for catch\n",
O2S(objPtr), StringForResultCode(result)));
- Tcl_DecrRefCount(objPtr); /* done with popped obj */
+ Tcl_DecrRefCount(objPtr);
goto checkForCatch;
} else {
newPcOffset = rangePtr->continueOffset;
@@ -1196,18 +1125,18 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("evalStk \"%.30s\" => %s ",
O2S(objPtr), StringForResultCode(result)),
valuePtr);
- Tcl_DecrRefCount(objPtr); /* done with popped obj */
+ Tcl_DecrRefCount(objPtr);
goto processCatch; /* it will use rangePtr */
default:
panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
}
- Tcl_DecrRefCount(objPtr); /* done with popped obj */
+ Tcl_DecrRefCount(objPtr);
pc = (codePtr->codeStart + newPcOffset);
continue; /* restart outer instruction loop at pc */
} else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */
TRACE_WITH_OBJ(("evalStk \"%.30s\" => ERROR: ", O2S(objPtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(objPtr); /* done with popped obj */
+ Tcl_DecrRefCount(objPtr);
goto checkForCatch;
}
@@ -1220,21 +1149,21 @@ TclExecuteByteCode(interp, codePtr)
if (result != TCL_OK) {
TRACE_WITH_OBJ(("exprStk \"%.30s\" => ERROR: ",
O2S(objPtr)), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(objPtr); /* done with popped object */
+ Tcl_DecrRefCount(objPtr);
goto checkForCatch;
}
stackPtr[++stackTop].o = valuePtr; /* already has right refct */
TRACE_WITH_OBJ(("exprStk \"%.30s\" => ", O2S(objPtr)), valuePtr);
- TclDecrRefCount(objPtr); /* done with popped object */
+ TclDecrRefCount(objPtr);
ADJUST_PC(1);
case INST_LOAD_SCALAR4:
- opnd = TclGetInt4AtPc(pc+1);
+ opnd = TclGetInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doLoadScalar;
case INST_LOAD_SCALAR1:
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doLoadScalar:
@@ -1261,23 +1190,23 @@ TclExecuteByteCode(interp, codePtr)
if (valuePtr == NULL) {
TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ERROR: ",
O2S(namePtr)), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done with popped name. */
+ Tcl_DecrRefCount(namePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ",
O2S(namePtr)), valuePtr);
- TclDecrRefCount(namePtr); /* done with popped name. */
+ TclDecrRefCount(namePtr);
ADJUST_PC(1);
case INST_LOAD_ARRAY4:
- opnd = TclGetUInt4AtPc(pc+1);
+ opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doLoadArray;
case INST_LOAD_ARRAY1:
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doLoadArray:
@@ -1292,14 +1221,14 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("%s %u \"%.30s\" => ERROR: ",
opName[opCode], opnd, O2S(elemPtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(elemPtr); /* done with element name. */
+ Tcl_DecrRefCount(elemPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
TRACE_WITH_OBJ(("%s %u \"%.30s\" => ",
opName[opCode], opnd, O2S(elemPtr)), valuePtr);
- TclDecrRefCount(elemPtr); /* done with element name. */
+ TclDecrRefCount(elemPtr);
}
ADJUST_PC(pcAdjustment);
@@ -1316,16 +1245,16 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ERROR: ",
O2S(namePtr), O2S(elemPtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done with array name */
- Tcl_DecrRefCount(elemPtr); /* and element name. */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(elemPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ",
O2S(namePtr), O2S(elemPtr)), valuePtr);
- TclDecrRefCount(namePtr); /* done with array name */
- TclDecrRefCount(elemPtr); /* and element name. */
+ TclDecrRefCount(namePtr);
+ TclDecrRefCount(elemPtr);
}
ADJUST_PC(1);
@@ -1338,23 +1267,23 @@ TclExecuteByteCode(interp, codePtr)
if (valuePtr == NULL) {
TRACE_WITH_OBJ(("loadStk \"%.30s\" => ERROR: ",
O2S(namePtr)), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done with popped name. */
+ Tcl_DecrRefCount(namePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
TRACE_WITH_OBJ(("loadStk \"%.30s\" => ", O2S(namePtr)),
valuePtr);
- TclDecrRefCount(namePtr); /* done with popped name. */
+ TclDecrRefCount(namePtr);
ADJUST_PC(1);
case INST_STORE_SCALAR4:
- opnd = TclGetUInt4AtPc(pc+1);
+ opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doStoreScalar;
case INST_STORE_SCALAR1:
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doStoreScalar:
@@ -1367,14 +1296,14 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ERROR: ",
opName[opCode], opnd, O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(valuePtr); /* done with popped value. */
+ Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ",
opName[opCode], opnd, O2S(valuePtr)), value2Ptr);
- TclDecrRefCount(valuePtr); /* done with popped value. */
+ TclDecrRefCount(valuePtr);
ADJUST_PC(pcAdjustment);
case INST_STORE_SCALAR_STK:
@@ -1389,8 +1318,8 @@ TclExecuteByteCode(interp, codePtr)
("storeScalarStk \"%.30s\" <- \"%.30s\" => ERROR: ",
O2S(namePtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done with popped name. */
- Tcl_DecrRefCount(valuePtr); /* done with popped value. */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
@@ -1400,17 +1329,17 @@ TclExecuteByteCode(interp, codePtr)
O2S(namePtr),
O2S(valuePtr)),
value2Ptr);
- TclDecrRefCount(namePtr); /* done with popped name. */
- TclDecrRefCount(valuePtr); /* done with popped value. */
+ TclDecrRefCount(namePtr);
+ TclDecrRefCount(valuePtr);
ADJUST_PC(1);
case INST_STORE_ARRAY4:
- opnd = TclGetUInt4AtPc(pc+1);
+ opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doStoreArray;
case INST_STORE_ARRAY1:
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doStoreArray:
@@ -1428,8 +1357,8 @@ TclExecuteByteCode(interp, codePtr)
("%s %u \"%.30s\" <- \"%.30s\" => ERROR: ",
opName[opCode], opnd, O2S(elemPtr),
O2S(valuePtr)), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(elemPtr); /* done with element name */
- Tcl_DecrRefCount(valuePtr); /* done with popped value */
+ Tcl_DecrRefCount(elemPtr);
+ Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
@@ -1437,8 +1366,8 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("%s %u \"%.30s\" <- \"%.30s\" => ",
opName[opCode], opnd, O2S(elemPtr), O2S(valuePtr)),
value2Ptr);
- TclDecrRefCount(elemPtr); /* done with element name */
- TclDecrRefCount(valuePtr); /* done with popped value */
+ TclDecrRefCount(elemPtr);
+ TclDecrRefCount(valuePtr);
}
ADJUST_PC(pcAdjustment);
@@ -1457,9 +1386,9 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
O2S(namePtr), O2S(elemPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done with array name, */
- Tcl_DecrRefCount(elemPtr); /* the element name, */
- Tcl_DecrRefCount(valuePtr); /* and the popped value. */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(elemPtr);
+ Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
@@ -1467,9 +1396,9 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ",
O2S(namePtr), O2S(elemPtr), O2S(valuePtr)),
value2Ptr);
- TclDecrRefCount(namePtr); /* done with array name, */
- TclDecrRefCount(elemPtr); /* the element name, */
- TclDecrRefCount(valuePtr); /* and popped value. */
+ TclDecrRefCount(namePtr);
+ TclDecrRefCount(elemPtr);
+ TclDecrRefCount(valuePtr);
}
ADJUST_PC(1);
@@ -1484,27 +1413,27 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ERROR: ",
O2S(namePtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done with popped name. */
- Tcl_DecrRefCount(valuePtr); /* and popped value. */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ",
O2S(namePtr), O2S(valuePtr)), value2Ptr);
- TclDecrRefCount(namePtr); /* done with popped name */
- TclDecrRefCount(valuePtr); /* and popped value. */
+ TclDecrRefCount(namePtr);
+ TclDecrRefCount(valuePtr);
ADJUST_PC(1);
case INST_INCR_SCALAR1:
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
valuePtr = POP_OBJECT();
if (valuePtr->typePtr != &tclIntType) {
result = tclIntType.setFromAnyProc(interp, valuePtr);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("incrScalar1 %u (by %s) => ERROR converting increment amount to int: ",
opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(valuePtr); /* done with incr amount */
+ Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
@@ -1515,14 +1444,14 @@ TclExecuteByteCode(interp, codePtr)
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ERROR: ",
opnd, i), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(valuePtr); /* done with incr amount */
+ Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ", opnd, i),
value2Ptr);
- TclDecrRefCount(valuePtr); /* done with incr amount */
+ TclDecrRefCount(valuePtr);
ADJUST_PC(2);
case INST_INCR_SCALAR_STK:
@@ -1535,8 +1464,8 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("%s \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
opName[opCode], O2S(namePtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done with var name */
- Tcl_DecrRefCount(valuePtr); /* done with incr amount */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
@@ -1549,23 +1478,23 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ERROR: ",
opName[opCode], O2S(namePtr), i),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done with var name */
- Tcl_DecrRefCount(valuePtr); /* done with incr amount */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ",
opName[opCode], O2S(namePtr), i), value2Ptr);
- Tcl_DecrRefCount(namePtr); /* done with var name */
- Tcl_DecrRefCount(valuePtr); /* done with incr amount */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(valuePtr);
ADJUST_PC(1);
case INST_INCR_ARRAY1:
{
Tcl_Obj *elemPtr;
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
valuePtr = POP_OBJECT();
elemPtr = POP_OBJECT();
if (valuePtr->typePtr != &tclIntType) {
@@ -1574,8 +1503,8 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
opnd, O2S(elemPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(elemPtr); /* done w elem name */
- Tcl_DecrRefCount(valuePtr); /* done w incr amount */
+ Tcl_DecrRefCount(elemPtr);
+ Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
@@ -1588,16 +1517,16 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ERROR: ",
opnd, O2S(elemPtr), i),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(elemPtr); /* done w element name */
- Tcl_DecrRefCount(valuePtr); /* done w incr amount */
+ Tcl_DecrRefCount(elemPtr);
+ Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ",
opnd, O2S(elemPtr), i), value2Ptr);
- Tcl_DecrRefCount(elemPtr); /* done w element name */
- Tcl_DecrRefCount(valuePtr); /* done w incr amount */
+ Tcl_DecrRefCount(elemPtr);
+ Tcl_DecrRefCount(valuePtr);
}
ADJUST_PC(2);
@@ -1614,9 +1543,9 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ",
O2S(namePtr), O2S(elemPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done w array name */
- Tcl_DecrRefCount(elemPtr); /* done w elem name */
- Tcl_DecrRefCount(valuePtr); /* done w incr amount */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(elemPtr);
+ Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
@@ -1629,24 +1558,24 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ERROR: ",
O2S(namePtr), O2S(elemPtr), i),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done w array name */
- Tcl_DecrRefCount(elemPtr); /* done w elem name */
- Tcl_DecrRefCount(valuePtr); /* done w incr amount */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(elemPtr);
+ Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ",
O2S(namePtr), O2S(elemPtr), i), value2Ptr);
- Tcl_DecrRefCount(namePtr); /* done w array name */
- Tcl_DecrRefCount(elemPtr); /* done w elem name */
- Tcl_DecrRefCount(valuePtr); /* done w incr amount */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(elemPtr);
+ Tcl_DecrRefCount(valuePtr);
}
ADJUST_PC(1);
case INST_INCR_SCALAR1_IMM:
- opnd = TclGetUInt1AtPc(pc+1);
- i = TclGetInt1AtPc(pc+2);
+ opnd = TclGetUInt1AtPtr(pc+1);
+ i = TclGetInt1AtPtr(pc+2);
DECACHE_STACK_INFO();
value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
CACHE_STACK_INFO();
@@ -1664,7 +1593,7 @@ TclExecuteByteCode(interp, codePtr)
case INST_INCR_SCALAR_STK_IMM:
case INST_INCR_STK_IMM:
namePtr = POP_OBJECT();
- i = TclGetInt1AtPc(pc+1);
+ i = TclGetInt1AtPtr(pc+1);
DECACHE_STACK_INFO();
value2Ptr = TclIncrVar2(interp, namePtr, (Tcl_Obj *) NULL, i,
/*part1NotParsed*/ (opCode == INST_INCR_STK_IMM));
@@ -1674,21 +1603,21 @@ TclExecuteByteCode(interp, codePtr)
opName[opCode], O2S(namePtr), i),
Tcl_GetObjResult(interp));
result = TCL_ERROR;
- Tcl_DecrRefCount(namePtr); /* done with var name */
+ Tcl_DecrRefCount(namePtr);
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ",
opName[opCode], O2S(namePtr), i), value2Ptr);
- TclDecrRefCount(namePtr); /* done with var name */
+ TclDecrRefCount(namePtr);
ADJUST_PC(2);
case INST_INCR_ARRAY1_IMM:
{
Tcl_Obj *elemPtr;
- opnd = TclGetUInt1AtPc(pc+1);
- i = TclGetInt1AtPc(pc+2);
+ opnd = TclGetUInt1AtPtr(pc+1);
+ i = TclGetInt1AtPtr(pc+2);
elemPtr = POP_OBJECT();
DECACHE_STACK_INFO();
value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
@@ -1698,14 +1627,14 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ERROR: ",
opnd, O2S(elemPtr), i),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(elemPtr); /* done with element name */
+ Tcl_DecrRefCount(elemPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ",
opnd, O2S(elemPtr), i), value2Ptr);
- Tcl_DecrRefCount(elemPtr); /* done with element name */
+ Tcl_DecrRefCount(elemPtr);
}
ADJUST_PC(3);
@@ -1713,7 +1642,7 @@ TclExecuteByteCode(interp, codePtr)
{
Tcl_Obj *elemPtr;
- i = TclGetInt1AtPc(pc+1);
+ i = TclGetInt1AtPtr(pc+1);
elemPtr = POP_OBJECT();
namePtr = POP_OBJECT();
DECACHE_STACK_INFO();
@@ -1724,38 +1653,38 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ERROR: ",
O2S(namePtr), O2S(elemPtr), i),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done with array name */
- Tcl_DecrRefCount(elemPtr); /* done with element name */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(elemPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ",
O2S(namePtr), O2S(elemPtr), i), value2Ptr);
- Tcl_DecrRefCount(namePtr); /* done with array name */
- Tcl_DecrRefCount(elemPtr); /* done with element name */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(elemPtr);
}
ADJUST_PC(2);
case INST_JUMP1:
- opnd = TclGetInt1AtPc(pc+1);
+ opnd = TclGetInt1AtPtr(pc+1);
TRACE(("jump1 %d => new pc %u\n", opnd,
(unsigned int)(pc + opnd - codePtr->codeStart)));
ADJUST_PC(opnd);
case INST_JUMP4:
- opnd = TclGetInt4AtPc(pc+1);
+ opnd = TclGetInt4AtPtr(pc+1);
TRACE(("jump4 %d => new pc %u\n", opnd,
(unsigned int)(pc + opnd - codePtr->codeStart)));
ADJUST_PC(opnd);
case INST_JUMP_TRUE4:
- opnd = TclGetInt4AtPc(pc+1);
+ opnd = TclGetInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doJumpTrue;
case INST_JUMP_TRUE1:
- opnd = TclGetInt1AtPc(pc+1);
+ opnd = TclGetInt1AtPtr(pc+1);
pcAdjustment = 2;
doJumpTrue:
@@ -1772,7 +1701,7 @@ TclExecuteByteCode(interp, codePtr)
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode],
opnd), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(valuePtr); /* done w popped obj */
+ Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
@@ -1780,23 +1709,23 @@ TclExecuteByteCode(interp, codePtr)
TRACE(("%s %d => %.20s true, new pc %u\n",
opName[opCode], opnd, O2S(valuePtr),
(unsigned int)(pc+opnd - codePtr->codeStart)));
- TclDecrRefCount(valuePtr); /* done with popped obj */
+ TclDecrRefCount(valuePtr);
ADJUST_PC(opnd);
} else {
TRACE(("%s %d => %.20s false\n", opName[opCode], opnd,
O2S(valuePtr)));
- TclDecrRefCount(valuePtr); /* done with popped obj */
+ TclDecrRefCount(valuePtr);
ADJUST_PC(pcAdjustment);
}
}
case INST_JUMP_FALSE4:
- opnd = TclGetInt4AtPc(pc+1);
+ opnd = TclGetInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doJumpFalse;
case INST_JUMP_FALSE1:
- opnd = TclGetInt1AtPc(pc+1);
+ opnd = TclGetInt1AtPtr(pc+1);
pcAdjustment = 2;
doJumpFalse:
@@ -1813,20 +1742,20 @@ TclExecuteByteCode(interp, codePtr)
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode],
opnd), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(valuePtr); /* done w popped obj */
+ Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
if (b) {
TRACE(("%s %d => %.20s true\n", opName[opCode], opnd,
O2S(valuePtr)));
- TclDecrRefCount(valuePtr); /* done with popped obj */
+ TclDecrRefCount(valuePtr);
ADJUST_PC(pcAdjustment);
} else {
TRACE(("%s %d => %.20s false, new pc %u\n",
opName[opCode], opnd, O2S(valuePtr),
(unsigned int)(pc + opnd - codePtr->codeStart)));
- TclDecrRefCount(valuePtr); /* done with popped obj */
+ TclDecrRefCount(valuePtr);
ADJUST_PC(opnd);
}
}
@@ -1858,19 +1787,19 @@ TclExecuteByteCode(interp, codePtr)
if (TclLooksLikeInt(s)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
- i = (valuePtr->internalRep.longValue != 0);
+ i = (i != 0);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d1);
- i = (valuePtr->internalRep.doubleValue != 0.0);
+ i = (d1 != 0.0);
}
if (result != TCL_OK) {
TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",
opName[opCode], O2S(valuePtr),
(t1Ptr? t1Ptr->name : "null")));
IllegalExprOperandType(interp, opCode, valuePtr);
- Tcl_DecrRefCount(valuePtr); /* done with object */
- Tcl_DecrRefCount(value2Ptr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
}
@@ -1884,19 +1813,19 @@ TclExecuteByteCode(interp, codePtr)
if (TclLooksLikeInt(s)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
value2Ptr, &i2);
- i2 = (value2Ptr->internalRep.longValue != 0);
+ i2 = (i2 != 0);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
value2Ptr, &d1);
- i2 = (value2Ptr->internalRep.doubleValue != 0.0);
+ i2 = (d1 != 0.0);
}
if (result != TCL_OK) {
TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",
opName[opCode], O2S(value2Ptr),
(t2Ptr? t2Ptr->name : "null")));
IllegalExprOperandType(interp, opCode, value2Ptr);
- Tcl_DecrRefCount(valuePtr); /* done with object */
- Tcl_DecrRefCount(value2Ptr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
}
@@ -1914,7 +1843,7 @@ TclExecuteByteCode(interp, codePtr)
PUSH_OBJECT(Tcl_NewLongObj(iResult));
TRACE(("%s %.20s %.20s => %ld\n", opName[opCode],
O2S(valuePtr), O2S(value2Ptr), iResult));
- TclDecrRefCount(valuePtr); /* done with object */
+ TclDecrRefCount(valuePtr);
} else { /* reuse the valuePtr object */
TRACE(("%s %.20s %.20s => %ld\n",
opName[opCode], /* NB: stack top is off by 1 */
@@ -1922,7 +1851,7 @@ TclExecuteByteCode(interp, codePtr)
Tcl_SetLongObj(valuePtr, iResult);
++stackTop; /* valuePtr now on stk top has right r.c. */
}
- TclDecrRefCount(value2Ptr); /* done with object */
+ TclDecrRefCount(value2Ptr);
}
ADJUST_PC(1);
@@ -1945,7 +1874,7 @@ TclExecuteByteCode(interp, codePtr)
double d1 = 0.0; /* Init. avoids compiler warning. */
double d2 = 0.0; /* Init. avoids compiler warning. */
long iResult = 0; /* Init. avoids compiler warning. */
-
+
value2Ptr = POP_OBJECT();
valuePtr = POP_OBJECT();
t1Ptr = valuePtr->typePtr;
@@ -2076,7 +2005,7 @@ TclExecuteByteCode(interp, codePtr)
PUSH_OBJECT(Tcl_NewLongObj(iResult));
TRACE(("%s %.20s %.20s => %ld\n", opName[opCode],
O2S(valuePtr), O2S(value2Ptr), iResult));
- TclDecrRefCount(valuePtr); /* done with object */
+ TclDecrRefCount(valuePtr);
} else { /* reuse the valuePtr object */
TRACE(("%s %.20s %.20s => %ld\n",
opName[opCode], /* NB: stack top is off by 1 */
@@ -2084,7 +2013,7 @@ TclExecuteByteCode(interp, codePtr)
Tcl_SetLongObj(valuePtr, iResult);
++stackTop; /* valuePtr now on stk top has right r.c. */
}
- TclDecrRefCount(value2Ptr); /* done with object */
+ TclDecrRefCount(value2Ptr);
}
ADJUST_PC(1);
@@ -2115,8 +2044,8 @@ TclExecuteByteCode(interp, codePtr)
(valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
IllegalExprOperandType(interp, opCode, valuePtr);
- Tcl_DecrRefCount(valuePtr); /* done with object */
- Tcl_DecrRefCount(value2Ptr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
}
@@ -2131,8 +2060,8 @@ TclExecuteByteCode(interp, codePtr)
(value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
IllegalExprOperandType(interp, opCode, value2Ptr);
- Tcl_DecrRefCount(valuePtr); /* done with object */
- Tcl_DecrRefCount(value2Ptr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
}
@@ -2147,8 +2076,8 @@ TclExecuteByteCode(interp, codePtr)
*/
if (i2 == 0) {
TRACE(("mod %ld %ld => DIVIDE BY ZERO\n", i, i2));
- Tcl_DecrRefCount(valuePtr); /* done with object */
- Tcl_DecrRefCount(value2Ptr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto divideByZero;
}
negative = 0;
@@ -2200,14 +2129,14 @@ TclExecuteByteCode(interp, codePtr)
PUSH_OBJECT(Tcl_NewLongObj(iResult));
TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2,
iResult));
- TclDecrRefCount(valuePtr); /* done with object */
+ TclDecrRefCount(valuePtr);
} else { /* reuse the valuePtr object */
TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2,
iResult)); /* NB: stack top is off by 1 */
Tcl_SetLongObj(valuePtr, iResult);
++stackTop; /* valuePtr now on stk top has right r.c. */
}
- TclDecrRefCount(value2Ptr); /* done with object */
+ TclDecrRefCount(value2Ptr);
}
ADJUST_PC(1);
@@ -2252,8 +2181,8 @@ TclExecuteByteCode(interp, codePtr)
(valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
IllegalExprOperandType(interp, opCode, valuePtr);
- Tcl_DecrRefCount(valuePtr); /* done with object */
- Tcl_DecrRefCount(value2Ptr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
t1Ptr = valuePtr->typePtr;
@@ -2278,8 +2207,8 @@ TclExecuteByteCode(interp, codePtr)
(value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
IllegalExprOperandType(interp, opCode, value2Ptr);
- Tcl_DecrRefCount(valuePtr); /* done with object */
- Tcl_DecrRefCount(value2Ptr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
t2Ptr = value2Ptr->typePtr;
@@ -2309,8 +2238,8 @@ TclExecuteByteCode(interp, codePtr)
if (d2 == 0.0) {
TRACE(("div %.6g %.6g => DIVIDE BY ZERO\n",
d1, d2));
- Tcl_DecrRefCount(valuePtr); /* done with obj */
- Tcl_DecrRefCount(value2Ptr); /* done with obj */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto divideByZero;
}
dResult = d1 / d2;
@@ -2326,8 +2255,8 @@ TclExecuteByteCode(interp, codePtr)
opName[opCode], O2S(valuePtr), O2S(value2Ptr)));
TclExprFloatError(interp, dResult);
result = TCL_ERROR;
- Tcl_DecrRefCount(valuePtr); /* done with object */
- Tcl_DecrRefCount(value2Ptr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
} else {
@@ -2354,8 +2283,8 @@ TclExecuteByteCode(interp, codePtr)
if (i2 == 0) {
TRACE(("div %ld %ld => DIVIDE BY ZERO\n",
i, i2));
- Tcl_DecrRefCount(valuePtr); /* done with obj */
- Tcl_DecrRefCount(value2Ptr); /* done with obj */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto divideByZero;
}
if (i2 < 0) {
@@ -2386,7 +2315,7 @@ TclExecuteByteCode(interp, codePtr)
TRACE(("%s %ld %ld => %ld\n", opName[opCode],
i, i2, iResult));
}
- TclDecrRefCount(valuePtr); /* done with object */
+ TclDecrRefCount(valuePtr);
} else { /* reuse the valuePtr object */
if (doDouble) { /* NB: stack top is off by 1 */
TRACE(("%s %.6g %.6g => %.6g\n", opName[opCode],
@@ -2399,7 +2328,7 @@ TclExecuteByteCode(interp, codePtr)
}
++stackTop; /* valuePtr now on stk top has right r.c. */
}
- TclDecrRefCount(value2Ptr); /* done with object */
+ TclDecrRefCount(value2Ptr);
}
ADJUST_PC(1);
@@ -2464,7 +2393,7 @@ TclExecuteByteCode(interp, codePtr)
opName[opCode], s,
(tPtr? tPtr->name : "null")));
IllegalExprOperandType(interp, opCode, valuePtr);
- Tcl_DecrRefCount(valuePtr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
tPtr = valuePtr->typePtr;
@@ -2495,7 +2424,7 @@ TclExecuteByteCode(interp, codePtr)
objPtr); /* NB: stack top is off by 1 */
}
PUSH_OBJECT(objPtr);
- TclDecrRefCount(valuePtr); /* done with popped obj */
+ TclDecrRefCount(valuePtr);
} else {
/*
* valuePtr is unshared. Modify it directly.
@@ -2545,7 +2474,7 @@ TclExecuteByteCode(interp, codePtr)
TRACE(("bitnot \"%.20s\" => ILLEGAL TYPE %s\n",
O2S(valuePtr), (tPtr? tPtr->name : "null")));
IllegalExprOperandType(interp, opCode, valuePtr);
- Tcl_DecrRefCount(valuePtr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
@@ -2554,7 +2483,7 @@ TclExecuteByteCode(interp, codePtr)
if (Tcl_IsShared(valuePtr)) {
PUSH_OBJECT(Tcl_NewLongObj(~i));
TRACE(("bitnot 0x%lx => (%lu)\n", i, ~i));
- TclDecrRefCount(valuePtr); /* done with popped obj */
+ TclDecrRefCount(valuePtr);
} else {
/*
* valuePtr is unshared. Modify it directly.
@@ -2567,7 +2496,7 @@ TclExecuteByteCode(interp, codePtr)
ADJUST_PC(1);
case INST_CALL_BUILTIN_FUNC1:
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
{
/*
* Call one of the built-in Tcl math functions.
@@ -2595,7 +2524,7 @@ TclExecuteByteCode(interp, codePtr)
ADJUST_PC(2);
case INST_CALL_FUNC1:
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
{
/*
* Call a non-builtin Tcl math function previously
@@ -2677,7 +2606,7 @@ TclExecuteByteCode(interp, codePtr)
objPtr = Tcl_NewDoubleObj(d);
}
Tcl_IncrRefCount(objPtr);
- TclDecrRefCount(valuePtr); /* done with object */
+ TclDecrRefCount(valuePtr);
valuePtr = objPtr;
tPtr = valuePtr->typePtr;
} else {
@@ -2695,6 +2624,8 @@ TclExecuteByteCode(interp, codePtr)
goto checkForCatch;
}
}
+ shared = shared; /* lint, shared not used. */
+ converted = converted; /* lint, converted not used. */
TRACE(("tryCvtToNumeric \"%.20s\" => numeric, %s, %s\n",
O2S(valuePtr),
(converted? "converted" : "not converted"),
@@ -2754,7 +2685,7 @@ TclExecuteByteCode(interp, codePtr)
if (rangePtr == NULL) {
TRACE(("continue => no encl. loop or catch, returning TCL_CONTINUE\n"));
result = TCL_CONTINUE;
- goto abnormalReturn; /* no catch exists to check */
+ goto abnormalReturn;
}
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
@@ -2778,7 +2709,7 @@ TclExecuteByteCode(interp, codePtr)
continue; /* restart outer instruction loop at pc */
case INST_FOREACH_START4:
- opnd = TclGetUInt4AtPc(pc+1);
+ opnd = TclGetUInt4AtPtr(pc+1);
{
/*
* Initialize the temporary local var that holds the count
@@ -2795,22 +2726,13 @@ TclExecuteByteCode(interp, codePtr)
iterVarPtr = &(compiledLocals[iterTmpIndex]);
oldValuePtr = iterVarPtr->value.objPtr;
-#ifdef TCL_COMPILE_DEBUG
- if (TclIsVarLink(iterVarPtr)) {
- panic("TclExecuteByteCode execution failure: foreach loop iter temp %d is link\n", iterTmpIndex);
- }
- if ((oldValuePtr != NULL) && Tcl_IsShared(oldValuePtr)) {
- panic("TclExecuteByteCode execution failure: foreach loop iter temp %d has shared object\n", iterTmpIndex);
- }
-#endif /* TCL_COMPILE_DEBUG */
-
if (oldValuePtr == NULL) {
iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
Tcl_IncrRefCount(iterVarPtr->value.objPtr);
if (oldValuePtr != NULL) {
- Tcl_DecrRefCount(oldValuePtr); /* free old value */
+ Tcl_DecrRefCount(oldValuePtr);
}
- } else { /* update object in place */
+ } else {
Tcl_SetLongObj(oldValuePtr, -1);
}
TclSetVarScalar(iterVarPtr);
@@ -2821,7 +2743,7 @@ TclExecuteByteCode(interp, codePtr)
ADJUST_PC(5);
case INST_FOREACH_STEP4:
- opnd = TclGetUInt4AtPc(pc+1);
+ opnd = TclGetUInt4AtPtr(pc+1);
{
/*
* "Step" a foreach loop (i.e., begin its next iteration) by
@@ -2848,18 +2770,6 @@ TclExecuteByteCode(interp, codePtr)
iterVarPtr = &(compiledLocals[iterTmpIndex]);
oldValuePtr = iterVarPtr->value.objPtr;
-#ifdef TCL_COMPILE_DEBUG
- if (TclIsVarLink(iterVarPtr) || TclIsVarUndefined(iterVarPtr)
- || !TclIsVarScalar(iterVarPtr)) {
- panic("TclExecuteByteCode execution failure: foreach loop iter temp %d is link, undefined, or array\n", iterTmpIndex);
- }
- if ((oldValuePtr == NULL)
- || (oldValuePtr->typePtr != &tclIntType)
- || (oldValuePtr->bytes != NULL)
- || Tcl_IsShared(oldValuePtr)) {
- panic("TclExecuteByteCode execution failure: foreach loop iter count object is bad\n");
- }
-#endif /* TCL_COMPILE_DEBUG */
iterNum = (oldValuePtr->internalRep.longValue + 1);
Tcl_SetLongObj(oldValuePtr, iterNum);
@@ -2875,17 +2785,6 @@ TclExecuteByteCode(interp, codePtr)
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
-#ifdef TCL_COMPILE_DEBUG
- if (TclIsVarLink(listVarPtr) || TclIsVarUndefined(listVarPtr)
- || !TclIsVarScalar(listVarPtr)) {
- panic("TclExecuteByteCode execution failure: foreach loop list temp %d is link, undefined, or array\n", listTmpIndex);
- }
- if (listPtr == NULL) {
- panic("TclExecuteByteCode execution failure: NULL foreach list temp %d: \"%s\"\n",
- listTmpIndex,
- Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length));
- }
-#endif /* TCL_COMPILE_DEBUG */
result = Tcl_ListObjLength(interp, listPtr, &listLen);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("foreach_step4 %u => ERROR converting list %ld, \"%s\": ",
@@ -2923,7 +2822,7 @@ TclExecuteByteCode(interp, codePtr)
int setEmptyStr = 0;
if (valIndex >= listLen) {
setEmptyStr = 1;
- elemPtr = Tcl_NewObj(); /* set to "" */
+ elemPtr = Tcl_NewObj();
} else {
elemPtr = listRepPtr->elements[valIndex];
}
@@ -2970,7 +2869,7 @@ TclExecuteByteCode(interp, codePtr)
*/
catchStackPtr[++catchTop] = stackTop;
TRACE(("beginCatch4 %u => catchTop=%d, stackTop=%d\n",
- TclGetUInt4AtPc(pc+1), catchTop, stackTop));
+ TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
ADJUST_PC(5);
case INST_END_CATCH:
@@ -2985,7 +2884,7 @@ TclExecuteByteCode(interp, codePtr)
ADJUST_PC(1);
case INST_PUSH_RETURN_CODE:
- PUSH_OBJECT(Tcl_NewLongObj(result)); /* i.e., the return code */
+ PUSH_OBJECT(Tcl_NewLongObj(result));
TRACE(("pushReturnCode => %u\n", result));
ADJUST_PC(1);
@@ -3007,68 +2906,71 @@ TclExecuteByteCode(interp, codePtr)
result = TCL_ERROR;
/*
- * Execution has generated an "exceptional return" (or "exception")
- * such as TCL_ERROR. Look for the closest enclosing catch exception
- * range, if any. If no enclosing catch range is found, stop
- * execution and return the "exceptional return" code.
+ * Execution has generated an "exception" such as TCL_ERROR. If the
+ * exception is an error, record information about what was being
+ * executed when the error occurred. Find the closest enclosing
+ * catch range, if any. If no enclosing catch range is found, stop
+ * execution and return the "exception" code.
*/
checkForCatch:
- rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 1, codePtr);
- if (rangePtr == NULL) {
- TRACE((" ... no enclosing catch, returning %s\n",
- StringForResultCode(result)));
- goto abnormalReturn; /* no catch exists to check */
- }
-
- /*
- * A catch exception range (rangePtr) has been to handle an
- * "exception". It was found either by checkForCatch just above or
- * by an instruction during break, continue, or error processing.
- * Jump to its catchOffset after unwinding the operand stack to
- * the depth it had when starting to execute the range's catch
- * command. Also, if the exception is an error, record information
- * about what was being executed when the error occurred.
- */
-
- processCatch:
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
+ int numChars;
+ char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
char buf[200];
- int cmdIndex = TclGetSrcInfoForPc(pc, codePtr);
-
- /*
- * Compute the line number where the error occurred.
- */
+ register char *p;
+ char *ellipsis = "";
- iPtr->errorLine = 1; /* no correct line # information yet */
-
/*
* Print the command in the error message (up to a certain
- * number of characters, or up to the first new-line).
+ * number of characters, or up to the first newline).
*/
-
- if (cmdIndex != -1) {
- CmdLocation *locPtr = &(codePtr->cmdMapPtr[cmdIndex]);
- char *ellipsis = "";
- int numChars = locPtr->numSrcChars;
+
+ iPtr->errorLine = 1;
+ if (cmd != NULL) {
+ for (p = codePtr->source; p != cmd; p++) {
+ if (*p == '\n') {
+ iPtr->errorLine++;
+ }
+ }
+ for ( ; (isspace(UCHAR(*p)) || (*p == ';')); p++) {
+ if (*p == '\n') {
+ iPtr->errorLine++;
+ }
+ }
+
if (numChars > 150) {
numChars = 150;
ellipsis = "...";
}
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
sprintf(buf, "\n while executing\n\"%.*s%s\"",
- numChars, (codePtr->source + locPtr->srcOffset),
- ellipsis);
+ numChars, cmd, ellipsis);
} else {
sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
- numChars, (codePtr->source + locPtr->srcOffset),
- ellipsis);
+ numChars, cmd, ellipsis);
}
Tcl_AddObjErrorInfo(interp, buf, -1);
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
-
+ rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 1, codePtr);
+ if (rangePtr == NULL) {
+ TRACE((" ... no enclosing catch, returning %s\n",
+ StringForResultCode(result)));
+ goto abnormalReturn;
+ }
+
+ /*
+ * A catch exception range (rangePtr) was found to handle an
+ * "exception". It was found either by checkForCatch just above or
+ * by an instruction during break, continue, or error processing.
+ * Jump to its catchOffset after unwinding the operand stack to
+ * the depth it had when starting to execute the range's catch
+ * command.
+ */
+
+ processCatch:
while (stackTop > catchStackPtr[catchTop]) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
@@ -3107,6 +3009,140 @@ TclExecuteByteCode(interp, codePtr)
/*
*----------------------------------------------------------------------
*
+ * PrintByteCodeInfo --
+ *
+ * This procedure prints a summary about a bytecode object to stdout.
+ * It is called by TclExecuteByteCode when starting to execute the
+ * bytecode object if tclTraceExec has the value 2 or more.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+PrintByteCodeInfo(codePtr)
+ register ByteCode *codePtr; /* The bytecode whose summary is printed
+ * to stdout. */
+{
+ Proc *procPtr = codePtr->procPtr;
+ int numCmds = codePtr->numCommands;
+ int numObjs = codePtr->numObjects;
+ int objBytes, i;
+
+ objBytes = (numObjs * sizeof(Tcl_Obj));
+ for (i = 0; i < numObjs; i++) {
+ Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i];
+ if (litObjPtr->bytes != NULL) {
+ objBytes += litObjPtr->length;
+ }
+ }
+
+ fprintf(stdout, "\nExecuting ByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n",
+ (unsigned int) codePtr, codePtr->refCount,
+ codePtr->compileEpoch, (unsigned int) codePtr->iPtr,
+ codePtr->iPtr->compileEpoch);
+
+ fprintf(stdout, " Source: ");
+ TclPrintSource(stdout, codePtr->source, 70);
+
+ fprintf(stdout, "\n Cmds %d, chars %d, inst %u, objs %u, aux %d, stk depth %u, code/src %.2fn",
+ numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs,
+ codePtr->numAuxDataItems, codePtr->maxStackDepth,
+ (codePtr->numSrcChars?
+ ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0));
+
+ fprintf(stdout, " Code %d = %d(header)+%d(inst)+%d(objs)+%d(exc)+%d(aux)+%d(cmd map)\n",
+ codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes,
+ objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)),
+ (codePtr->numAuxDataItems * sizeof(AuxData)),
+ codePtr->numCmdLocBytes);
+
+ if (procPtr != NULL) {
+ fprintf(stdout,
+ " Proc 0x%x, ref ct %d, args %d, compiled locals %d\n",
+ (unsigned int) procPtr, procPtr->refCount,
+ procPtr->numArgs, procPtr->numCompiledLocals);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ValidatePcAndStackTop --
+ *
+ * This procedure is called by TclExecuteByteCode when debugging to
+ * verify that the program counter and stack top are valid during
+ * execution.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Prints a message to stderr and panics if either the pc or stack
+ * top are invalid.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+static void
+ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, stackUpperBound)
+ register ByteCode *codePtr; /* The bytecode whose summary is printed
+ * to stdout. */
+ unsigned char *pc; /* Points to first byte of a bytecode
+ * instruction. The program counter. */
+ int stackTop; /* Current stack top. Must be between
+ * stackLowerBound and stackUpperBound
+ * (inclusive). */
+ int stackLowerBound; /* Smallest legal value for stackTop. */
+ int stackUpperBound; /* Greatest legal value for stackTop. */
+{
+ unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart);
+ unsigned int codeStart = (unsigned int) codePtr->codeStart;
+ unsigned int codeEnd = (unsigned int)
+ (codePtr->codeStart + codePtr->numCodeBytes);
+ unsigned char opCode = *pc;
+
+ if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) {
+ fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n",
+ (unsigned int) pc);
+ panic("TclExecuteByteCode execution failure: bad pc");
+ }
+ if ((unsigned int) opCode > LAST_INST_OPCODE) {
+ fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
+ (unsigned int) opCode, relativePc);
+ panic("TclExecuteByteCode execution failure: bad opcode");
+ }
+ if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) {
+ int numChars;
+ char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
+ char *ellipsis = "";
+
+ fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode",
+ stackTop, relativePc);
+ if (cmd != NULL) {
+ if (numChars > 100) {
+ numChars = 100;
+ ellipsis = "...";
+ }
+ fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd,
+ ellipsis);
+ } else {
+ fprintf(stderr, "\n");
+ }
+ panic("TclExecuteByteCode execution failure: bad stack top");
+ }
+}
+#endif /* TCL_COMPILE_DEBUG */
+
+/*
+ *----------------------------------------------------------------------
+ *
* IllegalExprOperandType --
*
* Used by TclExecuteByteCode to add an error message to errorInfo
@@ -3201,7 +3237,7 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
*/
p = (char *) ckalloc((unsigned) (numChars + 1));
- strncpy(p, command, (size_t) numChars);
+ memcpy((VOID *) p, (VOID *) command, (size_t) numChars);
p[numChars] = '\0';
/*
@@ -3218,21 +3254,20 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
/*
*----------------------------------------------------------------------
*
- * TclGetSrcInfoForPc --
+ * GetSrcInfoForPc --
*
- * Procedure that given a program counter value, returns an index
- * of the closest command's element in the bytecode code unit's
- * CmdLocation array. This element provides information about that
- * command's source: a pointer to its first byte and the number
- * of its characters.
+ * Given a program counter value, finds the closest command in the
+ * bytecode code unit's CmdLocation array and returns information about
+ * that command's source: a pointer to its first byte and the number of
+ * characters.
*
* Results:
- * If a command in the bytecode code unit is found that encloses
- * the program counter value, the index of the command's element
- * in the CmdLocation array is returned. If multiple commands
- * resulted in code at pc, the index for the command with code that
- * starts closest to pc is returned. If no matching command is
- * found, -1 is returned.
+ * If a command is found that encloses the program counter value, a
+ * pointer to the command's source is returned and the length of the
+ * source is stored at *lengthPtr. If multiple commands resulted in
+ * code at pc, information about the closest enclosing command is
+ * returned. If no matching command is found, NULL is returned and
+ * *lengthPtr is unchanged.
*
* Side effects:
* None.
@@ -3240,38 +3275,102 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
*----------------------------------------------------------------------
*/
-int
-TclGetSrcInfoForPc(pc, codePtr)
+static char *
+GetSrcInfoForPc(pc, codePtr, lengthPtr)
unsigned char *pc; /* The program counter value for which to
* return the closest command's source info.
* This points to a bytecode instruction
* in codePtr's code. */
ByteCode* codePtr; /* The bytecode sequence in which to look
* up the command source for the pc. */
+ int *lengthPtr; /* If non-NULL, the location where the
+ * length of the command's source should be
+ * stored. If NULL, no length is stored. */
{
- int codeOffset = (pc - codePtr->codeStart);
- int numCommands = codePtr->numCommands;
- CmdLocation *cmdMapPtr = codePtr->cmdMapPtr;
- register CmdLocation *locPtr;
- int bestCmd = -1; /* Index of current candidate for closest
- * command. */
- int bestDist = INT_MAX; /* Distance of pc to bestCmd's start pc. */
- int startOffset, endOffset, dist;
- register int i;
+ register int pcOffset = (pc - codePtr->codeStart);
+ int numCmds = codePtr->numCommands;
+ unsigned char *codeDeltaNext, *codeLengthNext;
+ unsigned char *srcDeltaNext, *srcLengthNext;
+ int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
+ int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
+ int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
+ int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
+
+ if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) {
+ return NULL;
+ }
+
+ /*
+ * Decode the code and source offset and length for each command. The
+ * closest enclosing command is the last one whose code started before
+ * pcOffset.
+ */
+
+ codeDeltaNext = codePtr->codeDeltaStart;
+ codeLengthNext = codePtr->codeLengthStart;
+ srcDeltaNext = codePtr->srcDeltaStart;
+ srcLengthNext = codePtr->srcLengthStart;
+ codeOffset = srcOffset = 0;
+ for (i = 0; i < numCmds; i++) {
+ if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
+ codeDeltaNext++;
+ delta = TclGetInt4AtPtr(codeDeltaNext);
+ codeDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(codeDeltaNext);
+ codeDeltaNext++;
+ }
+ codeOffset += delta;
- for (i = 0; i < numCommands; i++) {
- locPtr = &(cmdMapPtr[i]);
- startOffset = locPtr->codeOffset;
- endOffset = (startOffset + locPtr->numCodeBytes - 1);
- if ((startOffset <= codeOffset) && (codeOffset <= endOffset)) {
- dist = (codeOffset - startOffset);
+ if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
+ codeLengthNext++;
+ codeLen = TclGetInt4AtPtr(codeLengthNext);
+ codeLengthNext += 4;
+ } else {
+ codeLen = TclGetInt1AtPtr(codeLengthNext);
+ codeLengthNext++;
+ }
+ codeEnd = (codeOffset + codeLen - 1);
+
+ if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
+ srcDeltaNext++;
+ delta = TclGetInt4AtPtr(srcDeltaNext);
+ srcDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(srcDeltaNext);
+ srcDeltaNext++;
+ }
+ srcOffset += delta;
+
+ if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
+ srcLengthNext++;
+ srcLen = TclGetInt4AtPtr(srcLengthNext);
+ srcLengthNext += 4;
+ } else {
+ srcLen = TclGetInt1AtPtr(srcLengthNext);
+ srcLengthNext++;
+ }
+
+ if (codeOffset > pcOffset) { /* best cmd already found */
+ break;
+ } else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */
+ int dist = (pcOffset - codeOffset);
if (dist <= bestDist) {
- bestCmd = i;
bestDist = dist;
+ bestSrcOffset = srcOffset;
+ bestSrcLength = srcLen;
}
}
}
- return bestCmd;
+
+ if (bestDist == INT_MAX) {
+ return NULL;
+ }
+
+ if (lengthPtr != NULL) {
+ *lengthPtr = bestSrcLength;
+ }
+ return (codePtr->source + bestSrcOffset);
}
/*
@@ -3430,7 +3529,7 @@ ExprUnaryFunc(interp, eePtr, clientData)
*/
done:
- Tcl_DecrRefCount(valuePtr); /* done with popped obj */
+ Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
@@ -3530,8 +3629,8 @@ ExprBinaryFunc(interp, eePtr, clientData)
*/
done:
- Tcl_DecrRefCount(valuePtr); /* done with popped obj */
- Tcl_DecrRefCount(value2Ptr); /* done with popped obj */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
DECACHE_STACK_INFO();
return result;
}
@@ -3625,7 +3724,7 @@ ExprAbsFunc(interp, eePtr, clientData)
*/
done:
- Tcl_DecrRefCount(valuePtr); /* done with popped obj */
+ Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
@@ -3689,7 +3788,7 @@ ExprDoubleFunc(interp, eePtr, clientData)
*/
done:
- Tcl_DecrRefCount(valuePtr); /* done with popped obj */
+ Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
@@ -3782,7 +3881,7 @@ ExprIntFunc(interp, eePtr, clientData)
*/
done:
- Tcl_DecrRefCount(valuePtr); /* done with popped obj */
+ Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
@@ -3956,7 +4055,7 @@ ExprRoundFunc(interp, eePtr, clientData)
*/
done:
- Tcl_DecrRefCount(valuePtr); /* done with popped obj */
+ Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
@@ -3975,7 +4074,7 @@ ExprSrandFunc(interp, eePtr, clientData)
Tcl_Obj *valuePtr;
Tcl_ObjType *tPtr;
long i = 0; /* Initialized to avoid compiler warning. */
- int result = TCL_OK;
+ int result;
/*
* Set stackPtr and stackTop from eePtr.
@@ -4000,7 +4099,7 @@ ExprSrandFunc(interp, eePtr, clientData)
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
((tPtr == &tclDoubleType)? "floating-point value" : "non-numeric string"),
" as argument to srand", (char *) NULL);
- Tcl_DecrRefCount(valuePtr); /* done with popped obj */
+ Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
@@ -4264,6 +4363,39 @@ TclExprFloatError(interp, value)
/*
*----------------------------------------------------------------------
*
+ * TclLog2 --
+ *
+ * Procedure used while collecting compilation statistics to determine
+ * the log base 2 of an integer.
+ *
+ * Results:
+ * Returns the log base 2 of the operand. If the argument is less
+ * than or equal to zero, a zero is returned.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclLog2(value)
+ register int value; /* The integer for which to compute the
+ * log base 2. */
+{
+ register int n = value;
+ register int result = 0;
+
+ while (n > 1) {
+ n = n >> 1;
+ result++;
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* EvalStatsCmd --
*
* Implements the "evalstats" command that prints instruction execution
@@ -4287,23 +4419,108 @@ EvalStatsCmd(unused, interp, argc, argv)
{
register double total = 0.0;
register int i;
+ int maxSizeDecade = 0;
+ double totalHeaderBytes = (tclNumCompilations * sizeof(ByteCode));
for (i = 0; i < 256; i++) {
- if (instructionCount[i]) {
+ if (instructionCount[i] != 0) {
total += instructionCount[i];
}
- }
+ }
+
+ for (i = 31; i >= 0; i--) {
+ if ((tclSourceCount[i] > 0) && (tclByteCodeCount[i] > 0)) {
+ maxSizeDecade = i;
+ break;
+ }
+ }
- fprintf(stdout, "\nNumber of ByteCode compilations: %ld\n",
+ fprintf(stdout, "\nNumber of compilations %ld\n",
tclNumCompilations);
- fprintf(stdout, "Number of ByteCode executions: %ld\n",
+ fprintf(stdout, "Number of executions %ld\n",
numExecutions);
- fprintf(stdout, "Number of Tcl objects in use: %ld, allocated %ld, freed %ld\n",
- (tclObjsAlloced - tclObjsFreed), tclObjsAlloced, tclObjsFreed);
- fprintf(stdout, "Number of instructions executed: %.0f\n\n", total);
+ fprintf(stdout, "Average executions/compilation %.0f\n",
+ ((float) numExecutions/tclNumCompilations));
+
+ fprintf(stdout, "\nInstructions executed %.0f\n",
+ total);
+ fprintf(stdout, "Average instructions/compile %.0f\n",
+ total/tclNumCompilations);
+ fprintf(stdout, "Average instructions/execution %.0f\n",
+ total/numExecutions);
+
+ fprintf(stdout, "\nTotal source bytes %.6g\n",
+ tclTotalSourceBytes);
+ fprintf(stdout, "Total code bytes %.6g\n",
+ tclTotalCodeBytes);
+ fprintf(stdout, "Average code/compilation %.0f\n",
+ tclTotalCodeBytes/tclNumCompilations);
+ fprintf(stdout, "Average code/source %.2f\n",
+ tclTotalCodeBytes/tclTotalSourceBytes);
+ fprintf(stdout, "Current source bytes %.6g\n",
+ tclCurrentSourceBytes);
+ fprintf(stdout, "Current code bytes %.6g\n",
+ tclCurrentCodeBytes);
+ fprintf(stdout, "Current code/source %.2f\n",
+ tclCurrentCodeBytes/tclCurrentSourceBytes);
+
+ fprintf(stdout, "\nTotal objects allocated %ld\n",
+ tclObjsAlloced);
+ fprintf(stdout, "Total objects freed %ld\n",
+ tclObjsFreed);
+ fprintf(stdout, "Current objects: %ld\n",
+ (tclObjsAlloced - tclObjsFreed));
+
+ fprintf(stdout, "\nBreakdown of code byte requirements:\n");
+ fprintf(stdout, " Total bytes Pct of Avg per\n");
+ fprintf(stdout, " all code compile\n");
+ fprintf(stdout, "Total code %12.6g 100%% %8.2f\n",
+ tclTotalCodeBytes, tclTotalCodeBytes/tclNumCompilations);
+ fprintf(stdout, "Header %12.6g %8.2f%% %8.2f\n",
+ totalHeaderBytes,
+ ((totalHeaderBytes * 100.0) / tclTotalCodeBytes),
+ totalHeaderBytes/tclNumCompilations);
+ fprintf(stdout, "Instructions %12.6g %8.2f%% %8.2f\n",
+ tclTotalInstBytes,
+ ((tclTotalInstBytes * 100.0) / tclTotalCodeBytes),
+ tclTotalInstBytes/tclNumCompilations);
+ fprintf(stdout, "Objects %12.6g %8.2f%% %8.2f\n",
+ tclTotalObjBytes,
+ ((tclTotalObjBytes * 100.0) / tclTotalCodeBytes),
+ tclTotalObjBytes/tclNumCompilations);
+ fprintf(stdout, "Exception table %12.6g %8.2f%% %8.2f\n",
+ tclTotalExceptBytes,
+ ((tclTotalExceptBytes * 100.0) / tclTotalCodeBytes),
+ tclTotalExceptBytes/tclNumCompilations);
+ fprintf(stdout, "Auxiliary data %12.6g %8.2f%% %8.2f\n",
+ tclTotalAuxBytes,
+ ((tclTotalAuxBytes * 100.0) / tclTotalCodeBytes),
+ tclTotalAuxBytes/tclNumCompilations);
+ fprintf(stdout, "Command map %12.6g %8.2f%% %8.2f\n",
+ tclTotalCmdMapBytes,
+ ((tclTotalCmdMapBytes * 100.0) / tclTotalCodeBytes),
+ tclTotalCmdMapBytes/tclNumCompilations);
+
+ fprintf(stdout, "\nSource and ByteCode size distributions:\n");
+ fprintf(stdout, " binary decade source code\n");
+ for (i = 0; i <= maxSizeDecade; i++) {
+ int decadeLow, decadeHigh;
+
+ if (i == 0) {
+ decadeLow = 0;
+ } else {
+ decadeLow = 1 << i;
+ }
+ decadeHigh = (1 << (i+1)) - 1;
+ fprintf(stdout, " %6d -%6d %6d %6d\n",
+ decadeLow, decadeHigh,
+ tclSourceCount[i], tclByteCodeCount[i]);
+ }
+
+ fprintf(stdout, "\nInstruction counts:\n");
for (i = 0; i < 256; i++) {
if (instructionCount[i]) {
- fprintf(stdout, "%30s %8d %6.2f%%\n",
+ fprintf(stdout, "%20s %8d %6.2f%%\n",
opName[i], instructionCount[i],
(instructionCount[i] * 100.0)/total);
}
@@ -4494,7 +4711,8 @@ DupCmdNameInternalRep(srcPtr, copyPtr)
register ResolvedCmdName *resPtr =
(ResolvedCmdName *) srcPtr->internalRep.otherValuePtr;
- copyPtr->internalRep.otherValuePtr = (VOID *) resPtr;
+ copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
+ copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
if (resPtr != NULL) {
resPtr->refCount++;
}
@@ -4590,6 +4808,7 @@ SetCmdNameFromAny(interp, objPtr)
}
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
return TCL_OK;
}
diff --git a/contrib/tcl/generic/tclFileName.c b/contrib/tcl/generic/tclFileName.c
index 7464304..69d825c 100644
--- a/contrib/tcl/generic/tclFileName.c
+++ b/contrib/tcl/generic/tclFileName.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclFileName.c 1.28 97/05/14 13:23:48
+ * SCCS: @(#) tclFileName.c 1.31 97/08/05 15:23:04
*/
#include "tclInt.h"
@@ -1088,7 +1088,9 @@ DoTildeSubst(interp, user, resultPtr)
}
Tcl_JoinPath(1, &dir, resultPtr);
} else {
- if (TclGetUserHome(user, resultPtr) == NULL) {
+
+ /* lint, TclGetuserHome() always NULL under windows. */
+ if (TclGetUserHome(user, resultPtr) == NULL) {
if (interp) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist",
diff --git a/contrib/tcl/generic/tclHistory.c b/contrib/tcl/generic/tclHistory.c
index f6572c7..0419c3d 100644
--- a/contrib/tcl/generic/tclHistory.c
+++ b/contrib/tcl/generic/tclHistory.c
@@ -1,139 +1,23 @@
/*
* tclHistory.c --
*
- * This module implements history as an optional addition to Tcl.
- * It can be called to record commands ("events") before they are
- * executed, and it provides a command that may be used to perform
- * history substitutions.
+ * This module and the Tcl library file history.tcl together implement
+ * Tcl command history. Tcl_RecordAndEval(Obj) can be called to record
+ * commands ("events") before they are executed. Commands defined in
+ * history.tcl may be used to perform history substitutions.
*
* Copyright (c) 1990-1993 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1994-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.
*
- * SCCS: @(#) tclHistory.c 1.43 97/05/14 13:23:18
+ * SCCS: @(#) tclHistory.c 1.47 97/08/04 16:08:17
*/
#include "tclInt.h"
#include "tclPort.h"
-/*
- * This history stuff is mostly straightforward, except for one thing
- * that makes everything very complicated. Suppose that the following
- * commands get executed:
- * echo foo
- * history redo
- * It's important that the history event recorded for the second command
- * be "echo foo", not "history redo". Otherwise, if another "history redo"
- * command is typed, it will result in infinite recursions on the
- * "history redo" command. Thus, the actual recorded history must be
- * echo foo
- * echo foo
- * To do this, the history command revises recorded history as part of
- * its execution. In the example above, when "history redo" starts
- * execution, the current event is "history redo", but the history
- * command arranges for the current event to be changed to "echo foo".
- *
- * There are three additional complications. The first is that history
- * substitution may only be part of a command, as in the following
- * command sequence:
- * echo foo bar
- * echo [history word 3]
- * In this case, the second event should be recorded as "echo bar". Only
- * part of the recorded event is to be modified. Fortunately, Tcl_Eval
- * helps with this by recording (in the evalFirst and evalLast fields of
- * the intepreter) the location of the command being executed, so the
- * history module can replace exactly the range of bytes corresponding
- * to the history substitution command.
- *
- * The second complication is that there are two ways to revise history:
- * replace a command, and replace the result of a command. Consider the
- * two examples below:
- * format {result is %d} $num | format {result is %d} $num
- * print [history redo] | print [history word 3]
- * Recorded history for these two cases should be as follows:
- * format {result is %d} $num | format {result is %d} $num
- * print [format {result is %d} $num] | print $num
- * In the left case, the history command was replaced with another command
- * to be executed (the brackets were retained), but in the case on the
- * right the result of executing the history command was replaced (i.e.
- * brackets were replaced too).
- *
- * The third complication is that there could potentially be many
- * history substitutions within a single command, as in:
- * echo [history word 3] [history word 2]
- * There could even be nested history substitutions, as in:
- * history subs abc [history word 2]
- * If history revisions were made immediately during each "history" command
- * invocations, it would be very difficult to produce the correct cumulative
- * effect from several substitutions in the same command. To get around
- * this problem, the actual history revision isn't made during the execution
- * of the "history" command. Information about the changes is just recorded,
- * in xxx records, and the actual changes are made during the next call to
- * Tcl_RecordHistory (when we know that execution of the previous command
- * has finished).
- */
-
-/*
- * Default space allocation for command strings:
- */
-
-#define INITIAL_CMD_SIZE 40
-
-/*
- * Forward declarations for procedures defined later in this file:
- */
-
-static void DoRevs _ANSI_ARGS_((Interp *iPtr));
-static HistoryEvent * GetEvent _ANSI_ARGS_((Interp *iPtr, char *string));
-static char * GetWords _ANSI_ARGS_((Interp *iPtr, char *command,
- char *words));
-static void InitHistory _ANSI_ARGS_((Interp *iPtr));
-static void InsertRev _ANSI_ARGS_((Interp *iPtr,
- HistoryRev *revPtr));
-static void MakeSpace _ANSI_ARGS_((HistoryEvent *hPtr, int size));
-static void RevCommand _ANSI_ARGS_((Interp *iPtr, char *string));
-static void RevResult _ANSI_ARGS_((Interp *iPtr, char *string));
-static int SubsAndEval _ANSI_ARGS_((Interp *iPtr, char *cmd,
- char *old, char *new));
-
-/*
- *----------------------------------------------------------------------
- *
- * InitHistory --
- *
- * Initialize history-related state in an interpreter.
- *
- * Results:
- * None.
- *
- * Side effects:
- * History info is initialized in iPtr.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-InitHistory(iPtr)
- register Interp *iPtr; /* Interpreter to initialize. */
-{
- int i;
-
- if (iPtr->numEvents != 0) {
- return;
- }
- iPtr->numEvents = 20;
- iPtr->events = (HistoryEvent *)
- ckalloc((unsigned) (iPtr->numEvents * sizeof(HistoryEvent)));
- for (i = 0; i < iPtr->numEvents; i++) {
- iPtr->events[i].command = (char *) ckalloc(INITIAL_CMD_SIZE);
- *iPtr->events[i].command = 0;
- iPtr->events[i].bytesAvl = INITIAL_CMD_SIZE;
- }
- iPtr->curEvent = 0;
- iPtr->curEventNum = 0;
-}
/*
*----------------------------------------------------------------------
@@ -149,11 +33,7 @@ InitHistory(iPtr)
* executing cmd.
*
* Side effects:
- * The command is recorded and executed. In addition, pending history
- * revisions are carried out, and information is set up to enable
- * Tcl_Eval to identify history command ranges. This procedure also
- * initializes history information for the interpreter, if it hasn't
- * already been initialized.
+ * The command is recorded and executed.
*
*----------------------------------------------------------------------
*/
@@ -168,931 +48,108 @@ Tcl_RecordAndEval(interp, cmd, flags)
* TCL_EVAL_GLOBAL means use Tcl_GlobalEval
* instead of Tcl_Eval. */
{
- register Interp *iPtr = (Interp *) interp;
- register HistoryEvent *eventPtr;
- int length, result;
-
- if (iPtr->numEvents == 0) {
- InitHistory(iPtr);
- }
- DoRevs(iPtr);
-
- /*
- * Don't record empty commands.
- */
-
- while (isspace(UCHAR(*cmd))) {
- cmd++;
- }
- if (*cmd == '\0') {
- Tcl_ResetResult(interp);
- return TCL_OK;
- }
-
- iPtr->curEventNum++;
- iPtr->curEvent++;
- if (iPtr->curEvent >= iPtr->numEvents) {
- iPtr->curEvent = 0;
- }
- eventPtr = &iPtr->events[iPtr->curEvent];
-
- /*
- * Chop off trailing newlines before recording the command.
- */
-
- length = strlen(cmd);
- while (cmd[length-1] == '\n') {
- length--;
- }
- MakeSpace(eventPtr, length + 1);
- strncpy(eventPtr->command, cmd, (size_t) length);
- eventPtr->command[length] = 0;
-
- /*
- * Execute the command. Note: history revision isn't possible after
- * a nested call to this procedure, because the event at the top of
- * the history list no longer corresponds to what's going on when
- * a nested call here returns. Thus, must leave history revision
- * disabled when we return.
- */
-
- result = TCL_OK;
- if (!(flags & TCL_NO_EVAL)) {
- iPtr->historyFirst = cmd;
- iPtr->revDisables = 0;
- iPtr->evalFlags = (flags & ~TCL_EVAL_GLOBAL) | TCL_RECORD_BOUNDS;
- if (flags & TCL_EVAL_GLOBAL) {
- result = Tcl_GlobalEval(interp, cmd);
- } else {
- result = Tcl_Eval(interp, cmd);
- }
- }
- iPtr->revDisables = 1;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_HistoryCmd --
- *
- * This procedure is invoked to process the "history" Tcl command.
- * See the user documentation for details on what it does.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * See the user documentation.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-int
-Tcl_HistoryCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
-{
- register Interp *iPtr = (Interp *) interp;
- register HistoryEvent *eventPtr;
- size_t length;
- int c;
-
- if (iPtr->numEvents == 0) {
- InitHistory(iPtr);
- }
-
- /*
- * If no arguments, treat the same as "history info".
- */
-
- if (argc == 1) {
- goto infoCmd;
- }
-
- c = argv[1][0];
- length = strlen(argv[1]);
+ register Tcl_Obj *cmdPtr;
+ int length = strlen(cmd);
+ int result;
- if ((c == 'a') && (strncmp(argv[1], "add", length)) == 0) {
- if ((argc != 3) && (argc != 4)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " add event ?exec?\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (argc == 4) {
- if (strncmp(argv[3], "exec", strlen(argv[3])) != 0) {
- Tcl_AppendResult(interp, "bad argument \"", argv[3],
- "\": should be \"exec\"", (char *) NULL);
- return TCL_ERROR;
- }
- return Tcl_RecordAndEval(interp, argv[2], 0);
- }
- return Tcl_RecordAndEval(interp, argv[2], TCL_NO_EVAL);
- } else if ((c == 'c') && (strncmp(argv[1], "change", length)) == 0) {
- if ((argc != 3) && (argc != 4)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " change newValue ?event?\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (argc == 3) {
- eventPtr = &iPtr->events[iPtr->curEvent];
- iPtr->revDisables += 1;
- while (iPtr->revPtr != NULL) {
- HistoryRev *nextPtr;
-
- ckfree(iPtr->revPtr->newBytes);
- nextPtr = iPtr->revPtr->nextPtr;
- ckfree((char *) iPtr->revPtr);
- iPtr->revPtr = nextPtr;
- }
- } else {
- eventPtr = GetEvent(iPtr, argv[3]);
- if (eventPtr == NULL) {
- return TCL_ERROR;
- }
- }
- MakeSpace(eventPtr, (int) strlen(argv[2]) + 1);
- strcpy(eventPtr->command, argv[2]);
- return TCL_OK;
- } else if ((c == 'e') && (strncmp(argv[1], "event", length)) == 0) {
- if (argc > 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " event ?event?\"", (char *) NULL);
- return TCL_ERROR;
- }
- eventPtr = GetEvent(iPtr, argc==2 ? "-1" : argv[2]);
- if (eventPtr == NULL) {
- return TCL_ERROR;
- }
- RevResult(iPtr, eventPtr->command);
- Tcl_SetResult(interp, eventPtr->command, TCL_VOLATILE);
- return TCL_OK;
- } else if ((c == 'i') && (strncmp(argv[1], "info", length)) == 0) {
- int count, indx, i;
- char *newline;
-
- if ((argc != 2) && (argc != 3)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " info ?count?\"", (char *) NULL);
- return TCL_ERROR;
- }
- infoCmd:
- if (argc == 3) {
- if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
- return TCL_ERROR;
- }
- if (count > iPtr->numEvents) {
- count = iPtr->numEvents;
- }
- } else {
- count = iPtr->numEvents;
- }
- newline = "";
- for (i = 0, indx = iPtr->curEvent + 1 + iPtr->numEvents - count;
- i < count; i++, indx++) {
- char *cur, *next, savedChar;
- char serial[20];
-
- if (indx >= iPtr->numEvents) {
- indx -= iPtr->numEvents;
- }
- cur = iPtr->events[indx].command;
- if (*cur == '\0') {
- continue; /* No command recorded here. */
- }
- sprintf(serial, "%6d ", iPtr->curEventNum + 1 - (count - i));
- Tcl_AppendResult(interp, newline, serial, (char *) NULL);
- newline = "\n";
-
- /*
- * Tricky formatting here: for multi-line commands, indent
- * the continuation lines.
- */
+ if (length > 0) {
+ /*
+ * Call Tcl_RecordAndEvalObj to do the actual work.
+ */
- while (1) {
- next = strchr(cur, '\n');
- if (next == NULL) {
- break;
- }
- next++;
- savedChar = *next;
- *next = 0;
- Tcl_AppendResult(interp, cur, "\t", (char *) NULL);
- *next = savedChar;
- cur = next;
- }
- Tcl_AppendResult(interp, cur, (char *) NULL);
- }
- return TCL_OK;
- } else if ((c == 'k') && (strncmp(argv[1], "keep", length)) == 0) {
- int count, i, src;
- HistoryEvent *events;
+ TclNewObj(cmdPtr);
+ TclInitStringRep(cmdPtr, cmd, length);
+ Tcl_IncrRefCount(cmdPtr);
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " keep number\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
- return TCL_ERROR;
- }
- if ((count <= 0) || (count > 1000)) {
- Tcl_AppendResult(interp, "illegal keep count \"", argv[2],
- "\"", (char *) NULL);
- return TCL_ERROR;
- }
+ result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags);
/*
- * Create a new history array and copy as much existing history
- * as possible from the old array.
+ * Move the interpreter's object result to the string result,
+ * then reset the object result.
+ * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
*/
- events = (HistoryEvent *)
- ckalloc((unsigned) (count * sizeof(HistoryEvent)));
- if (count < iPtr->numEvents) {
- src = iPtr->curEvent + 1 - count;
- if (src < 0) {
- src += iPtr->numEvents;
- }
- } else {
- src = iPtr->curEvent + 1;
- }
- for (i = 0; i < count; i++, src++) {
- if (src >= iPtr->numEvents) {
- src = 0;
- }
- if (i < iPtr->numEvents) {
- events[i] = iPtr->events[src];
- iPtr->events[src].command = NULL;
- } else {
- events[i].command = (char *) ckalloc(INITIAL_CMD_SIZE);
- events[i].command[0] = 0;
- events[i].bytesAvl = INITIAL_CMD_SIZE;
- }
- }
+ Tcl_SetResult(interp,
+ TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
+ TCL_VOLATILE);
/*
- * Throw away everything left in the old history array, and
- * substitute the new one for the old one.
+ * Discard the Tcl object created to hold the command.
*/
-
- for (i = 0; i < iPtr->numEvents; i++) {
- if (iPtr->events[i].command != NULL) {
- ckfree(iPtr->events[i].command);
- }
- }
- ckfree((char *) iPtr->events);
- iPtr->events = events;
- if (count < iPtr->numEvents) {
- iPtr->curEvent = count-1;
- } else {
- iPtr->curEvent = iPtr->numEvents-1;
- }
- iPtr->numEvents = count;
- return TCL_OK;
- } else if ((c == 'n') && (strncmp(argv[1], "nextid", length)) == 0) {
- char buf[40];
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " nextid\"", (char *) NULL);
- return TCL_ERROR;
- }
- TclFormatInt(buf, iPtr->curEventNum+1);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- return TCL_OK;
- } else if ((c == 'r') && (strncmp(argv[1], "redo", length)) == 0) {
- if (argc > 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " redo ?event?\"", (char *) NULL);
- return TCL_ERROR;
- }
- eventPtr = GetEvent(iPtr, argc==2 ? "-1" : argv[2]);
- if (eventPtr == NULL) {
- return TCL_ERROR;
- }
- RevCommand(iPtr, eventPtr->command);
- return Tcl_Eval(interp, eventPtr->command);
- } else if ((c == 's') && (strncmp(argv[1], "substitute", length)) == 0) {
- if ((argc > 5) || (argc < 4)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " substitute old new ?event?\"", (char *) NULL);
- return TCL_ERROR;
- }
- eventPtr = GetEvent(iPtr, argc==4 ? "-1" : argv[4]);
- if (eventPtr == NULL) {
- return TCL_ERROR;
- }
- return SubsAndEval(iPtr, eventPtr->command, argv[2], argv[3]);
- } else if ((c == 'w') && (strncmp(argv[1], "words", length)) == 0) {
- char *words;
-
- if ((argc != 3) && (argc != 4)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " words num-num/pat ?event?\"", (char *) NULL);
- return TCL_ERROR;
- }
- eventPtr = GetEvent(iPtr, argc==3 ? "-1" : argv[3]);
- if (eventPtr == NULL) {
- return TCL_ERROR;
- }
- words = GetWords(iPtr, eventPtr->command, argv[2]);
- if (words == NULL) {
- return TCL_ERROR;
- }
- RevResult(iPtr, words);
- Tcl_SetResult(interp, words, TCL_DYNAMIC);
- return TCL_OK;
- }
-
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be add, change, event, info, keep, nextid, ",
- "redo, substitute, or words", (char *) NULL);
- return TCL_ERROR;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * MakeSpace --
- *
- * Given a history event, make sure it has enough space for
- * a string of a given length (enlarge the string area if
- * necessary).
- *
- * Results:
- * None.
- *
- * Side effects:
- * More memory may get allocated.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-MakeSpace(hPtr, size)
- HistoryEvent *hPtr;
- int size; /* # of bytes needed in hPtr. */
-{
- if (hPtr->bytesAvl < size) {
- ckfree(hPtr->command);
- hPtr->command = (char *) ckalloc((unsigned) size);
- hPtr->bytesAvl = size;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * InsertRev --
- *
- * Add a new revision to the list of those pending for iPtr.
- * Do it in a way that keeps the revision list sorted in
- * increasing order of firstIndex. Also, eliminate revisions
- * that are subsets of other revisions.
- *
- * Results:
- * None.
- *
- * Side effects:
- * RevPtr is added to iPtr's revision list.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-InsertRev(iPtr, revPtr)
- Interp *iPtr; /* Interpreter to use. */
- register HistoryRev *revPtr; /* Revision to add to iPtr's list. */
-{
- register HistoryRev *curPtr;
- register HistoryRev *prevPtr;
-
- for (curPtr = iPtr->revPtr, prevPtr = NULL; curPtr != NULL;
- prevPtr = curPtr, curPtr = curPtr->nextPtr) {
+ Tcl_DecrRefCount(cmdPtr);
+ } else {
/*
- * If this revision includes the new one (or vice versa) then
- * just eliminate the one that is a subset of the other.
+ * An empty string. Just reset the interpreter's result.
*/
- if ((revPtr->firstIndex <= curPtr->firstIndex)
- && (revPtr->lastIndex >= curPtr->firstIndex)) {
- curPtr->firstIndex = revPtr->firstIndex;
- curPtr->lastIndex = revPtr->lastIndex;
- curPtr->newSize = revPtr->newSize;
- ckfree(curPtr->newBytes);
- curPtr->newBytes = revPtr->newBytes;
- ckfree((char *) revPtr);
- return;
- }
- if ((revPtr->firstIndex >= curPtr->firstIndex)
- && (revPtr->lastIndex <= curPtr->lastIndex)) {
- ckfree(revPtr->newBytes);
- ckfree((char *) revPtr);
- return;
- }
-
- if (revPtr->firstIndex < curPtr->firstIndex) {
- break;
- }
- }
-
- /*
- * Insert revPtr just after prevPtr.
- */
-
- if (prevPtr == NULL) {
- revPtr->nextPtr = iPtr->revPtr;
- iPtr->revPtr = revPtr;
- } else {
- revPtr->nextPtr = prevPtr->nextPtr;
- prevPtr->nextPtr = revPtr;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * RevCommand --
- *
- * This procedure is invoked by the "history" command to record
- * a command revision. See the comments at the beginning of the
- * file for more information about revisions.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Revision information is recorded.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-RevCommand(iPtr, string)
- register Interp *iPtr; /* Interpreter in which to perform the
- * substitution. */
- char *string; /* String to substitute. */
-{
- register HistoryRev *revPtr;
-
- if ((iPtr->evalFirst == NULL) || (iPtr->revDisables > 0)) {
- return;
- }
- revPtr = (HistoryRev *) ckalloc(sizeof(HistoryRev));
- revPtr->firstIndex = iPtr->evalFirst - iPtr->historyFirst;
- revPtr->lastIndex = iPtr->evalLast - iPtr->historyFirst;
- revPtr->newSize = strlen(string);
- revPtr->newBytes = (char *) ckalloc((unsigned) (revPtr->newSize+1));
- strcpy(revPtr->newBytes, string);
- InsertRev(iPtr, revPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * RevResult --
- *
- * This procedure is invoked by the "history" command to record
- * a result revision. See the comments at the beginning of the
- * file for more information about revisions.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Revision information is recorded.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-RevResult(iPtr, string)
- register Interp *iPtr; /* Interpreter in which to perform the
- * substitution. */
- char *string; /* String to substitute. */
-{
- register HistoryRev *revPtr;
- char *evalFirst, *evalLast;
- char *argv[2];
-
- if ((iPtr->evalFirst == NULL) || (iPtr->revDisables > 0)) {
- return;
- }
-
- /*
- * Expand the replacement range to include the brackets that surround
- * the command. If there aren't any brackets (i.e. this command was
- * invoked at top-level) then don't do any revision. Also, if there
- * are several commands in brackets, of which this is just one,
- * then don't do any revision.
- */
-
- evalFirst = iPtr->evalFirst;
- evalLast = iPtr->evalLast + 1;
- while (1) {
- if (evalFirst == iPtr->historyFirst) {
- return;
- }
- evalFirst--;
- if (*evalFirst == '[') {
- break;
- }
- if (!isspace(UCHAR(*evalFirst))) {
- return;
- }
- }
- if (*evalLast != ']') {
- return;
- }
-
- revPtr = (HistoryRev *) ckalloc(sizeof(HistoryRev));
- revPtr->firstIndex = evalFirst - iPtr->historyFirst;
- revPtr->lastIndex = evalLast - iPtr->historyFirst;
- argv[0] = string;
- revPtr->newBytes = Tcl_Merge(1, argv);
- revPtr->newSize = strlen(revPtr->newBytes);
- InsertRev(iPtr, revPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * DoRevs --
- *
- * This procedure is called to apply the history revisions that
- * have been recorded in iPtr.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The most recent entry in the history for iPtr may be modified.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-DoRevs(iPtr)
- register Interp *iPtr; /* Interpreter whose history is to
- * be modified. */
-{
- register HistoryRev *revPtr;
- register HistoryEvent *eventPtr;
- char *newCommand, *p;
- unsigned int size;
- int bytesSeen, count;
-
- if (iPtr->revPtr == NULL) {
- return;
- }
-
- /*
- * The revision is done in two passes. The first pass computes the
- * amount of space needed for the revised event, and the second pass
- * pieces together the new event and frees up the revisions.
- */
-
- eventPtr = &iPtr->events[iPtr->curEvent];
- size = strlen(eventPtr->command) + 1;
- for (revPtr = iPtr->revPtr; revPtr != NULL; revPtr = revPtr->nextPtr) {
- size -= revPtr->lastIndex + 1 - revPtr->firstIndex;
- size += revPtr->newSize;
- }
-
- newCommand = (char *) ckalloc(size);
- p = newCommand;
- bytesSeen = 0;
- for (revPtr = iPtr->revPtr; revPtr != NULL; ) {
- HistoryRev *nextPtr = revPtr->nextPtr;
-
- count = revPtr->firstIndex - bytesSeen;
- if (count > 0) {
- strncpy(p, eventPtr->command + bytesSeen, (size_t) count);
- p += count;
- }
- strncpy(p, revPtr->newBytes, (size_t) revPtr->newSize);
- p += revPtr->newSize;
- bytesSeen = revPtr->lastIndex+1;
- ckfree(revPtr->newBytes);
- ckfree((char *) revPtr);
- revPtr = nextPtr;
- }
- strcpy(p, eventPtr->command + bytesSeen);
-
- /*
- * Replace the command in the event.
- */
-
- ckfree(eventPtr->command);
- eventPtr->command = newCommand;
- eventPtr->bytesAvl = size;
- iPtr->revPtr = NULL;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * GetEvent --
- *
- * Given a textual description of an event (see the manual page
- * for legal values) find the corresponding event and return its
- * command string.
- *
- * Results:
- * The return value is a pointer to the event named by "string".
- * If no such event exists, then NULL is returned and an error
- * message is left in iPtr.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static HistoryEvent *
-GetEvent(iPtr, string)
- register Interp *iPtr; /* Interpreter in which to look. */
- char *string; /* Description of event. */
-{
- int eventNum, index;
- register HistoryEvent *eventPtr;
- int length;
-
- /*
- * First check for a numeric specification of an event.
- */
-
- if (isdigit(UCHAR(*string)) || (*string == '-')) {
- if (Tcl_GetInt((Tcl_Interp *) iPtr, string, &eventNum) != TCL_OK) {
- return NULL;
- }
- if (eventNum < 0) {
- eventNum += iPtr->curEventNum;
- }
- if (eventNum > iPtr->curEventNum) {
- Tcl_AppendResult((Tcl_Interp *) iPtr, "event \"", string,
- "\" hasn't occurred yet", (char *) NULL);
- return NULL;
- }
- if ((eventNum <= iPtr->curEventNum-iPtr->numEvents)
- || (eventNum <= 0)) {
- Tcl_AppendResult((Tcl_Interp *) iPtr, "event \"", string,
- "\" is too far in the past", (char *) NULL);
- return NULL;
- }
- index = iPtr->curEvent + (eventNum - iPtr->curEventNum);
- if (index < 0) {
- index += iPtr->numEvents;
- }
- return &iPtr->events[index];
- }
-
- /*
- * Next, check for an event that contains the string as a prefix or
- * that matches the string in the sense of Tcl_StringMatch.
- */
-
- length = strlen(string);
- for (index = iPtr->curEvent - 1; ; index--) {
- if (index < 0) {
- index += iPtr->numEvents;
- }
- if (index == iPtr->curEvent) {
- break;
- }
- eventPtr = &iPtr->events[index];
- if ((strncmp(eventPtr->command, string, (size_t) length) == 0)
- || Tcl_StringMatch(eventPtr->command, string)) {
- return eventPtr;
- }
- }
-
- Tcl_AppendResult((Tcl_Interp *) iPtr, "no event matches \"", string,
- "\"", (char *) NULL);
- return NULL;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SubsAndEval --
- *
- * Generate a new command by making a textual substitution in
- * the "cmd" argument. Then execute the new command.
- *
- * Results:
- * The return value is a standard Tcl error.
- *
- * Side effects:
- * History gets revised if the substitution is occurring on
- * a recorded command line. Also, the re-executed command
- * may produce side-effects.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SubsAndEval(iPtr, cmd, old, new)
- register Interp *iPtr; /* Interpreter in which to execute
- * new command. */
- char *cmd; /* Command in which to substitute. */
- char *old; /* String to search for in command. */
- char *new; /* Replacement string for "old". */
-{
- char *src, *dst, *newCmd;
- int count, oldLength, newLength, length, result;
-
- /*
- * Figure out how much space it will take to hold the
- * substituted command (and complain if the old string
- * doesn't appear in the original command).
- */
-
- oldLength = strlen(old);
- newLength = strlen(new);
- src = cmd;
- count = 0;
- while (1) {
- src = strstr(src, old);
- if (src == NULL) {
- break;
- }
- src += oldLength;
- count++;
- }
- if (count == 0) {
- Tcl_AppendResult((Tcl_Interp *) iPtr, "\"", old,
- "\" doesn't appear in event", (char *) NULL);
- return TCL_ERROR;
- }
- length = strlen(cmd) + count*(newLength - oldLength);
-
- /*
- * Generate a substituted command.
- */
-
- newCmd = (char *) ckalloc((unsigned) (length + 1));
- dst = newCmd;
- while (1) {
- src = strstr(cmd, old);
- if (src == NULL) {
- strcpy(dst, cmd);
- break;
- }
- strncpy(dst, cmd, (size_t) (src-cmd));
- dst += src-cmd;
- strcpy(dst, new);
- dst += newLength;
- cmd = src + oldLength;
+ Tcl_ResetResult(interp);
+ result = TCL_OK;
}
-
- RevCommand(iPtr, newCmd);
- result = Tcl_Eval((Tcl_Interp *) iPtr, newCmd);
- ckfree(newCmd);
return result;
}
/*
*----------------------------------------------------------------------
*
- * GetWords --
+ * Tcl_RecordAndEvalObj --
*
- * Given a command string, return one or more words from the
- * command string.
+ * This procedure adds the command held in its argument object to the
+ * current list of recorded events and then executes the command by
+ * calling Tcl_EvalObj.
*
* Results:
- * The return value is a pointer to a dynamically-allocated
- * string containing the words of command specified by "words".
- * If the word specifier has improper syntax then an error
- * message is placed in iPtr->result and NULL is returned.
+ * The return value is a standard Tcl return value, the result of
+ * executing the command.
*
* Side effects:
- * Memory is allocated. It is the caller's responsibilty to
- * free the returned string..
+ * The command is recorded and executed.
*
*----------------------------------------------------------------------
*/
-static char *
-GetWords(iPtr, command, words)
- register Interp *iPtr; /* Tcl interpreter in which to place
- * an error message if needed. */
- char *command; /* Command string. */
- char *words; /* Description of which words to extract
- * from the command. Either num[-num] or
- * a pattern. */
+int
+Tcl_RecordAndEvalObj(interp, cmdPtr, flags)
+ Tcl_Interp *interp; /* Token for interpreter in which command
+ * will be executed. */
+ Tcl_Obj *cmdPtr; /* Points to object holding the command to
+ * record and execute. */
+ int flags; /* Additional flags. TCL_NO_EVAL means
+ * record only: don't execute the command.
+ * TCL_EVAL_GLOBAL means use
+ * Tcl_GlobalEvalObj instead of
+ * Tcl_EvalObj. */
{
- char *result;
- char *start, *end, *dst;
- register char *next;
- int first; /* First word desired. -1 means last word
- * only. */
- int last; /* Last word desired. -1 means use everything
- * up to the end. */
- int index; /* Index of current word. */
- char *pattern;
+ Interp *iPtr = (Interp *) interp;
+ int result;
+ Tcl_Obj *list[3];
+ register Tcl_Obj *objPtr;
/*
- * Figure out whether we're looking for a numerical range or for
- * a pattern.
+ * Do recording by eval'ing a tcl history command: history add $cmd.
*/
- pattern = NULL;
- first = 0;
- last = -1;
- if (*words == '$') {
- if (words[1] != '\0') {
- goto error;
- }
- first = -1;
- } else if (isdigit(UCHAR(*words))) {
- first = strtoul(words, &start, 0);
- if (*start == 0) {
- last = first;
- } else if (*start == '-') {
- start++;
- if (*start == '$') {
- start++;
- } else if (isdigit(UCHAR(*start))) {
- last = strtoul(start, &start, 0);
- } else {
- goto error;
- }
- if (*start != 0) {
- goto error;
- }
- }
- if ((first > last) && (last != -1)) {
- goto error;
- }
- } else {
- pattern = words;
- }
+ list[0] = Tcl_NewStringObj("history", -1);
+ list[1] = Tcl_NewStringObj("add", -1);
+ list[2] = cmdPtr;
+
+ objPtr = Tcl_NewListObj(3, list);
+ Tcl_IncrRefCount(objPtr);
+ (void) Tcl_GlobalEvalObj(interp, objPtr);
+ Tcl_DecrRefCount(objPtr);
/*
- * Scan through the words one at a time, copying those that are
- * relevant into the result string. Allocate a result area large
- * enough to hold all the words if necessary.
+ * Execute the command.
*/
- result = (char *) ckalloc((unsigned) (strlen(command) + 1));
- dst = result;
- for (next = command; isspace(UCHAR(*next)); next++) {
- /* Empty loop body: just find start of first word. */
- }
- for (index = 0; *next != 0; index++) {
- start = next;
- end = TclWordEnd(next, next + strlen(next), 0, (int *) NULL);
- if (*end != 0) {
- end++;
- for (next = end; isspace(UCHAR(*next)); next++) {
- /* Empty loop body: just find start of next word. */
- }
- }
- if ((first > index) || ((first == -1) && (*next != 0))) {
- continue;
- }
- if ((last != -1) && (last < index)) {
- continue;
- }
- if (pattern != NULL) {
- int match;
- char savedChar = *end;
-
- *end = 0;
- match = Tcl_StringMatch(start, pattern);
- *end = savedChar;
- if (!match) {
- continue;
- }
- }
- if (dst != result) {
- *dst = ' ';
- dst++;
+ result = TCL_OK;
+ if (!(flags & TCL_NO_EVAL)) {
+ iPtr->evalFlags = (flags & ~TCL_EVAL_GLOBAL);
+ if (flags & TCL_EVAL_GLOBAL) {
+ result = Tcl_GlobalEvalObj(interp, cmdPtr);
+ } else {
+ result = Tcl_EvalObj(interp, cmdPtr);
}
- strncpy(dst, start, (size_t) (end-start));
- dst += end-start;
- }
- *dst = 0;
-
- /*
- * Check for an out-of-range argument index.
- */
-
- if ((last >= index) || (first >= index)) {
- ckfree(result);
- Tcl_AppendResult((Tcl_Interp *) iPtr, "word selector \"", words,
- "\" specified non-existent words", (char *) NULL);
- return NULL;
}
return result;
-
- error:
- Tcl_AppendResult((Tcl_Interp *) iPtr, "bad word selector \"", words,
- "\": should be num-num or pattern", (char *) NULL);
- return NULL;
}
diff --git a/contrib/tcl/generic/tclIO.c b/contrib/tcl/generic/tclIO.c
index b562b7b..2b13e2d 100644
--- a/contrib/tcl/generic/tclIO.c
+++ b/contrib/tcl/generic/tclIO.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclIO.c 1.265 97/06/20 13:24:48
+ * SCCS: @(#) tclIO.c 1.268 97/07/28 14:20:36
*/
#include "tclInt.h"
@@ -1682,6 +1682,10 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush)
}
} else {
Tcl_SetErrno(errorCode);
+ if (interp != NULL) {
+ Tcl_SetResult(interp,
+ Tcl_PosixError(interp), TCL_VOLATILE);
+ }
}
/*
@@ -4969,7 +4973,9 @@ ChannelEventScriptInvoker(clientData, mask)
*/
if (result != TCL_OK) {
- DeleteScriptRecord(interp, chanPtr, mask);
+ if (chanPtr->typePtr != NULL) {
+ DeleteScriptRecord(interp, chanPtr, mask);
+ }
Tcl_BackgroundError(interp);
}
Tcl_Release((ClientData) interp);
@@ -5662,14 +5668,6 @@ TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr)
csPtr->total = 0;
csPtr->interp = interp;
if (cmdPtr) {
- /*
- * We save this command object and mutate it later with
- * extra arguments, so we need a private copy.
- */
-
- if (Tcl_IsShared(cmdPtr)) {
- cmdPtr = Tcl_DuplicateObj(cmdPtr);
- }
Tcl_IncrRefCount(cmdPtr);
}
csPtr->cmdPtr = cmdPtr;
@@ -5838,18 +5836,22 @@ CopyData(csPtr, mask)
/*
* Make the callback or return the number of bytes transferred.
- * The local total is used because StopCopoy frees csPtr.
+ * The local total is used because StopCopy frees csPtr.
*/
total = csPtr->total;
if (cmdPtr) {
+ /*
+ * Get a private copy of the command so we can mutate it
+ * by adding arguments. Note that StopCopy frees our saved
+ * reference to the original command obj.
+ */
+
+ cmdPtr = Tcl_DuplicateObj(cmdPtr);
Tcl_IncrRefCount(cmdPtr);
StopCopy(csPtr);
Tcl_Preserve((ClientData) interp);
- /*
- * This is already a private object, so we mutate it to add args.
- */
Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewIntObj(total));
if (errObj) {
Tcl_ListObjAppendElement(interp, cmdPtr, errObj);
diff --git a/contrib/tcl/generic/tclIOCmd.c b/contrib/tcl/generic/tclIOCmd.c
index ae09c8f..5640b47 100644
--- a/contrib/tcl/generic/tclIOCmd.c
+++ b/contrib/tcl/generic/tclIOCmd.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclIOCmd.c 1.117 97/06/23 18:57:17
+ * SCCS: @(#) tclIOCmd.c 1.119 97/07/25 20:49:23
*/
#include "tclInt.h"
@@ -579,7 +579,7 @@ Tcl_TellCmd(clientData, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_CloseCmd --
+ * Tcl_CloseObjCmd --
*
* This procedure is invoked to process the Tcl "close" command.
* See the user documentation for details on what it does.
@@ -595,26 +595,28 @@ Tcl_TellCmd(clientData, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_CloseCmd(clientData, interp, argc, argv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_CloseObjCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to close. */
int len; /* Length of error output. */
+ char *arg;
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelId\"", (char *) NULL);
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
- chan = Tcl_GetChannel(interp, argv[1], NULL);
+
+ arg = Tcl_GetStringFromObj(objv[1], NULL);
+ chan = Tcl_GetChannel(interp, arg, NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
- if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) {
+ if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) {
/*
* If there is an error message and it ends with a newline, remove
* the newline. This is done for command pipeline channels where the
@@ -633,6 +635,7 @@ Tcl_CloseCmd(clientData, interp, argc, argv)
return TCL_ERROR;
}
+
return TCL_OK;
}
@@ -705,7 +708,7 @@ Tcl_FconfigureCmd(clientData, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_EofCmd --
+ * Tcl_EofObjCmd --
*
* This procedure is invoked to process the Tcl "eof" command.
* See the user documentation for details on what it does.
@@ -722,22 +725,24 @@ Tcl_FconfigureCmd(clientData, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_EofCmd(unused, interp, argc, argv)
- ClientData unused; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_EofObjCmd(unused, interp, objc, objv)
+ ClientData unused; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to query for EOF. */
int mode; /* Mode in which channel is opened. */
char buf[40];
+ char *arg;
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelId\"", (char *) NULL);
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
- chan = Tcl_GetChannel(interp, argv[1], &mode);
+
+ arg = Tcl_GetStringFromObj(objv[1], NULL);
+ chan = Tcl_GetChannel(interp, arg, &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
@@ -891,7 +896,7 @@ Tcl_ExecCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_FblockedCmd --
+ * Tcl_FblockedObjCmd --
*
* This procedure is invoked to process the Tcl "fblocked" command.
* See the user documentation for details on what it does.
@@ -908,27 +913,30 @@ Tcl_ExecCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_FblockedCmd(unused, interp, argc, argv)
- ClientData unused; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_FblockedObjCmd(unused, interp, objc, objv)
+ ClientData unused; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to query for blocked. */
int mode; /* Mode in which channel was opened. */
char buf[40];
+ char *arg;
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelId\"", (char *) NULL);
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
- chan = Tcl_GetChannel(interp, argv[1], &mode);
+
+ arg = Tcl_GetStringFromObj(objv[1], NULL);
+ chan = Tcl_GetChannel(interp, arg, &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
- Tcl_AppendResult(interp, "channel \"", argv[1],
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
+ Tcl_GetStringFromObj(objv[1], NULL),
"\" wasn't opened for reading", (char *) NULL);
return TCL_ERROR;
}
@@ -1491,7 +1499,8 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv)
enum { FcopySize, FcopyCommand } index;
if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) {
- Tcl_WrongNumArgs(interp, 1, objv, "input output ?-size size? ?-command callback?");
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "input output ?-size size? ?-command callback?");
return TCL_ERROR;
}
@@ -1541,5 +1550,6 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv)
break;
}
}
+
return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr);
}
diff --git a/contrib/tcl/generic/tclIndexObj.c b/contrib/tcl/generic/tclIndexObj.c
index 86a394f..824270a 100644
--- a/contrib/tcl/generic/tclIndexObj.c
+++ b/contrib/tcl/generic/tclIndexObj.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclIndexObj.c 1.4 97/02/11 13:30:01
+ * SCCS: @(#) tclIndexObj.c 1.8 97/07/29 10:16:54
*/
#include "tclInt.h"
@@ -237,3 +237,72 @@ UpdateStringOfIndex(objPtr)
{
panic("UpdateStringOfIndex should never be invoked");
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_WrongNumArgs --
+ *
+ * This procedure generates a "wrong # args" error message in an
+ * interpreter. It is used as a utility function by many command
+ * procedures.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * An error message is generated in interp's result object to
+ * indicate that a command was invoked with the wrong number of
+ * arguments. The message has the form
+ * wrong # args: should be "foo bar additional stuff"
+ * where "foo" and "bar" are the initial objects in objv (objc
+ * determines how many of these are printed) and "additional stuff"
+ * is the contents of the message argument.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_WrongNumArgs(interp, objc, objv, message)
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments to print
+ * from objv. */
+ Tcl_Obj *CONST objv[]; /* Initial argument objects, which
+ * should be included in the error
+ * message. */
+ char *message; /* Error message to print after the
+ * leading objects in objv. The
+ * message may be NULL. */
+{
+ Tcl_Obj *objPtr;
+ char **tablePtr;
+ int i;
+
+ objPtr = Tcl_GetObjResult(interp);
+ Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
+ for (i = 0; i < objc; i++) {
+ /*
+ * If the object is an index type use the index table which allows
+ * for the correct error message even if the subcommand was
+ * abbreviated. Otherwise, just use the string rep.
+ */
+
+ if (objv[i]->typePtr == &tclIndexType) {
+ tablePtr = ((char **) objv[i]->internalRep.twoPtrValue.ptr1);
+ Tcl_AppendStringsToObj(objPtr,
+ tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2],
+ (char *) NULL);
+ } else {
+ Tcl_AppendStringsToObj(objPtr,
+ Tcl_GetStringFromObj(objv[i], (int *) NULL),
+ (char *) NULL);
+ }
+ if (i < (objc - 1)) {
+ Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL);
+ }
+ }
+ if (message) {
+ Tcl_AppendStringsToObj(objPtr, " ", message, (char *) NULL);
+ }
+ Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL);
+}
diff --git a/contrib/tcl/generic/tclInt.h b/contrib/tcl/generic/tclInt.h
index 1e88992..32ef58a 100644
--- a/contrib/tcl/generic/tclInt.h
+++ b/contrib/tcl/generic/tclInt.h
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclInt.h 1.277 97/06/20 15:19:00
+ *SCCS: @(#) tclInt.h 1.293 97/08/12 17:07:02
*/
#ifndef _TCLINT
@@ -281,8 +281,9 @@ typedef struct Var {
* call frame or the hash table: 1 for each
* additional variable whose linkPtr points
* here, 1 for each nested trace active on
- * variable. This record can't be deleted
- * until refCount becomes 0. */
+ * variable, and 1 if the variable is a
+ * namespace variable. This record can't be
+ * deleted until refCount becomes 0. */
VarTrace *tracePtr; /* First in list of all traces set for this
* variable. */
ArraySearch *searchPtr; /* First in list of all searches active
@@ -330,6 +331,14 @@ typedef struct Var {
* element, so it is not legal for it to be
* an array itself (the VAR_ARRAY flag had
* better not be set).
+ * VAR_NAMESPACE_VAR - 1 means that this variable was declared
+ * as a namespace variable. This flag ensures
+ * it persists until its namespace is
+ * destroyed or until the variable is unset;
+ * it will persist even if it has not been
+ * initialized and is marked undefined.
+ * The variable's refCount is incremented to
+ * reflect the "reference" from its namespace.
*/
#define VAR_SCALAR 0x1
@@ -339,6 +348,7 @@ typedef struct Var {
#define VAR_IN_HASHTABLE 0x10
#define VAR_TRACE_ACTIVE 0x20
#define VAR_ARRAY_ELEMENT 0x40
+#define VAR_NAMESPACE_VAR 0x80
/*
* Macros to ensure that various flag bits are set properly for variables.
@@ -404,6 +414,13 @@ typedef struct Var {
*/
/*
+ * Forward declaration to prevent an error when the forward reference to
+ * Command is encountered in the Proc and ImportRef types declared below.
+ */
+
+struct Command;
+
+/*
* The variable-length structure below describes a local variable of a
* procedure that was recognized by the compiler. These variables have a
* name, an element in the array of compiler-assigned local variables in the
@@ -459,8 +476,10 @@ typedef struct Proc {
* to the procedure that is currently
* active. This structure can be freed
* when refCount becomes zero. */
- Namespace *nsPtr; /* Points to the namespace that contains
- * this procedure. */
+ struct Command *cmdPtr; /* Points to the Command structure for
+ * this procedure. This is used to get
+ * the namespace in which to execute
+ * the procedure. */
Tcl_Obj *bodyPtr; /* Points to the ByteCode object for
* procedure's body command. */
int numArgs; /* Number of formal parameters. */
@@ -700,13 +719,6 @@ typedef struct ExecEnv {
*/
/*
- * Forward declaration to prevent an error when the forward reference to
- * Command is encountered in the ImportRef type declared below.
- */
-
-struct Command;
-
-/*
* An imported command is created in an namespace when it imports a "real"
* command from another namespace. An imported command has a Command
* structure that points (via its ClientData value) to the "real" Command
@@ -859,32 +871,6 @@ typedef struct Interp {
* is TCL_ERROR. Malloc'ed, may be NULL */
/*
- * Information related to history:
- */
-
- int numEvents; /* Number of previously-executed commands
- * to retain. */
- HistoryEvent *events; /* Array containing numEvents entries
- * (dynamically allocated). */
- int curEvent; /* Index into events of place where current
- * (or most recent) command is recorded. */
- int curEventNum; /* Event number associated with the slot
- * given by curEvent. */
- HistoryRev *revPtr; /* First in list of pending revisions. */
- char *historyFirst; /* First char. of current command executed
- * from history module or NULL if none. */
- int revDisables; /* 0 means history revision OK; > 0 gives
- * a count of number of times revision has
- * been disabled. */
- char *evalFirst; /* If TCL_RECORD_BOUNDS Tcl_Eval and
- * Tcl_EvalObj set this field to point to
- * the first char. of text from which the
- * current command came. Otherwise set to
- * NULL. */
- char *evalLast; /* Similar to evalFirst, except points to
- * last character of current command. */
-
- /*
* Information used by Tcl_AppendResult to keep track of partial
* results. See Tcl_AppendResult code for details.
*/
@@ -976,17 +962,12 @@ typedef struct Interp {
*
* TCL_BRACKET_TERM 1 means that the current script is terminated by
* a close bracket rather than the end of the string.
- * TCL_RECORD_BOUNDS Tells Tcl_Eval to record information in the
- * evalFirst and evalLast fields for each command
- * executed directly from the string (top-level
- * commands and those from command substitution).
* TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with
* a code other than TCL_OK or TCL_ERROR; 0 means
* codes other than these should be turned into errors.
*/
#define TCL_BRACKET_TERM 1
-#define TCL_RECORD_BOUNDS 2
#define TCL_ALLOW_EXCEPTIONS 4
/*
@@ -1016,6 +997,9 @@ typedef struct Interp {
* RAND_SEED_INITIALIZED: Non-zero means that the randSeed value of the
* interp has not be initialized. This is set 1
* when we first use the rand() or srand() functions.
+ * SAFE_INTERP: Non zero means that the current interp is a
+ * safe interp (ie it has only the safe commands
+ * installed, less priviledge than a regular interp).
*/
#define DELETED 1
@@ -1025,6 +1009,7 @@ typedef struct Interp {
#define EXPR_INITIALIZED 0x10
#define DONT_COMPILE_CMDS_INLINE 0x20
#define RAND_SEED_INITIALIZED 0x40
+#define SAFE_INTERP 0x80
/*
*----------------------------------------------------------------
@@ -1300,6 +1285,7 @@ EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp,
EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp,
int argc, char **argv)) ;
EXTERN void TclFinalizeCompExecEnv _ANSI_ARGS_((void));
+EXTERN void TclFinalizeEnvironment _ANSI_ARGS_((void));
EXTERN void TclFinalizeExecEnv _ANSI_ARGS_((void));
EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp *interp,
char *list, int listLength, char **elementPtr,
@@ -1318,7 +1304,7 @@ EXTERN Tcl_Channel TclGetDefaultStdChannel _ANSI_ARGS_((int type));
EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_((
Tcl_Interp *interp, int localIndex,
Tcl_Obj *elemPtr, int leaveErrorMsg));
-EXTERN char * TclGetEnv _ANSI_ARGS_((char *name));
+EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char *name));
EXTERN char * TclGetExtension _ANSI_ARGS_((char *name));
EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp,
char *string, CallFrame **framePtrPtr));
@@ -1388,6 +1374,7 @@ EXTERN int TclMatchFiles _ANSI_ARGS_((Tcl_Interp *interp,
char *separators, Tcl_DString *dirPtr,
char *pattern, char *tail));
EXTERN int TclNeedSpace _ANSI_ARGS_((char *start, char *end));
+EXTERN int TclObjCommandComplete _ANSI_ARGS_((Tcl_Obj *cmdPtr));
EXTERN int TclObjInterpProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
@@ -1396,6 +1383,17 @@ EXTERN int TclObjInvoke _ANSI_ARGS_((Tcl_Interp *interp,
EXTERN int TclObjInvokeGlobal _ANSI_ARGS_((Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[], int flags));
EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size));
+
+/*
+ * On a Mac, we can exit gracefully if the stack gets too small.
+ */
+
+#ifdef MAC_TCL
+EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void));
+#else
+#define TclpCheckStackSpace() (1)
+#endif
+
EXTERN int TclpCloseFile _ANSI_ARGS_((TclFile file));
EXTERN int TclpCopyFile _ANSI_ARGS_((char *source, char *dest));
EXTERN int TclpCopyDirectory _ANSI_ARGS_((char *source,
@@ -1419,15 +1417,27 @@ EXTERN unsigned long TclpGetSeconds _ANSI_ARGS_((void));
EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time *time));
EXTERN int TclpGetTimeZone _ANSI_ARGS_((unsigned long time));
EXTERN char * TclpGetTZName _ANSI_ARGS_((void));
+EXTERN int TclpListVolumes _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel,
int direction));
EXTERN TclFile TclpOpenFile _ANSI_ARGS_((char *fname, int mode));
-EXTERN int TclpListVolumes _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr,
unsigned int size));
EXTERN int TclpRemoveDirectory _ANSI_ARGS_((char *path,
int recursive, Tcl_DString *errorPtr));
EXTERN int TclpRenameFile _ANSI_ARGS_((char *source, char *dest));
+EXTERN char * TclpSetEnv _ANSI_ARGS_((CONST char *name,
+ CONST char *value));
+#ifndef TclpSysAlloc
+EXTERN VOID * TclpSysAlloc _ANSI_ARGS_((long size, int isBin));
+#endif
+#ifndef TclpSysFree
+EXTERN void TclpSysFree _ANSI_ARGS_((VOID *ptr));
+#endif
+#ifndef TclpSysRealloc
+EXTERN VOID * TclpSysRealloc _ANSI_ARGS_((VOID *cp,
+ unsigned int size));
+#endif
EXTERN int TclParseBraces _ANSI_ARGS_((Tcl_Interp *interp,
char *string, char **termPtr, ParseValue *pvPtr));
EXTERN int TclParseNestedCmd _ANSI_ARGS_((Tcl_Interp *interp,
@@ -1438,6 +1448,9 @@ EXTERN int TclParseQuotes _ANSI_ARGS_((Tcl_Interp *interp,
char **termPtr, ParseValue *pvPtr));
EXTERN void TclPlatformExit _ANSI_ARGS_((int status));
EXTERN void TclPlatformInit _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, char *name1, char *name2,
+ int flags));
EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Interp *cmdInterp, Tcl_Command cmd));
EXTERN void TclPrintByteCodeObj _ANSI_ARGS_((Tcl_Interp *interp,
@@ -1475,8 +1488,8 @@ EXTERN char * TclWordEnd _ANSI_ARGS_((char *start, char *lastChar,
*----------------------------------------------------------------
*/
-EXTERN int Tcl_AfterCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_AfterObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_AppendObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ArrayObjCmd _ANSI_ARGS_((ClientData clientData,
@@ -1489,18 +1502,18 @@ EXTERN int Tcl_CaseObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_CatchObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_CdCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_CdObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ClockObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_CloseCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_CloseObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ConcatObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ContinueCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
-EXTERN int Tcl_EofCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_EofObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ErrorObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_EvalObjCmd _ANSI_ARGS_((ClientData clientData,
@@ -1511,8 +1524,8 @@ EXTERN int Tcl_ExitObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ExprObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_FblockedCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_FblockedObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_FconfigureCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
EXTERN int Tcl_FcopyObjCmd _ANSI_ARGS_((ClientData dummy,
@@ -1527,8 +1540,8 @@ EXTERN int Tcl_ForCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
EXTERN int Tcl_ForeachObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_FormatCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_FormatObjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_GetsObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_GlobalObjCmd _ANSI_ARGS_((ClientData clientData,
@@ -1597,8 +1610,8 @@ EXTERN int Tcl_SeekCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
EXTERN int Tcl_SetCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
-EXTERN int Tcl_SplitCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_SplitObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_SocketCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
EXTERN int Tcl_SourceObjCmd _ANSI_ARGS_((ClientData clientData,
diff --git a/contrib/tcl/generic/tclInterp.c b/contrib/tcl/generic/tclInterp.c
index e9ad76a..ae5171a 100644
--- a/contrib/tcl/generic/tclInterp.c
+++ b/contrib/tcl/generic/tclInterp.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclInterp.c 1.115 97/06/19 18:06:39
+ * SCCS: @(#) tclInterp.c 1.125 97/08/05 15:22:51
*/
#include <stdio.h>
@@ -17,20 +17,6 @@
#include "tclPort.h"
/*
- * Tcl script to make an interpreter safe.
- */
-
-static char makeSafeScript[] =
-"if {[info exists env(DISPLAY)]} {\n\
- set ___x___ $env(DISPLAY)\n\
-}\n\
-unset env\n\
-if {[info exists ___x___]} {\n\
- set env(DISPLAY) $___x___\n\
- unset ___x___\n\
-}";
-
-/*
* Counter for how many aliases were created (global)
*/
@@ -108,13 +94,15 @@ typedef struct {
/*
* struct Master:
*
- * This record is used for three purposes: First, slaveTable (a hashtable)
+ * This record is used for two purposes: First, slaveTable (a hashtable)
* maps from names of commands to slave interpreters. This hashtable is
* used to store information about slave interpreters of this interpreter,
* to map over all slaves, etc. The second purpose is to store information
* about all aliases in slaves (or siblings) which direct to target commands
- * in this interpreter (using the targetTable hashtable). The third field in
- * the record, isSafe, denotes whether the interpreter is safe or not. Safe
+ * in this interpreter (using the targetTable hashtable).
+ *
+ * NB: the flags field in the interp structure, used with SAFE_INTERP
+ * mask denotes whether the interpreter is safe or not. Safe
* interpreters have restricted functionality, can only create safe slave
* interpreters and can only load safe extensions.
*/
@@ -122,7 +110,6 @@ typedef struct {
typedef struct {
Tcl_HashTable slaveTable; /* Hash table for slave interpreters.
* Maps from command names to Slave records. */
- int isSafe; /* Am I a "safe" interpreter? */
Tcl_HashTable targetTable; /* Hash table for Target Records. Contains
* all Target records which denote aliases
* from slaves or sibling interpreters that
@@ -204,6 +191,9 @@ static int InterpShareHelper _ANSI_ARGS_((Tcl_Interp *interp,
static int InterpTargetHelper _ANSI_ARGS_((Tcl_Interp *interp,
Master *masterPtr, int objc,
Tcl_Obj *CONST objv[]));
+static int InterpTransferHelper _ANSI_ARGS_((Tcl_Interp *interp,
+ Master *masterPtr, int objc,
+ Tcl_Obj *CONST objv[]));
static int MarkTrusted _ANSI_ARGS_((Tcl_Interp *interp));
static void MasterRecordDeleteProc _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp));
@@ -351,15 +341,9 @@ static int
MarkTrusted(interp)
Tcl_Interp *interp; /* Interpreter to be marked unsafe. */
{
- Master *masterPtr; /* Master record for interpreter to
- * be marked unsafe. */
+ Interp *iPtr = (Interp *) interp;
- masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord",
- NULL);
- if (masterPtr == (Master *) NULL) {
- panic("MarkTrusted: could not find master record");
- }
- masterPtr->isSafe = 0;
+ iPtr->flags &= ~SAFE_INTERP;
return TCL_OK;
}
@@ -386,28 +370,40 @@ int
Tcl_MakeSafe(interp)
Tcl_Interp *interp; /* Interpreter to be made safe. */
{
- Master *masterPtr; /* Master record of interp
- * to be made safe. */
Tcl_Channel chan; /* Channel to remove from
* safe interpreter. */
- Tcl_Obj *objPtr;
+ Interp *iPtr = (Interp *) interp;
TclHideUnsafeCommands(interp);
- masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord",
- NULL);
- if (masterPtr == (Master *) NULL) {
- panic("MakeSafe: could not find master record");
- }
- masterPtr->isSafe = 1;
- objPtr = Tcl_NewStringObj(makeSafeScript, -1);
- Tcl_IncrRefCount(objPtr);
+
+ iPtr->flags |= SAFE_INTERP;
- if (Tcl_EvalObj(interp, objPtr) == TCL_ERROR) {
- Tcl_DecrRefCount(objPtr);
- return TCL_ERROR;
- }
+ /*
+ * Unsetting variables : (which should not have been set
+ * in the first place, but...)
+ */
- Tcl_DecrRefCount(objPtr);
+ /*
+ * No env array in a safe slave.
+ */
+
+ Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY);
+
+ /*
+ * Remove unsafe parts of tcl_platform
+ */
+
+ Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
+
+ /*
+ * Unset path informations variables
+ * (the only one remaining is [info nameofexecutable])
+ */
+
+ Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);
/*
* Remove the standard channels from the interpreter; safe interpreters
@@ -557,7 +553,7 @@ CreateSlave(interp, masterPtr, slavePath, safe)
ckfree((char *) masterPath);
slavePath = argv[argc-1];
if (!safe) {
- safe = masterPtr->isSafe;
+ safe = Tcl_IsSafe(masterInterp);
}
}
hPtr = Tcl_CreateHashEntry(&(masterPtr->slaveTable), slavePath, &new);
@@ -572,7 +568,7 @@ CreateSlave(interp, masterPtr, slavePath, safe)
if (slaveInterp == (Tcl_Interp *) NULL) {
panic("CreateSlave: out of memory while creating a new interpreter");
}
- slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave));
+ slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL);
slavePtr->masterInterp = masterInterp;
slavePtr->slaveEntry = hPtr;
slavePtr->slaveInterp = slaveInterp;
@@ -648,10 +644,10 @@ CreateInterpObject(interp, masterPtr, objc, objv)
moreFlags = 1;
slavePath = NULL;
- safe = masterPtr->isSafe;
+ safe = Tcl_IsSafe(interp);
if ((objc < 2) || (objc > 5)) {
- Tcl_WrongNumArgs(interp, 1, objv, "create ?-safe? ?--? ?path?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
return TCL_ERROR;
}
for (i = 2; i < objc; i++) {
@@ -675,8 +671,23 @@ CreateInterpObject(interp, masterPtr, objc, objv)
}
}
if (slavePath == (char *) NULL) {
- sprintf(localSlaveName, "interp%d", interpCounter);
- interpCounter++;
+
+ /*
+ * Create an anonymous interpreter -- we choose its name and
+ * the name of the command. We check that the command name that
+ * we use for the interpreter does not collide with an existing
+ * command in the master interpreter.
+ */
+
+ while (1) {
+ Tcl_CmdInfo cmdInfo;
+
+ sprintf(localSlaveName, "interp%d", interpCounter);
+ interpCounter++;
+ if (!(Tcl_GetCommandInfo(interp, localSlaveName, &cmdInfo))) {
+ break;
+ }
+ }
slavePath = localSlaveName;
}
if (CreateSlave(interp, masterPtr, slavePath, safe) != NULL) {
@@ -850,19 +861,12 @@ AliasCreationHelper(curInterp, slaveInterp, masterInterp, masterPtr,
slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL);
/*
- * Fix it up if there is no slave record. This can happen if someone
- * uses "" as the source for an alias.
+ * Slave record should be always present because it is created when
+ * the interpreter is created.
*/
if (slavePtr == (Slave *) NULL) {
- slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave));
- slavePtr->masterInterp = (Tcl_Interp *) NULL;
- slavePtr->slaveEntry = (Tcl_HashEntry *) NULL;
- slavePtr->slaveInterp = slaveInterp;
- slavePtr->interpCmd = (Tcl_Command) NULL;
- Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS);
- (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord",
- SlaveRecordDeleteProc, (ClientData) slavePtr);
+ panic("AliasCreationHelper: could not find slave record");
}
if ((targetName == (char *) NULL) || (targetName[0] == '\0')) {
@@ -1018,7 +1022,7 @@ InterpAliasesHelper(interp, masterPtr, objc, objv)
Tcl_Obj *listObjPtr, *elemObjPtr; /* Local object pointers. */
if ((objc != 2) && (objc != 3)) {
- Tcl_WrongNumArgs(interp, 1, objv, " aliases ?path?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?path?");
return TCL_ERROR;
}
if (objc == 3) {
@@ -1092,8 +1096,8 @@ InterpAliasHelper(interp, masterPtr, objc, objv)
int len;
if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "alias slavePath slaveCmd masterPath masterCmd ?args ..?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "slavePath slaveCmd masterPath masterCmd ?args ..?");
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, masterPtr,
@@ -1114,8 +1118,8 @@ InterpAliasHelper(interp, masterPtr, objc, objv)
Tcl_GetStringFromObj(objv[3], &len));
}
if (objc < 6) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "alias slavePath slaveCmd masterPath masterCmd ?args ..?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "slavePath slaveCmd masterPath masterCmd ?args ..?");
return TCL_ERROR;
}
masterInterp = GetInterp(interp, masterPtr,
@@ -1159,19 +1163,19 @@ InterpExistsHelper(interp, masterPtr, objc, objv)
int len;
if (objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "exists ?path?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?path?");
return TCL_ERROR;
}
if (objc == 3) {
if (GetInterp(interp, masterPtr,
Tcl_GetStringFromObj(objv[2], &len), NULL) ==
(Tcl_Interp *) NULL) {
- objPtr = Tcl_NewStringObj("0", 1);
+ objPtr = Tcl_NewIntObj(0);
} else {
- objPtr = Tcl_NewStringObj("1", 1);
+ objPtr = Tcl_NewIntObj(1);
}
} else {
- objPtr = Tcl_NewStringObj("1", 1);
+ objPtr = Tcl_NewIntObj(1);
}
Tcl_SetObjResult(interp, objPtr);
@@ -1210,7 +1214,7 @@ InterpEvalHelper(interp, masterPtr, objc, objv)
char *string;
if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv, " eval path arg ?arg ...?");
+ Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, masterPtr,
@@ -1306,8 +1310,8 @@ InterpExposeHelper(interp, masterPtr, objc, objv)
int len; /* Dummy length variable. */
if ((objc != 4) && (objc != 5)) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "expose path hiddenCmdName ?cmdName?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "path hiddenCmdName ?cmdName?");
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
@@ -1368,8 +1372,8 @@ InterpHideHelper(interp, masterPtr, objc, objv)
int len; /* Dummy length variable. */
if ((objc != 4) && (objc != 5)) {
- Tcl_WrongNumArgs(interp, 1, objv,
- " hide path cmdName ?hiddenCmdName?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "path cmdName ?hiddenCmdName?");
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
@@ -1431,7 +1435,7 @@ InterpHiddenHelper(interp, masterPtr, objc, objv)
Tcl_Obj *listObjPtr; /* Local object pointer. */
if (objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "hidden ?path?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?path?");
return TCL_ERROR;
}
if (objc == 3) {
@@ -1498,8 +1502,8 @@ InterpInvokeHiddenHelper(interp, masterPtr, objc, objv)
char *string;
if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "invokehidden path ?-global? cmd ?arg ..?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "path ?-global? cmd ?arg ..?");
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
@@ -1511,8 +1515,8 @@ InterpInvokeHiddenHelper(interp, masterPtr, objc, objv)
if (strcmp(Tcl_GetStringFromObj(objv[3], &len), "-global") == 0) {
doGlobal = 1;
if (objc < 5) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "invokehidden path ?-global? cmd ?arg ..?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "path ?-global? cmd ?arg ..?");
return TCL_ERROR;
}
}
@@ -1607,7 +1611,7 @@ InterpMarkTrustedHelper(interp, masterPtr, objc, objv)
int len; /* Dummy length variable. */
if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "marktrusted path");
+ Tcl_WrongNumArgs(interp, 2, objv, "path");
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
@@ -1658,7 +1662,7 @@ InterpIsSafeHelper(interp, masterPtr, objc, objv)
Tcl_Obj *objPtr; /* Local object pointer. */
if (objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "issafe ?path?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?path?");
return TCL_ERROR;
}
if (objc == 3) {
@@ -1671,11 +1675,9 @@ InterpIsSafeHelper(interp, masterPtr, objc, objv)
(char *) NULL);
return TCL_ERROR;
}
- }
- if (masterPtr->isSafe == 0) {
- objPtr = Tcl_NewStringObj("0", 1);
+ objPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp));
} else {
- objPtr = Tcl_NewStringObj("1", 1);
+ objPtr = Tcl_NewIntObj(Tcl_IsSafe(interp));
}
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
@@ -1710,7 +1712,7 @@ InterpSlavesHelper(interp, masterPtr, objc, objv)
Tcl_Obj *listObjPtr; /* Local object pointers. */
if ((objc != 2) && (objc != 3)) {
- Tcl_WrongNumArgs(interp, 1, objv, "slaves ?path?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?path?");
return TCL_ERROR;
}
if (objc == 3) {
@@ -1768,7 +1770,7 @@ InterpShareHelper(interp, masterPtr, objc, objv)
Tcl_Channel chan;
if (objc != 5) {
- Tcl_WrongNumArgs(interp, 1, objv, "share srcPath channelId destPath");
+ Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");
return TCL_ERROR;
}
masterInterp = GetInterp(interp, masterPtr,
@@ -1826,7 +1828,7 @@ InterpTargetHelper(interp, masterPtr, objc, objv)
int len;
if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "target path alias");
+ Tcl_WrongNumArgs(interp, 2, objv, "path alias");
return TCL_ERROR;
}
return GetTarget(interp,
@@ -1865,8 +1867,8 @@ InterpTransferHelper(interp, masterPtr, objc, objv)
Tcl_Channel chan;
if (objc != 5) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "transfer srcPath channelId destPath");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "srcPath channelId destPath");
return TCL_ERROR;
}
masterInterp = GetInterp(interp, masterPtr,
@@ -1944,24 +1946,14 @@ DescribeAlias(interp, slaveInterp, aliasName)
slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",
NULL);
- if (slavePtr == (Slave *) NULL) {
- /*
- * It's possible that the interpreter still does not have a slave
- * record. If so, create such a record now. This is only possible
- * for interpreters that were created with Tcl_CreateInterp, not
- * those created with Tcl_CreateSlave, so this interpreter does
- * not have a master.
- */
-
- slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave));
- slavePtr->masterInterp = (Tcl_Interp *) NULL;
- slavePtr->slaveEntry = (Tcl_HashEntry *) NULL;
- slavePtr->slaveInterp = slaveInterp;
- slavePtr->interpCmd = (Tcl_Command) NULL;
- Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS);
- (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord",
- SlaveRecordDeleteProc, (ClientData) slavePtr);
+ /*
+ * The slave record should always be present because it is created
+ * by Tcl_CreateInterp.
+ */
+
+ if (slavePtr == (Slave *) NULL) {
+ panic("DescribeAlias: could not find slave record");
}
hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName);
if (hPtr == (Tcl_HashEntry *) NULL) {
@@ -2322,8 +2314,8 @@ SlaveAliasHelper(interp, slaveInterp, slavePtr, objc, objv)
switch (objc-2) {
case 0:
- Tcl_WrongNumArgs(interp, 1, objv,
- "alias aliasName ?targetName? ?args..?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "aliasName ?targetName? ?args..?");
return TCL_ERROR;
case 1:
@@ -2430,7 +2422,7 @@ SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv)
int result;
if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "eval arg ?arg ...?");
+ Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
return TCL_ERROR;
}
@@ -2517,7 +2509,7 @@ SlaveExposeHelper(interp, slaveInterp, slavePtr, objc, objv)
int len;
if ((objc != 3) && (objc != 4)) {
- Tcl_WrongNumArgs(interp, 1, objv, "expose hiddenCmdName ?cmdName?");
+ Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?");
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
@@ -2566,7 +2558,7 @@ SlaveHideHelper(interp, slaveInterp, slavePtr, objc, objv)
int len;
if ((objc != 3) && (objc != 4)) {
- Tcl_WrongNumArgs(interp, 1, objv, "hide cmdName ?hiddenCmdName?");
+ Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?");
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
@@ -2618,7 +2610,7 @@ SlaveHiddenHelper(interp, slaveInterp, slavePtr, objc, objv)
Tcl_HashSearch hSearch; /* For local searches. */
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "hidden");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -2661,24 +2653,15 @@ SlaveIsSafeHelper(interp, slaveInterp, slavePtr, objc, objv)
int objc; /* Count of arguments. */
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
{
- Master *masterPtr; /* Master record for slave interp. */
- Tcl_Obj *namePtr; /* Local object pointer. */
+ Tcl_Obj *resultPtr; /* Local object pointer. */
if (objc > 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "issafe");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
- masterPtr = (Master *) Tcl_GetAssocData(slaveInterp,
- "tclMasterRecord", NULL);
- if (masterPtr == (Master *) NULL) {
- panic("SlaveObjectCmd: could not find master record");
- }
- if (masterPtr->isSafe == 1) {
- namePtr = Tcl_NewStringObj("1", 1);
- } else {
- namePtr = Tcl_NewStringObj("0", 1);
- }
- Tcl_SetObjResult(interp, namePtr);
+ resultPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp));
+
+ Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
@@ -2715,8 +2698,8 @@ SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv)
Tcl_Obj *namePtr, *objPtr;
if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "invokehidden ?-global? cmd ?arg ..?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-global? cmd ?arg ..?");
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
@@ -2728,8 +2711,8 @@ SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv)
if (strcmp(Tcl_GetStringFromObj(objv[2], &len), "-global") == 0) {
doGlobal = 1;
if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "invokehidden path ?-global? cmd ?arg ..?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "path ?-global? cmd ?arg ..?");
return TCL_ERROR;
}
}
@@ -2821,7 +2804,7 @@ SlaveMarkTrustedHelper(interp, slaveInterp, slavePtr, objc, objv)
int len;
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "marktrusted");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
@@ -3459,14 +3442,26 @@ TclInterpInit(interp)
Tcl_Interp *interp; /* Interpreter to initialize. */
{
Master *masterPtr; /* Its Master record. */
+ Slave *slavePtr; /* And its slave record. */
masterPtr = (Master *) ckalloc((unsigned) sizeof(Master));
- masterPtr->isSafe = 0;
+
Tcl_InitHashTable(&(masterPtr->slaveTable), TCL_STRING_KEYS);
Tcl_InitHashTable(&(masterPtr->targetTable), TCL_ONE_WORD_KEYS);
(void) Tcl_SetAssocData(interp, "tclMasterRecord", MasterRecordDeleteProc,
(ClientData) masterPtr);
+
+ slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave));
+
+ slavePtr->masterInterp = (Tcl_Interp *) NULL;
+ slavePtr->slaveEntry = (Tcl_HashEntry *) NULL;
+ slavePtr->slaveInterp = interp;
+ slavePtr->interpCmd = (Tcl_Command) NULL;
+ Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS);
+
+ (void) Tcl_SetAssocData(interp, "tclSlaveRecord", SlaveRecordDeleteProc,
+ (ClientData) slavePtr);
return TCL_OK;
}
@@ -3491,16 +3486,14 @@ int
Tcl_IsSafe(interp)
Tcl_Interp *interp; /* Is this interpreter "safe" ? */
{
- Master *masterPtr; /* Its master record. */
+ Interp *iPtr;
if (interp == (Tcl_Interp *) NULL) {
return 0;
}
- masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL);
- if (masterPtr == (Master *) NULL) {
- panic("Tcl_IsSafe: could not find master record");
- }
- return masterPtr->isSafe;
+ iPtr = (Interp *) interp;
+
+ return ( (iPtr->flags) & SAFE_INTERP ) ? 1 : 0 ;
}
/*
diff --git a/contrib/tcl/generic/tclListObj.c b/contrib/tcl/generic/tclListObj.c
index 04b2633..0f76f6f 100644
--- a/contrib/tcl/generic/tclListObj.c
+++ b/contrib/tcl/generic/tclListObj.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclListObj.c 1.44 97/06/13 18:25:32
+ * SCCS: @(#) tclListObj.c 1.47 97/08/12 19:02:02
*/
#include "tclInt.h"
@@ -413,7 +413,7 @@ Tcl_ListObjAppendElement(interp, listPtr, objPtr)
{
register List *listRepPtr;
register Tcl_Obj **elemPtrs;
- int numElems;
+ int numElems, numRequired;
if (Tcl_IsShared(listPtr)) {
panic("Tcl_ListObjAppendElement called with shared object");
@@ -428,14 +428,14 @@ Tcl_ListObjAppendElement(interp, listPtr, objPtr)
listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
elemPtrs = listRepPtr->elements;
numElems = listRepPtr->elemCount;
+ numRequired = numElems + 1 ;
/*
* If there is no room in the current array of element pointers,
* allocate a new, larger array and copy the pointers to it.
*/
- if (numElems >= listRepPtr->maxElemCount) {
- int numRequired = (numElems + 1);
+ if (numRequired > listRepPtr->maxElemCount) {
int newMax = (2 * numRequired);
Tcl_Obj **newElemPtrs = (Tcl_Obj **)
ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *)));
@@ -639,7 +639,7 @@ Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv)
}
numRequired = (numElems - count + objc);
- if (numRequired < listRepPtr->maxElemCount) {
+ if (numRequired <= listRepPtr->maxElemCount) {
/*
* Enough room in the current array. First "delete" count
* elements starting at first.
@@ -941,7 +941,7 @@ SetListFromAny(interp, objPtr)
s = ckalloc((unsigned) elemSize + 1);
if (hasBrace) {
- strncpy(s, elemStart, (size_t) elemSize);
+ memcpy((VOID *) s, (VOID *) elemStart, (size_t) elemSize);
s[elemSize] = 0;
} else {
elemSize = TclCopyAndCollapse(elemSize, elemStart, s);
diff --git a/contrib/tcl/generic/tclLoad.c b/contrib/tcl/generic/tclLoad.c
index 2e4e615..a1deee0 100644
--- a/contrib/tcl/generic/tclLoad.c
+++ b/contrib/tcl/generic/tclLoad.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclLoad.c 1.16 97/05/14 13:23:37
+ * SCCS: @(#) tclLoad.c 1.17 97/07/24 20:05:04
*/
#include "tclInt.h"
@@ -370,6 +370,10 @@ Tcl_LoadCmd(dummy, interp, argc, argv)
* everything we need in target's $errorInfo.
*/
+ /*
+ * It is (abusively) assumed that errorInfo and errorCode vars exists.
+ * we changed SetVar2 to accept NULL values to avoid crashes. --dl
+ */
Tcl_ResetResult(interp);
Tcl_AddErrorInfo(interp, Tcl_GetVar2(target,
"errorInfo", (char *) NULL, TCL_GLOBAL_ONLY));
diff --git a/contrib/tcl/generic/tclMain.c b/contrib/tcl/generic/tclMain.c
index 6ed86e5..ce87636 100644
--- a/contrib/tcl/generic/tclMain.c
+++ b/contrib/tcl/generic/tclMain.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclMain.c 1.52 96/10/22 11:23:51
+ * SCCS: @(#) tclMain.c 1.54 97/08/07 19:04:43
*/
#include "tcl.h"
@@ -38,14 +38,13 @@ extern int isatty _ANSI_ARGS_((int fd));
extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src));
static Tcl_Interp *interp; /* Interpreter for application. */
-static Tcl_DString command; /* Used to buffer incomplete commands being
- * read from stdin. */
+
#ifdef TCL_MEM_DEBUG
static char dumpFile[100]; /* Records where to dump memory allocation
* information. */
-static int quitFlag = 0; /* 1 means the "checkmem" command was
- * invoked, so the application should quit
- * and dump memory allocation information. */
+static int quitFlag = 0; /* 1 means "checkmem" command was called,
+ * so the application should quit and dump
+ * memory allocation information. */
#endif
/*
@@ -78,14 +77,19 @@ static int CheckmemCmd _ANSI_ARGS_((ClientData clientData,
void
Tcl_Main(argc, argv, appInitProc)
- int argc; /* Number of arguments. */
- char **argv; /* Array of argument strings. */
- Tcl_AppInitProc *appInitProc; /* Application-specific initialization
- * procedure to call after most
- * initialization but before starting
- * to execute commands. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Array of argument strings. */
+ Tcl_AppInitProc *appInitProc;
+ /* Application-specific initialization
+ * procedure to call after most
+ * initialization but before starting to
+ * execute commands. */
{
- char buffer[1000], *cmd, *args, *fileName;
+ Tcl_Obj *prompt1NamePtr = NULL;
+ Tcl_Obj *prompt2NamePtr = NULL;
+ Tcl_Obj *resultPtr;
+ Tcl_Obj *commandPtr = NULL;
+ char buffer[1000], *args, *fileName, *bytes;
int code, gotPartial, tty, length;
int exitCode = 0;
Tcl_Channel inChannel, outChannel, errChannel;
@@ -178,29 +182,38 @@ Tcl_Main(argc, argv, appInitProc)
* eval, since they may have been changed.
*/
- gotPartial = 0;
- Tcl_DStringInit(&command);
+ commandPtr = Tcl_NewObj();
+ Tcl_IncrRefCount(commandPtr);
+ prompt1NamePtr = Tcl_NewStringObj("tcl_prompt1", -1);
+ Tcl_IncrRefCount(prompt1NamePtr);
+ prompt2NamePtr = Tcl_NewStringObj("tcl_prompt2", -1);
+ Tcl_IncrRefCount(prompt2NamePtr);
+
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
+ gotPartial = 0;
while (1) {
if (tty) {
- char *promptCmd;
+ Tcl_Obj *promptCmdPtr;
- promptCmd = Tcl_GetVar(interp,
- gotPartial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY);
- if (promptCmd == NULL) {
-defaultPrompt:
+ promptCmdPtr = Tcl_ObjGetVar2(interp,
+ (gotPartial? prompt2NamePtr : prompt1NamePtr),
+ (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
+ if (promptCmdPtr == NULL) {
+ defaultPrompt:
if (!gotPartial && outChannel) {
Tcl_Write(outChannel, "% ", 2);
}
} else {
- code = Tcl_Eval(interp, promptCmd);
+ code = Tcl_EvalObj(interp, promptCmdPtr);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (code != TCL_OK) {
if (errChannel) {
- Tcl_Write(errChannel, interp->result, -1);
+ resultPtr = Tcl_GetObjResult(interp);
+ bytes = Tcl_GetStringFromObj(resultPtr, &length);
+ Tcl_Write(errChannel, bytes, length);
Tcl_Write(errChannel, "\n", 1);
}
Tcl_AddErrorInfo(interp,
@@ -215,7 +228,7 @@ defaultPrompt:
if (!inChannel) {
goto done;
}
- length = Tcl_Gets(inChannel, &command);
+ length = Tcl_GetsObj(inChannel, commandPtr);
if (length < 0) {
goto done;
}
@@ -224,36 +237,41 @@ defaultPrompt:
}
/*
- * Add the newline removed by Tcl_Gets back to the string.
+ * Add the newline removed by Tcl_GetsObj back to the string.
*/
-
- (void) Tcl_DStringAppend(&command, "\n", -1);
- cmd = Tcl_DStringValue(&command);
- if (!Tcl_CommandComplete(cmd)) {
+ Tcl_AppendToObj(commandPtr, "\n", 1);
+ if (!TclObjCommandComplete(commandPtr)) {
gotPartial = 1;
continue;
}
gotPartial = 0;
- code = Tcl_RecordAndEval(interp, cmd, 0);
+ code = Tcl_RecordAndEvalObj(interp, commandPtr, 0);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
- Tcl_DStringFree(&command);
+ Tcl_SetObjLength(commandPtr, 0);
if (code != TCL_OK) {
if (errChannel) {
- Tcl_Write(errChannel, interp->result, -1);
+ resultPtr = Tcl_GetObjResult(interp);
+ bytes = Tcl_GetStringFromObj(resultPtr, &length);
+ Tcl_Write(errChannel, bytes, length);
Tcl_Write(errChannel, "\n", 1);
}
- } else if (tty && (*interp->result != 0)) {
- if (outChannel) {
- Tcl_Write(outChannel, interp->result, -1);
+ } else if (tty) {
+ resultPtr = Tcl_GetObjResult(interp);
+ bytes = Tcl_GetStringFromObj(resultPtr, &length);
+ if ((length > 0) && outChannel) {
+ Tcl_Write(outChannel, bytes, length);
Tcl_Write(outChannel, "\n", 1);
}
}
#ifdef TCL_MEM_DEBUG
if (quitFlag) {
+ Tcl_DecrRefCount(commandPtr);
+ Tcl_DecrRefCount(prompt1NamePtr);
+ Tcl_DecrRefCount(prompt2NamePtr);
Tcl_DeleteInterp(interp);
Tcl_Exit(0);
}
@@ -266,7 +284,16 @@ defaultPrompt:
* cleanup on exit. The Tcl_Eval call should never return.
*/
-done:
+ done:
+ if (commandPtr != NULL) {
+ Tcl_DecrRefCount(commandPtr);
+ }
+ if (prompt1NamePtr != NULL) {
+ Tcl_DecrRefCount(prompt1NamePtr);
+ }
+ if (prompt2NamePtr != NULL) {
+ Tcl_DecrRefCount(prompt2NamePtr);
+ }
sprintf(buffer, "exit %d", exitCode);
Tcl_Eval(interp, buffer);
}
diff --git a/contrib/tcl/generic/tclMath.h b/contrib/tcl/generic/tclMath.h
new file mode 100644
index 0000000..fdf2ac9
--- /dev/null
+++ b/contrib/tcl/generic/tclMath.h
@@ -0,0 +1,27 @@
+/*
+ * tclMath.h --
+ *
+ * This file is necessary because of Metrowerks CodeWarrior Pro 1
+ * on the Macintosh. With 8-byte doubles turned on, the definitions of
+ * sin, cos, acos, etc., are screwed up. They are fine as long as
+ * they are used as function calls, but if the function pointers
+ * are passed around and used, they will crash hard on the 68K.
+ *
+ * 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.
+ *
+ * SCCS: @(#) tclMath.h 1.2 97/07/23 17:39:14
+ */
+
+#ifndef _TCLMATH
+#define _TCLMATH
+
+#if defined(MAC_TCL)
+# include "tclMacMath.h"
+#else
+# include <math.h>
+#endif
+
+#endif /* _TCLMATH */
diff --git a/contrib/tcl/generic/tclNamesp.c b/contrib/tcl/generic/tclNamesp.c
index 2155ddf..d4ace43 100644
--- a/contrib/tcl/generic/tclNamesp.c
+++ b/contrib/tcl/generic/tclNamesp.c
@@ -18,7 +18,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclNamesp.c 1.21 97/06/20 15:21:04
+ * SCCS: @(#) tclNamesp.c 1.29 97/08/04 09:32:38
*/
#include "tclInt.h"
@@ -456,19 +456,20 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
/* Procedure called to delete client
* data when the namespace is deleted.
* NULL if no procedure should be
- * called.*/
+ * called. */
{
Interp *iPtr = (Interp *) interp;
register Namespace *nsPtr, *ancestorPtr;
Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr;
Namespace *globalNsPtr = iPtr->globalNsPtr;
+ char *simpleName;
Tcl_HashEntry *entryPtr;
Tcl_DString buffer1, buffer2;
int newEntry, result;
/*
- * Check first if there is no active namespace. If so, we assume
- * the interpreter is being initialized.
+ * If there is no active namespace, the interpreter is being
+ * initialized.
*/
if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) {
@@ -478,33 +479,41 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
*/
parentPtr = NULL;
- name = "";
+ simpleName = "";
+ } else if (*name == '\0') {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "can't create namespace \"\": only global namespace can have empty name", (char *) NULL);
+ return NULL;
} else {
/*
- * There is no active namespace. Find the parent namespace that will
- * contain the new namespace.
+ * Find the parent for the new namespace.
*/
result = TclGetNamespaceForQualName(interp, name,
(Namespace *) NULL,
/*flags*/ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
- &parentPtr, &dummy1Ptr, &dummy2Ptr, &name);
+ &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);
if (result != TCL_OK) {
return NULL;
}
+ /*
+ * If the unqualified name at the end is empty, there were trailing
+ * "::"s after the namespace's name which we ignore. The new
+ * namespace was already (recursively) created and is pointed to
+ * by parentPtr.
+ */
+
+ if (*simpleName == '\0') {
+ return (Tcl_Namespace *) parentPtr;
+ }
+
/*
* Check for a bad namespace name and make sure that the name
* does not already exist in the parent namespace.
*/
- if ((name == NULL) || (*name == '\0')) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "can't create namespace \"", name,
- "\": invalid name", (char *) NULL);
- return NULL;
- }
- if (Tcl_FindHashEntry(&parentPtr->childTable, name) != NULL) {
+ if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't create namespace \"", name,
"\": already exists", (char *) NULL);
@@ -520,8 +529,8 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
numNsCreated++;
nsPtr = (Namespace *) ckalloc(sizeof(Namespace));
- nsPtr->name = (char *) ckalloc((unsigned) (strlen(name)+1));
- strcpy(nsPtr->name, name);
+ nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1));
+ strcpy(nsPtr->name, simpleName);
nsPtr->fullName = NULL; /* set below */
nsPtr->clientData = clientData;
nsPtr->deleteProc = deleteProc;
@@ -540,7 +549,7 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
nsPtr->cmdRefEpoch = 0;
if (parentPtr != NULL) {
- entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, name,
+ entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName,
&newEntry);
Tcl_SetHashValue(entryPtr, (ClientData) nsPtr);
}
@@ -703,7 +712,6 @@ TclTeardownNamespace(nsPtr)
{
Interp *iPtr = (Interp *) nsPtr->interp;
register Tcl_HashEntry *entryPtr;
- Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_Namespace *childNsPtr;
Tcl_Command cmd;
@@ -798,16 +806,9 @@ TclTeardownNamespace(nsPtr)
/*
* Delete all commands in this namespace. Be careful when traversing the
* hash table: when each command is deleted, it removes itself from the
- * command table. There's a special hack here because "tkerror" is just
- * a synonym for "bgerror" (they share a Command structure). Just
- * delete the hash table entry for "tkerror" without invoking its
- * callback or cleaning up its Command structure.
+ * command table.
*/
- hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, "tkerror");
- if (hPtr != NULL) {
- Tcl_DeleteHashEntry(hPtr);
- }
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
entryPtr != NULL;
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) {
@@ -889,7 +890,7 @@ NamespaceFree(nsPtr)
*
* Tcl_Export --
*
- * Makes all the commands matching a pattern available to later ber
+ * Makes all the commands matching a pattern available to later be
* imported from the namespace specified by contextNsPtr (or the
* current namespace if contextNsPtr is NULL). The specified pattern is
* appended onto the namespace's export pattern list, which is
@@ -924,7 +925,7 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
* cmd conflicts with an existing one. */
{
#define INIT_EXPORT_PATTERNS 5
- Namespace *nsPtr, *exportNsPtr, *altNsPtr, *dummyPtr;
+ Namespace *nsPtr, *exportNsPtr, *dummyPtr;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
char *simplePattern, *patternCpy;
int neededElems, len, i, result;
@@ -961,16 +962,12 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
*/
result = TclGetNamespaceForQualName(interp, pattern, nsPtr,
- /*flags*/ TCL_LEAVE_ERR_MSG, &exportNsPtr, &altNsPtr,
+ /*flags*/ TCL_LEAVE_ERR_MSG, &exportNsPtr, &dummyPtr,
&dummyPtr, &simplePattern);
if (result != TCL_OK) {
return result;
}
- if (exportNsPtr == NULL) {
- exportNsPtr = altNsPtr;
- }
- if ((exportNsPtr != currNsPtr)
- || (strcmp(pattern, simplePattern) != 0)) {
+ if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"invalid export pattern \"", pattern,
"\": pattern can't specify a namespace",
@@ -983,23 +980,23 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
* new pattern.
*/
- neededElems = currNsPtr->numExportPatterns + 1;
- if (currNsPtr->exportArrayPtr == NULL) {
- currNsPtr->exportArrayPtr = (char **)
+ neededElems = nsPtr->numExportPatterns + 1;
+ if (nsPtr->exportArrayPtr == NULL) {
+ nsPtr->exportArrayPtr = (char **)
ckalloc((unsigned) (INIT_EXPORT_PATTERNS * sizeof(char *)));
- currNsPtr->numExportPatterns = 0;
- currNsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS;
- } else if (neededElems > currNsPtr->maxExportPatterns) {
- int numNewElems = 2 * currNsPtr->maxExportPatterns;
- size_t currBytes = currNsPtr->numExportPatterns * sizeof(char *);
+ nsPtr->numExportPatterns = 0;
+ nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS;
+ } else if (neededElems > nsPtr->maxExportPatterns) {
+ int numNewElems = 2 * nsPtr->maxExportPatterns;
+ size_t currBytes = nsPtr->numExportPatterns * sizeof(char *);
size_t newBytes = numNewElems * sizeof(char *);
char **newPtr = (char **) ckalloc((unsigned) newBytes);
- memcpy((VOID *) newPtr, (VOID *) currNsPtr->exportArrayPtr,
+ memcpy((VOID *) newPtr, (VOID *) nsPtr->exportArrayPtr,
currBytes);
- ckfree((char *) currNsPtr->exportArrayPtr);
- currNsPtr->exportArrayPtr = (char **) newPtr;
- currNsPtr->maxExportPatterns = numNewElems;
+ ckfree((char *) nsPtr->exportArrayPtr);
+ nsPtr->exportArrayPtr = (char **) newPtr;
+ nsPtr->maxExportPatterns = numNewElems;
}
/*
@@ -1010,8 +1007,8 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
patternCpy = (char *) ckalloc((unsigned) (len + 1));
strcpy(patternCpy, pattern);
- currNsPtr->exportArrayPtr[currNsPtr->numExportPatterns] = patternCpy;
- currNsPtr->numExportPatterns++;
+ nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
+ nsPtr->numExportPatterns++;
return TCL_OK;
#undef INIT_EXPORT_PATTERNS
}
@@ -1111,7 +1108,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
* cmd conflicts with an existing one. */
{
Interp *iPtr = (Interp *) interp;
- Namespace *nsPtr, *importNsPtr, *dummyPtr, *actualCtxPtr;
+ Namespace *nsPtr, *importNsPtr, *dummyPtr;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
char *simplePattern, *cmdName;
register Tcl_HashEntry *hPtr;
@@ -1145,7 +1142,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
}
result = TclGetNamespaceForQualName(interp, pattern, nsPtr,
/*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr,
- &actualCtxPtr, &simplePattern);
+ &dummyPtr, &simplePattern);
if (result != TCL_OK) {
return TCL_ERROR;
}
@@ -1620,7 +1617,11 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
} else if (flags & TCL_GLOBAL_ONLY) {
nsPtr = globalNsPtr;
} else if (nsPtr == NULL) {
- nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+ if (iPtr->varFramePtr != NULL) {
+ nsPtr = iPtr->varFramePtr->nsPtr;
+ } else {
+ nsPtr = iPtr->globalNsPtr;
+ }
}
start = qualName; /* pts to start of qualifying namespace */
@@ -1680,7 +1681,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
}
if ((*end == '\0')
- && !((len >= 2) && (*(end-1) == ':') && (*(end-2) == ':'))) {
+ && !((end-start >= 2) && (*(end-1) == ':') && (*(end-2) == ':'))) {
/*
* qualName ended with a simple name at start. If FIND_ONLY_NS
* was specified, look this up as a namespace. Otherwise,
@@ -2337,15 +2338,9 @@ Tcl_NamespaceObjCmd(clientData, interp, objc, objv)
* Return an index reflecting the particular subcommand.
*/
- result = Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], subCmds,
- "subcommand", /*flags*/ 0, (int *) &index);
+ result = Tcl_GetIndexFromObj((Tcl_Interp *) interp, objv[1], subCmds,
+ "option", /*flags*/ 0, (int *) &index);
if (result != TCL_OK) {
- Tcl_ResetResult(interp);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad namespace subcommand \"",
- Tcl_GetStringFromObj(objv[1], (int *) NULL),
- "\": should be children, code, current, delete, eval, export, forget, import, inscope, origin, parent, qualifiers, tail, or which",
- (char *) NULL);
return result;
}
@@ -2452,7 +2447,7 @@ NamespaceChildrenCmd(dummy, interp, objc, objv)
}
nsPtr = (Namespace *) namespacePtr;
} else {
- Tcl_WrongNumArgs(interp, 1, objv, "children ?name? ?pattern?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?");
return TCL_ERROR;
}
@@ -2539,7 +2534,7 @@ NamespaceCodeCmd(dummy, interp, objc, objv)
int length;
if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "code arg");
+ Tcl_WrongNumArgs(interp, 2, objv, "arg");
return TCL_ERROR;
}
@@ -2619,7 +2614,7 @@ NamespaceCurrentCmd(dummy, interp, objc, objv)
register Namespace *currNsPtr;
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "current");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -2685,7 +2680,7 @@ NamespaceDeleteCmd(dummy, interp, objc, objv)
register int i;
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "delete ?name name...?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?name name...?");
return TCL_ERROR;
}
@@ -2765,7 +2760,7 @@ NamespaceEvalCmd(dummy, interp, objc, objv)
int length, result;
if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "eval name arg ?arg...?");
+ Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
return TCL_ERROR;
}
@@ -2875,8 +2870,8 @@ NamespaceExportCmd(dummy, interp, objc, objv)
int firstArg, patternCt, i, result;
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "export ?-clear? ?pattern pattern...?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-clear? ?pattern pattern...?");
return TCL_ERROR;
}
@@ -2970,7 +2965,7 @@ NamespaceForgetCmd(dummy, interp, objc, objv)
register int i, result;
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "forget ?pattern pattern...?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?");
return TCL_ERROR;
}
@@ -3034,8 +3029,8 @@ NamespaceImportCmd(dummy, interp, objc, objv)
int firstArg;
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "import ?-force? ?pattern pattern...?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-force? ?pattern pattern...?");
return TCL_ERROR;
}
@@ -3117,7 +3112,7 @@ NamespaceInscopeCmd(dummy, interp, objc, objv)
int i, result;
if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "inscope name arg ?arg...?");
+ Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
return TCL_ERROR;
}
@@ -3233,7 +3228,7 @@ NamespaceOriginCmd(dummy, interp, objc, objv)
Tcl_Command command, origCommand;
if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "origin name");
+ Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
@@ -3306,7 +3301,7 @@ NamespaceParentCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
} else {
- Tcl_WrongNumArgs(interp, 1, objv, "parent ?name?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?name?");
return TCL_ERROR;
}
@@ -3358,7 +3353,7 @@ NamespaceQualifiersCmd(dummy, interp, objc, objv)
int length;
if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "qualifiers string");
+ Tcl_WrongNumArgs(interp, 2, objv, "string");
return TCL_ERROR;
}
@@ -3374,7 +3369,7 @@ NamespaceQualifiersCmd(dummy, interp, objc, objv)
while (--p >= name) {
if ((*p == ':') && (p > name) && (*(p-1) == ':')) {
p -= 2; /* back up over the :: */
- while ((*p == ':') && (p >= name)) {
+ while ((p >= name) && (*p == ':')) {
p--; /* back up over the preceeding : */
}
break;
@@ -3424,7 +3419,7 @@ NamespaceTailCmd(dummy, interp, objc, objv)
register char *name, *p;
if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "tail string");
+ Tcl_WrongNumArgs(interp, 2, objv, "string");
return TCL_ERROR;
}
@@ -3438,7 +3433,7 @@ NamespaceTailCmd(dummy, interp, objc, objv)
/* empty body */
}
while (--p > name) {
- if ((*p == ':') && (p > name) && (*(p-1) == ':')) {
+ if ((*p == ':') && (*(p-1) == ':')) {
p++; /* just after the last "::" */
break;
}
@@ -3486,8 +3481,8 @@ NamespaceWhichCmd(dummy, interp, objc, objv)
if (objc < 3) {
badArgs:
- Tcl_WrongNumArgs(interp, 1, objv,
- "which ?-command? ?-variable? name");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-command? ?-variable? name");
return TCL_ERROR;
}
diff --git a/contrib/tcl/generic/tclObj.c b/contrib/tcl/generic/tclObj.c
index 5d4afe5..bc697f3 100644
--- a/contrib/tcl/generic/tclObj.c
+++ b/contrib/tcl/generic/tclObj.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclObj.c 1.44 97/06/20 15:19:32
+ * SCCS: @(#) tclObj.c 1.45 97/07/07 18:26:00
*/
#include "tclInt.h"
@@ -2019,3 +2019,123 @@ Tcl_GetLongFromObj(interp, objPtr, longPtr)
}
return result;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DbIncrRefCount --
+ *
+ * This procedure is normally called when debugging: i.e., when
+ * TCL_MEM_DEBUG is defined. This checks to see whether or not
+ * the memory has been freed before incrementing the ref count.
+ *
+ * When TCL_MEM_DEBUG is not defined, this procedure just increments
+ * the reference count of the object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's ref count is incremented.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DbIncrRefCount(objPtr, file, line)
+ register Tcl_Obj *objPtr; /* The object we are adding a reference to. */
+ char *file; /* The name of the source file calling this
+ * procedure; used for debugging. */
+ int line; /* Line number in the source file; used
+ * for debugging. */
+{
+#ifdef TCL_MEM_DEBUG
+ if (objPtr->refCount == 0x61616161) {
+ fprintf(stderr, "file = %s, line = %d\n", file, line);
+ fflush(stderr);
+ panic("Trying to increment refCount of previously disposed object.");
+ }
+#endif
+ ++(objPtr)->refCount;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DbDecrRefCount --
+ *
+ * This procedure is normally called when debugging: i.e., when
+ * TCL_MEM_DEBUG is defined. This checks to see whether or not
+ * the memory has been freed before incrementing the ref count.
+ *
+ * When TCL_MEM_DEBUG is not defined, this procedure just increments
+ * the reference count of the object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's ref count is incremented.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DbDecrRefCount(objPtr, file, line)
+ register Tcl_Obj *objPtr; /* The object we are adding a reference to. */
+ char *file; /* The name of the source file calling this
+ * procedure; used for debugging. */
+ int line; /* Line number in the source file; used
+ * for debugging. */
+{
+#ifdef TCL_MEM_DEBUG
+ if (objPtr->refCount == 0x61616161) {
+ fprintf(stderr, "file = %s, line = %d\n", file, line);
+ fflush(stderr);
+ panic("Trying to increment refCount of previously disposed object.");
+ }
+#endif
+ if (--(objPtr)->refCount <= 0) {
+ TclFreeObj(objPtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DbIsShared --
+ *
+ * This procedure is normally called when debugging: i.e., when
+ * TCL_MEM_DEBUG is defined. This checks to see whether or not
+ * the memory has been freed before incrementing the ref count.
+ *
+ * When TCL_MEM_DEBUG is not defined, this procedure just decrements
+ * the reference count of the object and throws it away if the count
+ * is 0 or less.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's ref count is incremented.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_DbIsShared(objPtr, file, line)
+ register Tcl_Obj *objPtr; /* The object we are adding a reference to. */
+ char *file; /* The name of the source file calling this
+ * procedure; used for debugging. */
+ int line; /* Line number in the source file; used
+ * for debugging. */
+{
+#ifdef TCL_MEM_DEBUG
+ if (objPtr->refCount == 0x61616161) {
+ fprintf(stderr, "file = %s, line = %d\n", file, line);
+ fflush(stderr);
+ panic("Trying to increment refCount of previously disposed object.");
+ }
+#endif
+ return ((objPtr)->refCount > 1);
+}
diff --git a/contrib/tcl/generic/tclParse.c b/contrib/tcl/generic/tclParse.c
index 57ba1e1..69a9e00 100644
--- a/contrib/tcl/generic/tclParse.c
+++ b/contrib/tcl/generic/tclParse.c
@@ -6,12 +6,12 @@
* strings or nested sub-commands).
*
* Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1994-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.
*
- * SCCS: @(#) tclParse.c 1.55 97/05/14 13:23:19
+ * SCCS: @(#) tclParse.c 1.56 97/07/29 18:40:03
*/
#include "tclInt.h"
@@ -902,3 +902,37 @@ Tcl_CommandComplete(cmd)
p = ScriptEnd(cmd, cmd+strlen(cmd), 0);
return (*p != 0);
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclObjCommandComplete --
+ *
+ * Given a partial or complete Tcl command in a Tcl object, this
+ * procedure determines whether the command is complete in the sense of
+ * having matched braces and quotes and brackets.
+ *
+ * Results:
+ * 1 is returned if the command is complete, 0 otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclObjCommandComplete(cmdPtr)
+ Tcl_Obj *cmdPtr; /* Points to object holding command
+ * to check. */
+{
+ char *cmd, *p;
+ int length;
+
+ cmd = Tcl_GetStringFromObj(cmdPtr, &length);
+ if (length == 0) {
+ return 1;
+ }
+ p = ScriptEnd(cmd, cmd+length, /*nested*/ 0);
+ return (*p != 0);
+}
diff --git a/contrib/tcl/generic/tclProc.c b/contrib/tcl/generic/tclProc.c
index 14238d9..7cd94ec 100644
--- a/contrib/tcl/generic/tclProc.c
+++ b/contrib/tcl/generic/tclProc.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclProc.c 1.113 97/06/23 15:51:52
+ * SCCS: @(#) tclProc.c 1.115 97/08/12 13:36:11
*/
#include "tclInt.h"
@@ -56,6 +56,7 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
char **argArray = NULL;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_Obj *defPtr, *bodyPtr;
+ Tcl_Command cmd;
Tcl_DString ds;
int numArgs, length, result, i;
register CompiledLocal *localPtr;
@@ -120,8 +121,11 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
}
/*
- * We increment the ref count of the procedure's body object since
- * there will be a reference to it in the Proc structure.
+ * Create and initialize a Proc structure for the procedure. Note that
+ * we initialize its cmdPtr field below after we've created the command
+ * for the procedure. We increment the ref count of the procedure's
+ * body object since there will be a reference to it in the Proc
+ * structure.
*/
Tcl_IncrRefCount(bodyPtr);
@@ -129,7 +133,6 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
procPtr = (Proc *) ckalloc(sizeof(Proc));
procPtr->iPtr = iPtr;
procPtr->refCount = 1;
- procPtr->nsPtr = nsPtr;
procPtr->bodyPtr = bodyPtr;
procPtr->numArgs = 0; /* actual argument count is set below. */
procPtr->numCompiledLocals = 0;
@@ -243,10 +246,10 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
}
/*
- * Now create a command for the procedure. This will be in the current
- * namespace unless the procedure's name included namespace qualifiers.
- * To create the new command in the right namespace, we generate a
- * fully qualified name for it.
+ * Now create a command for the procedure. This will initially be in
+ * the current namespace unless the procedure's name included namespace
+ * qualifiers. To create the new command in the right namespace, we
+ * generate a fully qualified name for it.
*/
Tcl_DStringInit(&ds);
@@ -258,8 +261,18 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), InterpProc,
(ClientData) procPtr, ProcDeleteProc);
- Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc,
- (ClientData) procPtr, ProcDeleteProc);
+ cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
+ TclObjInterpProc, (ClientData) procPtr, ProcDeleteProc);
+
+ /*
+ * Now initialize the new procedure's cmdPtr field. This will be used
+ * later when the procedure is called to determine what namespace the
+ * procedure will run in. This will be different than the current
+ * namespace if the proc was renamed into a different namespace.
+ */
+
+ procPtr->cmdPtr = (Command *) cmd;
+
ckfree((char *) argArray);
return TCL_OK;
@@ -744,11 +757,14 @@ TclObjInterpProc(clientData, interp, objc, objv)
/*
* Set up and push a new call frame for the new procedure invocation.
* This call frame will execute in the proc's namespace, which might
- * be different than the current namespace.
+ * be different than the current namespace. The proc's namespace is
+ * that of its command, which can change if the command is renamed
+ * from one namespace to another.
*/
result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
- (Tcl_Namespace *) procPtr->nsPtr, /*isProcCallFrame*/ 1);
+ (Tcl_Namespace *) procPtr->cmdPtr->nsPtr,
+ /*isProcCallFrame*/ 1);
if (result != TCL_OK) {
return result;
}
@@ -768,7 +784,7 @@ TclObjInterpProc(clientData, interp, objc, objv)
localPtr = localPtr->nextPtr) {
varPtr->value.objPtr = NULL;
varPtr->name = localPtr->name; /* will be just '\0' if temp var */
- varPtr->nsPtr = procPtr->nsPtr;
+ varPtr->nsPtr = procPtr->cmdPtr->nsPtr;
varPtr->hPtr = NULL;
varPtr->refCount = 0;
varPtr->tracePtr = NULL;
@@ -826,6 +842,7 @@ TclObjInterpProc(clientData, interp, objc, objv)
Tcl_IncrRefCount(objPtr); /* since the local variable now has
* another reference to object. */
} else {
+ Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"no value given for parameter \"", localPtr->name,
"\" to \"", Tcl_GetStringFromObj(objv[0], (int *) NULL),
diff --git a/contrib/tcl/generic/tclStringObj.c b/contrib/tcl/generic/tclStringObj.c
index e421833..beed142 100644
--- a/contrib/tcl/generic/tclStringObj.c
+++ b/contrib/tcl/generic/tclStringObj.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclStringObj.c 1.29 97/06/13 18:17:19
+ * SCCS: @(#) tclStringObj.c 1.30 97/07/24 18:53:30
*/
#include "tclInt.h"
@@ -98,7 +98,7 @@ Tcl_NewStringObj(bytes, length)
register Tcl_Obj *objPtr;
if (length < 0) {
- length = strlen(bytes);
+ length = bytes ? strlen(bytes) : 0 ;
}
TclNewObj(objPtr);
TclInitStringRep(objPtr, bytes, length);
diff --git a/contrib/tcl/generic/tclTest.c b/contrib/tcl/generic/tclTest.c
index 7ee313b..ecc2abf 100644
--- a/contrib/tcl/generic/tclTest.c
+++ b/contrib/tcl/generic/tclTest.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclTest.c 1.111 97/06/26 14:33:03
+ * SCCS: @(#) tclTest.c 1.115 97/08/13 10:27:26
*/
#define TCL_TEST
@@ -84,6 +84,10 @@ static int CmdProc1 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
static int CmdProc2 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
+static void CmdTraceProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int level, char *command,
+ Tcl_CmdProc *cmdProc, ClientData cmdClientData,
+ int argc, char **argv));
static int CreatedCommandProc _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int argc, char **argv));
@@ -111,6 +115,8 @@ static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
+static int TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int argc, char **argv));
static int TestchmodCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestcreatecommandCmd _ANSI_ARGS_((ClientData dummy,
@@ -127,6 +133,8 @@ static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
+static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int argc, char **argv));
static int TestfileCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestfeventCmd _ANSI_ARGS_((ClientData dummy,
@@ -225,6 +233,8 @@ Tcltest_Init(interp)
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0,
@@ -240,6 +250,8 @@ Tcltest_Init(interp)
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testfile", TestfileCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
@@ -626,6 +638,85 @@ TestcmdtokenCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
+ * TestcmdtraceCmd --
+ *
+ * This procedure implements the "testcmdtrace" command. It is used
+ * to test Tcl_CreateTrace and Tcl_DeleteTrace.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Creates and deletes a command trace, and tests the invocation of
+ * a procedure by the command trace.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static int
+TestcmdtraceCmd(dummy, interp, argc, argv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ Tcl_Trace trace;
+ Tcl_DString buffer;
+ int result;
+
+ if (argc != 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " script\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_DStringInit(&buffer);
+ trace = Tcl_CreateTrace(interp, 50000,
+ (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
+
+ result = Tcl_Eval(interp, argv[1]);
+ if (result == TCL_OK) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
+ }
+
+ Tcl_DeleteTrace(interp, trace);
+ Tcl_DStringFree(&buffer);
+ return TCL_OK;
+}
+
+static void
+CmdTraceProc(clientData, interp, level, command, cmdProc, cmdClientData,
+ argc, argv)
+ ClientData clientData; /* Pointer to buffer in which the
+ * command and arguments are appended.
+ * Accumulates test result. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int level; /* Current trace level. */
+ char *command; /* The command being traced (after
+ * substitutions). */
+ Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */
+ ClientData cmdClientData; /* Client data associated with command
+ * procedure. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ Tcl_DString *bufPtr = (Tcl_DString *) clientData;
+ int i;
+
+ Tcl_DStringAppendElement(bufPtr, command);
+
+ Tcl_DStringStartSublist(bufPtr);
+ for (i = 0; i < argc; i++) {
+ Tcl_DStringAppendElement(bufPtr, argv[i]);
+ }
+ Tcl_DStringEndSublist(bufPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestcreatecommandCmd --
*
* This procedure implements the "testcreatecommand" command. It is
@@ -1133,6 +1224,37 @@ TestexprlongCmd(clientData, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
+ * TestexprstringCmd --
+ *
+ * This procedure tests the basic operation of Tcl_ExprString.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestexprstringCmd(clientData, interp, argc, argv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ if (argc != 2) {
+ Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
+ " expression\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ return Tcl_ExprString(interp, argv[1]);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestgetassocdataCmd --
*
* This procedure implements the "testgetassocdata" command. It is
diff --git a/contrib/tcl/generic/tclTimer.c b/contrib/tcl/generic/tclTimer.c
index 2a91f65..7bb8e7d 100644
--- a/contrib/tcl/generic/tclTimer.c
+++ b/contrib/tcl/generic/tclTimer.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclTimer.c 1.6 97/05/20 11:08:02
+ * SCCS: @(#) tclTimer.c 1.9 97/07/29 16:21:53
*/
#include "tclInt.h"
@@ -692,7 +692,7 @@ TclServiceIdle()
/*
*----------------------------------------------------------------------
*
- * Tcl_AfterCmd --
+ * Tcl_AfterObjCmd --
*
* This procedure is invoked to process the "after" Tcl command.
* See the user documentation for details on what it does.
@@ -708,13 +708,13 @@ TclServiceIdle()
/* ARGSUSED */
int
-Tcl_AfterCmd(clientData, interp, argc, argv)
+Tcl_AfterObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Points to the "tclAfter" assocData for
* this interpreter, or NULL if the assocData
* hasn't been created yet.*/
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
/*
* The variable below is used to generate unique identifiers for
@@ -731,11 +731,15 @@ Tcl_AfterCmd(clientData, interp, argc, argv)
AfterInfo *afterPtr;
AfterAssocData *assocPtr = (AfterAssocData *) clientData;
Tcl_CmdInfo cmdInfo;
- size_t length;
-
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " option ?arg arg ...?\"", (char *) NULL);
+ int length;
+ char *arg;
+ int index, result;
+ static char *subCmds[] = {
+ "cancel", "idle", "info",
+ (char *) NULL};
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
return TCL_ERROR;
}
@@ -752,39 +756,44 @@ Tcl_AfterCmd(clientData, interp, argc, argv)
assocPtr->firstAfterPtr = NULL;
Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc,
(ClientData) assocPtr);
- cmdInfo.proc = Tcl_AfterCmd;
- cmdInfo.clientData = (ClientData) assocPtr;
- cmdInfo.objProc = NULL;
- cmdInfo.objClientData = (ClientData) NULL;
+ cmdInfo.proc = NULL;
+ cmdInfo.clientData = (ClientData) NULL;
+ cmdInfo.objProc = Tcl_AfterObjCmd;
+ cmdInfo.objClientData = (ClientData) assocPtr;
cmdInfo.deleteProc = NULL;
cmdInfo.deleteData = (ClientData) assocPtr;
- Tcl_SetCommandInfo(interp, argv[0], &cmdInfo);
+ Tcl_SetCommandInfo(interp, Tcl_GetStringFromObj(objv[0], &length),
+ &cmdInfo);
}
/*
- * Parse the command.
+ * First lets see if the command was passed a number as the first argument.
*/
-
- length = strlen(argv[1]);
- if (isdigit(UCHAR(argv[1][0]))) {
- if (Tcl_GetInt(interp, argv[1], &ms) != TCL_OK) {
+
+ arg = Tcl_GetStringFromObj(objv[1], &length);
+ if (isdigit(UCHAR(arg[0]))) {
+ if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) {
return TCL_ERROR;
}
if (ms < 0) {
ms = 0;
}
- if (argc == 2) {
+ if (objc == 2) {
Tcl_Sleep(ms);
return TCL_OK;
}
afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
afterPtr->assocPtr = assocPtr;
- if (argc == 3) {
- afterPtr->command = (char *) ckalloc((unsigned)
- (strlen(argv[2]) + 1));
- strcpy(afterPtr->command, argv[2]);
+ if (objc == 3) {
+ arg = Tcl_GetStringFromObj(objv[2], &length);
+ afterPtr->command = (char *) ckalloc((unsigned) (length + 1));
+ strcpy(afterPtr->command, arg);
} else {
- afterPtr->command = Tcl_Concat(argc-2, argv+2);
+ Tcl_Obj *objPtr = Tcl_ConcatObj(objc-2, objv+2);
+ arg = Tcl_GetStringFromObj(objPtr, &length);
+ afterPtr->command = (char *) ckalloc((unsigned) (length + 1));
+ strcpy(afterPtr->command, arg);
+ Tcl_DecrRefCount(objPtr);
}
afterPtr->id = nextId;
nextId += 1;
@@ -793,95 +802,113 @@ Tcl_AfterCmd(clientData, interp, argc, argv)
afterPtr->nextPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr;
sprintf(interp->result, "after#%d", afterPtr->id);
- } else if (strncmp(argv[1], "cancel", length) == 0) {
- char *arg;
+ return TCL_OK;
+ }
- if (argc < 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " cancel id|command\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (argc == 3) {
- arg = argv[2];
- } else {
- arg = Tcl_Concat(argc-2, argv+2);
- }
- for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
- afterPtr = afterPtr->nextPtr) {
- if (strcmp(afterPtr->command, arg) == 0) {
+ /*
+ * If it's not a number it must be a subcommand.
+ */
+ result = Tcl_GetIndexFromObj(NULL, objv[1], subCmds, "option",
+ 0, (int *) &index);
+ if (result != TCL_OK) {
+ Tcl_AppendResult(interp, "bad argument \"", arg,
+ "\": must be cancel, idle, info, or a number",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ switch (index) {
+ case 0: /* cancel */
+ {
+ char *arg;
+ Tcl_Obj *objPtr = NULL;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "id|command");
+ return TCL_ERROR;
+ }
+ if (objc == 3) {
+ arg = Tcl_GetStringFromObj(objv[2], &length);
+ } else {
+ objPtr = Tcl_ConcatObj(objc-2, objv+2);;
+ arg = Tcl_GetStringFromObj(objPtr, &length);
+ }
+ for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
+ afterPtr = afterPtr->nextPtr) {
+ if (strcmp(afterPtr->command, arg) == 0) {
+ break;
+ }
+ }
+ if (afterPtr == NULL) {
+ afterPtr = GetAfterEvent(assocPtr, arg);
+ }
+ if (objPtr != NULL) {
+ Tcl_DecrRefCount(objPtr);
+ }
+ if (afterPtr != NULL) {
+ if (afterPtr->token != NULL) {
+ Tcl_DeleteTimerHandler(afterPtr->token);
+ } else {
+ Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
+ }
+ FreeAfterPtr(afterPtr);
+ }
break;
}
- }
- if (afterPtr == NULL) {
- afterPtr = GetAfterEvent(assocPtr, arg);
- }
- if (arg != argv[2]) {
- ckfree(arg);
- }
- if (afterPtr != NULL) {
- if (afterPtr->token != NULL) {
- Tcl_DeleteTimerHandler(afterPtr->token);
+ case 1: /* idle */
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "script script ...");
+ return TCL_ERROR;
+ }
+ afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
+ afterPtr->assocPtr = assocPtr;
+ if (objc == 3) {
+ arg = Tcl_GetStringFromObj(objv[2], &length);
+ afterPtr->command = (char *) ckalloc((unsigned) length + 1);
+ strcpy(afterPtr->command, arg);
} else {
- Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
+ Tcl_Obj *objPtr = Tcl_ConcatObj(objc-2, objv+2);;
+ arg = Tcl_GetStringFromObj(objPtr, &length);
+ afterPtr->command = (char *) ckalloc((unsigned) (length + 1));
+ strcpy(afterPtr->command, arg);
+ Tcl_DecrRefCount(objPtr);
}
- FreeAfterPtr(afterPtr);
- }
- } else if ((strncmp(argv[1], "idle", length) == 0)
- && (length >= 2)) {
- if (argc < 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " idle script script ...\"", (char *) NULL);
- return TCL_ERROR;
- }
- afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
- afterPtr->assocPtr = assocPtr;
- if (argc == 3) {
- afterPtr->command = (char *) ckalloc((unsigned)
- (strlen(argv[2]) + 1));
- strcpy(afterPtr->command, argv[2]);
- } else {
- afterPtr->command = Tcl_Concat(argc-2, argv+2);
- }
- afterPtr->id = nextId;
- nextId += 1;
- afterPtr->token = NULL;
- afterPtr->nextPtr = assocPtr->firstAfterPtr;
- assocPtr->firstAfterPtr = afterPtr;
- Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);
- sprintf(interp->result, "after#%d", afterPtr->id);
- } else if ((strncmp(argv[1], "info", length) == 0)
- && (length >= 2)) {
- if (argc == 2) {
- char buffer[30];
+ afterPtr->id = nextId;
+ nextId += 1;
+ afterPtr->token = NULL;
+ afterPtr->nextPtr = assocPtr->firstAfterPtr;
+ assocPtr->firstAfterPtr = afterPtr;
+ Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);
+ sprintf(interp->result, "after#%d", afterPtr->id);
+ break;
+ case 2: /* info */
+ if (objc == 2) {
+ char buffer[30];
- for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
- afterPtr = afterPtr->nextPtr) {
- if (assocPtr->interp == interp) {
- sprintf(buffer, "after#%d", afterPtr->id);
- Tcl_AppendElement(interp, buffer);
+ for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
+ afterPtr = afterPtr->nextPtr) {
+ if (assocPtr->interp == interp) {
+ sprintf(buffer, "after#%d", afterPtr->id);
+ Tcl_AppendElement(interp, buffer);
+ }
}
+ return TCL_OK;
}
- return TCL_OK;
- }
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " info ?id?\"", (char *) NULL);
- return TCL_ERROR;
- }
- afterPtr = GetAfterEvent(assocPtr, argv[2]);
- if (afterPtr == NULL) {
- Tcl_AppendResult(interp, "event \"", argv[2],
- "\" doesn't exist", (char *) NULL);
- return TCL_ERROR;
- }
- Tcl_AppendElement(interp, afterPtr->command);
- Tcl_AppendElement(interp,
- (afterPtr->token == NULL) ? "idle" : "timer");
- } else {
- Tcl_AppendResult(interp, "bad argument \"", argv[1],
- "\": must be cancel, idle, info, or a number",
- (char *) NULL);
- return TCL_ERROR;
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?id?");
+ return TCL_ERROR;
+ }
+ arg = Tcl_GetStringFromObj(objv[2], &length);
+ afterPtr = GetAfterEvent(assocPtr, arg);
+ if (afterPtr == NULL) {
+ Tcl_AppendResult(interp, "event \"", arg,
+ "\" doesn't exist", (char *) NULL);
+ return TCL_ERROR;
+ }
+ Tcl_AppendElement(interp, afterPtr->command);
+ Tcl_AppendElement(interp,
+ (afterPtr->token == NULL) ? "idle" : "timer");
+ break;
}
return TCL_OK;
}
diff --git a/contrib/tcl/generic/tclUtil.c b/contrib/tcl/generic/tclUtil.c
index 2eca40c..e43482f 100644
--- a/contrib/tcl/generic/tclUtil.c
+++ b/contrib/tcl/generic/tclUtil.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclUtil.c 1.154 97/06/26 13:49:14
+ * SCCS: @(#) tclUtil.c 1.161 97/08/12 17:07:18
*/
#include "tclInt.h"
@@ -38,6 +38,23 @@
#define BRACES_UNMATCHED 4
/*
+ * The following values determine the precision used when converting
+ * floating-point values to strings. This information is linked to all
+ * of the tcl_precision variables in all interpreters via the procedure
+ * TclPrecTraceProc.
+ *
+ * NOTE: these variables are not thread-safe.
+ */
+
+static char precisionString[10] = "12";
+ /* The string value of all the tcl_precision
+ * variables. */
+static char precisionFormat[10] = "%.12g";
+ /* The format string actually used in calls
+ * to sprintf. */
+
+
+/*
* Function prototypes for local procedures in this file:
*/
@@ -99,7 +116,7 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
* to indicate that arg was/wasn't
* in braces. */
{
- register char *p = list;
+ char *p = list;
char *elemStart; /* Points to first byte of first element. */
char *limit; /* Points just after list's last byte. */
int openBraces = 0; /* Brace nesting level during parse. */
@@ -313,10 +330,10 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
int
TclCopyAndCollapse(count, src, dst)
int count; /* Number of characters to copy from src. */
- register char *src; /* Copy from here... */
- register char *dst; /* ... to here. */
+ char *src; /* Copy from here... */
+ char *dst; /* ... to here. */
{
- register char c;
+ char c;
int numRead;
int newCount = 0;
@@ -378,7 +395,7 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr)
* array of pointers to list elements. */
{
char **argv;
- register char *p;
+ char *p;
int length, size, i, result, elSize, brace;
char *element;
@@ -422,7 +439,7 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr)
}
argv[i] = p;
if (brace) {
- (void) strncpy(p, element, (size_t) elSize);
+ memcpy((VOID *) p, (VOID *) element, (size_t) elSize);
p += elSize;
*p = 0;
p++;
@@ -463,7 +480,7 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr)
int
Tcl_ScanElement(string, flagPtr)
- char *string; /* String to convert to Tcl list element. */
+ CONST char *string; /* String to convert to Tcl list element. */
int *flagPtr; /* Where to store information to guide
* Tcl_ConvertCountedElement. */
{
@@ -497,14 +514,13 @@ Tcl_ScanElement(string, flagPtr)
int
Tcl_ScanCountedElement(string, length, flagPtr)
- char *string; /* String to convert to Tcl list element. */
+ CONST char *string; /* String to convert to Tcl list element. */
int length; /* Number of bytes in string, or -1. */
int *flagPtr; /* Where to store information to guide
* Tcl_ConvertElement. */
{
int flags, nestingLevel;
- register char *p;
- char *lastChar;
+ CONST char *p, *lastChar;
/*
* This procedure and Tcl_ConvertElement together do two things:
@@ -632,7 +648,7 @@ Tcl_ScanCountedElement(string, length, flagPtr)
int
Tcl_ConvertElement(src, dst, flags)
- register char *src; /* Source information for list element. */
+ CONST char *src; /* Source information for list element. */
char *dst; /* Place to put list-ified element. */
int flags; /* Flags produced by Tcl_ScanElement. */
{
@@ -664,13 +680,13 @@ Tcl_ConvertElement(src, dst, flags)
int
Tcl_ConvertCountedElement(src, length, dst, flags)
- register char *src; /* Source information for list element. */
+ CONST char *src; /* Source information for list element. */
int length; /* Number of bytes in src, or -1. */
char *dst; /* Place to put list-ified element. */
int flags; /* Flags produced by Tcl_ScanElement. */
{
- register char *p = dst;
- char *lastChar;
+ char *p = dst;
+ CONST char *lastChar;
/*
* See the comment block at the beginning of the Tcl_ScanElement
@@ -807,7 +823,7 @@ Tcl_Merge(argc, argv)
int localFlags[LOCAL_SIZE], *flagPtr;
int numChars;
char *result;
- register char *dst;
+ char *dst;
int i;
/*
@@ -873,7 +889,7 @@ Tcl_Concat(argc, argv)
char **argv; /* Array of strings to concatenate. */
{
int totalSize, i;
- register char *p;
+ char *p;
char *result;
for (totalSize = 1, i = 0; i < argc; i++) {
@@ -899,14 +915,15 @@ Tcl_Concat(argc, argv)
element++;
}
for (length = strlen(element);
- (length > 0) && (isspace(UCHAR(element[length-1])));
+ (length > 0) && (isspace(UCHAR(element[length-1])))
+ && ((length < 2) || (element[length-2] != '\\'));
length--) {
/* Null loop body. */
}
if (length == 0) {
continue;
}
- (void) strncpy(p, element, (size_t) length);
+ memcpy((VOID *) p, (VOID *) element, (size_t) length);
p += length;
*p = ' ';
p++;
@@ -943,10 +960,10 @@ Tcl_ConcatObj(objc, objv)
Tcl_Obj *CONST objv[]; /* Array of objects to concatenate. */
{
int allocSize, finalSize, length, elemLength, i;
- register char *p;
- register char *element;
+ char *p;
+ char *element;
char *concatStr;
- register Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr;
allocSize = 0;
for (i = 0; i < objc; i++) {
@@ -986,8 +1003,16 @@ Tcl_ConcatObj(objc, objv)
element++;
elemLength--;
}
+
+ /*
+ * Trim trailing white space. But, be careful not to trim
+ * a space character if it is preceded by a backslash: in
+ * this case it could be significant.
+ */
+
while ((elemLength > 0)
- && isspace(UCHAR(element[elemLength-1]))) {
+ && isspace(UCHAR(element[elemLength-1]))
+ && ((elemLength < 2) || (element[elemLength-2] != '\\'))) {
elemLength--;
}
if (elemLength == 0) {
@@ -1034,9 +1059,9 @@ Tcl_ConcatObj(objc, objv)
int
Tcl_StringMatch(string, pattern)
- register char *string; /* String. */
- register char *pattern; /* Pattern, which may contain
- * special characters. */
+ char *string; /* String. */
+ char *pattern; /* Pattern, which may contain special
+ * characters. */
{
char c2;
@@ -1171,13 +1196,13 @@ void
Tcl_SetResult(interp, string, freeProc)
Tcl_Interp *interp; /* Interpreter with which to associate the
* return value. */
- register char *string; /* Value to be returned. If NULL,
- * the result is set to an empty string. */
+ char *string; /* Value to be returned. If NULL, the
+ * result is set to an empty string. */
Tcl_FreeProc *freeProc; /* Gives information about the string:
* TCL_STATIC, TCL_VOLATILE, or the address
* of a Tcl_FreeProc such as free. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
int length;
Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
char *oldResult = iPtr->result;
@@ -1242,7 +1267,7 @@ Tcl_SetResult(interp, string, freeProc)
char *
Tcl_GetStringResult(interp)
- register Tcl_Interp *interp; /* Interpreter whose result to return. */
+ Tcl_Interp *interp; /* Interpreter whose result to return. */
{
/*
* If the string result is empty, move the object result to the
@@ -1282,12 +1307,12 @@ void
Tcl_SetObjResult(interp, objPtr)
Tcl_Interp *interp; /* Interpreter with which to associate the
* return object value. */
- register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the
+ Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the
* obj result is made an empty string
* object. */
{
- register Interp *iPtr = (Interp *) interp;
- register Tcl_Obj *oldObjResult = iPtr->objResultPtr;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *oldObjResult = iPtr->objResultPtr;
iPtr->objResultPtr = objPtr;
Tcl_IncrRefCount(objPtr); /* since interp result is a reference */
@@ -1341,9 +1366,9 @@ Tcl_Obj *
Tcl_GetObjResult(interp)
Tcl_Interp *interp; /* Interpreter whose result to return. */
{
- register Interp *iPtr = (Interp *) interp;
- register Tcl_Obj *objResultPtr;
- register int length;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *objResultPtr;
+ int length;
/*
* If the string result is non-empty, move the string result to the
@@ -1398,8 +1423,8 @@ void
Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
va_list argList;
- register Interp *iPtr;
- register char *string;
+ Interp *iPtr;
+ char *string;
int newSpace;
/*
@@ -1488,9 +1513,9 @@ Tcl_AppendElement(interp, string)
char *string; /* String to convert to list element and
* add to result. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
char *dst;
- register int size;
+ int size;
int flags;
/*
@@ -1552,7 +1577,7 @@ Tcl_AppendElement(interp, string)
static void
SetupAppendBuffer(iPtr, newSpace)
- register Interp *iPtr; /* Interpreter whose result is being set up. */
+ Interp *iPtr; /* Interpreter whose result is being set up. */
int newSpace; /* Make sure that at least this many bytes
* of new information may be added. */
{
@@ -1635,9 +1660,9 @@ SetupAppendBuffer(iPtr, newSpace)
void
Tcl_FreeResult(interp)
- register Tcl_Interp *interp; /* Interpreter for which to free result. */
+ Tcl_Interp *interp; /* Interpreter for which to free result. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
if (iPtr->freeProc != NULL) {
if ((iPtr->freeProc == TCL_DYNAMIC)
@@ -1676,7 +1701,7 @@ void
Tcl_ResetResult(interp)
Tcl_Interp *interp; /* Interpreter for which to clear result. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
TclResetObjResult(iPtr);
@@ -1805,7 +1830,7 @@ Tcl_RegExpCompile(interp, string)
char *string; /* String for which to produce
* compiled regular expression. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
int i, length;
regexp *result;
@@ -2009,8 +2034,7 @@ Tcl_RegExpMatch(interp, string, pattern)
void
Tcl_DStringInit(dsPtr)
- register Tcl_DString *dsPtr; /* Pointer to structure for
- * dynamic string. */
+ Tcl_DString *dsPtr; /* Pointer to structure for dynamic string. */
{
dsPtr->string = dsPtr->staticSpace;
dsPtr->length = 0;
@@ -2038,17 +2062,16 @@ Tcl_DStringInit(dsPtr)
char *
Tcl_DStringAppend(dsPtr, string, length)
- register Tcl_DString *dsPtr; /* Structure describing dynamic
- * string. */
- char *string; /* String to append. If length is
- * -1 then this must be
- * null-terminated. */
- int length; /* Number of characters from string
- * to append. If < 0, then append all
- * of string, up to null at end. */
+ Tcl_DString *dsPtr; /* Structure describing dynamic string. */
+ CONST char *string; /* String to append. If length is -1 then
+ * this must be null-terminated. */
+ int length; /* Number of characters from string to
+ * append. If < 0, then append all of string,
+ * up to null at end. */
{
int newSize;
- char *newString, *dst, *end;
+ char *newString, *dst;
+ CONST char *end;
if (length < 0) {
length = strlen(string);
@@ -2081,7 +2104,7 @@ Tcl_DStringAppend(dsPtr, string, length)
string < end; string++, dst++) {
*dst = *string;
}
- *dst = 0;
+ *dst = '\0';
dsPtr->length += length;
return dsPtr->string;
}
@@ -2106,10 +2129,9 @@ Tcl_DStringAppend(dsPtr, string, length)
char *
Tcl_DStringAppendElement(dsPtr, string)
- register Tcl_DString *dsPtr; /* Structure describing dynamic
- * string. */
- char *string; /* String to append. Must be
- * null-terminated. */
+ Tcl_DString *dsPtr; /* Structure describing dynamic string. */
+ CONST char *string; /* String to append. Must be
+ * null-terminated. */
{
int newSize, flags;
char *dst, *newString;
@@ -2173,9 +2195,8 @@ Tcl_DStringAppendElement(dsPtr, string)
void
Tcl_DStringSetLength(dsPtr, length)
- register Tcl_DString *dsPtr; /* Structure describing dynamic
- * string. */
- int length; /* New length for dynamic string. */
+ Tcl_DString *dsPtr; /* Structure describing dynamic string. */
+ int length; /* New length for dynamic string. */
{
if (length < 0) {
length = 0;
@@ -2223,8 +2244,7 @@ Tcl_DStringSetLength(dsPtr, length)
void
Tcl_DStringFree(dsPtr)
- register Tcl_DString *dsPtr; /* Structure describing dynamic
- * string. */
+ Tcl_DString *dsPtr; /* Structure describing dynamic string. */
{
if (dsPtr->string != dsPtr->staticSpace) {
ckfree(dsPtr->string);
@@ -2257,10 +2277,9 @@ Tcl_DStringFree(dsPtr)
void
Tcl_DStringResult(interp, dsPtr)
- Tcl_Interp *interp; /* Interpreter whose result is to be
- * reset. */
- register Tcl_DString *dsPtr; /* Dynamic string that is to become
- * the result of interp. */
+ Tcl_Interp *interp; /* Interpreter whose result is to be reset. */
+ Tcl_DString *dsPtr; /* Dynamic string that is to become the
+ * result of interp. */
{
Tcl_ResetResult(interp);
@@ -2302,12 +2321,11 @@ Tcl_DStringResult(interp, dsPtr)
void
Tcl_DStringGetResult(interp, dsPtr)
- Tcl_Interp *interp; /* Interpreter whose result is to be
- * reset. */
- register Tcl_DString *dsPtr; /* Dynamic string that is to become the
- * result of interp. */
+ Tcl_Interp *interp; /* Interpreter whose result is to be reset. */
+ Tcl_DString *dsPtr; /* Dynamic string that is to become the
+ * result of interp. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
if (dsPtr->string != dsPtr->staticSpace) {
ckfree(dsPtr->string);
@@ -2438,9 +2456,9 @@ Tcl_PrintDouble(interp, value, dst)
* must have at least TCL_DOUBLE_SPACE
* characters. */
{
- register char *p;
+ char *p;
- sprintf(dst, "%.17g", value);
+ sprintf(dst, precisionFormat, value);
/*
* If the ASCII result looks like an integer, add ".0" so that it
@@ -2461,6 +2479,92 @@ Tcl_PrintDouble(interp, value, dst)
/*
*----------------------------------------------------------------------
*
+ * TclPrecTraceProc --
+ *
+ * This procedure is invoked whenever the variable "tcl_precision"
+ * is written.
+ *
+ * Results:
+ * Returns NULL if all went well, or an error message if the
+ * new value for the variable doesn't make sense.
+ *
+ * Side effects:
+ * If the new value doesn't make sense then this procedure
+ * undoes the effect of the variable modification. Otherwise
+ * it modifies the format string that's used by Tcl_PrintDouble.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+char *
+TclPrecTraceProc(clientData, interp, name1, name2, flags)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Interpreter containing variable. */
+ char *name1; /* Name of variable. */
+ char *name2; /* Second part of variable name. */
+ int flags; /* Information about what happened. */
+{
+ char *value, *end;
+ int prec;
+
+ /*
+ * If the variable is unset, then recreate the trace.
+ */
+
+ if (flags & TCL_TRACE_UNSETS) {
+ if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) {
+ Tcl_TraceVar2(interp, name1, name2,
+ TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
+ |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData);
+ }
+ return (char *) NULL;
+ }
+
+ /*
+ * When the variable is read, reset its value from our shared
+ * value. This is needed in case the variable was modified in
+ * some other interpreter so that this interpreter's value is
+ * out of date.
+ */
+
+ if (flags & TCL_TRACE_READS) {
+ Tcl_SetVar2(interp, name1, name2, precisionString,
+ flags & TCL_GLOBAL_ONLY);
+ return (char *) NULL;
+ }
+
+ /*
+ * The variable is being written. Check the new value and disallow
+ * it if it isn't reasonable or if this is a safe interpreter (we
+ * don't want safe interpreters messing up the precision of other
+ * interpreters).
+ */
+
+ if (Tcl_IsSafe(interp)) {
+ Tcl_SetVar2(interp, name1, name2, precisionString,
+ flags & TCL_GLOBAL_ONLY);
+ return "can't modify precision from a safe interpreter";
+ }
+ value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
+ if (value == NULL) {
+ value = "";
+ }
+ prec = strtoul(value, &end, 10);
+ if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) ||
+ (end == value) || (*end != 0)) {
+ Tcl_SetVar2(interp, name1, name2, precisionString,
+ flags & TCL_GLOBAL_ONLY);
+ return "improper value for precision";
+ }
+ TclFormatInt(precisionString, prec);
+ sprintf(precisionFormat, "%%.%dg", prec);
+ return (char *) NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclNeedSpace --
*
* This procedure checks to see whether it is appropriate to
@@ -2539,12 +2643,12 @@ TclNeedSpace(start, end)
int
TclFormatInt(buffer, n)
- register char *buffer; /* Points to the storage into which the
+ char *buffer; /* Points to the storage into which the
* formatted characters are written. */
long n; /* The integer to format. */
{
- register long intVal;
- register int i;
+ long intVal;
+ int i;
int numFormatted, j;
char *digits = "0123456789";
@@ -2612,7 +2716,7 @@ TclFormatInt(buffer, n)
int
TclLooksLikeInt(p)
- register char *p; /* Pointer to string. */
+ char *p; /* Pointer to string. */
{
while (isspace(UCHAR(*p))) {
p++;
@@ -2636,54 +2740,6 @@ TclLooksLikeInt(p)
/*
*----------------------------------------------------------------------
*
- * Tcl_WrongNumArgs --
- *
- * This procedure generates a "wrong # args" error message in an
- * interpreter. It is used as a utility function by many command
- * procedures.
- *
- * Results:
- * None.
- *
- * Side effects:
- * An error message is generated in interp's result object to
- * indicate that a command was invoked with the wrong number of
- * arguments. The message has the form
- * wrong # args: should be "foo bar additional stuff"
- * where "foo" and "bar" are the initial objects in objv (objc
- * determines how many of these are printed) and "additional stuff"
- * is the contents of the message argument.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_WrongNumArgs(interp, objc, objv, message)
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments to print
- * from objv. */
- Tcl_Obj *CONST objv[]; /* Initial argument objects, which
- * should be included in the error
- * message. */
- char *message; /* Error message to print after the
- * leading objects in objv. */
-{
- Tcl_Obj *objPtr;
- int i;
-
- objPtr = Tcl_GetObjResult(interp);
- Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
- for (i = 0; i < objc; i++) {
- Tcl_AppendStringsToObj(objPtr,
- Tcl_GetStringFromObj(objv[i], (int *) NULL), " ",
- (char *) NULL);
- }
- Tcl_AppendStringsToObj(objPtr, message, "\"", (char *) NULL);
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclGetIntForIndex --
*
* This procedure returns an integer corresponding to the list index
@@ -2711,15 +2767,15 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting.
* If NULL, then no error message is left
* after errors. */
- register Tcl_Obj *objPtr; /* Points to an object containing either
+ Tcl_Obj *objPtr; /* Points to an object containing either
* "end" or an integer. */
int endValue; /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
- register int *indexPtr; /* Location filled in with an integer
+ int *indexPtr; /* Location filled in with an integer
* representing an index. */
{
Interp *iPtr = (Interp *) interp;
- register char *bytes;
+ char *bytes;
int index, length, result;
/*
diff --git a/contrib/tcl/generic/tclVar.c b/contrib/tcl/generic/tclVar.c
index 577ba74..587eca9 100644
--- a/contrib/tcl/generic/tclVar.c
+++ b/contrib/tcl/generic/tclVar.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclVar.c 1.113 97/06/25 08:54:16
+ * SCCS: @(#) tclVar.c 1.125 97/08/06 14:47:55
*/
#include "tclInt.h"
@@ -782,6 +782,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg)
* that we return. Initialized to avoid
* compiler warning. */
char *elem, *msg;
+ int new;
#ifdef TCL_COMPILE_DEBUG
Proc *procPtr = varFramePtr->procPtr;
@@ -833,23 +834,34 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg)
}
/*
- * Look up the element.
+ * Look up the element. Note that we must create the element (but leave
+ * it marked undefined) if it does not already exist. This allows a
+ * trace to create new array elements "on the fly" that did not exist
+ * before. A trace is always passed a variable for the array element. If
+ * the trace does not define the variable, it will be deleted below (at
+ * errorReturn) and an error returned.
*/
- hPtr = Tcl_FindHashEntry(arrayPtr->value.tablePtr, elem);
- if (hPtr == NULL) {
- if (leaveErrorMsg) {
- VarErrMsg(interp, arrayName, elem, "read", noSuchElement);
+ hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new);
+ if (new) {
+ if (arrayPtr->searchPtr != NULL) {
+ DeleteSearches(arrayPtr);
}
- goto errorReturn;
+ varPtr = NewVar();
+ Tcl_SetHashValue(hPtr, varPtr);
+ varPtr->hPtr = hPtr;
+ varPtr->nsPtr = varFramePtr->nsPtr;
+ TclSetVarArrayElement(varPtr);
+ } else {
+ varPtr = (Var *) Tcl_GetHashValue(hPtr);
}
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
/*
* Invoke any traces that have been set for the element variable.
*/
- if (varPtr->tracePtr != NULL) {
+ if ((varPtr->tracePtr != NULL)
+ || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem,
TCL_TRACE_READS);
if (msg != NULL) {
@@ -1034,12 +1046,12 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags)
* Tcl_ObjSetVar2 to actually set the variable.
*/
- length = strlen(newValue);
+ length = newValue ? strlen(newValue) : 0;
TclNewObj(valuePtr);
TclInitStringRep(valuePtr, newValue, length);
Tcl_IncrRefCount(valuePtr);
- length = strlen(part1);
+ length = strlen(part1) ;
TclNewObj(part1Ptr);
TclInitStringRep(part1Ptr, part1, length);
Tcl_IncrRefCount(part1Ptr);
@@ -2119,6 +2131,22 @@ Tcl_UnsetVar2(interp, part1, part2, flags)
TclDecrRefCount(objPtr);
dummyVarPtr->value.objPtr = NULL;
}
+
+ /*
+ * If the variable was a namespace variable, decrement its reference
+ * count. We are in the process of destroying its namespace so that
+ * namespace will no longer "refer" to the variable.
+ */
+
+ if (varPtr->flags & VAR_NAMESPACE_VAR) {
+ varPtr->flags &= ~VAR_NAMESPACE_VAR;
+ varPtr->refCount--;
+ }
+
+ /*
+ * It's an error to unset an undefined variable.
+ */
+
if (result != TCL_OK) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, part1, part2, "unset",
@@ -2751,26 +2779,35 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
+ static char *arrayOptions[] = {"anymore", "donesearch", "exists", "get",
+ "names", "nextelement", "set", "size", "startsearch",
+ (char *) NULL};
Var *varPtr, *arrayPtr;
Tcl_HashEntry *hPtr;
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
- int notArray, c;
- char *varName, *option;
- int length, result;
+ int notArray;
+ char *varName;
+ int index, result;
+
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?arg ...?");
return TCL_ERROR;
}
+ if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option", 0, &index)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+
/*
* Locate the array variable (and it better be an array).
* THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE.
*/
-
varName = TclGetStringFromObj(objv[2], (int *) NULL);
varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0,
/*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+
notArray = 0;
if (varPtr == NULL) {
notArray = 1;
@@ -2780,295 +2817,289 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
}
}
- /*
- * Dispatch based on the option.
- * THIS FAILS IF THE OPTIONS OBJECT'S STRING REP HAS A NULL BYTE.
- */
-
- option = TclGetStringFromObj(objv[1], (int *) NULL);
- c = option[0];
- length = strlen(option);
- if ((c == 'a')
- && (strncmp(option, "anymore", (unsigned) length) == 0)) {
- ArraySearch *searchPtr;
- char *searchId;
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "anymore arrayName searchId");
- return TCL_ERROR;
- }
- if (notArray) {
- goto error;
- }
- searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL);
- searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
- if (searchPtr == NULL) {
- return TCL_ERROR;
- }
- while (1) {
- Var *varPtr2;
+ switch (index) {
+ case 0: { /* anymore */
+ ArraySearch *searchPtr;
+ char *searchId;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "arrayName searchId");
+ return TCL_ERROR;
+ }
+ if (notArray) {
+ goto error;
+ }
+ searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL);
+ searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
+ if (searchPtr == NULL) {
+ return TCL_ERROR;
+ }
+ while (1) {
+ Var *varPtr2;
- if (searchPtr->nextEntry != NULL) {
- varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
- if (!TclIsVarUndefined(varPtr2)) {
- break;
+ if (searchPtr->nextEntry != NULL) {
+ varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
+ if (!TclIsVarUndefined(varPtr2)) {
+ break;
+ }
+ }
+ searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
+ if (searchPtr->nextEntry == NULL) {
+ Tcl_SetIntObj(resultPtr, 0);
+ return TCL_OK;
}
}
- searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
- if (searchPtr->nextEntry == NULL) {
- Tcl_SetIntObj(resultPtr, 0);
- return TCL_OK;
- }
+ Tcl_SetIntObj(resultPtr, 1);
+ break;
}
- Tcl_SetIntObj(resultPtr, 1);
- return TCL_OK;
- } else if ((c == 'd')
- && (strncmp(option, "donesearch", (unsigned) length) == 0)) {
- ArraySearch *searchPtr, *prevPtr;
- char *searchId;
+ case 1: { /* donesearch */
+ ArraySearch *searchPtr, *prevPtr;
+ char *searchId;
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "donesearch arrayName searchId");
- return TCL_ERROR;
- }
- if (notArray) {
- goto error;
- }
- searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL);
- searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
- if (searchPtr == NULL) {
- return TCL_ERROR;
- }
- if (varPtr->searchPtr == searchPtr) {
- varPtr->searchPtr = searchPtr->nextPtr;
- } else {
- for (prevPtr = varPtr->searchPtr; ;
- prevPtr = prevPtr->nextPtr) {
- if (prevPtr->nextPtr == searchPtr) {
- prevPtr->nextPtr = searchPtr->nextPtr;
- break;
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "arrayName searchId");
+ return TCL_ERROR;
+ }
+ if (notArray) {
+ goto error;
+ }
+ searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL);
+ searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
+ if (searchPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (varPtr->searchPtr == searchPtr) {
+ varPtr->searchPtr = searchPtr->nextPtr;
+ } else {
+ for (prevPtr = varPtr->searchPtr; ;
+ prevPtr = prevPtr->nextPtr) {
+ if (prevPtr->nextPtr == searchPtr) {
+ prevPtr->nextPtr = searchPtr->nextPtr;
+ break;
+ }
}
}
+ ckfree((char *) searchPtr);
+ break;
}
- ckfree((char *) searchPtr);
- } else if ((c == 'e')
- && (strncmp(option, "exists", (unsigned) length) == 0)) {
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "exists arrayName");
- return TCL_ERROR;
- }
- Tcl_SetIntObj(resultPtr, !notArray);
- } else if ((c == 'g')
- && (strncmp(option, "get", (unsigned) length) == 0)) {
- Tcl_HashSearch search;
- Var *varPtr2;
- char *pattern = NULL;
- char *name;
- Tcl_Obj *namePtr, *valuePtr;
-
- if ((objc != 3) && (objc != 4)) {
- Tcl_WrongNumArgs(interp, 1, objv, "get arrayName ?pattern?");
- return TCL_ERROR;
- }
- if (notArray) {
- return TCL_OK;
- }
- if (objc == 4) {
- pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL);
+ case 2: { /* exists */
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
+ return TCL_ERROR;
+ }
+ Tcl_SetIntObj(resultPtr, !notArray);
+ break;
}
- for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
- hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
- varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
- if (TclIsVarUndefined(varPtr2)) {
- continue;
+ case 3: { /*get*/
+ Tcl_HashSearch search;
+ Var *varPtr2;
+ char *pattern = NULL;
+ char *name;
+ Tcl_Obj *namePtr, *valuePtr;
+
+ if ((objc != 3) && (objc != 4)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
+ return TCL_ERROR;
}
- name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
- if ((objc == 4) && !Tcl_StringMatch(name, pattern)) {
- continue; /* element name doesn't match pattern */
+ if (notArray) {
+ return TCL_OK;
}
-
- namePtr = Tcl_NewStringObj(name, -1);
- result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr);
- if (result != TCL_OK) {
- Tcl_DecrRefCount(namePtr); /* free unneeded name object */
- return result;
+ if (objc == 4) {
+ pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL);
}
+ for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+ varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
+ if (TclIsVarUndefined(varPtr2)) {
+ continue;
+ }
+ name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
+ if ((objc == 4) && !Tcl_StringMatch(name, pattern)) {
+ continue; /* element name doesn't match pattern */
+ }
+
+ namePtr = Tcl_NewStringObj(name, -1);
+ result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr);
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount(namePtr); /* free unneeded name object */
+ return result;
+ }
- if (varPtr2->value.objPtr == NULL) {
- TclNewObj(valuePtr);
- } else {
- valuePtr = varPtr2->value.objPtr;
- }
- result = Tcl_ListObjAppendElement(interp, resultPtr, valuePtr);
- if (result != TCL_OK) {
if (varPtr2->value.objPtr == NULL) {
- Tcl_DecrRefCount(valuePtr); /* free unneeded object */
+ TclNewObj(valuePtr);
+ } else {
+ valuePtr = varPtr2->value.objPtr;
+ }
+ result = Tcl_ListObjAppendElement(interp, resultPtr, valuePtr);
+ if (result != TCL_OK) {
+ if (varPtr2->value.objPtr == NULL) {
+ Tcl_DecrRefCount(valuePtr); /* free unneeded object */
+ }
+ return result;
}
- return result;
}
+ break;
}
- } else if ((c == 'n')
- && (strncmp(option, "names", (unsigned) length) == 0)
- && (length >= 2)) {
- Tcl_HashSearch search;
- Var *varPtr2;
- char *pattern = NULL;
- char *name;
- Tcl_Obj *namePtr;
-
- if ((objc != 3) && (objc != 4)) {
- Tcl_WrongNumArgs(interp, 1, objv, "names arrayName ?pattern?");
- return TCL_ERROR;
- }
- if (notArray) {
- return TCL_OK;
- }
- if (objc == 4) {
- pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL);
- }
- for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
- hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
- varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
- if (TclIsVarUndefined(varPtr2)) {
- continue;
+ case 4: { /* names */
+ Tcl_HashSearch search;
+ Var *varPtr2;
+ char *pattern = NULL;
+ char *name;
+ Tcl_Obj *namePtr;
+
+ if ((objc != 3) && (objc != 4)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
+ return TCL_ERROR;
}
- name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
- if ((objc == 4) && !Tcl_StringMatch(name, pattern)) {
- continue; /* element name doesn't match pattern */
+ if (notArray) {
+ return TCL_OK;
}
-
- namePtr = Tcl_NewStringObj(name, -1);
- result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr);
- if (result != TCL_OK) {
- Tcl_DecrRefCount(namePtr); /* free unneeded name object */
- return result;
+ if (objc == 4) {
+ pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL);
}
+ for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+ varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
+ if (TclIsVarUndefined(varPtr2)) {
+ continue;
+ }
+ name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
+ if ((objc == 4) && !Tcl_StringMatch(name, pattern)) {
+ continue; /* element name doesn't match pattern */
+ }
+
+ namePtr = Tcl_NewStringObj(name, -1);
+ result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr);
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount(namePtr); /* free unneeded name object */
+ return result;
+ }
+ }
+ break;
}
- } else if ((c == 'n')
- && (strncmp(option, "nextelement", (unsigned) length) == 0)
- && (length >= 2)) {
- ArraySearch *searchPtr;
- char *searchId;
- Tcl_HashEntry *hPtr;
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "nextelement arrayName searchId");
- return TCL_ERROR;
- }
- if (notArray) {
- goto error;
- }
- searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL);
- searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
- if (searchPtr == NULL) {
- return TCL_ERROR;
- }
- while (1) {
- Var *varPtr2;
+ case 5: { /*nextelement*/
+ ArraySearch *searchPtr;
+ char *searchId;
+ Tcl_HashEntry *hPtr;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "arrayName searchId");
+ return TCL_ERROR;
+ }
+ if (notArray) {
+ goto error;
+ }
+ searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL);
+ searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
+ if (searchPtr == NULL) {
+ return TCL_ERROR;
+ }
+ while (1) {
+ Var *varPtr2;
- hPtr = searchPtr->nextEntry;
- if (hPtr == NULL) {
- hPtr = Tcl_NextHashEntry(&searchPtr->search);
+ hPtr = searchPtr->nextEntry;
if (hPtr == NULL) {
- return TCL_OK;
+ hPtr = Tcl_NextHashEntry(&searchPtr->search);
+ if (hPtr == NULL) {
+ return TCL_OK;
+ }
+ } else {
+ searchPtr->nextEntry = NULL;
+ }
+ varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
+ if (!TclIsVarUndefined(varPtr2)) {
+ break;
}
- } else {
- searchPtr->nextEntry = NULL;
- }
- varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
- if (!TclIsVarUndefined(varPtr2)) {
- break;
}
+ Tcl_SetStringObj(resultPtr,
+ Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1);
+ break;
}
- Tcl_SetStringObj(resultPtr,
- Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1);
- } else if ((c == 's')
- && (strncmp(option, "set", (unsigned) length) == 0)
- && (length >= 2)) {
- Tcl_Obj **elemPtrs;
- int listLen, i, result;
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "set arrayName list");
- return TCL_ERROR;
- }
- result = Tcl_ListObjGetElements(interp, objv[3], &listLen, &elemPtrs);
- if (result != TCL_OK) {
+ case 6: { /*set*/
+ Tcl_Obj **elemPtrs;
+ int listLen, i, result;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName list");
+ return TCL_ERROR;
+ }
+ result = Tcl_ListObjGetElements(interp, objv[3], &listLen,
+ &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (listLen & 1) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "list must have an even number of elements", -1);
+ return TCL_ERROR;
+ }
+ for (i = 0; i < listLen; i += 2) {
+ if (Tcl_ObjSetVar2(interp, objv[2], elemPtrs[i], elemPtrs[i+1],
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ result = TCL_ERROR;
+ break;
+ }
+ }
return result;
}
- if (listLen & 1) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "list must have an even number of elements", -1);
- return TCL_ERROR;
- }
- for (i = 0; i < listLen; i += 2) {
- if (Tcl_ObjSetVar2(interp, objv[2], elemPtrs[i], elemPtrs[i+1],
- TCL_LEAVE_ERR_MSG) == NULL) {
- result = TCL_ERROR;
- break;
+ case 7: { /*size*/
+ Tcl_HashSearch search;
+ Var *varPtr2;
+ int size;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
+ return TCL_ERROR;
}
- }
- return result;
- } else if ((c == 's')
- && (strncmp(option, "size", (unsigned) length) == 0)
- && (length >= 2)) {
- Tcl_HashSearch search;
- Var *varPtr2;
- int size;
-
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "size arrayName");
- return TCL_ERROR;
- }
- size = 0;
- if (!notArray) {
- for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
- hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
- varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
- if (TclIsVarUndefined(varPtr2)) {
- continue;
+ size = 0;
+ if (!notArray) {
+ for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr,
+ &search);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+ varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
+ if (TclIsVarUndefined(varPtr2)) {
+ continue;
+ }
+ size++;
}
- size++;
}
+ Tcl_SetIntObj(resultPtr, size);
+ break;
}
- Tcl_SetIntObj(resultPtr, size);
- } else if ((c == 's')
- && (strncmp(option, "startsearch", (unsigned) length) == 0)
- && (length >= 2)) {
- ArraySearch *searchPtr;
-
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "startsearch arrayName");
- return TCL_ERROR;
- }
- if (notArray) {
- goto error;
- }
- searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
- if (varPtr->searchPtr == NULL) {
- searchPtr->id = 1;
- Tcl_AppendStringsToObj(resultPtr, "s-1-", varName,
- (char *) NULL);
- } else {
- char string[20];
+ case 8: { /*startsearch*/
+ ArraySearch *searchPtr;
- searchPtr->id = varPtr->searchPtr->id + 1;
- TclFormatInt(string, searchPtr->id);
- Tcl_AppendStringsToObj(resultPtr, "s-", string, "-", varName,
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
+ return TCL_ERROR;
+ }
+ if (notArray) {
+ goto error;
+ }
+ searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
+ if (varPtr->searchPtr == NULL) {
+ searchPtr->id = 1;
+ Tcl_AppendStringsToObj(resultPtr, "s-1-", varName,
+ (char *) NULL);
+ } else {
+ char string[20];
+
+ searchPtr->id = varPtr->searchPtr->id + 1;
+ TclFormatInt(string, searchPtr->id);
+ Tcl_AppendStringsToObj(resultPtr, "s-", string, "-", varName,
(char *) NULL);
+ }
+ searchPtr->varPtr = varPtr;
+ searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
+ &searchPtr->search);
+ searchPtr->nextPtr = varPtr->searchPtr;
+ varPtr->searchPtr = searchPtr;
+ break;
}
- searchPtr->varPtr = varPtr;
- searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
- &searchPtr->search);
- searchPtr->nextPtr = varPtr->searchPtr;
- varPtr->searchPtr = searchPtr;
- } else {
- Tcl_AppendStringsToObj(resultPtr, "bad option \"", option,
- "\": should be anymore, donesearch, exists, ",
- "get, names, nextelement, ",
- "set, size, or startsearch", (char *) NULL);
- return TCL_ERROR;
}
return TCL_OK;
@@ -3581,6 +3612,17 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv)
}
/*
+ * Mark the variable as a namespace variable and increment its
+ * reference count so that it will persist until its namespace is
+ * destroyed or until the variable is unset.
+ */
+
+ if (!(varPtr->flags & VAR_NAMESPACE_VAR)) {
+ varPtr->flags |= VAR_NAMESPACE_VAR;
+ varPtr->refCount++;
+ }
+
+ /*
* If a value was specified, set the variable to that value.
* Otherwise, if the variable is new, leave it undefined.
* (If the variable already exists and no value was specified,
@@ -3594,7 +3636,7 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv)
if (varValuePtr == NULL) {
return TCL_ERROR;
}
- }
+ }
/*
* If we are executing inside a Tcl procedure, create a local
@@ -4159,6 +4201,18 @@ TclDeleteVars(iPtr, tablePtr)
TclSetVarScalar(varPtr);
/*
+ * If the variable was a namespace variable, decrement its
+ * reference count. We are in the process of destroying its
+ * namespace so that namespace will no longer "refer" to the
+ * variable.
+ */
+
+ if (varPtr->flags & VAR_NAMESPACE_VAR) {
+ varPtr->flags &= ~VAR_NAMESPACE_VAR;
+ varPtr->refCount--;
+ }
+
+ /*
* Recycle the variable's memory space if there aren't any upvar's
* pointing to it. If there are upvars to this variable, then the
* variable will get freed when the last upvar goes away.
diff --git a/contrib/tcl/library/history.tcl b/contrib/tcl/library/history.tcl
new file mode 100644
index 0000000..a6beb43
--- /dev/null
+++ b/contrib/tcl/library/history.tcl
@@ -0,0 +1,369 @@
+# history.tcl --
+#
+# Implementation of the history command.
+#
+# SCCS: @(#) history.tcl 1.7 97/08/07 16:45:50
+#
+# 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
+ set i [incr history(nextid)]
+ set history($i) $command
+ set j [incr history(oldest)]
+ if {[info exists history($j)]} {unset history($j)}
+ if {[string match e* $exec]} {
+ return [uplevel #0 $command]
+ } else {
+ return {}
+ }
+}
+
+# tcl::HistKeep --
+#
+# Set or query the limit on the length of the history list
+#
+# Parameters:
+# limit (optional) the length of the history list
+#
+# Results:
+# If no limit is specified, the current limit is returned
+#
+# Side Effects:
+# Updates history(keep) if a limit is specified
+
+ proc tcl::HistKeep {{limit {}}} {
+ variable history
+ if {[string length $limit] == 0} {
+ return $history(keep)
+ } else {
+ set oldold $history(oldest)
+ set history(oldest) [expr $history(nextid) - $limit]
+ for {} {$oldold <= $history(oldest)} {incr oldold} {
+ if {[info exists history($oldold)]} {unset history($oldold)}
+ }
+ set history(keep) $limit
+ }
+}
+
+# tcl::HistClear --
+#
+# Erase the history list
+#
+# Parameters:
+# none
+#
+# Results:
+# none
+#
+# Side Effects:
+# Resets the history array, except for the keep limit
+
+ proc tcl::HistClear {} {
+ variable history
+ set keep $history(keep)
+ unset history
+ array set history [list \
+ nextid 0 \
+ keep $keep \
+ oldest -$keep \
+ ]
+}
+
+# tcl::HistInfo --
+#
+# Return a pretty-printed version of the history list
+#
+# Parameters:
+# num (optional) the length of the history list to return
+#
+# Results:
+# A formatted history list
+
+ proc tcl::HistInfo {{num {}}} {
+ variable history
+ if {$num == {}} {
+ set num [expr $history(keep) + 1]
+ }
+ set result {}
+ set newline ""
+ for {set i [expr $history(nextid) - $num + 1]} \
+ {$i <= $history(nextid)} {incr i} {
+ if ![info exists history($i)] {
+ continue
+ }
+ set cmd [string trimright $history($i) \ \n]
+ regsub -all \n $cmd "\n\t" cmd
+ append result $newline[format "%6d %s" $i $cmd]
+ set newline \n
+ }
+ return $result
+}
+
+# tcl::HistRedo --
+#
+# Fetch the previous or specified event, execute it, and then
+# replace the current history item with that event.
+#
+# Parameters:
+# event (optional) index of history item to redo. Defaults to -1,
+# which means the previous event.
+#
+# Results:
+# Those of the command being redone.
+#
+# Side Effects:
+# Replaces the current history list item with the one being redone.
+
+ proc tcl::HistRedo {{event -1}} {
+ variable history
+ if {[string length $event] == 0} {
+ set event -1
+ }
+ set i [HistIndex $event]
+ if {$i == $history(nextid)} {
+ return -code error "cannot redo the current event"
+ }
+ set cmd $history($i)
+ HistChange $cmd 0
+ uplevel #0 $cmd
+}
+
+# tcl::HistIndex --
+#
+# Map from an event specifier to an index in the history list.
+#
+# Parameters:
+# event index of history item to redo.
+# If this is a positive number, it is used directly.
+# If it is a negative number, then it counts back to a previous
+# event, where -1 is the most recent event.
+# A string can be matched, either by being the prefix of
+# a command or by matching a command with string match.
+#
+# Results:
+# The index into history, or an error if the index didn't match.
+
+ proc tcl::HistIndex {event} {
+ variable history
+ if {[catch {expr $event}]} {
+ for {set i $history(nextid)} {[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/contrib/tcl/library/http1.0/http.tcl b/contrib/tcl/library/http1.0/http.tcl
index 366b3ed..450d643 100644
--- a/contrib/tcl/library/http1.0/http.tcl
+++ b/contrib/tcl/library/http1.0/http.tcl
@@ -5,7 +5,7 @@
# These procedures use a callback interface to avoid using vwait,
# which is not defined in the safe base.
#
-# SCCS: @(#) http.tcl 1.6 97/05/20 18:09:27
+# SCCS: @(#) http.tcl 1.8 97/07/22 13:37:20
#
# See the http.n man page for documentation
@@ -118,13 +118,16 @@ proc http_get { url args } {
return -code error "Unknown option $flag, can be: $usage"
}
}
- if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)} $url \
+ if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
x proto host y port srvurl]} {
error "Unsupported URL: $url"
}
if {[string length $port] == 0} {
set port 80
}
+ if {[string length $srvurl] == 0} {
+ set srvurl /
+ }
if {[string length $proto] == 0} {
set url http://$url
}
@@ -221,6 +224,9 @@ proc http_size {token} {
if ![regexp -nocase ^text $state(type)] {
# Turn off conversions for non-text data
fconfigure $s -translation binary
+ if {[info exists state(-channel)]} {
+ fconfigure $state(-channel) -translation binary
+ }
}
if {[info exists state(-channel)] &&
![info exists state(-handler)]} {
diff --git a/contrib/tcl/library/http2.0/http.tcl b/contrib/tcl/library/http2.0/http.tcl
new file mode 100644
index 0000000..80fbfc6
--- /dev/null
+++ b/contrib/tcl/library/http2.0/http.tcl
@@ -0,0 +1,460 @@
+# http.tcl --
+#
+# Client-side HTTP for GET, POST, and HEAD commands.
+# These routines can be used in untrusted code that uses
+# the Safesock security policy. These procedures use a
+# callback interface to avoid using vwait, which is not
+# defined in the safe base.
+#
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# SCCS: @(#) http.tcl 1.6 97/08/07 16:48:32
+
+package provide http 2.0 ;# This uses Tcl namespaces
+
+namespace eval http {
+ variable http
+
+ array set http {
+ -accept */*
+ -proxyhost {}
+ -proxyport {}
+ -useragent {Tcl http client package 2.0}
+ -proxyfilter http::ProxyRequired
+ }
+
+ variable formMap
+ set alphanumeric a-zA-Z0-9
+
+ for {set i 1} {$i <= 256} {incr i} {
+ set c [format %c $i]
+ if {![string match \[$alphanumeric\] $c]} {
+ set formMap($c) %[format %.2x $i]
+ }
+ }
+ # These are handled specially
+ array set formMap {
+ " " + \n %0d%0a
+ }
+
+ namespace export geturl config reset wait formatQuery
+ # Useful, but not exported: data size status code
+}
+
+# http::config --
+#
+# See documentaion for details.
+#
+# Arguments:
+# args Options parsed by the procedure.
+# Results:
+# TODO
+
+proc http::config {args} {
+ variable http
+ set options [lsort [array names http -*]]
+ set usage [join $options ", "]
+ if {[llength $args] == 0} {
+ set result {}
+ foreach name $options {
+ lappend result $name $http($name)
+ }
+ return $result
+ }
+ regsub -all -- - $options {} options
+ set pat ^-([join $options |])$
+ if {[llength $args] == 1} {
+ set flag [lindex $args 0]
+ if {[regexp -- $pat $flag]} {
+ return $http($flag)
+ } else {
+ return -code error "Unknown option $flag, must be: $usage"
+ }
+ } else {
+ foreach {flag value} $args {
+ if [regexp -- $pat $flag] {
+ set http($flag) $value
+ } else {
+ return -code error "Unknown option $flag, must be: $usage"
+ }
+ }
+ }
+}
+
+ proc http::Finish { token {errormsg ""} } {
+ variable $token
+ upvar 0 $token state
+ global errorInfo errorCode
+ if {[string length $errormsg] != 0} {
+ set state(error) [list $errormsg $errorInfo $errorCode]
+ set state(status) error
+ }
+ catch {close $state(sock)}
+ catch {after cancel $state(after)}
+ if {[info exists state(-command)]} {
+ if {[catch {eval $state(-command) {$token}} err]} {
+ if {[string length $errormsg] == 0} {
+ set state(error) [list $err $errorInfo $errorCode]
+ set state(status) error
+ }
+ }
+ unset state(-command)
+ }
+}
+
+# http::reset --
+#
+# See documentaion for details.
+#
+# Arguments:
+# token Connection token.
+# why Status info.
+# Results:
+# TODO
+
+proc http::reset { token {why reset} } {
+ variable $token
+ upvar 0 $token state
+ set state(status) $why
+ catch {fileevent $state(sock) readable {}}
+ Finish $token
+ if {[info exists state(error)]} {
+ set errorlist $state(error)
+ unset state(error)
+ eval error $errorlist
+ }
+}
+
+# http::geturl --
+#
+# Establishes a connection to a remote url via http.
+#
+# Arguments:
+# url The http URL to goget.
+# args Option value pairs. Valid options include:
+# -blocksize, -validate, -headers, -timeout
+# Results:
+# Returns a token for this connection.
+
+
+proc http::geturl { url args } {
+ variable http
+ if ![info exists http(uid)] {
+ set http(uid) 0
+ }
+ set token [namespace current]::[incr http(uid)]
+ variable $token
+ upvar 0 $token state
+ reset $token
+ array set state {
+ -blocksize 8192
+ -validate 0
+ -headers {}
+ -timeout 0
+ state header
+ meta {}
+ currentsize 0
+ totalsize 0
+ type text/html
+ body {}
+ status ""
+ }
+ set options {-blocksize -channel -command -handler -headers \
+ -progress -query -validate -timeout}
+ set usage [join $options ", "]
+ regsub -all -- - $options {} options
+ set pat ^-([join $options |])$
+ foreach {flag value} $args {
+ if [regexp $pat $flag] {
+ # Validate numbers
+ if {[info exists state($flag)] && \
+ [regexp {^[0-9]+$} $state($flag)] && \
+ ![regexp {^[0-9]+$} $value]} {
+ return -code error "Bad value for $flag ($value), must be integer"
+ }
+ set state($flag) $value
+ } else {
+ return -code error "Unknown option $flag, can be: $usage"
+ }
+ }
+ if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
+ x proto host y port srvurl]} {
+ error "Unsupported URL: $url"
+ }
+ if {[string length $port] == 0} {
+ set port 80
+ }
+ if {[string length $srvurl] == 0} {
+ set srvurl /
+ }
+ if {[string length $proto] == 0} {
+ set url http://$url
+ }
+ set state(url) $url
+ if {![catch {$http(-proxyfilter) $host} proxy]} {
+ set phost [lindex $proxy 0]
+ set pport [lindex $proxy 1]
+ }
+ if {$state(-timeout) > 0} {
+ set state(after) [after $state(-timeout) [list http::reset $token timeout]]
+ }
+ if {[info exists phost] && [string length $phost]} {
+ set srvurl $url
+ set s [socket $phost $pport]
+ } else {
+ set s [socket $host $port]
+ }
+ set state(sock) $s
+
+ # Send data in cr-lf format, but accept any line terminators
+
+ fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)
+
+ # The following is disallowed in safe interpreters, but the socket
+ # is already in non-blocking mode in that case.
+
+ catch {fconfigure $s -blocking off}
+ set len 0
+ set how GET
+ if {[info exists state(-query)]} {
+ set len [string length $state(-query)]
+ if {$len > 0} {
+ set how POST
+ }
+ } elseif {$state(-validate)} {
+ set how HEAD
+ }
+ puts $s "$how $srvurl HTTP/1.0"
+ puts $s "Accept: $http(-accept)"
+ puts $s "Host: $host"
+ puts $s "User-Agent: $http(-useragent)"
+ foreach {key value} $state(-headers) {
+ regsub -all \[\n\r\] $value {} value
+ set key [string trim $key]
+ if {[string length $key]} {
+ puts $s "$key: $value"
+ }
+ }
+ if {$len > 0} {
+ puts $s "Content-Length: $len"
+ puts $s "Content-Type: application/x-www-form-urlencoded"
+ puts $s ""
+ fconfigure $s -translation {auto binary}
+ puts $s $state(-query)
+ } else {
+ puts $s ""
+ }
+ flush $s
+ fileevent $s readable [list http::Event $token]
+ if {! [info exists state(-command)]} {
+ wait $token
+ }
+ return $token
+}
+
+# Data access functions:
+# Data - the URL data
+# Status - the transaction status: ok, reset, eof, timeout
+# Code - the HTTP transaction code, e.g., 200
+# Size - the size of the URL data
+
+proc http::data {token} {
+ variable $token
+ upvar 0 $token state
+ return $state(body)
+}
+proc http::status {token} {
+ variable $token
+ upvar 0 $token state
+ return $state(status)
+}
+proc http::code {token} {
+ variable $token
+ upvar 0 $token state
+ return $state(http)
+}
+proc http::size {token} {
+ variable $token
+ upvar 0 $token state
+ return $state(currentsize)
+}
+
+ proc http::Event {token} {
+ variable $token
+ upvar 0 $token state
+ set s $state(sock)
+
+ if [::eof $s] then {
+ Eof $token
+ return
+ }
+ if {$state(state) == "header"} {
+ set n [gets $s line]
+ if {$n == 0} {
+ set state(state) body
+ if ![regexp -nocase ^text $state(type)] {
+ # Turn off conversions for non-text data
+ fconfigure $s -translation binary
+ if {[info exists state(-channel)]} {
+ fconfigure $state(-channel) -translation binary
+ }
+ }
+ if {[info exists state(-channel)] &&
+ ![info exists state(-handler)]} {
+ # Initiate a sequence of background fcopies
+ fileevent $s readable {}
+ CopyStart $s $token
+ }
+ } elseif {$n > 0} {
+ if [regexp -nocase {^content-type:(.+)$} $line x type] {
+ set state(type) [string trim $type]
+ }
+ if [regexp -nocase {^content-length:(.+)$} $line x length] {
+ set state(totalsize) [string trim $length]
+ }
+ if [regexp -nocase {^([^:]+):(.+)$} $line x key value] {
+ lappend state(meta) $key $value
+ } elseif {[regexp ^HTTP $line]} {
+ set state(http) $line
+ }
+ }
+ } else {
+ if [catch {
+ if {[info exists state(-handler)]} {
+ set n [eval $state(-handler) {$s $token}]
+ } else {
+ set block [read $s $state(-blocksize)]
+ set n [string length $block]
+ if {$n >= 0} {
+ append state(body) $block
+ }
+ }
+ if {$n >= 0} {
+ incr state(currentsize) $n
+ }
+ } err] {
+ Finish $token $err
+ } else {
+ if [info exists state(-progress)] {
+ eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
+ }
+ }
+ }
+}
+ proc http::CopyStart {s token} {
+ variable $token
+ upvar 0 $token state
+ if [catch {
+ fcopy $s $state(-channel) -size $state(-blocksize) -command \
+ [list http::CopyDone $token]
+ } err] {
+ Finish $token $err
+ }
+}
+ proc http::CopyDone {token count} {
+ variable $token
+ upvar 0 $token state
+ set s $state(sock)
+ incr state(currentsize) $count
+ if [info exists state(-progress)] {
+ eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
+ }
+ if [::eof $s] {
+ Eof $token
+ } else {
+ CopyStart $s $token
+ }
+}
+ proc http::Eof {token} {
+ variable $token
+ upvar 0 $token state
+ if {$state(state) == "header"} {
+ # Premature eof
+ set state(status) eof
+ } else {
+ set state(status) ok
+ }
+ set state(state) eof
+ Finish $token
+}
+
+# http::wait --
+#
+# See documentaion for details.
+#
+# Arguments:
+# token Connection token.
+# Results:
+# The status after the wait.
+
+proc http::wait {token} {
+ variable $token
+ upvar 0 $token state
+
+ if {![info exists state(status)] || [string length $state(status)] == 0} {
+ vwait $token\(status)
+ }
+ if {[info exists state(error)]} {
+ set errorlist $state(error)
+ unset state(error)
+ eval error $errorlist
+ }
+ return $state(status)
+}
+
+# http::formatQuery --
+#
+# See documentaion for details.
+# Call http::formatQuery with an even number of arguments, where
+# the first is a name, the second is a value, the third is another
+# name, and so on.
+#
+# Arguments:
+# args A list of name-value pairs.
+# Results:
+# TODO
+
+proc http::formatQuery {args} {
+ set result ""
+ set sep ""
+ foreach i $args {
+ append result $sep [mapReply $i]
+ if {$sep != "="} {
+ set sep =
+ } else {
+ set sep &
+ }
+ }
+ return $result
+}
+
+# do x-www-urlencoded character mapping
+# The spec says: "non-alphanumeric characters are replaced by '%HH'"
+# 1 leave alphanumerics characters alone
+# 2 Convert every other character to an array lookup
+# 3 Escape constructs that are "special" to the tcl parser
+# 4 "subst" the result, doing all the array substitutions
+
+ proc http::mapReply {string} {
+ variable formMap
+ set alphanumeric a-zA-Z0-9
+ regsub -all \[^$alphanumeric\] $string {$formMap(&)} string
+ regsub -all \n $string {\\n} string
+ regsub -all \t $string {\\t} string
+ regsub -all {[][{})\\]\)} $string {\\&} string
+ return [subst $string]
+}
+
+# Default proxy filter.
+ proc http::ProxyRequired {host} {
+ variable http
+ if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
+ if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} {
+ set http(-proxyport) 8080
+ }
+ return [list $http(-proxyhost) $http(-proxyport)]
+ } else {
+ return {}
+ }
+}
diff --git a/contrib/tcl/library/http2.0/pkgIndex.tcl b/contrib/tcl/library/http2.0/pkgIndex.tcl
new file mode 100644
index 0000000..01052f3
--- /dev/null
+++ b/contrib/tcl/library/http2.0/pkgIndex.tcl
@@ -0,0 +1,11 @@
+# Tcl package index file, version 1.0
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script. It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands. When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+package ifneeded http 2.0 [list tclPkgSetup $dir http 2.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait}}}]
diff --git a/contrib/tcl/library/init.tcl b/contrib/tcl/library/init.tcl
index 43bd37c..1985224 100644
--- a/contrib/tcl/library/init.tcl
+++ b/contrib/tcl/library/init.tcl
@@ -3,7 +3,7 @@
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
-# SCCS: @(#) init.tcl 1.79 97/06/24 17:18:54
+# SCCS: @(#) init.tcl 1.86 97/08/08 10:37:39
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -18,9 +18,11 @@ if {[info commands package] == ""} {
package require -exact Tcl 8.0
# Compute the auto path to use in this interpreter.
-
-if [catch {set auto_path $env(TCLLIBPATH)}] {
- set auto_path ""
+# (auto_path could be already set, in safe interps for instance)
+if {![info exists auto_path]} {
+ if [catch {set auto_path $env(TCLLIBPATH)}] {
+ set auto_path ""
+ }
}
if {[lsearch -exact $auto_path [info library]] < 0} {
lappend auto_path [info library]
@@ -47,6 +49,14 @@ if {[info commands exec] == ""} {
set errorCode ""
set errorInfo ""
+# Define a log command (which can be overwitten to log errors
+# differently, specially when stderr is not available)
+
+if {[info commands tclLog] == ""} {
+ proc tclLog {string} {
+ catch {puts stderr $string}
+ }
+}
# unknown --
# This procedure is called when a Tcl command is invoked that doesn't
@@ -132,14 +142,17 @@ proc unknown args {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
if {$name == "!!"} {
-# return [uplevel {history redo}]
- return -code error "!! is disabled until history is fixed in Tcl8.0"
+ set newcmd [history event]
+ } elseif {[regexp {^!(.+)$} $name dummy event]} {
+ set newcmd [history event $event]
+ } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
+ set newcmd [history event -1]
+ catch {regsub -all -- $old $newcmd $new newcmd}
}
- if [regexp {^!(.+)$} $name dummy event] {
- return [uplevel [list history redo $event]]
- }
- if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
- return [uplevel [list history substitute $old $new]]
+ if [info exists newcmd] {
+ tclLog $newcmd
+ history change $newcmd 0
+ return [uplevel $newcmd]
}
set ret [catch {set cmds [info commands $name*]} msg]
@@ -177,9 +190,11 @@ proc unknown args {
proc auto_load cmd {
global auto_index auto_oldpath auto_path env errorInfo errorCode
- if [info exists auto_index($cmd)] {
- uplevel #0 $auto_index($cmd)
- return [expr {[info commands $cmd] != ""}]
+ foreach name [list $cmd ::$cmd] {
+ if [info exists auto_index($name)] {
+ uplevel #0 $auto_index($name)
+ return [expr {[info commands $name] != ""}]
+ }
}
if ![info exists auto_path] {
return 0
@@ -455,6 +470,10 @@ proc auto_mkindex {dir args} {
proc pkg_mkIndex {dir args} {
global errorCode errorInfo
+ if {[llength $args] == 0} {
+ return -code error "wrong # args: should be\
+ \"pkg_mkIndex dir pattern ?pattern ...?\"";
+ }
append index "# Tcl package index file, version 1.0\n"
append index "# This file is generated by the \"pkg_mkIndex\" command\n"
append index "# and sourced either when an application starts up or\n"
@@ -489,6 +508,13 @@ proc pkg_mkIndex {dir args} {
if [catch {
$c eval {
proc dummy args {}
+ rename package package-orig
+ proc package {what args} {
+ switch -- $what {
+ require { return ; # ignore transitive requires }
+ default { eval package-orig {$what} $args }
+ }
+ }
package unknown dummy
set origCmds [info commands]
set dir "" ;# in case file is pkgIndex.tcl
@@ -514,11 +540,23 @@ proc pkg_mkIndex {dir args} {
source $file
set type source
}
+ foreach ns [namespace children] {
+ namespace import ${ns}::*
+ }
foreach i [info commands] {
set cmds($i) 1
}
foreach i $origCmds {
catch {unset cmds($i)}
+
+ }
+ foreach i [array names cmds] {
+ # reverse engineer which namespace a command comes from
+ set absolute [namespace origin $i]
+ if {[string compare ::$i $absolute] != 0} {
+ set cmds($absolute) 1
+ unset cmds($i)
+ }
}
foreach i [package names] {
if {([string compare [package provide $i] ""] != 0)
@@ -529,7 +567,7 @@ proc pkg_mkIndex {dir args} {
}
}
} msg] {
- puts "error while loading or sourcing $file: $msg"
+ tclLog "error while loading or sourcing $file: $msg"
}
foreach pkg [$c eval set pkgs] {
lappend files($pkg) [list $file [$c eval set type] \
@@ -623,33 +661,37 @@ proc tclPkgUnknown {name version {exact {}}} {
set save_dir $dir
}
for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
- foreach file [glob -nocomplain [file join [lindex $auto_path $i] \
- * pkgIndex.tcl]] {
- set dir [file dirname $file]
- if [catch {source $file} msg] {
- puts stderr \
- "error reading package index file $file: $msg"
+ # we can't use glob in safe interps, so enclose the following
+ # in a catch statement
+ catch {
+ foreach file [glob -nocomplain [file join [lindex $auto_path $i] \
+ * pkgIndex.tcl]] {
+ set dir [file dirname $file]
+ if [catch {source $file} msg] {
+ tclLog "error reading package index file $file: $msg"
+ }
}
- }
+ }
set dir [lindex $auto_path $i]
set file [file join $dir pkgIndex.tcl]
- if [file readable $file] {
- if [catch {source $file} msg] {
- puts stderr \
- "error reading package index file $file: $msg"
+ # safe interps usually don't have "file readable", nor stderr channel
+ if {[interp issafe] || [file readable $file]} {
+ if {[catch {source $file} msg] && ![interp issafe]} {
+ tclLog "error reading package index file $file: $msg"
}
}
# On the Macintosh we also look in the resource fork
# of shared libraries
- if {$tcl_platform(platform) == "macintosh"} {
+ # We can't use tclMacPkgSearch in safe interps because it uses glob
+ if {(![interp issafe]) && ($tcl_platform(platform) == "macintosh")} {
set dir [lindex $auto_path $i]
tclMacPkgSearch $dir
- foreach x [glob -nocomplain [file join $dir *]] {
- if [file isdirectory $x] {
- set dir $x
- tclMacPkgSearch $dir
+ foreach x [glob -nocomplain [file join $dir *]] {
+ if [file isdirectory $x] {
+ set dir $x
+ tclMacPkgSearch $dir
+ }
}
- }
}
}
if {[info exists save_dir]} {
diff --git a/contrib/tcl/library/opt0.1/optparse.tcl b/contrib/tcl/library/opt0.1/optparse.tcl
new file mode 100644
index 0000000..ee5b399
--- /dev/null
+++ b/contrib/tcl/library/opt0.1/optparse.tcl
@@ -0,0 +1,1067 @@
+# optparse.tcl --
+#
+# (Private) option parsing package
+#
+# This might be documented and exported in 8.1
+# and some function hopefully moved to the C core for
+# efficiency, if there is enough demand. (mail! ;-)
+#
+# Author: Laurent Demailly - Laurent.Demailly@sun.com - dl@mail.box.eu.org
+#
+# Credits:
+# this is a complete 'over kill' rewrite by me, from a version
+# written initially with Brent Welch, itself initially
+# based on work with Steve Uhler. Thanks them !
+#
+# SCCS: @(#) optparse.tcl 1.11 97/08/11 16:39:15
+
+package provide opt 0.1
+
+namespace eval ::tcl {
+
+ # Exported APIs
+ namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
+ OptProc OptProcArgGiven OptParse \
+ Lassign Lvarpop Lvarset Lvarincr Lfirst \
+ 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 ! ###############
+# You should really not look any further :
+# The following is private unexported undocumented unblessed... code
+# time to hit "q" ;-) !
+
+# Hmmm... ok, you really want to know ?
+
+# You've been warned... Here it is...
+
+ # 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 [Lfirst $program] >= 2
+# while
+# llength [Lfirst $singleStep] == 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 compare $key ""] == 0} {
+ # 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 {};
+
+ 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 [Lfirst $res];
+ 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;
+ }
+ } else {
+ if {$state == "flags"} {
+ set inflags 1;
+ # sub program counter + first sub program
+ set flagsprg [list [list "P" 1] $res];
+ } else {
+ lappend program $res;
+ }
+ }
+ }
+ if {$inflags} {
+ 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 [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 namespace current];
+ if { ([string match $name "::*"])
+ || ([string compare $namespace "::"]==0)} {
+ # 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 [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} {
+ Lfirst $lst;
+ }
+ # 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 {[Lfirst $item]=="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 [Lfirst $lst] 1 end] {
+ lappend res [Lget $lst $idx];
+ }
+ return $res;
+ }
+
+ # Advance to next description
+ proc OptNextDesc {descName} {
+ uplevel [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} {
+ Lfirst $item
+ }
+
+ # current state
+ proc OptCurState {descriptions} {
+ OptState [OptCurDesc $descriptions];
+ }
+
+ #######
+ # Arguments manipulation
+
+ # Returns the argument that has to be processed now
+ proc OptCurrentArg {lst} {
+ Lfirst $lst;
+ }
+ # Advance to next argument
+ proc OptNextArg {argsName} {
+ uplevel [list Lvarpop $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];
+ }
+ if {![Lempty $arguments]} {
+ return -code error [OptTooManyArgs $descriptions $arguments];
+ }
+ }
+
+ # 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")} {
+ 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 compare "--" $arg] == 0} {
+ # 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 compare "-help" [string tolower $arglist]] == 0} {
+ return -code error [OptError "Usage information:" $desc 1];
+ }
+
+ OptDoAll 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 ![regexp {^(-+)?[0-9]+$} $arg] {
+ error "not an integer"
+ }
+ return $arg;
+ }
+ float {
+ return [expr double($arg)]
+ }
+ script -
+ list {
+ # if llength fail : malformed list
+ if {[llength $arg]==0} {
+ if {[OptIsFlag $arg]} {
+ error "no values with leading -"
+ }
+ }
+ return $arg;
+ }
+ boolean {
+ if ![regexp -nocase {^(true|false|0|1)$} $arg] {
+ error "non canonic boolean"
+ }
+ # convert true/false because expr/if is broken with "!,...
+ if {$arg} {
+ return 1
+ } else {
+ return 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;
+ foreach item [lrange $desc 1 end] {
+ set flag [OptName $item]
+ # lets try to match case insensitively
+ if {[string match [string tolower $arg*] [string tolower $flag]]} {
+ 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} {
+ string compare [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 compare $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 compare $type "string"] == 0} {
+ if {$isflag} {
+ set type boolflag
+ set def false
+ } else {
+ set type any
+ set def ""
+ }
+ set help $arg1
+ } else {
+ set help ""
+ set def $arg1
+ }
+ return [OptNewInst $state $varname $type $def $help];
+ }
+ 3 {
+ # varname type value
+ # varname value comment
+
+ if [regexp {^-(.+)$} $arg1 x type] {
+ # flags/optValue as they are optional, need a "value",
+ # on the contrary, for a variable (non optional),
+ # default value is pointless, 'cept for choices :
+ if {$isflag || $isopt || ($type == "choice")} {
+ return [OptNewInst $state $varname $type $arg2 ""];
+ } else {
+ return [OptNewInst $state $varname $type "" $arg2];
+ }
+ } else {
+ return [OptNewInst $state $varname\
+ [OptGuessType $arg1] $arg1 $arg2]
+ }
+ }
+ 4 {
+ if [regexp {^-(.+)$} $arg1 x type] {
+ return [OptNewInst $state $varname $type $arg2 $arg3];
+ } else {
+ return -code error [OptOptUsage $item];
+ }
+ }
+ default {
+ return -code error [OptOptUsage $item];
+ }
+ }
+ }
+
+ # Auto magic lasy type determination
+ proc OptGuessType {arg} {
+ if [regexp -nocase {^(true|false)$} $arg] {
+ return boolean
+ }
+ if [regexp {^(-+)?[0-9]+$} $arg] {
+ return int
+ }
+ if ![catch {expr double($arg)}] {
+ return float
+ }
+ return string
+ }
+
+ # Error messages front ends
+
+ proc OptAmbigous {desc arg} {
+ OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc]
+ }
+ proc OptFlagUsage {desc arg} {
+ OptError "bad flag \"$arg\", must be one of" $desc;
+ }
+ proc OptTooManyArgs {desc arguments} {
+ OptError "too many arguments (unexpected argument(s): $arguments),\
+ usage:"\
+ $desc 1
+ }
+ proc OptParamType {item} {
+ if {[OptIsFlag $item]} {
+ return "flag";
+ } else {
+ return "parameter";
+ }
+ }
+ proc OptBadValue {item arg {err {}}} {
+# puts "bad val err = \"$err\"";
+ OptError "bad value \"$arg\" for [OptParamType $item]"\
+ [list $item]
+ }
+ proc OptMissingValue {descriptions} {
+# set item [OptCurDescFinal $descriptions];
+ set item [OptCurDesc $descriptions];
+ OptError "no value given for [OptParamType $item] \"[OptName $item]\"\
+ (use -help for full usage) :"\
+ [list $item]
+ }
+
+proc ::tcl::OptKeyError {prefix descKey} {
+ OptError $prefix [OptKeyGetDesc $descKey];
+}
+
+ # 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 [Lfirst $indexLst]] [Lrest $indexLst];
+}
+# 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 [Lfirst $indexLst];
+ 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 [Lrest $indexLst] $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 [Lfirst $indexLst];
+ set targetList [lindex $list $idx];
+ # reduce refcount on targetList
+ Lvarset1nc list $idx {};
+ # recursively replace in targetList
+ Lvarincr targetList [Lrest $indexLst] $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;
+}
+# Returns the first element of a list
+proc ::tcl::Lfirst {list} {
+ lindex $list 0
+}
+# Returns the rest of the list minus first element
+proc ::tcl::Lrest {list} {
+ lrange $list 1 end
+}
+# Removes the first element of a list
+proc ::tcl::Lvarpop {listName} {
+ upvar $listName list;
+ set list [lrange $list 1 end];
+}
+# Same but returns the removed element
+proc ::tcl::Lvarpop2 {listName} {
+ upvar $listName list;
+ set el [Lfirst $list];
+ 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 [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/contrib/tcl/library/opt0.1/pkgIndex.tcl b/contrib/tcl/library/opt0.1/pkgIndex.tcl
new file mode 100644
index 0000000..4e660cd
--- /dev/null
+++ b/contrib/tcl/library/opt0.1/pkgIndex.tcl
@@ -0,0 +1,7 @@
+# Tcl package index file, version 1.0
+# This file is NOT generated by the "pkg_mkIndex" command
+# because if someone just did "package require opt", let's just load
+# the package now, so they can readily use it
+# and even "namespace import tcl::*" ...
+# (tclPkgSetup just makes things slow and do not work so well with namespaces)
+package ifneeded opt 0.1 [list source [file join $dir optparse.tcl]]
diff --git a/contrib/tcl/library/safe.tcl b/contrib/tcl/library/safe.tcl
new file mode 100644
index 0000000..e923cc6
--- /dev/null
+++ b/contrib/tcl/library/safe.tcl
@@ -0,0 +1,710 @@
+# 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.
+#
+# SCCS: @(#) safe.tcl 1.21 97/08/13 15:37:22
+
+#
+# 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.1;
+
+# Create the safe namespace
+namespace eval ::safe {
+
+ # Exported API:
+ namespace export interp \
+ interpAddToAccessPath interpFindInAccessPath \
+ setLogCmd ;
+
+# Proto/dummy declarations for auto_mkIndex
+proc ::safe::interpCreate {} {}
+proc ::safe::interpInit {} {}
+proc ::safe::interpConfigure {} {}
+proc ::safe::interpDelete {} {}
+
+
+ # Interface/entry point function and front end for "Create"
+ ::tcl::OptProc interpCreate {
+ {?slave? -name {} "name of the slave (optional)"}
+ {-accessPath -list {} "access path for the slave"}
+ {-noStatics "prevent loading of statically linked pkgs"}
+ {-nestedLoadOk "allow nested loading"}
+ {-deleteHook -script {} "delete hook"}
+ } {
+ InterpCreate $slave $accessPath \
+ [expr {!$noStatics}] $nestedLoadOk $deleteHook;
+ }
+
+ # Interface/entry point function and front end for "Init"
+ ::tcl::OptProc interpInit {
+ {slave -name {} "name of the slave"}
+ {-accessPath -list {} "access path for the slave"}
+ {-noStatics "prevent loading of statically linked pkgs"}
+ {-nestedLoadOk "allow nested loading"}
+ {-deleteHook -script {} "delete hook"}
+ } {
+ InterpInit $slave $accessPath \
+ [expr {!$noStatics}] $nestedLoadOk $deleteHook;
+ }
+
+ # Interface/entry point function and front end for "Configure"
+ ::tcl::OptProc interpConfigure {
+ {slave -name {} "name of the slave"}
+ {-accessPath -list {} "access path for the slave"}
+ {-noStatics "prevent loading of statically linked pkgs"}
+ {-nestedLoadOk "allow nested loading"}
+ {-deleteHook -script {} "delete hook"}
+ } {
+ # Check that at least one flag was given:
+ if {[string match "*-*" $Args]} {
+ # reconfigure everything (because otherwise you can't
+ # change -noStatics for instance)
+ InterpConfigure $slave $accessPath \
+ [expr {!$noStatics}] $nestedLoadOk $deleteHook;
+ # auto_reset the slave (to completly synch the new access_path)
+ if {[catch {::interp eval $slave {auto_reset}} msg]} {
+ Log $slave "auto_reset failed: $msg";
+ }
+ } else {
+ # none was given, lets return current values instead
+ set res {}
+ lappend res [list -accessPath [Set [PathListName $slave]]]
+ if {![Set [StaticsOkName $slave]]} {
+ lappend res "-noStatics"
+ }
+ if {[Set [NestedOkName $slave]]} {
+ lappend res "-nestedLoadOk"
+ }
+ lappend res [list -deleteHook [Set [DeleteHookName $slave]]]
+ join $res
+ }
+ }
+
+
+ #
+ # 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 {[string compare "" $slave]} {
+ ::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;
+ }
+
+
+ #
+ # InterpConfigure (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::InterpConfigure {slave access_path staticsok\
+ nestedok deletehook} {
+
+ # determine and store the access path if empty
+ if {[string match "" $access_path]} {
+ set access_path [uplevel #0 set auto_path];
+ # Make sure that tcl_library is in auto_path
+ # and at the first position (needed by setAccessPath)
+ set where [lsearch -exact $access_path [info library]];
+ if {$where == -1} {
+ # not found, add it.
+ set access_path [concat [list [info library]] $access_path];
+ Log $slave "tcl_library was not in auto_path,\
+ added it to slave's access_path" NOTICE;
+ } elseif {$where != 0} {
+ # not first, move it first
+ set access_path [concat [list [info library]]\
+ [lreplace $access_path $where $where]];
+ Log $slave "tcl_libray was not in first in auto_path,\
+ moved it to front of slave's access_path" NOTICE;
+
+ }
+
+ # Add 1st level sub dirs (will searched by auto loading from tcl
+ # code in the slave using glob and thus fail, so we add them
+ # here so by default it works the same).
+ set access_path [AddSubDirs $access_path];
+ }
+
+ Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\
+ nestedok=$nestedok deletehook=($deletehook)" NOTICE;
+
+ # clear old autopath if it existed
+ set nname [PathNumberName $slave];
+ if {[Exists $nname]} {
+ set n [Set $nname];
+ for {set i 0} {$i<$n} {incr i} {
+ Unset [PathToken $i $slave];
+ }
+ }
+
+ # build new one
+ set slave_auto_path {}
+ set i 0;
+ foreach dir $access_path {
+ Set [PathToken $i $slave] $dir;
+ lappend slave_auto_path "\$[PathToken $i]";
+ incr i;
+ }
+ Set $nname $i;
+ Set [PathListName $slave] $access_path;
+ Set [VirtualPathListName $slave] $slave_auto_path;
+
+ Set [StaticsOkName $slave] $staticsok
+ Set [NestedOkName $slave] $nestedok
+ Set [DeleteHookName $slave] $deletehook
+
+ SyncAccessPath $slave;
+ }
+
+ #
+ #
+ # FindInAccessPath:
+ # Search for a real directory and returns its virtual Id
+ # (including the "$")
+proc ::safe::interpFindInAccessPath {slave path} {
+ set access_path [GetAccessPath $slave];
+ set where [lsearch -exact $access_path $path];
+ if {$where == -1} {
+ return -code error "$path not found in access path $access_path";
+ }
+ return "\$[PathToken $where]";
+ }
+
+ #
+ # addToAccessPath:
+ # add (if needed) a real directory to access path
+ # and return its virtual token (including the "$").
+proc ::safe::interpAddToAccessPath {slave path} {
+ # first check if the directory is already in there
+ if {![catch {interpFindInAccessPath $slave $path} res]} {
+ return $res;
+ }
+ # new one, add it:
+ set nname [PathNumberName $slave];
+ set n [Set $nname];
+ Set [PathToken $n $slave] $path;
+
+ set token "\$[PathToken $n]";
+
+ Lappend [VirtualPathListName $slave] $token;
+ Lappend [PathListName $slave] $path;
+ Set $nname [expr $n+1];
+
+ SyncAccessPath $slave;
+
+ return $token;
+ }
+
+ # This procedure applies the initializations to an already existing
+ # interpreter. It is useful when you want to install the safe base
+ # aliases into a preexisting safe interpreter.
+ proc ::safe::InterpInit {
+ slave
+ access_path
+ staticsok
+ nestedok
+ deletehook
+ } {
+
+ # Configure will generate an access_path when access_path is
+ # empty.
+ InterpConfigure $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 have access to a subset of the 'file'
+ # command functionality.
+
+ AliasSubset $slave file file dir.* join root.* ext.* tail \
+ path.* split
+
+ # This alias interposes on the 'exit' command and cleanly terminates
+ # the slave.
+
+ ::interp alias $slave exit {} [namespace current]::interpDelete $slave
+
+ # The allowed slave variables already have been set
+ # by Tcl_MakeSafe(3)
+
+
+ # Source init.tcl into the slave, to get auto_load and other
+ # procedures defined:
+
+ # We don't try to use the -rsrc on the mac because it would get
+ # confusing if you would want to customize init.tcl
+ # for a given set of safe slaves, on all the platforms
+ # you just need to give a specific access_path and
+ # the mac should be no exception. As there is no
+ # obvious full "safe ressources" design nor implementation
+ # for the mac, safe interps there will just don't
+ # have that ability. (A specific app can still reenable
+ # that using custom aliases if they want to).
+ # It would also make the security analysis and the Safe Tcl security
+ # model platform dependant and thus more error prone.
+
+ if {[catch {::interp eval $slave\
+ {source [file join $tcl_library init.tcl]}}\
+ msg]} {
+ Log $slave "can't source init.tcl ($msg)";
+ error "can't source init.tcl into slave $slave ($msg)"
+ }
+
+ return $slave
+ }
+
+
+ # Add (only if needed, avoid duplicates) 1 level of
+ # sub directories to an existing path list.
+ # Also removes non directories from the returned list.
+ proc AddSubDirs {pathList} {
+ set res {}
+ foreach dir $pathList {
+ if {[file isdirectory $dir]} {
+ # check that we don't have it yet as a children
+ # of a previous dir
+ if {[lsearch -exact $res $dir]<0} {
+ lappend res $dir;
+ }
+ foreach sub [glob -nocomplain -- [file join $dir *]] {
+ if { ([file isdirectory $sub])
+ && ([lsearch -exact $res $sub]<0) } {
+ # new sub dir, add it !
+ lappend res $sub;
+ }
+ }
+ }
+ }
+ return $res;
+ }
+
+ # This procedure deletes a safe slave managed by Safe Tcl and
+ # cleans up associated state:
+
+ proc ::safe::interpDelete {slave} {
+
+ Log $slave "About to delete" NOTICE;
+
+ # If the slave has a cleanup hook registered, call it.
+ # check the existance because we might be called to delete an interp
+ # which has not been registered with us at all
+ set hookname [DeleteHookName $slave];
+ if {[Exists $hookname]} {
+ set hook [Set $hookname];
+ if {![::tcl::Lempty $hook]} {
+ # remove the hook now, otherwise if the hook
+ # calls us somehow, we'll loop
+ Unset $hookname;
+ if {[catch {eval $hook $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";
+ }
+
+ # 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 {[string compare "" $slave]} {
+ return "[InterpStateName $slave](access_path,$n)";
+ } else {
+ # We need to have a ":" in the token string so
+ # [file join] on the mac won't turn it into a relative
+ # path.
+ return "p(:$n:)";
+ }
+ }
+ # returns the variable name of the complete path list
+ proc PathListName {slave} {
+ return "[InterpStateName $slave](access_path)";
+ }
+ # returns the variable name of the complete path list
+ proc VirtualPathListName {slave} {
+ return "[InterpStateName $slave](access_path_slave)";
+ }
+ # returns the variable name of the number of items
+ proc PathNumberName {slave} {
+ return "[InterpStateName $slave](access_path,n)";
+ }
+ # returns the staticsok flag var name
+ proc StaticsOkName {slave} {
+ return "[InterpStateName $slave](staticsok)";
+ }
+ # returns the nestedok flag var name
+ proc NestedOkName {slave} {
+ return "[InterpStateName $slave](nestedok)";
+ }
+ # Run some code at the namespace toplevel
+ proc Toplevel {args} {
+ namespace eval [namespace current] $args;
+ }
+ # set/get values
+ proc Set {args} {
+ eval Toplevel set $args;
+ }
+ # lappend on toplevel vars
+ proc Lappend {args} {
+ eval Toplevel lappend $args;
+ }
+ # unset a var/token (currently just an global level eval)
+ proc Unset {args} {
+ eval Toplevel unset $args;
+ }
+ # test existance
+ proc Exists {varname} {
+ Toplevel info exists $varname;
+ }
+ # short cut for access path getting
+ proc GetAccessPath {slave} {
+ Set [PathListName $slave]
+ }
+ # short cut for statics ok flag getting
+ proc StaticsOk {slave} {
+ Set [StaticsOkName $slave]
+ }
+ # short cut for getting the multiples interps sub loading ok flag
+ proc NestedOk {slave} {
+ Set [NestedOkName $slave]
+ }
+ # interp deletion storing hook name
+ proc DeleteHookName {slave} {
+ return [InterpStateName $slave](cleanupHook)
+ }
+
+ #
+ # translate virtual path into real path
+ #
+ proc TranslatePath {slave path} {
+ # somehow strip the namespaces 'functionality' out (the danger
+ # is that we would strip valid macintosh "../" queries... :
+ if {[regexp {(::)|(\.\.)} $path]} {
+ error "invalid characters in path $path";
+ }
+ set n [expr [Set [PathNumberName $slave]]-1];
+ for {} {$n>=0} {incr n -1} {
+ # fill the token virtual names with their real value
+ set [PathToken $n] [Set [PathToken $n $slave]];
+ }
+ # replaces the token by their value
+ subst -nobackslashes -nocommands $path;
+ }
+
+
+ # Log eventually log an error
+ # to enable error logging, set Log to {puts stderr} for instance
+ proc Log {slave msg {type ERROR}} {
+ variable Log;
+ if {[info exists Log] && [llength $Log]} {
+ eval $Log [list "$type for slave $slave : $msg"];
+ }
+ }
+
+
+ # file name control (limit access to files/ressources that should be
+ # a valid tcl source file)
+ proc CheckFileName {slave file} {
+ # limit what can be sourced to .tcl
+ # and forbid files with more than 1 dot and
+ # longer than 14 chars
+ set ftail [file tail $file];
+ if {[string length $ftail]>14} {
+ error "$ftail: filename too long";
+ }
+ if {[regexp {\..*\.} $ftail]} {
+ error "$ftail: more than one dot is forbidden";
+ }
+ if {[string compare $ftail "tclIndex"] && \
+ [string compare [string tolower [file extension $ftail]]\
+ ".tcl"]} {
+ error "$ftail: must be a *.tcl or tclIndex";
+ }
+
+ if {![file exists $file]} {
+ # don't tell the file path
+ error "no such file or directory";
+ }
+
+ if {![file readable $file]} {
+ # don't tell the file path
+ error "not readable";
+ }
+
+ }
+
+
+ # AliasSource is the target of the "source" alias in safe interpreters.
+
+ proc AliasSource {slave args} {
+
+ set argc [llength $args];
+ # Allow only "source filename"
+ # (and not mac specific -rsrc for instance - see comment in ::init
+ # for current rationale)
+ if {$argc != 1} {
+ set msg "wrong # args: should be \"source fileName\""
+ Log $slave "$msg ($args)";
+ return -code error $msg;
+ }
+ set file [lindex $args 0]
+
+ # get the real path from the virtual one.
+ if {[catch {set file [TranslatePath $slave $file]} msg]} {
+ Log $slave $msg;
+ return -code error "permission denied"
+ }
+
+ # check that the path is in the access path of that slave
+ if {[catch {FileInAccessPath $slave $file} msg]} {
+ Log $slave $msg;
+ return -code error "permission denied"
+ }
+
+ # do the checks on the filename :
+ if {[catch {CheckFileName $slave $file} msg]} {
+ Log $slave "$file:$msg";
+ return -code error $msg;
+ }
+
+ # passed all the tests , lets source it:
+ if {[catch {::interp invokehidden $slave source $file} msg]} {
+ Log $slave $msg;
+ return -code error "script error";
+ }
+ return $msg
+ }
+
+ # AliasLoad is the target of the "load" alias in safe interpreters.
+
+ proc AliasLoad {slave file args} {
+
+ set argc [llength $args];
+ if {$argc > 2} {
+ set msg "load error: too many arguments";
+ Log $slave "$msg ($argc) {$file $args}";
+ return -code error $msg;
+ }
+
+ # package name (can be empty if file is not).
+ set package [lindex $args 0];
+
+ # Determine where to load. load use a relative interp path
+ # and {} means self, so we can directly and safely use passed arg.
+ set target [lindex $args 1];
+ if {[string length $target]} {
+ # we will try to load into a sub sub interp
+ # check that we want to authorize that.
+ if {![NestedOk $slave]} {
+ Log $slave "loading to a sub interp (nestedok)\
+ disabled (trying to load $package to $target)";
+ return -code error "permission denied (nested load)";
+ }
+
+ }
+
+ # Determine what kind of load is requested
+ if {[string length $file] == 0} {
+ # static package loading
+ if {[string length $package] == 0} {
+ set msg "load error: empty filename and no package name";
+ Log $slave $msg;
+ return -code error $msg;
+ }
+ if {![StaticsOk $slave]} {
+ Log $slave "static packages loading disabled\
+ (trying to load $package to $target)";
+ return -code error "permission denied (static package)";
+ }
+ } else {
+ # file loading
+
+ # get the real path from the virtual one.
+ if {[catch {set file [TranslatePath $slave $file]} msg]} {
+ Log $slave $msg;
+ return -code error "permission denied"
+ }
+
+ # check the translated path
+ if {[catch {FileInAccessPath $slave $file} msg]} {
+ Log $slave $msg;
+ return -code error "permission denied (path)"
+ }
+ }
+
+ if {[catch {::interp invokehidden\
+ $slave load $file $package $target} msg]} {
+ Log $slave $msg;
+ return -code error $msg
+ }
+
+ return $msg
+ }
+
+ # FileInAccessPath raises an error if the file is not found in
+ # the list of directories contained in the (master side recorded) slave's
+ # access path.
+
+ # the security here relies on "file dirname" answering the proper
+ # result.... needs checking ?
+ proc FileInAccessPath {slave file} {
+
+ set access_path [GetAccessPath $slave];
+
+ if {[file isdirectory $file]} {
+ error "\"$file\": is a directory"
+ }
+ set parent [file dirname $file]
+ if {[lsearch -exact $access_path $parent] == -1} {
+ error "\"$file\": not in access_path";
+ }
+ }
+
+ # This procedure enables access from a safe interpreter to only a subset of
+ # the subcommands of a command:
+
+ proc Subset {slave command okpat args} {
+ set subcommand [lindex $args 0]
+ if {[regexp $okpat $subcommand]} {
+ return [eval {$command $subcommand} [lrange $args 1 end]]
+ }
+ set msg "not allowed to invoke subcommand $subcommand of $command";
+ Log $slave $msg;
+ error $msg;
+ }
+
+ # This procedure installs an alias in a slave that invokes "safesubset"
+ # in the master to execute allowed subcommands. It precomputes the pattern
+ # of allowed subcommands; you can use wildcards in the pattern if you wish
+ # to allow subcommand abbreviation.
+ #
+ # Syntax is: AliasSubset slave alias target subcommand1 subcommand2...
+
+ proc AliasSubset {slave alias target args} {
+ set pat ^(; set sep ""
+ foreach sub $args {
+ append pat $sep$sub
+ set sep |
+ }
+ append pat )\$
+ ::interp alias $slave $alias {}\
+ [namespace current]::Subset $slave $target $pat
+ }
+
+}
diff --git a/contrib/tcl/library/tclIndex b/contrib/tcl/library/tclIndex
index a0acc86..7ef9563 100644
--- a/contrib/tcl/library/tclIndex
+++ b/contrib/tcl/library/tclIndex
@@ -6,28 +6,6 @@
# element name is the name of a command and the value is
# a script that loads the command.
-set auto_index(parray) [list source [file join $dir parray.tcl]]
-set auto_index(tclLdAout) [list source [file join $dir ldAout.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_safeCreateInterp) [list source [file join $dir safeinit.tcl]]
-set auto_index(tcl_safeInitInterp) [list source [file join $dir safeinit.tcl]]
-set auto_index(tcl_safeDeleteInterp) [list source [file join $dir safeinit.tcl]]
-set auto_index(tclSafeComputePolicyPath) [list source [file join $dir safeinit.tcl]]
-set auto_index(tclSafeAliasSource) [list source [file join $dir safeinit.tcl]]
-set auto_index(tclSafeAliasLoad) [list source [file join $dir safeinit.tcl]]
-set auto_index(tclFileInPath) [list source [file join $dir safeinit.tcl]]
-set auto_index(tclSafeCheckAutoPath) [list source [file join $dir safeinit.tcl]]
-set auto_index(tclSafeAliasPkgUnknown) [list source [file join $dir safeinit.tcl]]
-set auto_index(tclSafeLoadPkg) [list source [file join $dir safeinit.tcl]]
-set auto_index(tclSafeLoadPkgInternal) [list source [file join $dir safeinit.tcl]]
-set auto_index(tclSafeResearchPolicyPath) [list source [file join $dir safeinit.tcl]]
-set auto_index(tclSafeLoadPolicy) [list source [file join $dir safeinit.tcl]]
-set auto_index(tclSafeSubset) [list source [file join $dir safeinit.tcl]]
-set auto_index(tclAliasSubset) [list source [file join $dir safeinit.tcl]]
set auto_index(unknown) [list source [file join $dir init.tcl]]
set auto_index(auto_load) [list source [file join $dir init.tcl]]
set auto_index(auto_execok) [list source [file join $dir init.tcl]]
@@ -38,3 +16,18 @@ set auto_index(pkg_mkIndex) [list source [file join $dir init.tcl]]
set auto_index(tclPkgSetup) [list source [file join $dir init.tcl]]
set auto_index(tclMacPkgSearch) [list source [file join $dir init.tcl]]
set auto_index(tclPkgUnknown) [list source [file join $dir init.tcl]]
+set auto_index(parray) [list source [file join $dir parray.tcl]]
+set auto_index(tclLdAout) [list source [file join $dir ldAout.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(::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::interpConfigure) [list source [file join $dir safe.tcl]]
+set auto_index(::safe::interpDelete) [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::setLogCmd) [list source [file join $dir safe.tcl]]
+set auto_index(history) [list source [file join $dir history.tcl]]
diff --git a/contrib/tcl/tests/all b/contrib/tcl/tests/all
index b50794c..4023e55 100644
--- a/contrib/tcl/tests/all
+++ b/contrib/tcl/tests/all
@@ -2,9 +2,15 @@
# tests. Execute it by invoking "source all" when running tclTest
# in this directory.
#
-# SCCS: @(#) all 1.7 96/02/16 08:55:38
+# SCCS: @(#) all 1.8 97/08/01 11:07:14
-foreach i [lsort [glob *.test]] {
+if {$tcl_platform(os) == "Win32s"} {
+ set files [glob *.tes]
+} else {
+ set files [glob *.test]
+}
+
+foreach i [lsort $files] {
if [string match l.*.test $i] {
# This is an SCCS lock file; ignore it.
continue
diff --git a/contrib/tcl/tests/basic.test b/contrib/tcl/tests/basic.test
index d2f3701..a0b6ea0 100644
--- a/contrib/tcl/tests/basic.test
+++ b/contrib/tcl/tests/basic.test
@@ -14,7 +14,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) basic.test 1.6 97/06/20 14:51:18
+# SCCS: @(#) basic.test 1.18 97/08/07 10:36:59
#
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -82,6 +82,8 @@ test basic-3.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden c
[catch {localP} msg] $msg
} {27 27 {} 1 {invalid command name "p"} {} 1 {invalid command name "localP"}}
+# NB: More tests about hide/expose are found in interp.test
+
test basic-4.1 {Tcl_HideCommand, names of hidden cmds can't have namespace qualifiers} {
catch {interp delete test_interp}
interp create test_interp
@@ -92,9 +94,11 @@ test basic-4.1 {Tcl_HideCommand, names of hidden cmds can't have namespace quali
}
}
}
- list [catch {test_interp hide test_ns_basic::p} msg] $msg \
+ list [catch {test_interp hide test_ns_basic::p x} msg] $msg \
+ [catch {test_interp hide x test_ns_basic::p} msg1] $msg1 \
[interp delete test_interp]
-} {1 {hidden command names can't have namespace qualifiers} {}}
+} {1 {can only hide global namespace commands (use rename then hide)} 1 {cannot use namespace qualifiers as hidden commandtoken (rename)} {}}
+
test basic-4.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} {
catch {namespace delete test_ns_basic}
catch {rename cmd ""}
@@ -120,7 +124,7 @@ test basic-4.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace
[namespace delete test_ns_basic]
} {:: {} 1 {invalid command name "cmd"} {} :: {}}
-test basic-5.1 {Tcl_ExposeCommand, an exposed cmd goes back to its containing namespace unless cmd name has namespace qualifiers} {
+test basic-5.1 {Tcl_ExposeCommand, a command stays in the global namespace and can not go to another namespace} {
catch {namespace delete test_ns_basic}
catch {rename cmd ""}
proc cmd {} { ;# note that this is global
@@ -130,19 +134,24 @@ test basic-5.1 {Tcl_ExposeCommand, an exposed cmd goes back to its containing na
proc hideCmd {} {
interp hide {} cmd
}
- proc exposeCmd {} {
+ proc exposeCmdFailing {} {
interp expose {} cmd ::test_ns_basic::newCmd
}
+ proc exposeCmdWorkAround {} {
+ interp expose {} cmd;
+ rename cmd ::test_ns_basic::newCmd;
+ }
proc callCmd {} {
cmd
}
}
list [test_ns_basic::callCmd] \
[test_ns_basic::hideCmd] \
- [test_ns_basic::exposeCmd] \
+ [catch {test_ns_basic::exposeCmdFailing} msg] $msg \
+ [test_ns_basic::exposeCmdWorkAround] \
[test_ns_basic::newCmd] \
[namespace delete test_ns_basic]
-} {:: {} {} :: {}}
+} {:: {} 1 {can not expose to a namespace (use expose to toplevel, then rename)} {} ::test_ns_basic {}}
test basic-5.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} {
catch {rename p ""}
catch {rename cmd ""}
@@ -248,7 +257,7 @@ test basic-7.6 {TclRenameCommand, check for command shadowing by newly renamed c
list [test_ns_basic::callP] \
[rename q test_ns_basic::p] \
[test_ns_basic::callP]
-} {{p in ::} {} {q in ::}}
+} {{p in ::} {} {q in ::test_ns_basic}}
test basic-8.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {
catch {eval namespace delete [namespace children :: test_ns_*]}
@@ -271,7 +280,7 @@ test basic-8.2 {Tcl_GetCommandInfo, names for commands created outside namespace
[testcmdtoken name $x]
} {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}}
-test namespace-9.1 {Tcl_GetCommandFullName} {
+test basic-9.1 {Tcl_GetCommandFullName} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_basic1 {
namespace export cmd*
@@ -294,7 +303,7 @@ test namespace-9.1 {Tcl_GetCommandFullName} {
}
} {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2}
-test basic-10.1 {Tcl_DeleteCommand2, invalidate all compiled code if cmd has compile proc} {
+test basic-10.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} {
catch {interp delete test_interp}
catch {unset x}
interp create test_interp
@@ -314,7 +323,7 @@ test basic-10.1 {Tcl_DeleteCommand2, invalidate all compiled code if cmd has com
[interp eval test_interp {useSet}] \
[interp delete test_interp]
} {123 {set called with a 123} {}}
-test basic-10.2 {Tcl_DeleteCommand2, deleting commands changes command epoch} {
+test basic-10.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
proc p {} {
@@ -332,7 +341,7 @@ test basic-10.2 {Tcl_DeleteCommand2, deleting commands changes command epoch} {
[rename test_ns_basic::p ""] \
[test_ns_basic::callP]
} {{namespace p} {} {global p}}
-test basic-10.3 {Tcl_DeleteCommand2, delete imported cmds that refer to a deleted cmd} {
+test basic-10.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to a deleted cmd} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
namespace eval test_ns_basic {
@@ -371,6 +380,10 @@ test basic-11.1 {TclObjInvoke, lookup of "unknown" command} {
[interp delete test_interp]
} {newAlias 0 {global unknown} {}}
+test basic-12.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
+ testcmdtrace {set stuff [info tclversion]}
+} {{info tclversion} {info tclversion} {set stuff [info tclversion]} {set stuff 8.0}}
+
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {namespace delete george}
catch {interp delete test_interp}
@@ -379,3 +392,5 @@ catch {rename q ""}
catch {rename cmd ""}
catch {rename value:at: ""}
catch {unset x}
+set x 0
+unset x
diff --git a/contrib/tcl/tests/binary.test b/contrib/tcl/tests/binary.test
index 13e1f8a..f64b2bb 100644
--- a/contrib/tcl/tests/binary.test
+++ b/contrib/tcl/tests/binary.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) binary.test 1.6 97/05/13 15:56:39
+# SCCS: @(#) binary.test 1.10 97/08/06 08:56:11
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -22,7 +22,7 @@ test binary-1.2 {Tcl_BinaryObjCmd: bad args} {
test binary-1.3 {Tcl_BinaryObjCmd: format error} {
list [catch {binary f} msg] $msg
-} {1 {wrong # args: should be "binary f formatString ?arg arg ...?"}}
+} {1 {wrong # args: should be "binary format formatString ?arg arg ...?"}}
test binary-1.4 {Tcl_BinaryObjCmd: format} {
binary format ""
} {}
@@ -439,10 +439,10 @@ test binary-13.11 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
test binary-13.12 {Tcl_BinaryObjCmd: float overflow} {nonPortable macOrUnix} {
binary format f -3.402825e+38
-} \x00\x80\x00\x00
+} \xff\x7f\xff\xff
test binary-13.13 {Tcl_BinaryObjCmd: float overflow} {nonPortable pcOnly} {
binary format f -3.402825e+38
-} \x00\x00\x80\x00
+} \xff\xff\x7f\xff
test binary-13.14 {Tcl_BinaryObjCmd: format} {
list [catch {binary format f2 {1.6}} msg] $msg
} {1 {number of elements in list does not match count}}
@@ -560,7 +560,7 @@ test binary-18.1 {Tcl_BinaryObjCmd: format} {
test binary-19.1 {Tcl_BinaryObjCmd: errors} {
list [catch {binary s} msg] $msg
-} {1 {wrong # args: should be "binary s value formatString ?varName varName ...?"}}
+} {1 {wrong # args: should be "binary scan value formatString ?varName varName ...?"}}
test binary-19.2 {Tcl_BinaryObjCmd: errors} {
list [catch {binary scan foo} msg] $msg
} {1 {wrong # args: should be "binary scan value formatString ?varName varName ...?"}}
@@ -1053,27 +1053,27 @@ test binary-31.1 {Tcl_BinaryObjCmd: scan} {
test binary-31.2 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f* arg1] $arg1
-} {1 {1.6000000238418579 3.4000000953674316}}
+} {1 {1.60000002384 3.40000009537}}
test binary-31.3 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1}
list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f* arg1] $arg1
-} {1 {1.6000000238418579 3.4000000953674316}}
+} {1 {1.60000002384 3.40000009537}}
test binary-31.4 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f arg1] $arg1
-} {1 1.6000000238418579}
+} {1 1.60000002384}
test binary-31.5 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1}
list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f arg1] $arg1
-} {1 1.6000000238418579}
+} {1 1.60000002384}
test binary-31.6 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xcc\xcc\xcd f1 arg1] $arg1
-} {1 1.6000000238418579}
+} {1 1.60000002384}
test binary-31.7 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1}
list [binary scan \xcd\xcc\xcc\x3f f1 arg1] $arg1
-} {1 1.6000000238418579}
+} {1 1.60000002384}
test binary-31.8 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xcc\xcc\xcd f0 arg1] $arg1
@@ -1085,11 +1085,11 @@ test binary-31.9 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
test binary-31.10 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f2 arg1] $arg1
-} {1 {1.6000000238418579 3.4000000953674316}}
+} {1 {1.60000002384 3.40000009537}}
test binary-31.11 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1}
list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f2 arg1] $arg1
-} {1 {1.6000000238418579 3.4000000953674316}}
+} {1 {1.60000002384 3.40000009537}}
test binary-31.12 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 foo
@@ -1105,13 +1105,13 @@ test binary-31.14 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
set arg1 foo
set arg2 bar
list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 f2c* arg1 arg2] $arg1 $arg2
-} {2 {1.6000000238418579 3.4000000953674316} 5}
+} {2 {1.60000002384 3.40000009537} 5}
test binary-31.15 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1 arg2}
set arg1 foo
set arg2 bar
list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 f2c* arg1 arg2] $arg1 $arg2
-} {2 {1.6000000238418579 3.4000000953674316} 5}
+} {2 {1.60000002384 3.40000009537} 5}
test binary-32.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc d} msg] $msg
@@ -1119,27 +1119,27 @@ test binary-32.1 {Tcl_BinaryObjCmd: scan} {
test binary-32.2 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d* arg1] $arg1
-} {1 {1.6000000000000001 3.3999999999999999}}
+} {1 {1.6 3.4}}
test binary-32.3 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1}
list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d* arg1] $arg1
-} {1 {1.6000000000000001 3.3999999999999999}}
+} {1 {1.6 3.4}}
test binary-32.4 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d arg1] $arg1
-} {1 1.6000000000000001}
+} {1 1.6}
test binary-32.5 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1}
list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d arg1] $arg1
-} {1 1.6000000000000001}
+} {1 1.6}
test binary-32.6 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d1 arg1] $arg1
-} {1 1.6000000000000001}
+} {1 1.6}
test binary-32.7 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1}
list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f d1 arg1] $arg1
-} {1 1.6000000000000001}
+} {1 1.6}
test binary-32.8 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d0 arg1] $arg1
@@ -1151,11 +1151,11 @@ test binary-32.9 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
test binary-32.10 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d2 arg1] $arg1
-} {1 {1.6000000000000001 3.3999999999999999}}
+} {1 {1.6 3.4}}
test binary-32.11 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1}
list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d2 arg1] $arg1
-} {1 {1.6000000000000001 3.3999999999999999}}
+} {1 {1.6 3.4}}
test binary-32.12 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 foo
@@ -1171,13 +1171,13 @@ test binary-32.14 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
set arg1 foo
set arg2 bar
list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33\x05 d2c* arg1 arg2] $arg1 $arg2
-} {2 {1.6000000000000001 3.3999999999999999} 5}
+} {2 {1.6 3.4} 5}
test binary-32.15 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1 arg2}
set arg1 foo
set arg2 bar
list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40\x05 d2c* arg1 arg2] $arg1 $arg2
-} {2 {1.6000000000000001 3.3999999999999999} 5}
+} {2 {1.6 3.4} 5}
test binary-33.1 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
@@ -1312,9 +1312,15 @@ test binary-37.8 {GetFormatSpec: numbers} {
set arg1 foo
list [binary scan abcdef "a0x3" arg1] $arg1
} {1 {}}
+test binary-37.8 {GetFormatSpec: numbers} {
+ # test format of neg numbers
+ # bug report/fix provided by Harald Kirsch
+ set x [binary format f* {1 -1 2 -2 0}]
+ binary scan $x f* bla
+ set bla
+} {1.0 -1.0 2.0 -2.0 0.0}
# FormatNumber is thoroughly tested above, so we don't have any explicit tests
-
test binary-38.1 {ScanNumber: sign extension} {
catch {unset arg1}
list [binary scan \x52\xa3 c2 arg1] $arg1
diff --git a/contrib/tcl/tests/cmdAH.test b/contrib/tcl/tests/cmdAH.test
index cbf3ae7..351008e 100644
--- a/contrib/tcl/tests/cmdAH.test
+++ b/contrib/tcl/tests/cmdAH.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) cmdAH.test 1.30 97/06/23 18:17:47
+# SCCS: @(#) cmdAH.test 1.35 97/07/22 14:07:43
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -851,65 +851,83 @@ makeFile abcde gorp.file
makeDirectory dir.file
# readable
-# Can't run on macintosh - requires chmod
-if {$tcl_platform(platform) != "macintosh"} {
test cmdAH-12.1 {Tcl_FileObjCmd: readable} {
list [catch {file readable a b} msg] $msg
} {1 {wrong # args: should be "file readable name"}}
-catch {exec chmod 444 gorp.file}
-test cmdAH-12.2 {Tcl_FileObjCmd: readable} {unixExecs} {file readable gorp.file} 1
-catch {exec chmod 333 gorp.file}
-if {$user != "root"} {
- test cmdAH-12.3 {Tcl_FileObjCmd: readable} {unixOnly} {
- file reada gorp.file
- } 0
-}
-}
+testchmod 444 gorp.file
+test cmdAH-12.2 {Tcl_FileObjCmd: readable} {
+ file readable gorp.file
+} 1
+testchmod 333 gorp.file
+test cmdAH-12.3 {Tcl_FileObjCmd: readable} {unixOnly && !root} {
+ file reada gorp.file
+} 0
# writable
-# Can't run on macintosh - requires chmod
-if {$tcl_platform(platform) != "macintosh"} {
test cmdAH-13.1 {Tcl_FileObjCmd: writable} {
list [catch {file writable a b} msg] $msg
} {1 {wrong # args: should be "file writable name"}}
-catch {exec chmod 555 gorp.file}
-if {$user != "root"} {
- test cmdAH-13.2 {Tcl_FileObjCmd: writable} {unixExecs} {
- file writable gorp.file
- } 0
-}
-catch {exec chmod 222 gorp.file}
-test cmdAH-13.3 {Tcl_FileObjCmd: writable} {unixExecs} {file w gorp.file} 1
-}
+testchmod 555 gorp.file
+test cmdAH-13.2 {Tcl_FileObjCmd: writable} {!root} {
+ file writable gorp.file
+} 0
+testchmod 222 gorp.file
+test cmdAH-13.3 {Tcl_FileObjCmd: writable} {
+ file writable gorp.file
+} 1
# executable
-# Can't run on macintosh - requires chmod
-if {$tcl_platform(platform) != "macintosh"} {
-test cmdAH-14.1 {Tcl_FileObjCmd: executable} {unixExecs} {
+file delete -force dir.file gorp.file
+file mkdir dir.file
+makeFile abcde gorp.file
+
+test cmdAH-14.1 {Tcl_FileObjCmd: executable} {
list [catch {file executable a b} msg] $msg
} {1 {wrong # args: should be "file executable name"}}
-catch {exec chmod 000 dir.file}
-if {$user != "root"} {
- test cmdAH-14.2 {Tcl_FileObjCmd: executable} {unixOnly} {
- file executable gorp.file
- } 0
-}
-catch {exec chmod 775 gorp.file}
-test cmdAH-14.3 {Tcl_FileObjCmd: executable} {unixExecs} {file exe gorp.file} 1
-}
+test cmdAH-14.2 {Tcl_FileObjCmd: executable} {
+ file executable gorp.file
+} 0
+test cmdAH-14.3 {Tcl_FileObjCmd: executable} {unix} {
+ # Only on unix will setting the execute bit on a regular file
+ # cause that file to be executable.
+
+ testchmod 775 gorp.file
+ file exe gorp.file
+} 1
+test cmdAH-14.4 {Tcl_FileObjCmd: executable} {mac} {
+ # On mac, the only executable files are of type APPL.
+
+ set x [file exe gorp.file]
+ file attrib gorp.file -type APPL
+ lappend x [file exe gorp.file]
+} {0 1}
+test cmdAH-14.5 {Tcl_FileObjCmd: executable} {pc} {
+ # On pc, must be a .exe, .com, etc.
+
+ set x [file exe gorp.file]
+ makeFile foo gorp.exe
+ lappend x [file exe gorp.exe]
+ file delete gorp.exe
+ set x
+} {0 1}
+test cmdAH-14.6 {Tcl_FileObjCmd: executable} {
+ # Directories are always executable.
+
+ file exe dir.file
+} 1
+
+file delete -force dir.file
+file delete gorp.file
+file delete link.file
# exists
test cmdAH-15.1 {Tcl_FileObjCmd: exists} {
list [catch {file exists a b} msg] $msg
} {1 {wrong # args: should be "file exists name"}}
-catch {exec chmod 777 dir.file}
-file delete -force dir.file
-file delete gorp.file
-file delete link.file
test cmdAH-15.2 {Tcl_FileObjCmd: exists} {file exists gorp.file} 0
test cmdAH-15.3 {Tcl_FileObjCmd: exists} {
file exists [file join dir.file gorp.file]
@@ -919,8 +937,10 @@ catch {
makeDirectory dir.file
makeFile 12345 [file join dir.file gorp.file]
}
-test cmdAH-15.4 {Tcl_FileObjCmd: exists} {unixExecs} {file exists gorp.file} 1
-test cmdAH-15.5 {Tcl_FileObjCmd: exists} {unixExecs} {
+test cmdAH-15.4 {Tcl_FileObjCmd: exists} {
+ file exists gorp.file
+} 1
+test cmdAH-15.5 {Tcl_FileObjCmd: exists} {
file exists [file join dir.file gorp.file]
} 1
@@ -938,6 +958,14 @@ test cmdAH-15.8 {Tcl_FileObjCmd: nativename} {
list [catch {file nativename a/b} msg] $msg [testsetplatform $platform]
} {0 :a:b {}}
+test cmdAH-15.9 {Tcl_FileObjCmd: ~ : exists} {
+ file exists ~nOsUcHuSeR
+} 0
+test cmdAH-15.10 {Tcl_FileObjCmd: ~ : nativename} {
+ # should probably be 0 in fact...
+ catch {file nativename ~nOsUcHuSeR}
+} 1
+
# The test below has to be done in /tmp rather than the current
# directory in order to guarantee (?) a local file system: some
# NFS file systems won't do the stuff below correctly.
@@ -986,8 +1014,12 @@ test cmdAH-16.3 {Tcl_FileObjCmd: atime} {
test cmdAH-17.1 {Tcl_FileObjCmd: isdirectory} {
list [catch {file isdirectory a b} msg] $msg
} {1 {wrong # args: should be "file isdirectory name"}}
-test cmdAH-17.2 {Tcl_FileObjCmd: isdirectory} {file isdirectory gorp.file} 0
-test cmdAH-17.3 {Tcl_FileObjCmd: isdirectory} {unixExecs} {file isd dir.file} 1
+test cmdAH-17.2 {Tcl_FileObjCmd: isdirectory} {
+ file isdirectory gorp.file
+} 0
+test cmdAH-17.3 {Tcl_FileObjCmd: isdirectory} {
+ file isd dir.file
+} 1
# isfile
@@ -1001,10 +1033,10 @@ test cmdAH-18.3 {Tcl_FileObjCmd: isfile} {file isfile dir.file} 0
# sites will have symbolic links
catch {exec ln -s gorp.file link.file}
-test cmdAH-19.1 {Tcl_FileObjCmd: lstat} {unixExecs} {
+test cmdAH-19.1 {Tcl_FileObjCmd: lstat} {
list [catch {file lstat a} msg] $msg
} {1 {wrong # args: should be "file lstat name varName"}}
-test cmdAH-19.2 {Tcl_FileObjCmd: lstat} {unixExecs} {
+test cmdAH-19.2 {Tcl_FileObjCmd: lstat} {
list [catch {file lstat a b c} msg] $msg
} {1 {wrong # args: should be "file lstat name varName"}}
test cmdAH-19.3 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} {
@@ -1021,7 +1053,7 @@ test cmdAH-19.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} {
string tolower [list [catch {file lstat _bogus_ stat} msg] \
$msg $errorCode]
} {1 {couldn't lstat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
-test cmdAH-19.6 {Tcl_FileObjCmd: lstat errors} {unixExecs nonPortable} {
+test cmdAH-19.6 {Tcl_FileObjCmd: lstat errors} {
catch {unset x}
set x 44
list [catch {file lstat gorp.file x} msg] $msg $errorCode
@@ -1033,7 +1065,7 @@ catch {unset stat}
test cmdAH-20.1 {Tcl_FileObjCmd: mtime} {
list [catch {file mtime a b} msg] $msg
} {1 {wrong # args: should be "file mtime name"}}
-test cmdAH-20.2 {Tcl_FileObjCmd: mtime} {unixExecs} {
+test cmdAH-20.2 {Tcl_FileObjCmd: mtime} {
set old [file mtime gorp.file]
after 2000
set f [open gorp.file w]
@@ -1042,13 +1074,13 @@ test cmdAH-20.2 {Tcl_FileObjCmd: mtime} {unixExecs} {
set new [file mtime gorp.file]
expr {($new > $old) && ($new <= ($old+5))}
} {1}
-test cmdAH-20.3 {Tcl_FileObjCmd: mtime} {unixExecs} {
+test cmdAH-20.3 {Tcl_FileObjCmd: mtime} {
catch {unset stat}
file stat gorp.file stat
list [expr {[file mtime gorp.file] == $stat(mtime)}] \
[expr {[file atime gorp.file] == $stat(atime)}]
} {1 1}
-test cmdAH-20.4 {Tcl_FileObjCmd: mtime} {unixExecs} {
+test cmdAH-20.4 {Tcl_FileObjCmd: mtime} {
string tolower [list [catch {file mtime _bogus_} msg] $msg \
$errorCode]
} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
@@ -1079,10 +1111,12 @@ test cmdAH-20.5 {Tcl_FileObjCmd: mtime} {
test cmdAH-21.1 {Tcl_FileObjCmd: owned} {
list [catch {file owned a b} msg] $msg
} {1 {wrong # args: should be "file owned name"}}
-test cmdAH-21.2 {Tcl_FileObjCmd: owned} {unixExecs} {file owned gorp.file} 1
-if {$user != "root"} {
- test cmdAH-21.3 {Tcl_FileObjCmd: owned} {unixOnly} {file owned /} 0
-}
+test cmdAH-21.2 {Tcl_FileObjCmd: owned} {
+ file owned gorp.file
+} 1
+test cmdAH-21.3 {Tcl_FileObjCmd: owned} {unixOnly && !root} {
+ file owned /
+} 0
# readlink
@@ -1140,16 +1174,21 @@ test cmdAH-24.3 {Tcl_FileObjCmd: stat} {
file stat gorp.file stat
lsort [array names stat]
} {atime ctime dev gid ino mode mtime nlink size type uid}
-test cmdAH-24.4 {Tcl_FileObjCmd: stat} {unixOnly} {
+test cmdAH-24.4 {Tcl_FileObjCmd: stat} {
catch {unset stat}
file stat gorp.file stat
- list $stat(nlink) $stat(size) [expr $stat(mode)&0777] $stat(type)
-} {1 12 501 file}
-test cmdAH-24.5 {Tcl_FileObjCmd: stat} {
+ list $stat(nlink) $stat(size) $stat(type)
+} {1 12 file}
+test cmdAH-24.5 {Tcl_FileObjCmd: stat} {unix} {
+ catch {unset stat}
+ file stat gorp.file stat
+ expr $stat(mode)&0777
+} {501}
+test cmdAH-24.6 {Tcl_FileObjCmd: stat} {
string tolower [list [catch {file stat _bogus_ stat} msg] \
$msg $errorCode]
} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
-test cmdAH-24.6 {Tcl_FileObjCmd: stat} {
+test cmdAH-24.7 {Tcl_FileObjCmd: stat} {
catch {unset x}
set x 44
list [catch {file stat gorp.file x} msg] $msg $errorCode
@@ -1163,7 +1202,7 @@ file delete link.file
test cmdAH-25.1 {Tcl_FileObjCmd: type} {
list [catch {file size a b} msg] $msg
} {1 {wrong # args: should be "file size name"}}
-test cmdAH-25.2 {Tcl_FileObjCmd: type} {unixExecs} {
+test cmdAH-25.2 {Tcl_FileObjCmd: type} {
file type dir.file
} directory
test cmdAH-25.3 {Tcl_FileObjCmd: type} {
diff --git a/contrib/tcl/tests/cmdIL.test b/contrib/tcl/tests/cmdIL.test
index 55210a1..ceeb86b 100644
--- a/contrib/tcl/tests/cmdIL.test
+++ b/contrib/tcl/tests/cmdIL.test
@@ -7,7 +7,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) cmdIL.test 1.15 97/05/22 16:38:11
+# SCCS: @(#) cmdIL.test 1.17 97/07/11 15:33:16
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -46,7 +46,7 @@ test cmdIL-1.10 {Tcl_LsortObjCmd procedure, -index option} {
} {1 {"-index" option must be followed by list index}}
test cmdIL-1.11 {Tcl_LsortObjCmd procedure, -index option} {
list [catch {lsort -index foo {1 3 2 5}} msg] $msg
-} {1 {expected integer but got "foo"}}
+} {1 {bad index "foo": must be integer or "end"}}
test cmdIL-1.12 {Tcl_LsortObjCmd procedure, -index option} {
lsort -index end -integer {{2 25} {10 20 50 100} {3 16 42} 1}
} {1 {2 25} {3 16 42} {10 20 50 100}}
@@ -154,7 +154,7 @@ test cmdIL-3.15 {SortCompare procedure, -command option} {
} {1 {comparison error} {comparison error
while executing
"error "comparison error""
- (procedure "cmp" line 1)
+ (procedure "cmp" line 2)
invoked from within
"cmp 48 6"
(-compare command)
diff --git a/contrib/tcl/tests/compile.test b/contrib/tcl/tests/compile.test
index 6d8e032..9e30fb3 100644
--- a/contrib/tcl/tests/compile.test
+++ b/contrib/tcl/tests/compile.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) compile.test 1.5 97/06/25 11:43:49
+# SCCS: @(#) compile.test 1.7 97/08/12 13:34:13
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -22,12 +22,32 @@ catch {unset x}
catch {unset y}
catch {unset a}
-test compile-1.1 {TclCompileDollarVar: global scalar name with ::s} {
+test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} {
+ catch {namespace delete test_ns_compile}
+ catch {unset x}
+ set x 123
+ namespace eval test_ns_compile {
+ proc set {args} {
+ global x
+ lappend x test_ns_compile::set
+ }
+ proc p {} {
+ set 0
+ }
+ }
+ list [test_ns_compile::p] [set x]
+} {{123 test_ns_compile::set} {123 test_ns_compile::set}}
+test compile-1.2 {TclCompileString, error result is reset if TclGetLong determines word isn't an integer} {
+ proc p {x} {info commands 3m}
+ list [catch {p} msg] $msg
+} {1 {no value given for parameter "x" to "p"}}
+
+test compile-2.1 {TclCompileDollarVar: global scalar name with ::s} {
catch {unset x}
set x 123
list $::x [expr {[lsearch -exact [info globals] x] != 0}]
} {123 1}
-test compile-1.2 {TclCompileDollarVar: global scalar name with ::s} {
+test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} {
catch {unset y}
proc p {} {
set ::y 789
@@ -35,12 +55,12 @@ test compile-1.2 {TclCompileDollarVar: global scalar name with ::s} {
}
list [p] $::y [expr {[lsearch -exact [info globals] y] != 0}]
} {789 789 1}
-test compile-1.3 {TclCompileDollarVar: global array name with ::s} {
+test compile-2.3 {TclCompileDollarVar: global array name with ::s} {
catch {unset a}
set ::a(1) 2
list $::a(1) [set ::a($::a(1)) 3] $::a(2) [expr {[lsearch -exact [info globals] a] != 0}]
} {2 3 3 1}
-test compile-1.4 {TclCompileDollarVar: global scalar name with ::s} {
+test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} {
catch {unset a}
proc p {} {
set ::a(1) 1
@@ -49,7 +69,7 @@ test compile-1.4 {TclCompileDollarVar: global scalar name with ::s} {
list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
} {1 1 1}
-test compile-2.1 {TclCompileSetCmd: global scalar names with ::s} {
+test compile-3.1 {TclCompileSetCmd: global scalar names with ::s} {
catch {unset x}
catch {unset y}
set x 123
@@ -60,7 +80,7 @@ test compile-2.1 {TclCompileSetCmd: global scalar names with ::s} {
list $::x [expr {[lsearch -exact [info globals] x] != 0}] \
[p] $::y [expr {[lsearch -exact [info globals] y] != 0}]
} {123 1 789 789 1}
-test compile-2.2 {TclCompileSetCmd: global array names with ::s} {
+test compile-3.2 {TclCompileSetCmd: global array names with ::s} {
catch {unset a}
set ::a(1) 2
proc p {} {
@@ -69,7 +89,7 @@ test compile-2.2 {TclCompileSetCmd: global array names with ::s} {
}
list $::a(1) [p] [set ::a($::a(1)) 3] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
} {2 1 3 3 1}
-test compile-2.3 {TclCompileSetCmd: namespace var names with ::s} {
+test compile-3.3 {TclCompileSetCmd: namespace var names with ::s} {
catch {namespace delete test_ns_compile}
catch {unset x}
namespace eval test_ns_compile {
@@ -81,17 +101,17 @@ test compile-2.3 {TclCompileSetCmd: namespace var names with ::s} {
list $::x $::test_ns_compile::arr(1)
} {hello 123}
-test compile-3.1 {CollectArgInfo: binary data} {
+test compile-4.1 {CollectArgInfo: binary data} {
list [catch "string length \000foo" msg] $msg
} {0 4}
-test compile-3.2 {CollectArgInfo: binary data} {
+test compile-4.2 {CollectArgInfo: binary data} {
list [catch "string length foo\000" msg] $msg
} {0 4}
-test compile-3.3 {CollectArgInfo: handle "]" at end of command properly} {
+test compile-4.3 {CollectArgInfo: handle "]" at end of command properly} {
set x ]
} {]}
-test compile-4.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} {
+test compile-5.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} {
proc p {} {
set x {}
eval $x
diff --git a/contrib/tcl/tests/defs b/contrib/tcl/tests/defs
index ead6aeb..61f90ec 100644
--- a/contrib/tcl/tests/defs
+++ b/contrib/tcl/tests/defs
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) defs 1.52 97/06/24 11:13:36
+# SCCS: @(#) defs 1.60 97/08/13 18:10:19
if ![info exists VERBOSE] {
set VERBOSE 0
@@ -31,6 +31,7 @@ if {$tcl_platform(platform) == "unix"} {
if {$user == "root"} {
puts stdout "Warning: you're executing as root. I'll have to"
puts stdout "skip some of the tests, since they'll fail as root."
+ set testConfig(root) 1
}
}
@@ -69,6 +70,10 @@ if {[info commands memory] == ""} {
# where the configuration is well known. The presence
# of the file "doAllTests" in this directory indicates
# that it is safe to run non-portable tests.
+# knownBug - The test is known to fail and the bug is not yet
+# fixed. The test will be run only if the file
+# "doBuggyTests" exists (intended for Tcl dev. group
+# internal use only).
# tempNotPc - The inverse of pcOnly. This flag is used to
# temporarily disable a test.
# tempNotMac - The inverse of macOnly. This flag is used to
@@ -111,7 +116,8 @@ if {$tcl_platform(platform) == "windows"} {
set testConfig(unixOrPc) [expr $testConfig(unixOnly) || $testConfig(pcOnly)]
set testConfig(macOrPc) [expr $testConfig(macOnly) || $testConfig(pcOnly)]
set testConfig(macOrUnix) [expr $testConfig(macOnly) || $testConfig(unixOnly)]
-set testConfig(nonPortable) [file exists doAllTests]
+set testConfig(nonPortable) [expr [file exists doAllTests] || [file exists doAllTe]]
+set testConfig(knownBug) [expr [file exists doBuggyTests] || [file exists doBuggyT]]
set testConfig(notIfCompiled) [file exists doAllCompilerTests]
set testConfig(unix) $testConfig(unixOnly)
@@ -126,7 +132,7 @@ set testConfig(win32s) [expr {$tcl_platform(os) == "Win32s"}]
# certain platforms, so that they can be reactivated again when the
# underlying problem is fixed.
-set testConfig(winCrash) $testConfig(macOrUnix)
+set testConfig(pcCrash) $testConfig(macOrUnix)
set testConfig(macCrash) $testConfig(unixOrPc)
set testConfig(unixCrash) $testConfig(macOrPc)
@@ -221,9 +227,13 @@ if {($testConfig(unixExecs) == 1) && ($tcl_platform(platform) == "windows")} {
}
}
-proc print_verbose {name description script code answer} {
+proc print_verbose {name description constraints script code answer} {
puts stdout "\n"
- puts stdout "==== $name $description"
+ if {[string length $constraints]} {
+ puts stdout "==== $name $description\t--- ($constraints) ---"
+ } else {
+ puts stdout "==== $name $description"
+ }
puts stdout "==== Contents of test case:"
puts stdout "$script"
if {$code != 0} {
@@ -282,7 +292,7 @@ proc test {name description script answer args} {
}
set i [llength $args]
if {$i == 0} {
- # Empty body
+ set constraints {}
} elseif {$i == 1} {
# "constraints" argument exists; shuffle arguments down, then
# make sure that the constraints are satisfied.
@@ -294,7 +304,7 @@ proc test {name description script answer args} {
if {[string match {*[$\[]*} $constraints] != 0} {
# full expression, e.g. {$foo > [info tclversion]}
- catch {set doTest [uplevel #0 expr $constraints]}
+ catch {set doTest [uplevel #0 expr [list $constraints]]} msg
} elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
# something like {a || b} should be turned into
# $testConfig(a) || $testConfig(b).
@@ -325,18 +335,20 @@ proc test {name description script answer args} {
memory tag $name
set code [catch {uplevel $script} result]
if {$code != 0} {
- print_verbose $name $description $script \
+ print_verbose $name $description $constraints $script \
$code $result
} elseif {[string compare $result $answer] == 0} then {
if $VERBOSE then {
if {$VERBOSE > 0} {
- print_verbose $name $description $script \
+ print_verbose $name $description $constraints $script \
$code $result
}
- puts stdout "++++ $name PASSED"
+ if {$VERBOSE != -2} {
+ puts stdout "++++ $name PASSED"
+ }
}
} else {
- print_verbose $name $description $script \
+ print_verbose $name $description $constraints $script \
$code $result
puts stdout "---- Result should have been:"
puts stdout "$answer"
@@ -397,10 +409,39 @@ proc viewFile {name} {
# Locate tcltest executable
-set tcltest [list [info nameofexecutable]]
+set tcltest [info nameofexecutable]
+
if {$tcltest == "{}"} {
set tcltest {}
puts "Unable to find tcltest executable, multiple process tests will fail."
}
+if {$tcl_platform(os) != "Win32s"} {
+ # Don't even try running another copy of tcltest under win32s, or you
+ # get an error dialog about multiple instances.
+
+ catch {
+ file delete -force tmp
+ set f [open tmp w]
+ puts $f {
+ exit
+ }
+ close $f
+ set f [open "|[list $tcltest tmp]" r]
+ close $f
+ set testConfig(stdio) 1
+ }
+}
+
+if {($tcl_platform(platform) == "windows") && ($testConfig(stdio) == 0)} {
+ puts "(will skip tests that redirect stdio of exec'd 32-bit applications)"
+}
+
+catch {socket} msg
+set testConfig(socket) [expr {$msg != "sockets are not available on this system"}]
+
+if {$testConfig(socket) == 0} {
+ puts "(will skip tests that use sockets)"
+}
+
diff --git a/contrib/tcl/tests/env.test b/contrib/tcl/tests/env.test
index 22f1284..e76ad7d 100644
--- a/contrib/tcl/tests/env.test
+++ b/contrib/tcl/tests/env.test
@@ -10,42 +10,50 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) env.test 1.9 96/02/16 08:55:47
+# SCCS: @(#) env.test 1.13 97/08/05 11:40:30
if {[string compare test [info procs test]] == 1} then {source defs}
-# If there is no "printenv" program on this system, then it's just too
-# much trouble to run this test (can't necessarily run csh to get the
-# environment: on some systems it barfs if there isn't a minimum set
-# predefined environment variables. Also, printenv returns a non-zero
-# status on some systems, so read the environment using a procedure
-# that catches errors.
+if {[info commands exec] == ""} {
+ puts "exec not implemented for this machine"
+ return
+}
-set printenv {}
-if [info exists env(PATH)] {
- set dirs [split $env(PATH) :]
-} else {
- set dirs {/bin /usr/bin /usr/ucb /usr/local /usr/public /usr/etc}
+if {$tcl_platform(os) == "Win32s"} {
+ puts "Cannot run multiple copies of tcl at the same time under Win32s"
+ return
}
-foreach i $dirs {
- if [file executable $i/printenv] {
- # The following hack is needed because of weirdness with
- # environment variables in symbolic lines on Apollos (?!#?).
- if ![catch {exec sh -c "cd $i; pwd"} x] {
- set printenv $x/printenv
- } else {
- set printenv $i/printenv
+
+set f [open printenv w]
+puts $f {
+ proc lrem {listname name} {
+ upvar $listname list
+ set i [lsearch $list $name]
+ if {$i >= 0} {
+ set list [lreplace $list $i $i]
}
- break
+ return $list
+ }
+
+ set names [lsort [array names env]]
+ if {$tcl_platform(platform) == "windows"} {
+ lrem names HOME
+ lrem names COMSPEC
+ lrem names ComSpec
+ lrem names ""
+ }
+ foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH} {
+ lrem names $name
+ }
+ foreach p $names {
+ puts "$p=$env($p)"
}
}
-if {$printenv == ""} {
- puts stdout "Skipping env tests: need \"printenv\" to read environment."
- return ""
-}
+close $f
+
proc getenv {} {
- global printenv
- catch {exec $printenv} out
+ global printenv tcltest
+ catch {exec $tcltest printenv} out
if {$out == "child process exited abnormally"} {
set out {}
}
@@ -59,6 +67,15 @@ foreach name [array names env] {
unset env($name)
}
+# Added the following lines so that child tcltest can actually find its
+# library if the initial tcltest is run from a non-standard place.
+# ('saved' env vars)
+foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH} {
+ if {[info exists env2($name)]} {
+ set env($name) $env2($name);
+ }
+}
+
test env-1.1 {adding environment variables} {
getenv
} {}
@@ -106,3 +123,5 @@ foreach name [array names env] {
foreach name [array names env2] {
set env($name) $env2($name)
}
+
+file delete printenv
diff --git a/contrib/tcl/tests/error.test b/contrib/tcl/tests/error.test
index 3421edc..1421e9b 100644
--- a/contrib/tcl/tests/error.test
+++ b/contrib/tcl/tests/error.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) error.test 1.18 96/11/07 18:36:09
+# SCCS: @(#) error.test 1.22 97/08/12 17:02:43
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -42,7 +42,7 @@ test error-1.3 {simple errors from commands} {
set errorInfo
} {wrong # args: should be "string compare string1 string2"
while executing
-"format [string compare]"}
+"string compare"}
test error-1.4 {simple errors from commands} {
catch {error glorp} b
@@ -62,6 +62,17 @@ test error-1.7 {simple errors from commands} {
set b
} {wrong # args: should be "catch command ?varName?"}
+test error-1.8 {simple errors from commands} {nonPortable} {
+ # This test is non-portable: it generates a memory fault on
+ # machines like DEC Alphas (infinite recursion overflows
+ # stack?)
+
+ proc p {} {
+ uplevel 1 catch p error
+ }
+ p
+} 0
+
# Check errors nested in procedures. Also check the optional argument
# to "error" to generate a new error trace.
@@ -80,7 +91,7 @@ test error-2.3 {errors in nested procedures} {
} {Human-generated
while executing
"error {Human-generated}"
- (procedure "foo" line 1)
+ (procedure "foo" line 4)
invoked from within
"foo"}
@@ -98,8 +109,8 @@ test error-2.6 {errors in nested procedures} {
set errorInfo
} {glorp2
while executing
-"format [error glorp2]"
- (procedure "foo2" line 1)
+"error glorp2"
+ (procedure "foo2" line 3)
invoked from within
"foo2"}
@@ -160,4 +171,5 @@ test error-6.1 {catch must reset error state} {
list $errorCode $errorInfo
} {NONE 1}
+catch {rename p ""}
return ""
diff --git a/contrib/tcl/tests/eval.test b/contrib/tcl/tests/eval.test
index 48ee9ce..07f610c 100644
--- a/contrib/tcl/tests/eval.test
+++ b/contrib/tcl/tests/eval.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) eval.test 1.9 96/09/10 13:50:39
+# SCCS: @(#) eval.test 1.10 97/07/02 16:40:56
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -47,7 +47,7 @@ test eval-2.5 {error in eval'ed command: setting errorInfo} {
} "test error
while executing
\"error \"test error\"\"
- (\"eval\" body line 1)
+ (\"eval\" body line 3)
invoked from within
\"eval {
set a 1
diff --git a/contrib/tcl/tests/event.test b/contrib/tcl/tests/event.test
index 6741836..027f7e0 100644
--- a/contrib/tcl/tests/event.test
+++ b/contrib/tcl/tests/event.test
@@ -8,7 +8,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# "@(#) event.test 1.27 97/06/23 18:21:18"
+# "@(#) event.test 1.35 97/08/11 11:58:38"
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -46,7 +46,7 @@ if {[catch {testfilehandler create 0 off off}] == 0 } {
testfilehandler close
set result
} {{0 1} {0 2} {0 2}}
- test event-1.3 {Tcl_DeleteFileHandler} {
+ test event-1.3 {Tcl_DeleteFileHandler} {nonPortable} {
testfilehandler close
testfilehandler create 2 disabled disabled
testfilehandler create 1 readable writable
@@ -66,7 +66,7 @@ if {[catch {testfilehandler create 0 off off}] == 0 } {
set result
} {{0 1} {1 1} {1 2} {0 0}}
- test event-2.1 {Tcl_DeleteFileHandler} {
+ test event-2.1 {Tcl_DeleteFileHandler} {nonPortable} {
testfilehandler close
testfilehandler create 2 disabled disabled
testfilehandler create 1 readable writable
@@ -84,7 +84,7 @@ if {[catch {testfilehandler create 0 off off}] == 0 } {
testfilehandler close
set result
} {{0 1} {1 1} {1 2} {0 0}}
- test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} {
+ test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} {nonPortable} {
testfilehandler close
testfilehandler create 0 readable writable
testfilehandler fillpartial 0
@@ -109,7 +109,7 @@ if {[catch {testfilehandler create 0 off off}] == 0 } {
set result
} {0 0}
- test event-4.1 {FileHandlerEventProc, race between event and disabling } {
+ test event-4.1 {FileHandlerEventProc, race between event and disabling} {nonPortable} {
update
testfilehandler close
testfilehandler create 2 disabled disabled
@@ -128,7 +128,7 @@ if {[catch {testfilehandler create 0 off off}] == 0 } {
testfilehandler close
set result
} {{0 1} {1 1} {1 2} {0 0}}
- test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off } {
+ test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off} {nonPortable} {
update
testfilehandler close
testfilehandler create 1 readable writable
@@ -208,70 +208,75 @@ test event-6.1 {BgErrorDeleteProc procedure} {
} {Unmodified
}
-test event-7.1 {tkerror/bgerror backwards compabitility} {
- catch {rename bgerror {}}
- proc tkerror {x y} {
- return [expr $x + $y]
- }
- list [tkerror 4 7] [bgerror 8 -3]
-} {11 5}
-test event-7.2 {tkerror/bgerror backwards compabitility} {
- proc bgerror {x y} {
- return [expr 1 + $x + $y]
+test event-7.1 {bgerror / regular} {
+ set errRes {}
+ proc bgerror {err} {
+ global errRes;
+ set errRes $err;
}
- list [tkerror 6 -2] [bgerror 7 2]
-} {5 10}
-test event-7.3 {tkerror/bgerror backwards compabitility} {
- proc bgerror {x y} {
- return [expr 1 + $x + $y]
+ after 0 {error err1}
+ vwait errRes;
+ set errRes;
+} err1
+
+test event-7.2 {bgerror / accumulation} {
+ set errRes {}
+ proc bgerror {err} {
+ global errRes;
+ lappend errRes $err;
}
- set result [list [info commands bgerror] [info commands tkerror]]
- rename tkerror {}
- lappend result [info commands bgerror] [info commands tkerror]
-} {bgerror tkerror {} {}}
-test event-7.4 {tkerror/bgerror backwards compabitility} {
- proc tkerror {x y} {
- return [expr 1 + $x + $y]
+ after 0 {error err1}
+ after 0 {error err2}
+ after 0 {error err3}
+ update
+ set errRes;
+} {err1 err2 err3}
+
+test event-7.3 {bgerror / accumulation / break} {
+ set errRes {}
+ proc bgerror {err} {
+ global errRes;
+ lappend errRes $err;
+ return -code break "skip!";
}
- set result [list [info commands bgerror] [info commands tkerror]]
- rename bgerror {}
- lappend result [info commands bgerror] [info commands tkerror]
-} {bgerror tkerror {} {}}
-test event-7.5 {tkerror/bgerror backwards compabitility} {
- proc tkerror {x y} {
- return [expr 1 + $x + $y]
+ after 0 {error err1}
+ after 0 {error err2}
+ after 0 {error err3}
+ update
+ set errRes;
+} err1
+
+test event-7.4 {tkerror is nothing special anymore to tcl} {
+ set errRes {}
+ # we don't just rename bgerror to empty because it could then
+ # be autoloaded...
+ proc bgerror {err} {
+ global errRes;
+ lappend errRes "bg:$err";
}
- rename tkerror foo
- list [info commands bgerror] [info commands tkerror] [foo 4 3]
-} {{} {} 8}
-test event-7.6 {tkerror/bgerror backwards compabitility} {
- proc bgerror {x y} {
- return [expr 1 + $x + $y]
+ proc tkerror {err} {
+ global errRes;
+ lappend errRes "tk:$err";
}
- catch {rename foo {}}
- rename bgerror foo
- list [info commands bgerror] [info commands tkerror] [foo 4 3]
-} {{} {} 8}
-test event-7.7 {tkerror/bgerror backwards compabitility} {
- proc foo args {return $args}
- catch {rename tkerror {}}
- rename foo tkerror
- list [info commands bgerror] [info commands tkerror] [info commands foo] [tkerror a b c d]
-} {bgerror tkerror {} {a b c d}}
-test event-7.8 {tkerror/bgerror backwards compabitility} {
- proc foo args {return $args}
- catch {rename bgerror {}}
- rename foo bgerror
- list [info commands bgerror] [info commands tkerror] [info commands foo] [tkerror a b c d]
-} {bgerror tkerror {} {a b c d}}
-test event-7.9 {tkerror/bgerror backwards compabitility} {
- proc bgerror args {return $args}
- list [catch {rename bgerror tkerror} msg] $msg
-} {1 {can't rename to "tkerror": command already exists}}
+ after 0 {error err1}
+ update
+ rename tkerror {}
+ set errRes
+} bg:err1
+
+# someday : add a test checking that
+# when there is no bgerror, an error msg goes to stderr
+# ideally one would use sub interp and transfer a fake stderr
+# to it, unfortunatly the current interp tcl API does not allow
+# that. the other option would be to use fork a test but it
+# then becomes more a file/exec test than a bgerror test.
+
+# end of bgerror tests
catch {rename bgerror {}}
+
if {[info commands testexithandler] != ""} {
- test event-8.1 {Tcl_CreateExitHandler procedure} {unixOrPc} {
+ test event-8.1 {Tcl_CreateExitHandler procedure} {stdio} {
set child [open |[list [info nameofexecutable]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; exit"
@@ -284,7 +289,7 @@ even 4
odd 41
}
- test event-9.1 {Tcl_DeleteExitHandler procedure} {unixOrPc} {
+ test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio} {
set child [open |[list [info nameofexecutable]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 41"
@@ -297,7 +302,7 @@ odd 41
even 6
even 4
}
- test event-9.2 {Tcl_DeleteExitHandler procedure} {unixOrPc} {
+ test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio} {
set child [open |[list [info nameofexecutable]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 4"
@@ -310,7 +315,7 @@ even 4
even 6
odd 41
}
- test event-9.3 {Tcl_DeleteExitHandler procedure} {unixOrPc} {
+ test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio} {
set child [open |[list [info nameofexecutable]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 6"
@@ -323,7 +328,7 @@ odd 41
even 4
odd 41
}
- test event-9.4 {Tcl_DeleteExitHandler procedure} {unixOrPc} {
+ test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio} {
set child [open |[list [info nameofexecutable]] r+]
puts $child "testexithandler create 41; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
@@ -335,7 +340,7 @@ odd 41
}
}
-test event-10.1 {Tcl_Exit procedure} {unixOrPc} {
+test event-10.1 {Tcl_Exit procedure} {stdio} {
set child [open |[list [info nameofexecutable]] r+]
puts $child "exit 3"
list [catch {close $child} msg] $msg [lindex $errorCode 0] \
@@ -357,6 +362,7 @@ test event-11.4 {Tcl_VwaitCmd procedure} {
foreach i [after info] {
after cancel $i
}
+ after 10; update; # On Mac make sure update won't take long
after 100 {set x x-done}
after 200 {set y y-done}
after 300 {set z z-done}
@@ -372,7 +378,7 @@ foreach i [after info] {
after cancel $i
}
-test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {
+test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {socket} {
set f1 [open test1 w]
proc accept {s args} {
puts $s foobar
@@ -435,8 +441,9 @@ test event-12.4 {Tcl_UpdateCmd procedure} {
foreach i [after info] {
after cancel $i
}
+ after 10; update; # On Mac make sure update won't take long
after 200 {set x x-done}
- after 500 {set y y-done}
+ after 600 {set y y-done}
after idle {set z z-done}
set x before
set y before
diff --git a/contrib/tcl/tests/exec.test b/contrib/tcl/tests/exec.test
index 4b00c44..169885a 100644
--- a/contrib/tcl/tests/exec.test
+++ b/contrib/tcl/tests/exec.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) exec.test 1.56 97/06/20 13:27:37
+# SCCS: @(#) exec.test 1.58 97/08/01 11:10:00
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -20,181 +20,255 @@ if {[info commands exec] == ""} {
puts "exec not implemented for this machine"
return
}
+if {$testConfig(stdio) == 0} {
+ return
+}
-proc cat {name} {
- set f [open $name r]
- set x [read -nonewline $f]
- close $f
- set x
+set f [open echo w]
+puts $f {
+ puts -nonewline [lindex $argv 0]
+ foreach str [lrange $argv 1 end] {
+ puts -nonewline " $str"
+ }
+ puts {}
}
+close $f
+
+set f [open cat w]
+puts $f {
+ if {$argv == {}} {
+ set argv -
+ }
+ foreach name $argv {
+ if {$name == "-"} {
+ set f stdin
+ } elseif {[catch {open $name r} f] != 0} {
+ puts stderr $f
+ continue
+ }
+ while {[eof $f] == 0} {
+ puts -nonewline [read $f]
+ }
+ if {$f != "stdin"} {
+ close $f
+ }
+ }
+}
+close $f
+
+set f [open wc w]
+puts $f {
+ set data [read stdin]
+ set lines [regsub -all "\n" $data {} dummy]
+ set words [regsub -all "\[^ \t\n]+" $data {} dummy]
+ set chars [string length $data]
+ puts [format "%8.d%8.d%8.d" $lines $words $chars]
+}
+close $f
+
+set f [open sh w]
+puts $f {
+ if {[lindex $argv 0] != "-c"} {
+ error "sh: unexpected arguments $argv"
+ }
+ set cmd [lindex $argv 1]
+ lappend cmd ";"
+
+ set newcmd {}
+
+ foreach arg $cmd {
+ if {$arg == ";"} {
+ eval exec >@stdout 2>@stderr [list [info nameofexecutable]] $newcmd
+ set newcmd {}
+ continue
+ }
+ if {$arg == "1>&2"} {
+ set arg >@stderr
+ }
+ lappend newcmd $arg
+ }
+}
+close $f
+
+set f [open sleep w]
+puts $f {
+ after [expr $argv*1000]
+}
+close $f
+
+set f [open exit w]
+puts $f {
+ exit $argv
+}
+close $f
# Basic operations.
-test exec-1.1 {basic exec operation} {unixExecs} {
- exec echo a b c
+test exec-1.1 {basic exec operation} {
+ exec $tcltest echo a b c
} "a b c"
-test exec-1.2 {pipelining} {unixExecs} {
- exec echo a b c d | cat | cat
+test exec-1.2 {pipelining} {
+ exec $tcltest echo a b c d | $tcltest cat | $tcltest cat
} "a b c d"
-test exec-1.3 {pipelining} {unixExecs} {
- set a [exec echo a b c d | cat | wc]
+test exec-1.3 {pipelining} {
+ set a [exec $tcltest echo a b c d | $tcltest cat | $tcltest wc]
list [scan $a "%d %d %d" b c d] $b $c
} {3 1 4}
set arg {12345678901234567890123456789012345678901234567890}
set arg "$arg$arg$arg$arg$arg$arg"
-test exec-1.4 {long command lines} {unixExecs} {
- exec echo $arg
+test exec-1.4 {long command lines} {
+ exec $tcltest echo $arg
} $arg
set arg {}
# I/O redirection: input from Tcl command.
-test exec-2.1 {redirecting input from immediate source} {unixExecs} {
- exec cat << "Sample text"
+test exec-2.1 {redirecting input from immediate source} {
+ exec $tcltest cat << "Sample text"
} {Sample text}
-test exec-2.2 {redirecting input from immediate source} {unixExecs} {
- exec << "Sample text" cat | cat
+test exec-2.2 {redirecting input from immediate source} {
+ exec << "Sample text" $tcltest cat | $tcltest cat
} {Sample text}
-test exec-2.3 {redirecting input from immediate source} {unixExecs} {
- exec cat << "Sample text" | cat
+test exec-2.3 {redirecting input from immediate source} {
+ exec $tcltest cat << "Sample text" | $tcltest cat
} {Sample text}
-test exec-2.4 {redirecting input from immediate source} {unixExecs} {
- exec cat | cat << "Sample text"
+test exec-2.4 {redirecting input from immediate source} {
+ exec $tcltest cat | $tcltest cat << "Sample text"
} {Sample text}
-test exec-2.5 {redirecting input from immediate source} {unixExecs} {
- exec cat "<<Joined to arrows"
+test exec-2.5 {redirecting input from immediate source} {
+ exec $tcltest cat "<<Joined to arrows"
} {Joined to arrows}
# I/O redirection: output to file.
-catch {exec rm -f gorp.file}
-test exec-3.1 {redirecting output to file} {unixExecs} {
- exec echo "Some simple words" > gorp.file
- exec cat gorp.file
+file delete gorp.file
+test exec-3.1 {redirecting output to file} {
+ exec $tcltest echo "Some simple words" > gorp.file
+ exec $tcltest cat gorp.file
} "Some simple words"
-test exec-3.2 {redirecting output to file} {unixExecs} {
- exec echo "More simple words" | >gorp.file cat | cat
- exec cat gorp.file
+test exec-3.2 {redirecting output to file} {
+ exec $tcltest echo "More simple words" | >gorp.file $tcltest cat | $tcltest cat
+ exec $tcltest cat gorp.file
} "More simple words"
-test exec-3.3 {redirecting output to file} {unixExecs} {
- exec > gorp.file echo "Different simple words" | cat | cat
- exec cat gorp.file
+test exec-3.3 {redirecting output to file} {
+ exec > gorp.file $tcltest echo "Different simple words" | $tcltest cat | $tcltest cat
+ exec $tcltest cat gorp.file
} "Different simple words"
-test exec-3.4 {redirecting output to file} {unixExecs} {
- exec echo "Some simple words" >gorp.file
- exec cat gorp.file
+test exec-3.4 {redirecting output to file} {
+ exec $tcltest echo "Some simple words" >gorp.file
+ exec $tcltest cat gorp.file
} "Some simple words"
-test exec-3.5 {redirecting output to file} {unixExecs} {
- exec echo "First line" >gorp.file
- exec echo "Second line" >> gorp.file
- exec cat gorp.file
+test exec-3.5 {redirecting output to file} {
+ exec $tcltest echo "First line" >gorp.file
+ exec $tcltest echo "Second line" >> gorp.file
+ exec $tcltest cat gorp.file
} "First line\nSecond line"
-test exec-3.6 {redirecting output to file} {unixExecs} {
- exec echo "First line" >gorp.file
- exec echo "Second line" >>gorp.file
- exec cat gorp.file
+test exec-3.6 {redirecting output to file} {
+ exec $tcltest echo "First line" >gorp.file
+ exec $tcltest echo "Second line" >>gorp.file
+ exec $tcltest cat gorp.file
} "First line\nSecond line"
-test exec-3.7 {redirecting output to file} {unixExecs} {
+test exec-3.7 {redirecting output to file} {
set f [open gorp.file w]
puts $f "Line 1"
flush $f
- exec echo "More text" >@ $f
- exec echo >@$f "Even more"
+ exec $tcltest echo "More text" >@ $f
+ exec $tcltest echo >@$f "Even more"
puts $f "Line 3"
close $f
- exec cat gorp.file
+ exec $tcltest cat gorp.file
} "Line 1\nMore text\nEven more\nLine 3"
# I/O redirection: output and stderr to file.
-catch {exec rm -f gorp.file}
-test exec-4.1 {redirecting output and stderr to file} {unixExecs} {
- exec echo "test output" >& gorp.file
- exec cat gorp.file
+file delete gorp.file
+test exec-4.1 {redirecting output and stderr to file} {
+ exec $tcltest echo "test output" >& gorp.file
+ exec $tcltest cat gorp.file
} "test output"
-test exec-4.2 {redirecting output and stderr to file} {unixExecs} {
- list [exec sh -c "echo foo bar 1>&2" >&gorp.file] \
- [exec cat gorp.file]
+test exec-4.2 {redirecting output and stderr to file} {
+ list [exec $tcltest sh -c "echo foo bar 1>&2" >&gorp.file] \
+ [exec $tcltest cat gorp.file]
} {{} {foo bar}}
-test exec-4.3 {redirecting output and stderr to file} {unixExecs} {
- exec echo "first line" > gorp.file
- list [exec sh -c "echo foo bar 1>&2" >>&gorp.file] \
- [exec cat gorp.file]
+test exec-4.3 {redirecting output and stderr to file} {
+ exec $tcltest echo "first line" > gorp.file
+ list [exec $tcltest sh -c "echo foo bar 1>&2" >>&gorp.file] \
+ [exec $tcltest cat gorp.file]
} "{} {first line\nfoo bar}"
-test exec-4.4 {redirecting output and stderr to file} {unixExecs} {
+test exec-4.4 {redirecting output and stderr to file} {
set f [open gorp.file w]
puts $f "Line 1"
flush $f
- exec echo "More text" >&@ $f
- exec echo >&@$f "Even more"
+ exec $tcltest echo "More text" >&@ $f
+ exec $tcltest echo >&@$f "Even more"
puts $f "Line 3"
close $f
- exec cat gorp.file
+ exec $tcltest cat gorp.file
} "Line 1\nMore text\nEven more\nLine 3"
-test exec-4.5 {redirecting output and stderr to file} {unixExecs} {
+test exec-4.5 {redirecting output and stderr to file} {
set f [open gorp.file w]
puts $f "Line 1"
flush $f
- exec >&@ $f sh -c "echo foo bar 1>&2"
- exec >&@$f sh -c "echo xyzzy 1>&2"
+ exec >&@ $f $tcltest sh -c "echo foo bar 1>&2"
+ exec >&@$f $tcltest sh -c "echo xyzzy 1>&2"
puts $f "Line 3"
close $f
- exec cat gorp.file
+ exec $tcltest cat gorp.file
} "Line 1\nfoo bar\nxyzzy\nLine 3"
# I/O redirection: input from file.
-catch {exec echo "Just a few thoughts" > gorp.file}
-test exec-5.1 {redirecting input from file} {unixExecs} {
- exec cat < gorp.file
+exec $tcltest echo "Just a few thoughts" > gorp.file
+test exec-5.1 {redirecting input from file} {
+ exec $tcltest cat < gorp.file
} {Just a few thoughts}
-test exec-5.2 {redirecting input from file} {unixExecs} {
- exec cat | cat < gorp.file
+test exec-5.2 {redirecting input from file} {
+ exec $tcltest cat | $tcltest cat < gorp.file
} {Just a few thoughts}
-test exec-5.3 {redirecting input from file} {unixExecs} {
- exec cat < gorp.file | cat
+test exec-5.3 {redirecting input from file} {
+ exec $tcltest cat < gorp.file | $tcltest cat
} {Just a few thoughts}
-test exec-5.4 {redirecting input from file} {unixExecs} {
- exec < gorp.file cat | cat
+test exec-5.4 {redirecting input from file} {
+ exec < gorp.file $tcltest cat | $tcltest cat
} {Just a few thoughts}
-test exec-5.5 {redirecting input from file} {unixExecs} {
- exec cat <gorp.file
+test exec-5.5 {redirecting input from file} {
+ exec $tcltest cat <gorp.file
} {Just a few thoughts}
-test exec-5.6 {redirecting input from file} {unixExecs} {
+test exec-5.6 {redirecting input from file} {
set f [open gorp.file r]
- set result [exec cat <@ $f]
+ set result [exec $tcltest cat <@ $f]
close $f
set result
} {Just a few thoughts}
-test exec-5.7 {redirecting input from file} {unixExecs} {
+test exec-5.7 {redirecting input from file} {
set f [open gorp.file r]
- set result [exec <@$f cat]
+ set result [exec <@$f $tcltest cat]
close $f
set result
} {Just a few thoughts}
# I/O redirection: standard error through a pipeline.
-test exec-6.1 {redirecting stderr through a pipeline} {unixExecs} {
- exec sh -c "echo foo bar" |& cat
+test exec-6.1 {redirecting stderr through a pipeline} {
+ exec $tcltest sh -c "echo foo bar" |& $tcltest cat
} "foo bar"
-test exec-6.2 {redirecting stderr through a pipeline} {unixExecs} {
- exec sh -c "echo foo bar 1>&2" |& cat
+test exec-6.2 {redirecting stderr through a pipeline} {
+ exec $tcltest sh -c "echo foo bar 1>&2" |& $tcltest cat
} "foo bar"
-test exec-6.3 {redirecting stderr through a pipeline} {unixExecs} {
- exec sh -c "echo foo bar 1>&2" \
- |& sh -c "echo second msg 1>&2; cat" |& cat
+test exec-6.3 {redirecting stderr through a pipeline} {
+ exec $tcltest sh -c "echo foo bar 1>&2" \
+ |& $tcltest sh -c "echo second msg 1>&2 ; cat" |& $tcltest cat
} "second msg\nfoo bar"
# I/O redirection: combinations.
catch {exec rm -f gorp.file2}
-test exec-7.1 {multiple I/O redirections} {unixExecs} {
- exec << "command input" > gorp.file2 cat < gorp.file
- exec cat gorp.file2
+test exec-7.1 {multiple I/O redirections} {
+ exec << "command input" > gorp.file2 $tcltest cat < gorp.file
+ exec $tcltest cat gorp.file2
} {Just a few thoughts}
-test exec-7.2 {multiple I/O redirections} {unixExecs} {
- exec < gorp.file << "command input" cat
+test exec-7.2 {multiple I/O redirections} {
+ exec < gorp.file << "command input" $tcltest cat
} {command input}
# Long input to command and output from command.
@@ -204,8 +278,8 @@ set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
-test exec-8.1 {long input and output} {unixExecs} {
- exec cat << $a
+test exec-8.1 {long input and output} {
+ exec $tcltest cat << $a
} $a
# Commands that return errors.
@@ -214,25 +288,25 @@ test exec-9.1 {commands returning errors} {
set x [catch {exec gorp456} msg]
list $x [string tolower $msg] [string tolower $errorCode]
} {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}}
-test exec-9.2 {commands returning errors} {unixExecs} {
- string tolower [list [catch {exec echo foo | foo123} msg] $msg $errorCode]
+test exec-9.2 {commands returning errors} {
+ string tolower [list [catch {exec $tcltest echo foo | foo123} msg] $msg $errorCode]
} {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}}
-test exec-9.3 {commands returning errors} {unixExecs} {
- list [catch {exec sleep 1 | sh -c "exit 43" | sleep 1} msg] $msg
+test exec-9.3 {commands returning errors} {
+ list [catch {exec $tcltest sleep 1 | $tcltest exit 43 | $tcltest sleep 1} msg] $msg
} {1 {child process exited abnormally}}
-test exec-9.4 {commands returning errors} {unixExecs} {
- list [catch {exec sh -c "exit 43" | echo "foo bar"} msg] $msg
+test exec-9.4 {commands returning errors} {
+ list [catch {exec $tcltest exit 43 | $tcltest echo "foo bar"} msg] $msg
} {1 {foo bar
child process exited abnormally}}
-test exec-9.5 {commands returning errors} {unixExecs} {
- list [catch {exec gorp456 | echo a b c} msg] [string tolower $msg]
+test exec-9.5 {commands returning errors} {
+ list [catch {exec gorp456 | $tcltest echo a b c} msg] [string tolower $msg]
} {1 {couldn't execute "gorp456": no such file or directory}}
-test exec-9.6 {commands returning errors} {unixExecs} {
- list [catch {exec sh -c "echo error msg 1>&2"} msg] $msg
+test exec-9.6 {commands returning errors} {
+ list [catch {exec $tcltest sh -c "echo error msg 1>&2"} msg] $msg
} {1 {error msg}}
-test exec-9.7 {commands returning errors} {unixExecs} {
- list [catch {exec sh -c "echo error msg 1>&2" \
- | sh -c "echo error msg 1>&2"} msg] $msg
+test exec-9.7 {commands returning errors} {
+ list [catch {exec $tcltest sh -c "echo error msg 1>&2" \
+ | $tcltest sh -c "echo error msg 1>&2"} msg] $msg
} {1 {error msg
error msg}}
@@ -281,13 +355,13 @@ test exec-10.13 {errors in exec invocation} {
test exec-10.14 {errors in exec invocation} {
list [catch {exec cat <@} msg] $msg
} {1 {can't specify "<@" as last word in command}}
-test exec-10.15 {errors in exec invocation} {unixExecs} {
+test exec-10.15 {errors in exec invocation} {
list [catch {exec cat < a/b/c} msg] [string tolower $msg]
} {1 {couldn't read file "a/b/c": no such file or directory}}
-test exec-10.16 {errors in exec invocation} {unixExecs} {
+test exec-10.16 {errors in exec invocation} {
list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
-test exec-10.17 {errors in exec invocation} {unixExecs} {
+test exec-10.17 {errors in exec invocation} {
list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
set f [open gorp.file w]
@@ -303,36 +377,36 @@ close $f
test exec-10.20 {errors in exec invocation} {
list [catch {exec ~non_existent_user/foo/bar} msg] $msg
} {1 {user "non_existent_user" doesn't exist}}
-test exec-10.21 {errors in exec invocation} {unixExecs} {
- list [catch {exec true | ~xyzzy_bad_user/x | false} msg] $msg
+test exec-10.21 {errors in exec invocation} {
+ list [catch {exec $tcltest true | ~xyzzy_bad_user/x | false} msg] $msg
} {1 {user "xyzzy_bad_user" doesn't exist}}
# Commands in background.
-test exec-11.1 {commands in background} {unixExecs} {
- set x [lindex [time {exec sleep 2 &}] 0]
+test exec-11.1 {commands in background} {
+ set x [lindex [time {exec $tcltest sleep 2 &}] 0]
expr $x<1000000
} 1
-test exec-11.2 {commands in background} {unixExecs} {
- list [catch {exec echo a &b} msg] $msg
+test exec-11.2 {commands in background} {
+ list [catch {exec $tcltest echo a &b} msg] $msg
} {0 {a &b}}
-test exec-11.3 {commands in background} {unixExecs} {
- llength [exec sleep 1 &]
+test exec-11.3 {commands in background} {
+ llength [exec $tcltest sleep 1 &]
} 1
-test exec-11.4 {commands in background} {unixExecs} {
- llength [exec sleep 1 | sleep 1 | sleep 1 &]
+test exec-11.4 {commands in background} {
+ llength [exec $tcltest sleep 1 | $tcltest sleep 1 | $tcltest sleep 1 &]
} 3
-test exec-11.5 {commands in background} {unixExecs} {
+test exec-11.5 {commands in background} {
set f [open gorp.file w]
- puts $f { catch { exec echo foo & } }
+ puts $f { catch { exec [info nameofexecutable] echo foo & } }
close $f
- string compare "foo" [exec [info nameofexecutable] gorp.file]
+ string compare "foo" [exec $tcltest gorp.file]
} 0
# Make sure that background commands are properly reaped when
# they eventually die.
-catch {exec sleep 3}
+exec $tcltest sleep 3
test exec-12.1 {reaping background processes} {unixOnly nonPortable} {
for {set i 0} {$i < 20} {incr i} {
exec echo foo > /dev/null &
@@ -341,7 +415,7 @@ test exec-12.1 {reaping background processes} {unixOnly nonPortable} {
catch {exec ps | fgrep "echo foo" | fgrep -v fgrep | wc} msg
lindex $msg 0
} 0
-test exec-12.2 {reaping background processes} {unixExecs nonPortable} {
+test exec-12.2 {reaping background processes} {unixOnly nonPortable} {
exec sleep 2 | sleep 2 | sleep 2 &
catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg
set x [lindex $msg 0]
@@ -372,11 +446,11 @@ test exec-12.3 {reaping background processes} {unixOnly nonPortable} {
# Make sure "errorCode" is set correctly.
-test exec-13.1 {setting errorCode variable} {unixExecs} {
- list [catch {exec cat < a/b/c} msg] [string tolower $errorCode]
+test exec-13.1 {setting errorCode variable} {
+ list [catch {exec $tcltest cat < a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
-test exec-13.2 {setting errorCode variable} {unixExecs} {
- list [catch {exec cat > a/b/c} msg] [string tolower $errorCode]
+test exec-13.2 {setting errorCode variable} {
+ list [catch {exec $tcltest cat > a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
test exec-13.3 {setting errorCode variable} {
set x [catch {exec _weird_cmd_} msg]
@@ -386,8 +460,8 @@ test exec-13.3 {setting errorCode variable} {
# Switches before the first argument
-test exec-14.1 {-keepnewline switch} {unixExecs} {
- exec -keepnewline echo foo
+test exec-14.1 {-keepnewline switch} {
+ exec -keepnewline $tcltest echo foo
} "foo\n"
test exec-14.2 {-keepnewline switch} {
list [catch {exec -keepnewline} msg] $msg
@@ -401,75 +475,77 @@ test exec-14.4 {-- switch} {
# Redirecting standard error separately from standard output
-test exec-15.1 {standard error redirection} {unixExecs} {
- exec echo "First line" > gorp.file
- list [exec sh -c "echo foo bar 1>&2" 2> gorp.file] \
- [exec cat gorp.file]
+test exec-15.1 {standard error redirection} {
+ exec $tcltest echo "First line" > gorp.file
+ list [exec $tcltest sh -c "echo foo bar 1>&2" 2> gorp.file] \
+ [exec $tcltest cat gorp.file]
} {{} {foo bar}}
-test exec-15.2 {standard error redirection} {unixExecs} {
- list [exec sh -c "echo foo bar 1>&2" | echo biz baz >gorp.file \
- 2> gorp.file2] [exec cat gorp.file] \
- [exec cat gorp.file2]
+test exec-15.2 {standard error redirection} {
+ list [exec $tcltest sh -c "echo foo bar 1>&2" \
+ | $tcltest echo biz baz >gorp.file 2> gorp.file2] \
+ [exec $tcltest cat gorp.file] \
+ [exec $tcltest cat gorp.file2]
} {{} {biz baz} {foo bar}}
-test exec-15.3 {standard error redirection} {unixExecs} {
- list [exec sh -c "echo foo bar 1>&2" | echo biz baz 2>gorp.file \
- > gorp.file2] [exec cat gorp.file] \
- [exec cat gorp.file2]
+test exec-15.3 {standard error redirection} {
+ list [exec $tcltest sh -c "echo foo bar 1>&2" \
+ | $tcltest echo biz baz 2>gorp.file > gorp.file2] \
+ [exec $tcltest cat gorp.file] \
+ [exec $tcltest cat gorp.file2]
} {{} {foo bar} {biz baz}}
-test exec-15.4 {standard error redirection} {unixExecs} {
+test exec-15.4 {standard error redirection} {
set f [open gorp.file w]
puts $f "Line 1"
flush $f
- exec sh -c "echo foo bar 1>&2" 2>@ $f
+ exec $tcltest sh -c "echo foo bar 1>&2" 2>@ $f
puts $f "Line 3"
close $f
- exec cat gorp.file
+ exec $tcltest cat gorp.file
} {Line 1
foo bar
Line 3}
-test exec-15.5 {standard error redirection} {unixExecs} {
- exec echo "First line" > gorp.file
- exec sh -c "echo foo bar 1>&2" 2>> gorp.file
- exec cat gorp.file
+test exec-15.5 {standard error redirection} {
+ exec $tcltest echo "First line" > gorp.file
+ exec $tcltest sh -c "echo foo bar 1>&2" 2>> gorp.file
+ exec $tcltest cat gorp.file
} {First line
foo bar}
-test exec-15.6 {standard error redirection} {unixExecs} {
- exec sh -c "echo foo bar 1>&2" > gorp.file2 2> gorp.file \
- >& gorp.file 2> gorp.file2 | echo biz baz
- list [exec cat gorp.file] [exec cat gorp.file2]
+test exec-15.6 {standard error redirection} {
+ exec $tcltest sh -c "echo foo bar 1>&2" > gorp.file2 2> gorp.file \
+ >& gorp.file 2> gorp.file2 | $tcltest echo biz baz
+ list [exec $tcltest cat gorp.file] [exec $tcltest cat gorp.file2]
} {{biz baz} {foo bar}}
-test exec-16.1 {flush output before exec} {unixExecs} {
+test exec-16.1 {flush output before exec} {
set f [open gorp.file w]
puts $f "First line"
- exec echo "Second line" >@ $f
+ exec $tcltest echo "Second line" >@ $f
puts $f "Third line"
close $f
- exec cat gorp.file
+ exec $tcltest cat gorp.file
} {First line
Second line
Third line}
test exec-16.2 {flush output before exec} {} {
set f [open gorp.file w]
puts $f "First line"
- exec [lindex $tcltest 0] << {puts stderr {Second line}} >&@ $f > gorp.file2
+ exec $tcltest << {puts stderr {Second line}} >&@ $f > gorp.file2
puts $f "Third line"
close $f
- cat gorp.file
+ exec $tcltest cat gorp.file
} {First line
Second line
Third line}
-test exec-17.1 { inheriting standard I/O } {unixOrPc unixExecs} {
+test exec-17.1 { inheriting standard I/O } {
set f [open script w]
puts $f {close stdout
set f [open gorp.file w]
- catch {exec echo foobar &}
- exec sleep 2
+ catch {exec [info nameofexecutable] echo foobar &}
+ exec [info nameofexecutable] sleep 2
close $f
}
close $f
- catch {eval exec $tcltest script} result
+ catch {exec $tcltest script} result
set f [open gorp.file r]
lappend result [read $f]
close $f
@@ -477,8 +553,5 @@ test exec-17.1 { inheriting standard I/O } {unixOrPc unixExecs} {
} {{foobar
}}
-removeFile script
-removeFile gorp.file
-removeFile gorp.file2
-
-return {}
+file delete script gorp.file gorp.file2
+file delete echo cat wc sh sleep exit
diff --git a/contrib/tcl/tests/execute.test b/contrib/tcl/tests/execute.test
index 6c63750..81fde45 100644
--- a/contrib/tcl/tests/execute.test
+++ b/contrib/tcl/tests/execute.test
@@ -13,7 +13,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) execute.test 1.3 97/06/20 14:51:19
+# SCCS: @(#) execute.test 1.5 97/08/12 11:16:31
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -111,3 +111,4 @@ catch {rename { } ""}
catch {unset x}
catch {unset y}
catch {unset msg}
+concat {}
diff --git a/contrib/tcl/tests/expr-old.test b/contrib/tcl/tests/expr-old.test
index e25a1eb..b2f577e 100644
--- a/contrib/tcl/tests/expr-old.test
+++ b/contrib/tcl/tests/expr-old.test
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) expr-old.test 1.59 97/06/26 14:33:32
+# SCCS: @(#) expr-old.test 1.61 97/08/13 10:26:38
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -82,19 +82,17 @@ test expr-old-1.52 {integer operators} {expr +36%+5} 1
# Check the floating-point operators individually, along with
# automatic conversion to integers where needed.
-test expr-old-2.1 {floating-point operators} {format %.6g [expr -4.2]} -4.2
-test expr-old-2.2 {floating-point operators} {
- format %.6g [expr -(1.1+4.2)]
-} -5.3
+test expr-old-2.1 {floating-point operators} {expr -4.2} -4.2
+test expr-old-2.2 {floating-point operators} {expr -(1.1+4.2)} -5.3
test expr-old-2.3 {floating-point operators} {expr +5.7} 5.7
test expr-old-2.4 {floating-point operators} {expr +--+-62.0} -62.0
test expr-old-2.5 {floating-point operators} {expr !2.1} 0
test expr-old-2.6 {floating-point operators} {expr !0.0} 1
-test expr-old-2.7 {floating-point operators} {format %.6g [expr 4.2*6.3]} 26.46
+test expr-old-2.7 {floating-point operators} {expr 4.2*6.3} 26.46
test expr-old-2.8 {floating-point operators} {expr 36.0/12.0} 3.0
test expr-old-2.9 {floating-point operators} {expr 27/4.0} 6.75
-test expr-old-2.10 {floating-point operators} {format %.6g [expr 2.3+2.1]} 4.4
-test expr-old-2.11 {floating-point operators} {format %.6g [expr 2.3-6.5]} -4.2
+test expr-old-2.10 {floating-point operators} {expr 2.3+2.1} 4.4
+test expr-old-2.11 {floating-point operators} {expr 2.3-6.5} -4.2
test expr-old-2.12 {floating-point operators} {expr 3.1>2.1} 1
test expr-old-2.13 {floating-point operators} {expr {2.1 > 2.1}} 0
test expr-old-2.14 {floating-point operators} {expr 1.23>2.34e+1} 0
@@ -119,12 +117,10 @@ test expr-old-2.32 {floating-point operators} {expr 0.0||0.0} 0
test expr-old-2.33 {floating-point operators} {expr 0.0||1.3} 1
test expr-old-2.34 {floating-point operators} {expr 1.3||0.0} 1
test expr-old-2.35 {floating-point operators} {expr 3.3||0.0} 1
-test expr-old-2.36 {floating-point operators} {
- format %.6g [expr 3.3>2.3?44.3:66.3]} 44.3
-test expr-old-2.37 {floating-point operators} {
- format %.6g [expr 2.3>3.3?44.3:66.3]} 66.3
+test expr-old-2.36 {floating-point operators} {expr 3.3>2.3?44.3:66.3} 44.3
+test expr-old-2.37 {floating-point operators} {expr 2.3>3.3?44.3:66.3} 66.3
test expr-old-2.38 {floating-point operators} {
- list [catch {format %.6g [expr 028.1 + 09.2]} msg] $msg
+ list [catch {expr 028.1 + 09.2} msg] $msg
} {0 37.3}
# Operators that aren't legal on floating-point numbers
@@ -385,7 +381,7 @@ test expr-old-24.2 {numbers in different bases} {expr 015} 13
test expr-old-25.1 {type conversions} {expr 2+2.5} 4.5
test expr-old-25.2 {type conversions} {expr 2.5+2} 4.5
test expr-old-25.3 {type conversions} {expr 2-2.5} -0.5
-test expr-old-25.4 {type conversions} {format %.6g [expr 2/2.5]} 0.8
+test expr-old-25.4 {type conversions} {expr 2/2.5} 0.8
test expr-old-25.5 {type conversions} {expr 2>2.5} 0
test expr-old-25.6 {type conversions} {expr 2.5>2} 1
test expr-old-25.7 {type conversions} {expr 2<2.5} 1
@@ -400,7 +396,7 @@ test expr-old-25.15 {type conversions} {expr {24.1 > "24.1a"}} 0
test expr-old-25.16 {type conversions} {expr 2+2.5} 4.5
test expr-old-25.17 {type conversions} {expr 2+2.5} 4.5
test expr-old-25.18 {type conversions} {expr 2.0e2} 200.0
-test expr-old-25.19 {type conversions} {format %.6g [expr 2.0e15]} 2e+15
+test expr-old-25.19 {type conversions} {expr 2.0e15} 2e+15
test expr-old-25.20 {type conversions} {expr 10.0} 10.0
# Various error conditions.
@@ -589,7 +585,7 @@ test expr-old-28.14 {Tcl_ExprBool usage} {
test expr-old-29.1 {braces} {expr {{abc}}} abc
test expr-old-29.2 {braces} {expr {{00010}}} 8
-test expr-old-29.3 {braces} {format %.6g [expr {{3.1200000}}]} 3.12
+test expr-old-29.3 {braces} {expr {{3.1200000}}} 3.12
test expr-old-29.4 {braces} {expr {{a{b}{1 {2 3}}c}}} "a{b}{1 {2 3}}c"
test expr-old-29.5 {braces} {
list [catch {expr "\{abc"} msg] $msg
@@ -705,7 +701,7 @@ test expr-old-32.26 {math functions in expressions} {
expr double(1)
} {1.0}
test expr-old-32.27 {math functions in expressions} {
- format %.6g [expr double(1.1)]
+ expr double(1.1)
} {1.1}
test expr-old-32.28 {math functions in expressions} {
expr int(1)
@@ -861,11 +857,11 @@ test expr-old-36.2 {ExprLooksLikeInt procedure} {
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-36.3 {ExprLooksLikeInt procedure} {
- list [catch {format %.6g [expr 0289.1]} msg] $msg
+ list [catch {expr 0289.1} msg] $msg
} {0 289.1}
test expr-old-36.4 {ExprLooksLikeInt procedure} {
set x 0289.1
- list [catch {format %.6g [expr {$x+1}]} msg] $msg
+ list [catch {expr {$x+1}} msg] $msg
} {0 290.1}
test expr-old-36.5 {ExprLooksLikeInt procedure} {
set x { +22}
@@ -892,6 +888,10 @@ test expr-old-37.1 {Check that Tcl_ExprLong doesn't modify interpreter result if
testexprlong
} {This is a result: 5}
+test expr-old-38.1 {Verify Tcl_ExprString's basic operation} {
+ list [testexprstring "1+4"] [testexprstring "2*3+4.2"] \
+ [catch {testexprstring "1+"} msg] $msg
+} {5 10.2 1 {syntax error in expression "1+"}}
# Special test for Pentium arithmetic bug of 1994:
diff --git a/contrib/tcl/tests/expr.test b/contrib/tcl/tests/expr.test
index 481e3ab..e0825f9 100644
--- a/contrib/tcl/tests/expr.test
+++ b/contrib/tcl/tests/expr.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) expr.test 1.29 97/06/23 18:46:25
+# SCCS: @(#) expr.test 1.33 97/08/07 10:45:57
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -77,7 +77,7 @@ test expr-1.2 {TclCompileExprCmd: one expression word} {
expr -25
} -25
test expr-1.3 {TclCompileExprCmd: two expression words} {
- format %.6g [expr -8.2 -6]
+ expr -8.2 -6
} -14.2
test expr-1.4 {TclCompileExprCmd: five expression words} {
expr 20 - 5 +10 -7
@@ -117,6 +117,11 @@ test expr-1.13 {TclCompileExprCmd: second level of substitutions in expr not in
set x 27; set bool {$x}; if $bool {set a foo}
set a
} foo
+test expr-1.14 {TclCompileExprCmd: second level of substitutions in expr with comparison as top-level operator} {
+ set a xxx
+ set x 2; set b {$x}; set a [expr $b == 2]
+ set a
+} 1
test expr-2.1 {TclCompileExpr: are builtin functions registered?} {
expr double(5*[llength "6 2"])
@@ -426,7 +431,7 @@ test expr-14.3 {CompilePrimaryExpr: literal primary} {expr 0xff} 255
test expr-14.4 {CompilePrimaryExpr: literal primary} {expr 00010} 8
test expr-14.5 {CompilePrimaryExpr: literal primary} {expr 62.0} 62.0
test expr-14.6 {CompilePrimaryExpr: literal primary} {
- format %.6g [expr 3.1400000]
+ expr 3.1400000
} 3.14
test expr-14.7 {CompilePrimaryExpr: literal primary} {expr {{abcde}<{abcdef}}} 1
test expr-14.8 {CompilePrimaryExpr: literal primary} {expr {{abc\
@@ -466,7 +471,7 @@ test expr-14.16 {CompilePrimaryExpr: error compiling var reference primary} {
} {missing )
(parsing index for array "a")
while compiling
-"expr"}
+"expr {$a(foo}"}
test expr-14.17 {CompilePrimaryExpr: string primary that looks like var ref} {
expr $
} $
@@ -476,12 +481,12 @@ test expr-14.18 {CompilePrimaryExpr: quoted string primary} {
test expr-14.19 {CompilePrimaryExpr: quoted string primary} {
set i 123
set x 456
- format %.6g [expr "$i+$x"]
+ expr "$i+$x"
} 579
test expr-14.20 {CompilePrimaryExpr: quoted string primary} {
set i 3
set x 6
- format %.6g [expr 2+"$i.$x"]
+ expr 2+"$i.$x"
} 5.6
test expr-14.21 {CompilePrimaryExpr: error in quoted string primary} {
catch {expr "[set]"} msg
@@ -497,15 +502,15 @@ test expr-14.23 {CompilePrimaryExpr: error in subcommand primary} {
while compiling
"set"
while compiling
-"expr"}
+"expr {[set]}"}
test expr-14.24 {CompilePrimaryExpr: error in subcommand primary} {
catch {expr {[set i}} msg
set errorInfo
} {missing close-bracket or close-brace
while compiling
-"set"
+"set i"
while compiling
-"expr"}
+"expr {[set i}"}
test expr-14.25 {CompilePrimaryExpr: math function primary} {
format %.6g [expr exp(1.0)]
} 2.71828
@@ -528,7 +533,7 @@ test expr-14.29 {CompilePrimaryExpr: error in subexpression primary} {
while compiling
"set"
while compiling
-"expr"}
+"expr 2+(3*[set])"}
test expr-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} {
catch {expr 2+(3*(4+5)} msg
set errorInfo
diff --git a/contrib/tcl/tests/fCmd.test b/contrib/tcl/tests/fCmd.test
index f53da0c..e7d2279 100644
--- a/contrib/tcl/tests/fCmd.test
+++ b/contrib/tcl/tests/fCmd.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) fCmd.test 1.30 97/06/23 17:29:36
+# SCCS: @(#) fCmd.test 1.31 97/08/05 11:42:09
#
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -468,7 +468,10 @@ test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} {
file mkdir td2
list [catch {file rename -force td2 td1} msg] $msg
} [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}]
-test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} {
+test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} {!$testConfig(win32s) || ($root == "C:/")} {
+ # Don't run this test under Win32s on a drive mounted from an NT
+ # machine; it causes the NT machine to die.
+
cleanup
list [catch {file rename -force $root tf1} msg] $msg
} [subst {1 {error renaming "$root" to "tf1": trying to rename a volume or move a directory into itself}}]
diff --git a/contrib/tcl/tests/fileName.test b/contrib/tcl/tests/fileName.test
index f7f4594..f6be5ac 100644
--- a/contrib/tcl/tests/fileName.test
+++ b/contrib/tcl/tests/fileName.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) fileName.test 1.28 97/06/23 17:30:15
+# SCCS: @(#) fileName.test 1.30 97/08/01 11:13:27
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -1089,34 +1089,34 @@ test filename-11.13 {Tcl_GlobCmd} {
list [catch {file join [lindex [glob ~] 0]} msg] $msg
} [list 0 [file join $env(HOME)]]
-# The following tests will work on Windows platforms only if MKS
-# toolkit is installed.
+set oldhome $env(HOME)
+set env(HOME) [pwd]
+file delete -force globTest
+file mkdir globTest/a1/b1
+file mkdir globTest/a1/b2
+file mkdir globTest/a2/b3
+file mkdir globTest/a3
+close [open globTest/x1.c w]
+close [open globTest/y1.c w]
+close [open globTest/z1.c w]
+close [open "globTest/weird name.c" w]
+close [open globTest/a1/b1/x2.c w]
+close [open globTest/a1/b2/y2.c w]
-catch {
- set oldhome $env(HOME)
- set env(HOME) [pwd]
- file delete -force globTest
- file mkdir globTest/a1/b1
- file mkdir globTest/a1/b2
- file mkdir globTest/a2/b3
- file mkdir globTest/a3
- close [open globTest/x1.c w]
- close [open globTest/y1.c w]
- close [open globTest/z1.c w]
- close [open globTest/x,z1.c w]
- close [open "globTest/weird name.c" w]
- close [open globTest/.1 w]
- close [open globTest/a1/b1/x2.c w]
- close [open globTest/a1/b2/y2.c w]
-}
+# Cannot create a file with the following names under Win32s. We have to
+# skip the tests that are checking the difference between a "." or "," in
+# the file name vs. a "." or "," in the glob pattern.
+
+catch {close [open globTest/.1 w]}
+catch {close [open globTest/x,z1.c w]}
-test filename-11.14 {Tcl_GlobCmd} {unixExecs} {
+test filename-11.14 {Tcl_GlobCmd} {
list [catch {glob ~/globTest} msg] $msg
} [list 0 [list [file join $env(HOME) globTest]]]
-test filename-11.15 {Tcl_GlobCmd} {unixExecs} {
+test filename-11.15 {Tcl_GlobCmd} {
list [catch {glob ~\\/globTest} msg] $msg
} [list 0 [list [file join $env(HOME) globTest]]]
-test filename-11.16 {Tcl_GlobCmd} {unixExecs} {
+test filename-11.16 {Tcl_GlobCmd} {
list [catch {glob globTest} msg] $msg
} {0 globTest}
@@ -1140,14 +1140,14 @@ set y1 y1.c
test filename-12.4 {simple globbing} {unixOrPc} {
lsort [glob globTest/x1.c globTest/y1.c globTest/foo]
} "$globPreResult$x1 $globPreResult$y1"
-test filename-12.5 {simple globbing} {unixExecs} {
+test filename-12.5 {simple globbing} {
list [catch {glob globTest\\/x1.c} msg] $msg
} "0 $globPreResult$x1"
-test filename-12.6 {simple globbing} {unixExecs} {
+test filename-12.6 {simple globbing} {
list [catch {glob globTest\\/\\x1.c} msg] $msg
} "0 $globPreResult$x1"
-test filename-13.1 {globbing with brace substitution} {unixExecs} {
+test filename-13.1 {globbing with brace substitution} {
list [catch {glob globTest/\{\}} msg] $msg
} "0 $globPreResult"
test filename-13.2 {globbing with brace substitution} {
@@ -1162,107 +1162,119 @@ test filename-13.4 {globbing with brace substitution} {
test filename-13.5 {globbing with brace substitution} {
list [catch {glob globTest/\}} msg] $msg
} {1 {unmatched close-brace in file name}}
-test filename-13.6 {globbing with brace substitution} {unixExecs} {
+test filename-13.6 {globbing with brace substitution} {
list [catch {glob globTest/\{\}x1.c} msg] $msg
} "0 $globPreResult$x1"
-test filename-13.7 {globbing with brace substitution} {unixExecs} {
+test filename-13.7 {globbing with brace substitution} {
list [catch {glob globTest/\{x\}1.c} msg] $msg
} "0 $globPreResult$x1"
-test filename-13.8 {globbing with brace substitution} {unixExecs} {
+test filename-13.8 {globbing with brace substitution} {
list [catch {glob globTest/\{x\{\}\}1.c} msg] $msg
} "0 $globPreResult$x1"
-test filename-13.9 {globbing with brace substitution} {unixExecs} {
+test filename-13.9 {globbing with brace substitution} {!win32s} {
list [lsort [catch {glob globTest/\{x,y\}1.c} msg]] $msg
} [list 0 [list $globPreResult$x1 $globPreResult$y1]]
-test filename-13.10 {globbing with brace substitution} {unixExecs} {
+test filename-13.10 {globbing with brace substitution} {!win32s} {
list [lsort [catch {glob globTest/\{x,,y\}1.c} msg]] $msg
} [list 0 [list $globPreResult$x1 $globPreResult$y1]]
-test filename-13.11 {globbing with brace substitution} {unixOrPc unixExecs} {
+test filename-13.11 {globbing with brace substitution} {unixOrPc && !win32s} {
list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg
} {0 {globTest/x1.c globTest/x,z1.c globTest/z1.c}}
test filename-13.12 {globbing with brace substitution} {macOnly} {
list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg
} {0 {:globTest:x1.c :globTest:x,z1.c :globTest:z1.c}}
-test filename-13.13 {globbing with brace substitution} {unixExecs} {
+test filename-13.13 {globbing with brace substitution} {
lsort [glob globTest/{a,b,x,y}1.c]
} [list $globPreResult$x1 $globPreResult$y1]
-test filename-13.14 {globbing with brace substitution} {unixOrPc unixExecs} {
+test filename-13.14 {globbing with brace substitution} {unixOrPc} {
lsort [glob {globTest/{x1,y2,weird name}.c}]
} {{globTest/weird name.c} globTest/x1.c}
test filename-13.15 {globbing with brace substitution} {macOnly} {
lsort [glob {globTest/{x1,y2,weird name}.c}]
} {{:globTest:weird name.c} :globTest:x1.c}
-test filename-13.16 {globbing with brace substitution} {unixOrPc unixExecs} {
+test filename-13.16 {globbing with brace substitution} {unixOrPc} {
lsort [glob globTest/{x1.c,a1/*}]
} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c}
test filename-13.17 {globbing with brace substitution} {macOnly} {
lsort [glob globTest/{x1.c,a1/*}]
} {:globTest:a1:b1 :globTest:a1:b2 :globTest:x1.c}
-test filename-13.18 {globbing with brace substitution} {unixOrPc unixExecs} {
+test filename-13.18 {globbing with brace substitution} {unixOrPc} {
lsort [glob globTest/{x1.c,{a},a1/*}]
} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c}
test filename-13.19 {globbing with brace substitution} {macOnly} {
lsort [glob globTest/{x1.c,{a},a1/*}]
} {:globTest:a1:b1 :globTest:a1:b2 :globTest:x1.c}
-test filename-13.20 {globbing with brace substitution} {unixOrPc unixExecs} {
+test filename-13.20 {globbing with brace substitution} {unixOrPc} {
lsort [glob globTest/{a,x}1/*/{x,y}*]
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
test filename-13.21 {globbing with brace substitution} {macOnly} {
lsort [glob globTest/{a,x}1/*/{x,y}*]
} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c}
-test filename-13.22 {globbing with brace substitution} {unixExecs} {
+test filename-13.22 {globbing with brace substitution} {
list [catch {glob globTest/\{a,x\}1/*/\{} msg] $msg
} {1 {unmatched open-brace in file name}}
-test filename-14.1 {asterisks, question marks, and brackets} {unixExecs unixOrPc} {
+test filename-14.1 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
lsort [glob g*/*.c]
} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
+test filename-14.1 {asterisks, question marks, and brackets} {win32s} {
+ lsort [glob g*/*.c]
+} {globtest/weirdn~1.c globtest/x1.c globtest/y1.c globtest/z1.c}
test filename-14.2 {asterisks, question marks, and brackets} {macOnly} {
lsort [glob g*/*.c]
} {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}
-test filename-14.3 {asterisks, question marks, and brackets} {unixExecs unixOrPc} {
+test filename-14.3 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob globTest/?1.c]
} {globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.4 {asterisks, question marks, and brackets} {macOnly} {
lsort [glob globTest/?1.c]
} {:globTest:x1.c :globTest:y1.c :globTest:z1.c}
-test filename-14.5 {asterisks, question marks, and brackets} {unixExecs unixOrPc} {
+test filename-14.5 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
lsort [glob */*/*/*.c]
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
+test filename-14.5 {asterisks, question marks, and brackets} {win32s} {
+ lsort [glob */*/*/*.c]
+} {globtest/a1/b1/x2.c globtest/a1/b2/y2.c}
test filename-14.6 {asterisks, question marks, and brackets} {macOnly} {
lsort [glob */*/*/*.c]
} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c}
-test filename-14.7 {asterisks, question marks, and brackets} {unixExecs unixOrPc} {
+test filename-14.7 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
lsort [glob globTest/*]
} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
+test filename-14.7 {asterisks, question marks, and brackets} {win32s} {
+ lsort [glob globTest/*]
+} {globTest/a1 globTest/a2 globTest/a3 globTest/weirdn~1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.8 {asterisks, question marks, and brackets} {macOnly} {
lsort [glob globTest/*]
} {:globTest:.1 :globTest:a1 :globTest:a2 :globTest:a3 {:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}
-test filename-14.9 {asterisks, question marks, and brackets} {unixExecs unixOrPc} {
+test filename-14.9 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
lsort [glob globTest/.*]
} {globTest/. globTest/.. globTest/.1}
+test filename-14.9 {asterisks, question marks, and brackets} {win32s} {
+ lsort [glob globTest/.*]
+} {globTest/. globTest/..}
test filename-14.10 {asterisks, question marks, and brackets} {macOnly} {
lsort [glob globTest/.*]
} {:globTest:.1}
-test filename-14.11 {asterisks, question marks, and brackets} {unixExecs unixOrPc} {
+test filename-14.11 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob globTest/*/*]
} {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3}
test filename-14.12 {asterisks, question marks, and brackets} {macOnly} {
lsort [glob globTest/*/*]
} {:globTest:a1:b1 :globTest:a1:b2 :globTest:a2:b3}
-test filename-14.13 {asterisks, question marks, and brackets} {unixExecs unixOrPc} {
+test filename-14.13 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob {globTest/[xyab]1.*}]
} {globTest/x1.c globTest/y1.c}
test filename-14.14 {asterisks, question marks, and brackets} {macOnly} {
lsort [glob {globTest/[xyab]1.*}]
} {:globTest:x1.c :globTest:y1.c}
-test filename-14.15 {asterisks, question marks, and brackets} {unixExecs unixOrPc} {
+test filename-14.15 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob globTest/*/]
} {globTest/a1/ globTest/a2/ globTest/a3/}
test filename-14.16 {asterisks, question marks, and brackets} {macOnly} {
lsort [glob globTest/*/]
} {:globTest:a1: :globTest:a2: :globTest:a3:}
-test filename-14.17 {asterisks, question marks, and brackets} {unixExecs} {
+test filename-14.17 {asterisks, question marks, and brackets} {
global env
set temp $env(HOME)
set env(HOME) [file join $env(HOME) globTest]
@@ -1270,9 +1282,12 @@ test filename-14.17 {asterisks, question marks, and brackets} {unixExecs} {
set env(HOME) $temp
set result
} [list 0 [list [file join $env(HOME) globTest z1.c]]]
-test filename-14.18 {asterisks, question marks, and brackets} {unixExecs unixOrPc} {
+test filename-14.18 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg
} {0 {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}}
+test filename-14.18 {asterisks, question marks, and brackets} {win32s} {
+ list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg
+} {0 {globTest/weirdn~1.c globTest/x1.c globTest/y1.c globTest/z1.c}}
test filename-14.19 {asterisks, question marks, and brackets} {macOnly} {
list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg
} {0 {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}}
@@ -1303,10 +1318,9 @@ if {$tcl_platform(platform) == "unix"} {
string tolower [list [catch {glob globTest/*} msg] $msg $errorCode]
} {1 {couldn't read directory "globtest": permission denied} {posix eacces {permission denied}}}
exec chmod 755 globTest
-
- test filename-15.2 {unix specific globbing} {nonPortable} {
- glob ~ouster/.csh*
- } "/home/ouster/.cshrc"
+ test filename-15.2 {unix specific globbing} {nonPortable} {
+ glob ~ouster/.csh*
+ } "/home/ouster/.cshrc"
close [open globTest/odd\\\[\]*?\{\}name w]
test filename-15.3 {unix specific globbing} {
global env
@@ -1332,44 +1346,67 @@ if {$tcl_platform(platform) == "windows"} {
close [open globTest/z1.bat w]
}
- test filename-16.1 {windows specific globbing} {unixExecs} {
+ test filename-16.1 {windows specific globbing} {!win32s} {
lsort [glob globTest/*.bat]
} {globTest/x1.BAT globTest/y1.Bat globTest/z1.bat}
+ test filename-16.1 {windows specific globbing} {win32s} {
+ lsort [glob globTest/*.bat]
+ } {globTest/x1.bat globTest/y1.bat globTest/z1.bat}
test filename-16.2 {windows specific globbing} {
glob c:
} c:
- test filename-16.3 {windows specific globbing} {unixExecs} {
+ test filename-16.3 {windows specific globbing} {
glob c:\\\\
} c:/
test filename-16.4 {windows specific globbing} {
glob c:/
} c:/
- test filename-16.5 {windows specific globbing} {unixExecs} {
+ test filename-16.5 {windows specific globbing} {!win32s} {
glob c:*Test
} c:globTest
- test filename-16.6 {windows specific globbing} {unixExecs} {
+ test filename-16.5 {windows specific globbing} {win32s} {
+ glob c:*Test
+ } c:globtest
+ test filename-16.6 {windows specific globbing} {!win32s} {
glob c:\\\\*Test
} c:/globTest
- test filename-16.7 {windows specific globbing} {unixExecs} {
+ test filename-16.6 {windows specific globbing} {win32s} {
+ glob c:\\\\*Test
+ } c:/globtest
+ test filename-16.7 {windows specific globbing} {!win32s} {
glob c:/*Test
} c:/globTest
- test filename-16.8 {windows specific globbing} {unixExecs} {
+ test filename-16.7 {windows specific globbing} {win32s} {
+ glob c:/*Test
+ } c:/globtest
+ test filename-16.8 {windows specific globbing} {!win32s} {
lsort [glob c:globTest/*.bat]
} {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat}
- test filename-16.9 {windows specific globbing} {unixExecs} {
+ test filename-16.8 {windows specific globbing} {win32s} {
+ lsort [glob c:globTest/*.bat]
+ } {c:globTest/x1.bat c:globTest/y1.bat c:globTest/z1.bat}
+ test filename-16.9 {windows specific globbing} {!win32s} {
lsort [glob c:/globTest/*.bat]
} {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat}
- test filename-16.10 {windows specific globbing} {unixExecs} {
+ test filename-16.9 {windows specific globbing} {win32s} {
+ lsort [glob c:/globTest/*.bat]
+ } {c:/globTest/x1.bat c:/globTest/y1.bat c:/globTest/z1.bat}
+ test filename-16.10 {windows specific globbing} {!win32s} {
lsort [glob c:globTest\\\\*.bat]
} {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat}
- test filename-16.11 {windows specific globbing} {unixExecs} {
+ test filename-16.10 {windows specific globbing} {win32s} {
+ lsort [glob c:globTest\\\\*.bat]
+ } {c:globTest/x1.bat c:globTest/y1.bat c:globTest/z1.bat}
+ test filename-16.11 {windows specific globbing} {!win32s} {
lsort [glob c:\\\\globTest\\\\*.bat]
} {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat}
+ test filename-16.11 {windows specific globbing} {win32s} {
+ lsort [glob c:\\\\globTest\\\\*.bat]
+ } {c:/globTest/x1.bat c:/globTest/y1.bat c:/globTest/z1.bat}
removeDirectory globTest
- if $testConfig(nonPortable) {
- cd //gaspode/d
+ if {($testConfig(nonPortable) != 0) && [catch {cd //gaspode/d}] == 0} {
removeDirectory globTest
makeDirectory globTest
diff --git a/contrib/tcl/tests/for.test b/contrib/tcl/tests/for.test
index 7b518fe..aa918ec 100644
--- a/contrib/tcl/tests/for.test
+++ b/contrib/tcl/tests/for.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) for.test 1.9 97/06/23 18:40:35
+# SCCS: @(#) for.test 1.10 97/07/02 16:40:59
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -22,7 +22,7 @@ test for-1.2 {TclCompileForCmd: error in initial command} {
list [catch {for {set}} msg] $msg $errorInfo
} {1 {wrong # args: should be "for start test next command"} {wrong # args: should be "for start test next command"
while compiling
-"for"}}
+"for {set}"}}
catch {unset i}
test for-1.3 {TclCompileForCmd: missing test expression} {
catch {for {set i 0}} msg
@@ -33,7 +33,7 @@ test for-1.4 {TclCompileForCmd: error in test expression} {
set errorInfo
} {wrong # args: should be "for start test next command"
while compiling
-"for"}
+"for {set i 0} {$i<}"}
test for-1.5 {TclCompileForCmd: test expression is enclosed in quotes} {
set i 0
for {} "$i > 5" {incr i} {}
@@ -54,7 +54,7 @@ test for-1.8 {TclCompileForCmd: error compiling command body} {
"set"
("for" body line 1)
while compiling
-"for"}
+"for {set i 0} {$i < 5} {incr i} {set}"}
catch {unset a}
test for-1.9 {TclCompileForCmd: simple command body} {
set a {}
@@ -88,7 +88,7 @@ test for-1.12 {TclCompileForCmd: error in "next" command} {
"set"
("for" loop-end command)
while compiling
-"for"}
+"for {set i 0} {$i < 5} {set} {puts $i}"}
test for-1.13 {TclCompileForCmd: long command body} {
set a {}
for {set i 1} {$i<6} {set i [expr $i+1]} {
diff --git a/contrib/tcl/tests/foreach.test b/contrib/tcl/tests/foreach.test
index 64fffc5..f87dd39 100644
--- a/contrib/tcl/tests/foreach.test
+++ b/contrib/tcl/tests/foreach.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) foreach.test 1.7 97/06/23 18:23:42
+# SCCS: @(#) foreach.test 1.8 97/08/12 18:19:27
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -157,6 +157,15 @@ test foreach-3.1 {compiled foreach backward jump works correctly} {
foo x
} {{0 zero} {1 one} {2 two} {3 three}}
+test foreach-4.1 {noncompiled foreach and shared variable or value list objects that are converted to another type} {
+ catch {unset x}
+ foreach {12.0} {a b c} {
+ set x 12.0
+ set x [expr $x + 1]
+ }
+ set x
+} 13.0
+
# Check "continue".
test foreach-4.1 {continue tests} {catch continue} 4
diff --git a/contrib/tcl/tests/format.test b/contrib/tcl/tests/format.test
index 219327b..680b626 100644
--- a/contrib/tcl/tests/format.test
+++ b/contrib/tcl/tests/format.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) format.test 1.24 96/10/08 17:40:55
+# SCCS: @(#) format.test 1.28 97/08/11 14:45:15
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -302,11 +302,15 @@ test format-7.22 {error conditions} {
catch {format %d} msg
set msg
} {not enough arguments for all format specifiers}
+test format-7.23 {error conditions} {
+ catch {format "%d %d" 24 xyz} msg
+ set msg
+} {expected integer but got "xyz"}
test format-8.1 {long result} {
set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
- format {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG %s %s %s} $a $a $a
-} {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
+ format {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG %s %s} $a $a
+} {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
test format-9.1 {"h" format specifier} {nonPortable} {
format %hd 0xffff
@@ -358,3 +362,57 @@ test format-10.12 {XPG3 %$n specifiers} {
test format-11.1 {negative width specifiers} {
format "%*d" -47 25
} {25}
+test format-12.1 {tcl_precision fuzzy comparison} {
+ catch {unset a}
+ catch {unset b}
+ catch {unset c}
+ catch {unset d}
+ set a 0.0000000000001
+ set b 0.00000000000001
+ set c 0.00000000000000001
+ set d [expr $a + $b + $c]
+ format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d
+} {0.0000000000 0.000000000000 0.000000000000110 0.00000000000011001}
+test format-12.2 {tcl_precision fuzzy comparison} {
+ catch {unset a}
+ catch {unset b}
+ catch {unset c}
+ catch {unset d}
+ set a 0.000000000001
+ set b 0.000000000000005
+ set c 0.0000000000000008
+ set d [expr $a + $b + $c]
+ format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d
+} {0.0000000000 0.000000000001 0.000000000001006 0.00000000000100580}
+test format-12.3 {tcl_precision fuzzy comparison} {
+ catch {unset a}
+ catch {unset b}
+ catch {unset c}
+ set a 0.00000000000099
+ set b 0.000000000000011
+ set c [expr $a + $b]
+ format {%0.10f %0.12f %0.15f %0.17f} $c $c $c $c
+} {0.0000000000 0.000000000001 0.000000000001001 0.00000000000100100}
+test format-12.4 {tcl_precision fuzzy comparison} {
+ catch {unset a}
+ catch {unset b}
+ catch {unset c}
+ set a 0.444444444444
+ set b 0.33333333333333
+ set c [expr $a + $b]
+ format {%0.10f %0.12f %0.15f %0.16f} $c $c $c $c
+} {0.7777777778 0.777777777777 0.777777777777330 0.7777777777773300}
+test format-12.5 {tcl_precision fuzzy comparison} {
+ catch {unset a}
+ catch {unset b}
+ catch {unset c}
+ set a 0.444444444444
+ set b 0.99999999999999
+ set c [expr $a + $b]
+ format {%0.10f %0.12f %0.15f} $c $c $c
+} {1.4444444444 1.444444444444 1.444444444443990}
+catch {unset a}
+catch {unset b}
+catch {unset c}
+catch {unset d}
+return
diff --git a/contrib/tcl/tests/history.test b/contrib/tcl/tests/history.test
index 1d30955..498fb2e 100644
--- a/contrib/tcl/tests/history.test
+++ b/contrib/tcl/tests/history.test
@@ -10,9 +10,9 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) history.test 1.12 96/03/11 18:06:04
+# SCCS: @(#) history.test 1.15 97/08/13 14:37:10
-if {[info commands history] == ""} {
+if {[catch {history}]} {
puts stdout "This version of Tcl was built without the history command;\n"
puts stdout "history tests will be skipped.\n"
return
@@ -94,7 +94,7 @@ test history-3.9 {add option} {
history change "A test value"
test history-4.1 {change option} {history event [expr {[history n]-1}]} \
"A test value"
-history c "Another test" -1
+history ch "Another test" -1
test history-4.2 {change option} {history e} "Another test"
test history-4.3 {change option} {history event [expr {[history n]-1}]} \
"A test value"
@@ -106,10 +106,11 @@ test history-4.5 {change option} {
test history-4.6 {change option} {
catch {history change Foo [expr {[history n]-4}]}
} 1
+set num [expr {[history n]-4}]
test history-4.7 {change option} {
- catch {history change Foo [expr {[history n]-4}]}
+ catch {history change Foo $num} msg
set msg
-} {wrong # args: should be "history change newValue ?event?"}
+} "event \"$num\" is too far in the past"
# "history info"
@@ -162,17 +163,20 @@ test history-6.10 {keep option} {catch {history keep 4 6}} 1
test history-6.11 {keep option} {
catch {history keep 4 6} msg
set msg
-} {wrong # args: should be "history keep number"}
-test history-6.12 {keep option} {catch {history keep}} 1
+} {wrong # args: should be "history keep ?count?"}
+test history-6.12 {keep option} {catch {history keep}} 0
test history-6.13 {keep option} {
- catch {history keep} msg
- set msg
-} {wrong # args: should be "history keep number"}
+ history keep
+} {5}
test history-6.14 {keep option} {catch {history keep -3}} 1
test history-6.15 {keep option} {
catch {history keep -3} msg
set msg
} {illegal keep count "-3"}
+test history-6.16 {keep option} {
+ catch {history keep butter} msg
+ set msg
+} {illegal keep count "butter"}
# "history nextid"
@@ -187,200 +191,21 @@ test history-7.4 {nextid option} {
set msg
} {wrong # args: should be "history nextid"}
-# "history substitute"
-
-test history-8.1 {substitute option} {
- history add "set a {test foo test b c test}"
- history add "Test command 2"
- set a 0
- history substitute foo bar -1
- set a
-} {test bar test b c test}
-test history-8.2 {substitute option} {
- history add "set a {test foo test b c test}"
- history add "Test command 2"
- set a 0
- history substitute test gorp
- set a
-} {gorp foo gorp b c gorp}
-test history-8.3 {substitute option} {
- history add "set a {test foo test b c test}"
- history add "Test command 2"
- set a 0
- history sub " te" to
- set a
-} {test footost b ctost}
-test history-8.4 {substitute option} {catch {history sub xxx yyy}} 1
-test history-8.5 {substitute option} {
- catch {history sub xxx yyy} msg
- set msg
-} {"xxx" doesn't appear in event}
-test history-8.6 {substitute option} {catch {history s a b -10}} 1
-test history-8.7 {substitute option} {
- catch {history s a b -10} msg
- set msg
-} {event "-10" is too far in the past}
-test history-8.8 {substitute option} {catch {history s a b -1 20}} 1
-test history-8.9 {substitute option} {
- catch {history s a b -1 20} msg
- set msg
-} {wrong # args: should be "history substitute old new ?event?"}
+# "history clear"
-# "history words"
-
-test history-9.1 {words option} {
- history add {word0 word1 word2 a b c word6}
- history add foo
- history words 0-$
-} {word0 word1 word2 a b c word6}
-test history-9.2 {words option} {
- history add {word0 word1 word2 a b c word6}
- history add foo
- history w 2 -1
-} word2
-test history-9.3 {words option} {
- history add {word0 word1 word2 a b c word6}
- history add foo
- history wo $
-} word6
-test history-9.4 {words option} {catch {history w 1--1} msg} 1
-test history-9.5 {words option} {
- catch {history w 1--1} msg
- set msg
-} {bad word selector "1--1": should be num-num or pattern}
-test history-9.6 {words option} {
- history add {word0 word1 word2 a b c word6}
- history add foo
- history w w
-} {}
-test history-9.7 {words option} {
- history add {word0 word1 word2 a b c word6}
- history add foo
- history w *2
-} word2
-test history-9.8 {words option} {
- history add {word0 word1 word2 a b c word6}
- history add foo
- history w *or*
-} {word0 word1 word2 word6}
-test history-9.9 {words option} {catch {history words 10}} 1
-test history-9.10 {words option} {
- catch {history words 10} msg
- set msg
-} {word selector "10" specified non-existent words}
-test history-9.11 {words option} {catch {history words 1 -1 20}} 1
-test history-9.12 {words option} {
- catch {history words 1 -1 20} msg
- set msg
-} {wrong # args: should be "history words num-num/pat ?event?"}
-
-# history revision
-
-test history-10.1 {history revision} {
- set a 0
- history a {set a 12345}
- history a {set a [history e]} exec
- set a
-} {set a 12345}
-test history-10.2 {history revision} {notIfCompiled} {
- set a 0
- history a {set a 12345}
- history a {set a [history e]} exec
- history a foo
- history ev -1
-} {set a {set a 12345}}
-test history-10.3 {history revision} {notIfCompiled} {
- set a 0
- history a {set a 12345}
- history a {set a [history e]} exec
- history a foo
- history a {history r -2} exec
- history a {set a 12345}
- history ev -1
-} {set a {set a 12345}}
-test history-10.4 {history revision} {notIfCompiled} {
- history a {set a 12345}
- history a {history s 123 999} exec
- history a foo
- history ev -1
-} {set a 99945}
-test history-10.5 {history revision} {
- history add {word0 word1 word2 a b c word6}
- history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec
- set a
-} {word0 {a b}}
-test history-10.6 {history revision} {notIfCompiled} {
- history add {word0 word1 word2 a b c word6}
- history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec
- history add foo
- history ev
-} {set a [list word0 {a b}]}
-test history-10.7 {history revision} {notIfCompiled} {
- history add {word0 word1 word2 a b c word6}
- history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec
- history add {format b}
- history add {word0 word1 word2 a b c word6}
- set a 0
- history add {set [history subs b a -2] [list abc [history r -2] [history w 1-3]]} exec
- history add foo
- history ev
-} {set [format a] [list abc [format b] {word1 word2 a}]}
-test history-10.8 {history revision} {notIfCompiled} {
- history add {set a 12345}
- concat a b c
- history add {history redo; set b 44} exec
- history add foo
- history ev
-} {set a 12345; set b 44}
-test history-10.9 {history revision} {
- history add {set a 12345}
- history add {history redo; history change "A simple test"; history subs 45 xx} exec
- set a
-} 123xx
-test history-10.10 {history revision} {
- history add {set a 12345}
- history add {history redo; history change "A simple test"; history subs 45 xx} exec
- history add foo
- history e
-} {A simple test}
-test history-10.11 {history revision} {
- history add {word0 word1 $ a b c word6}
- history add {set a [history w 4-[history word 2]]} exec
- set a
-} {b c word6}
-test history-10.12 {history revision} {notIfCompiled} {
- history add {word0 word1 $ a b c word6}
- history add {set a [history w 4-[history word 2]]} exec
- history add foo
- history e
-} {set a {b c word6}}
-test history-10.13 {history revision} {
- history add {history word 0} exec
- history add foo
- history e
-} {history word 0}
-test history-10.14 {history revision} {
- history add {set a [history word 0; format c]} exec
- history add foo
- history e
-} {set a [history word 0; format c]}
-test history-10.15 {history revision even when nested} {notIfCompiled} {
- proc x {a b} {history word $a $b}
- history add {word1 word2 word3 word4}
- history add {set a [x 1-3 -1]} exec
- history add foo
- history e
-} {set a {word2 word3 word4}}
-test history-10.16 {disable history revision in nested history evals} {notIfCompiled} {
- history add {word1 word2 word3 word4}
- history add {set a [history words 0]; history add foo; set a [history words 0]} exec
- history e
-} {set a word1; history add foo; set a [history words 0]}
+set num [history n]
+history add "Testing"
+history add "Testing2"
+test history-8.1 {clear option} {catch {history clear junk}} 1
+test history-8.2 {clear option} {history clear} {}
+history add "Testing"
+test history-8.3 {clear option} {history} { 1 Testing}
# miscellaneous
-test history-11.1 {miscellaneous} {catch {history gorp} msg} 1
-test history-11.2 {miscellaneous} {
+test history-9.1 {miscellaneous} {catch {history gorp} msg} 1
+test history-9.2 {miscellaneous} {
catch {history gorp} msg
set msg
-} {bad option "gorp": must be add, change, event, info, keep, nextid, redo, substitute, or words}
+} {bad option "gorp": must be add, change, clear, event, info, keep, nextid, or redo}
+
diff --git a/contrib/tcl/tests/http.test b/contrib/tcl/tests/http.test
index 3c47c27..2770e13 100644
--- a/contrib/tcl/tests/http.test
+++ b/contrib/tcl/tests/http.test
@@ -1,4 +1,4 @@
-# Commands covered: http_config, http_get, http_wait, http_reset
+# Commands covered: http::config, http::geturl, http::wait, http::reset
#
# This file contains a collection of tests for the http script library.
# Sourcing this file into Tcl runs the tests and
@@ -10,14 +10,23 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) http.test 1.9 97/06/24 17:32:56
+#
+# SCCS: @(#) http2.test 1.8 97/08/13 11:16:50
if {[string compare test [info procs test]] == 1} then {source defs}
-
-if [catch {package require http 1.0}] {
- catch {puts stderr "Cannot find http package"}
- return
+if {[catch {package require http 2.0}]} {
+ if {[info exist http2]} {
+ catch {puts stderr "Cannot load http 2.0 package"}
+ return
+ } else {
+ catch {puts stderr "Running http 2.0 tests in slave interp"}
+ set interp [interp create http2]
+ $interp eval [list set http2 "running"]
+ $interp eval [list source [info script]]
+ interp delete $interp
+ return
+ }
}
############### The httpd_ procedures implement a stub http server. ########
@@ -117,22 +126,30 @@ upvar #0 httpd$sock data
# Respond to the query.
+set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
proc httpdRespond { sock } {
- global httpd
+ global httpd bindata port
upvar #0 httpd$sock data
- set html "<html><head><title>HTTP/1.0 TEST</title></head><body>
+ if {[string match *binary* $data(url)]} {
+ set html "$bindata[info hostname]:$port$data(url)"
+ set type application/octet-stream
+ } else {
+ set type text/html
+
+ set html "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>$data(proto) $data(url)</h2>
"
- if {[info exists data(query)] && [string length $data(query)]} {
- append html "<h2>Query</h2>\n<dl>\n"
- foreach {key value} [split $data(query) &=] {
- append html "<dt>$key<dd>$value\n"
+ if {[info exists data(query)] && [string length $data(query)]} {
+ append html "<h2>Query</h2>\n<dl>\n"
+ foreach {key value} [split $data(query) &=] {
+ append html "<dt>$key<dd>$value\n"
+ }
+ append html </dl>\n
}
- append html </dl>\n
+ append html </body></html>
}
- append html </body></html>
if {$data(proto) == "HEAD"} {
puts $sock "HTTP/1.0 200 OK"
@@ -140,7 +157,7 @@ proc httpdRespond { sock } {
puts $sock "HTTP/1.0 200 Data follows"
}
puts $sock "Date: [clock format [clock clicks]]"
- puts $sock "Content-Type: text/html"
+ puts $sock "Content-Type: $type"
puts $sock "Content-Length: [string length $html]"
puts $sock ""
if {$data(proto) != "HEAD"} {
@@ -150,7 +167,7 @@ proc httpdRespond { sock } {
httpd_log $sock Done ""
httpdSockDone $sock
}
-##################### end server ###########################33
+##################### end server ###########################
set port 8010
if [catch {httpd_init $port} listen] {
@@ -159,46 +176,58 @@ if [catch {httpd_init $port} listen] {
return
}
-test http-1.1 {http_config} {
- http_config
-} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}}
+test http-1.1 {http::config} {
+ http::config
+} {-accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 2.0}}
-test http-1.2 {http_config} {
- http_config -proxyfilter
-} httpProxyRequired
+test http-1.2 {http::config} {
+ http::config -proxyfilter
+} http::ProxyRequired
-test http-1.3 {http_config} {
- catch {http_config -junk}
+test http-1.3 {http::config} {
+ catch {http::config -junk}
} 1
-test http-1.4 {http_config} {
- http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite"
- set x [http_config]
- http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired
+test http-1.4 {http::config} {
+ set savedconf [http::config]
+ http::config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite"
+ set x [http::config]
+ eval http::config $savedconf
set x
} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}
-test http-1.5 {http_config} {
- catch {http_config -proxyhost {} -junk 8080}
+test http-1.5 {http::config} {
+ catch {http::config -proxyhost {} -junk 8080}
} 1
-test http-2.1 {http_reset} {
- catch {http_reset http#1}
+test http-2.1 {http::reset} {
+ catch {http::reset http#1}
} 0
-test http-3.1 {http_get} {
- catch {http_get -bogus flag}
+test http-3.1 {http::geturl} {
+ catch {http::geturl -bogus flag}
} 1
-test http-3.2 {http_get} {
- catch {http_get junk} err
+test http-3.2 {http::geturl} {
+ catch {http::geturl http:junk} err
set err
-} {Unsupported URL: junk}
+} {Unsupported URL: http:junk}
+
+set url [info hostname]:$port
+test http-3.3 {http::geturl} {
+ set token [http::geturl $url]
+ http::data $token
+} "<html><head><title>HTTP/1.0 TEST</title></head><body>
+<h1>Hello, World!</h1>
+<h2>GET /</h2>
+</body></html>"
set tail /a/b/c
set url [info hostname]:$port/a/b/c
-test http-3.3 {http_get} {
- set token [http_get $url]
- http_data $token
+set binurl [info hostname]:$port/binary
+
+test http-3.4 {http::geturl} {
+ set token [http::geturl $url]
+ http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
@@ -208,37 +237,37 @@ proc selfproxy {host} {
global port
return [list [info hostname] $port]
}
-test http-3.4 {http_get} {
- http_config -proxyfilter selfproxy
- set token [http_get $url]
- http_config -proxyfilter httpProxyRequired
- http_data $token
+test http-3.5 {http::geturl} {
+ http::config -proxyfilter selfproxy
+ set token [http::geturl $url]
+ http::config -proxyfilter http::ProxyRequired
+ http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET http://$url</h2>
</body></html>"
-test http-3.5 {http_get} {
- http_config -proxyfilter bogus
- set token [http_get $url]
- http_config -proxyfilter httpProxyRequired
- http_data $token
+test http-3.6 {http::geturl} {
+ http::config -proxyfilter bogus
+ set token [http::geturl $url]
+ http::config -proxyfilter http::ProxyRequired
+ http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
-test http-3.6 {http_get} {
- set token [http_get $url -headers {Pragma no-cache}]
- http_data $token
+test http-3.7 {http::geturl} {
+ set token [http::geturl $url -headers {Pragma no-cache}]
+ http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
-test http-3.7 {http_get} {
- set token [http_get $url -query Name=Value&Foo=Bar]
- http_data $token
+test http-3.8 {http::geturl} {
+ set token [http::geturl $url -query Name=Value&Foo=Bar]
+ http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>POST $tail</h2>
@@ -249,33 +278,34 @@ test http-3.7 {http_get} {
</dl>
</body></html>"
-test http-3.8 {http_get} {
- set token [http_get $url -validate 1]
- http_code $token
+test http-3.9 {http::geturl} {
+ set token [http::geturl $url -validate 1]
+ http::code $token
} "HTTP/1.0 200 OK"
-test http-4.1 {httpEvent} {
- set token [http_get $url]
+
+test http-4.1 {http::Event} {
+ set token [http::geturl $url]
upvar #0 $token data
array set meta $data(meta)
expr ($data(totalsize) == $meta(Content-Length))
} 1
-test http-4.2 {httpEvent} {
- set token [http_get $url]
+test http-4.2 {http::Event} {
+ set token [http::geturl $url]
upvar #0 $token data
array set meta $data(meta)
string compare $data(type) [string trim $meta(Content-Type)]
} 0
-test http-4.3 {httpEvent} {
- set token [http_get $url]
- http_code $token
+test http-4.3 {http::Event} {
+ set token [http::geturl $url]
+ http::code $token
} {HTTP/1.0 200 Data follows}
-test http-4.4 {httpEvent} {
+test http-4.4 {http::Event} {
set out [open testfile w]
- set token [http_get $url -channel $out]
+ set token [http::geturl $url -channel $out]
close $out
set in [open testfile]
set x [read $in]
@@ -287,15 +317,27 @@ test http-4.4 {httpEvent} {
<h2>GET $tail</h2>
</body></html>"
-test http-4.5 {httpEvent} {
+test http-4.5 {http::Event} {
set out [open testfile w]
- set token [http_get $url -channel $out]
+ set token [http::geturl $url -channel $out]
close $out
upvar #0 $token data
file delete testfile
expr $data(currentsize) == $data(totalsize)
} 1
+test http-4.6 {http::Event} {
+ set out [open testfile w]
+ set token [http::geturl $binurl -channel $out]
+ close $out
+ set in [open testfile]
+ fconfigure $in -translation binary
+ set x [read $in]
+ close $in
+ file delete testfile
+ set x
+} "$bindata$binurl"
+
proc myProgress {token total current} {
global progress httpLog
if {[info exists httpLog] && $httpLog} {
@@ -306,55 +348,55 @@ proc myProgress {token total current} {
if 0 {
# This test hangs on Windows95 because the client never gets EOF
set httpLog 1
- test http-4.6 {httpEvent} {
- set token [http_get $url -blocksize 50 -progress myProgress]
+ test http-4.6 {http::Event} {
+ set token [http::geturl $url -blocksize 50 -progress myProgress]
set progress
} {111 111}
}
-test http-4.7 {httpEvent} {
- set token [http_get $url -progress myProgress]
+test http-4.7 {http::Event} {
+ set token [http::geturl $url -progress myProgress]
set progress
} {111 111}
-test http-4.8 {httpEvent} {
- set token [http_get $url]
- http_status $token
+test http-4.8 {http::Event} {
+ set token [http::geturl $url]
+ http::status $token
} {ok}
-test http-4.9 {httpEvent} {
- set token [http_get $url -progress myProgress]
- http_code $token
+test http-4.9 {http::Event} {
+ set token [http::geturl $url -progress myProgress]
+ http::code $token
} {HTTP/1.0 200 Data follows}
-test http-4.10 {httpEvent} {
- set token [http_get $url -progress myProgress]
- http_size $token
+test http-4.10 {http::Event} {
+ set token [http::geturl $url -progress myProgress]
+ http::size $token
} {111}
-test http-4.11 {httpEvent} {
- set token [http_get $url -timeout 1 -command {#}]
- http_reset $token
- http_status $token
+test http-4.11 {http::Event} {
+ set token [http::geturl $url -timeout 1 -command {#}]
+ http::reset $token
+ http::status $token
} {reset}
-test http-4.12 {httpEvent} {
- set token [http_get $url -timeout 1 -command {#}]
- update
- http_status $token
+test http-4.12 {http::Event} {
+ set token [http::geturl $url -timeout 1 -command {#}]
+ http::wait $token
+ http::status $token
} {timeout}
-test http-5.1 {http_formatQuery} {
- http_formatQuery name1 value1 name2 "value two"
+test http-5.1 {http::formatQuery} {
+ http::formatQuery name1 value1 name2 "value two"
} {name1=value1&name2=value+two}
-test http-5.2 {http_formatQuery} {
- http_formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
+test http-5.2 {http::formatQuery} {
+ http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
} {name1=%7ebwelch&name2=%a1%a2%a2}
-test http-5.3 {http_formatQuery} {
- http_formatQuery lines "line1\nline2\nline3"
+test http-5.3 {http::formatQuery} {
+ http::formatQuery lines "line1\nline2\nline3"
} {lines=line1%0d%0aline2%0d%0aline3}
-test http-6.1 {httpProxyRequired} {
- http_config -proxyhost [info hostname] -proxyport $port
- set token [http_get $url]
- http_wait $token
- http_config -proxyhost {} -proxyport {}
+test http-6.1 {http::ProxyRequired} {
+ http::config -proxyhost [info hostname] -proxyport $port
+ set token [http::geturl $url]
+ http::wait $token
+ http::config -proxyhost {} -proxyport {}
upvar #0 $token data
set data(body)
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
diff --git a/contrib/tcl/tests/httpold.test b/contrib/tcl/tests/httpold.test
new file mode 100644
index 0000000..5e9ba0c
--- /dev/null
+++ b/contrib/tcl/tests/httpold.test
@@ -0,0 +1,411 @@
+# Commands covered: http_config, http_get, http_wait, http_reset
+#
+# This file contains a collection of tests for the http script library.
+# Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1991-1993 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# SCCS: @(#) http.test 1.12 97/07/29 17:04:12
+
+if {[string compare test [info procs test]] == 1} then {source defs}
+
+
+if {[catch {package require http 1.0}]} {
+ if {[info exist httpold]} {
+ catch {puts stderr "Cannot load http 1.0 package"}
+ return
+ } else {
+ catch {puts stderr "Running http 1.0 tests in slave interp"}
+ set interp [interp create httpold]
+ $interp eval [list set httpold "running"]
+ $interp eval [list source [info script]]
+ interp delete $interp
+ return
+ }
+}
+
+############### The httpd_ procedures implement a stub http server. ########
+proc httpd_init {{port 8015}} {
+ socket -server httpdAccept $port
+}
+proc httpd_log {args} {
+ global httpLog
+ if {[info exists httpLog] && $httpLog} {
+ puts stderr "httpd: [join $args { }]"
+ }
+}
+array set httpdErrors {
+ 204 {No Content}
+ 400 {Bad Request}
+ 404 {Not Found}
+ 503 {Service Unavailable}
+ 504 {Service Temporarily Unavailable}
+ }
+
+proc httpdError {sock code args} {
+ global httpdErrors
+ puts $sock "$code $httpdErrors($code)"
+ httpd_log "error: [join $args { }]"
+}
+proc httpdAccept {newsock ipaddr port} {
+ global httpd
+ upvar #0 httpd$newsock data
+
+ fconfigure $newsock -blocking 0 -translation {auto crlf}
+ httpd_log $newsock Connect $ipaddr $port
+ set data(ipaddr) $ipaddr
+ fileevent $newsock readable [list httpdRead $newsock]
+}
+
+# read data from a client request
+
+proc httpdRead { sock } {
+ upvar #0 httpd$sock data
+
+ set readCount [gets $sock line]
+ if {![info exists data(state)]} {
+ if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/1.0} \
+ $line x data(proto) data(url) data(query)] {
+ set data(state) mime
+ httpd_log $sock Query $line
+ } else {
+ httpdError $sock 400
+ httpd_log $sock Error "bad first line:$line"
+ httpdSockDone $sock
+ }
+ return
+ }
+
+ # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1
+
+ set state [string compare $readCount 0],$data(state),$data(proto)
+ httpd_log $sock $state
+ switch -- $state {
+ -1,mime,HEAD -
+ -1,mime,GET -
+ -1,mime,POST {
+ # gets would block
+ return
+ }
+ 0,mime,HEAD -
+ 0,mime,GET -
+ 0,query,POST { httpdRespond $sock }
+ 0,mime,POST { set data(state) query }
+ 1,mime,HEAD -
+ 1,mime,POST -
+ 1,mime,GET {
+ if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] {
+ set data(mime,[string tolower $key]) $value
+ }
+ }
+ 1,query,POST {
+ append data(query) $line
+ httpdRespond $sock
+ }
+ default {
+ if [eof $sock] {
+ httpd_log $sock Error "unexpected eof on <$data(url)> request"
+ } else {
+ httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>"
+ }
+ httpdError $sock 404
+ httpdSockDone $sock
+ }
+ }
+}
+proc httpdSockDone { sock } {
+upvar #0 httpd$sock data
+ unset data
+ catch {close $sock}
+}
+
+# Respond to the query.
+
+set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
+proc httpdRespond { sock } {
+ global httpd bindata port
+ upvar #0 httpd$sock data
+
+ if {[string match *binary* $data(url)]} {
+ set html "$bindata[info hostname]:$port$data(url)"
+ set type application/octet-stream
+ } else {
+ set type text/html
+
+ set html "<html><head><title>HTTP/1.0 TEST</title></head><body>
+<h1>Hello, World!</h1>
+<h2>$data(proto) $data(url)</h2>
+"
+ if {[info exists data(query)] && [string length $data(query)]} {
+ append html "<h2>Query</h2>\n<dl>\n"
+ foreach {key value} [split $data(query) &=] {
+ append html "<dt>$key<dd>$value\n"
+ }
+ append html </dl>\n
+ }
+ append html </body></html>
+ }
+
+ if {$data(proto) == "HEAD"} {
+ puts $sock "HTTP/1.0 200 OK"
+ } else {
+ puts $sock "HTTP/1.0 200 Data follows"
+ }
+ puts $sock "Date: [clock format [clock clicks]]"
+ puts $sock "Content-Type: $type"
+ puts $sock "Content-Length: [string length $html]"
+ puts $sock ""
+ if {$data(proto) != "HEAD"} {
+ fconfigure $sock -translation binary
+ puts -nonewline $sock $html
+ }
+ httpd_log $sock Done ""
+ httpdSockDone $sock
+}
+##################### end server ###########################
+
+set port 8010
+if [catch {httpd_init $port} listen] {
+ puts stderr "Cannot start http server, http test skipped"
+ unset port
+ return
+}
+
+test http-1.1 {http_config} {
+ http_config
+} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}}
+
+test http-1.2 {http_config} {
+ http_config -proxyfilter
+} httpProxyRequired
+
+test http-1.3 {http_config} {
+ catch {http_config -junk}
+} 1
+
+test http-1.4 {http_config} {
+ http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite"
+ set x [http_config]
+ http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired \
+ -useragent "Tcl http client package 1.0"
+ set x
+} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}
+
+test http-1.5 {http_config} {
+ catch {http_config -proxyhost {} -junk 8080}
+} 1
+
+test http-2.1 {http_reset} {
+ catch {http_reset http#1}
+} 0
+
+test http-3.1 {http_get} {
+ catch {http_get -bogus flag}
+} 1
+test http-3.2 {http_get} {
+ catch {http_get http:junk} err
+ set err
+} {Unsupported URL: http:junk}
+
+set url [info hostname]:$port
+test http-3.3 {http_get} {
+ set token [http_get $url]
+ http_data $token
+} "<html><head><title>HTTP/1.0 TEST</title></head><body>
+<h1>Hello, World!</h1>
+<h2>GET /</h2>
+</body></html>"
+
+set tail /a/b/c
+set url [info hostname]:$port/a/b/c
+set binurl [info hostname]:$port/binary
+
+test http-3.4 {http_get} {
+ set token [http_get $url]
+ http_data $token
+} "<html><head><title>HTTP/1.0 TEST</title></head><body>
+<h1>Hello, World!</h1>
+<h2>GET $tail</h2>
+</body></html>"
+
+proc selfproxy {host} {
+ global port
+ return [list [info hostname] $port]
+}
+test http-3.5 {http_get} {
+ http_config -proxyfilter selfproxy
+ set token [http_get $url]
+ http_config -proxyfilter httpProxyRequired
+ http_data $token
+} "<html><head><title>HTTP/1.0 TEST</title></head><body>
+<h1>Hello, World!</h1>
+<h2>GET http://$url</h2>
+</body></html>"
+
+test http-3.6 {http_get} {
+ http_config -proxyfilter bogus
+ set token [http_get $url]
+ http_config -proxyfilter httpProxyRequired
+ http_data $token
+} "<html><head><title>HTTP/1.0 TEST</title></head><body>
+<h1>Hello, World!</h1>
+<h2>GET $tail</h2>
+</body></html>"
+
+test http-3.7 {http_get} {
+ set token [http_get $url -headers {Pragma no-cache}]
+ http_data $token
+} "<html><head><title>HTTP/1.0 TEST</title></head><body>
+<h1>Hello, World!</h1>
+<h2>GET $tail</h2>
+</body></html>"
+
+test http-3.8 {http_get} {
+ set token [http_get $url -query Name=Value&Foo=Bar]
+ http_data $token
+} "<html><head><title>HTTP/1.0 TEST</title></head><body>
+<h1>Hello, World!</h1>
+<h2>POST $tail</h2>
+<h2>Query</h2>
+<dl>
+<dt>Name<dd>Value
+<dt>Foo<dd>Bar
+</dl>
+</body></html>"
+
+test http-3.9 {http_get} {
+ set token [http_get $url -validate 1]
+ http_code $token
+} "HTTP/1.0 200 OK"
+
+
+test http-4.1 {httpEvent} {
+ set token [http_get $url]
+ upvar #0 $token data
+ array set meta $data(meta)
+ expr ($data(totalsize) == $meta(Content-Length))
+} 1
+
+test http-4.2 {httpEvent} {
+ set token [http_get $url]
+ upvar #0 $token data
+ array set meta $data(meta)
+ string compare $data(type) [string trim $meta(Content-Type)]
+} 0
+
+test http-4.3 {httpEvent} {
+ set token [http_get $url]
+ http_code $token
+} {HTTP/1.0 200 Data follows}
+
+test http-4.4 {httpEvent} {
+ set out [open testfile w]
+ set token [http_get $url -channel $out]
+ close $out
+ set in [open testfile]
+ set x [read $in]
+ close $in
+ file delete testfile
+ set x
+} "<html><head><title>HTTP/1.0 TEST</title></head><body>
+<h1>Hello, World!</h1>
+<h2>GET $tail</h2>
+</body></html>"
+
+test http-4.5 {httpEvent} {
+ set out [open testfile w]
+ set token [http_get $url -channel $out]
+ close $out
+ upvar #0 $token data
+ file delete testfile
+ expr $data(currentsize) == $data(totalsize)
+} 1
+
+test http-4.6 {httpEvent} {
+ set out [open testfile w]
+ set token [http_get $binurl -channel $out]
+ close $out
+ set in [open testfile]
+ fconfigure $in -translation binary
+ set x [read $in]
+ close $in
+ file delete testfile
+ set x
+} "$bindata$binurl"
+
+proc myProgress {token total current} {
+ global progress httpLog
+ if {[info exists httpLog] && $httpLog} {
+ puts "progress $total $current"
+ }
+ set progress [list $total $current]
+}
+if 0 {
+ # This test hangs on Windows95 because the client never gets EOF
+ set httpLog 1
+ test http-4.6 {httpEvent} {
+ set token [http_get $url -blocksize 50 -progress myProgress]
+ set progress
+ } {111 111}
+}
+test http-4.7 {httpEvent} {
+ set token [http_get $url -progress myProgress]
+ set progress
+} {111 111}
+test http-4.8 {httpEvent} {
+ set token [http_get $url]
+ http_status $token
+} {ok}
+test http-4.9 {httpEvent} {
+ set token [http_get $url -progress myProgress]
+ http_code $token
+} {HTTP/1.0 200 Data follows}
+test http-4.10 {httpEvent} {
+ set token [http_get $url -progress myProgress]
+ http_size $token
+} {111}
+test http-4.11 {httpEvent} {
+ set token [http_get $url -timeout 1 -command {#}]
+ http_reset $token
+ http_status $token
+} {reset}
+test http-4.12 {httpEvent} {
+ update
+ set token [http_get $url -timeout 1 -command {#}]
+ update
+ http_status $token
+} {timeout}
+
+test http-5.1 {http_formatQuery} {
+ http_formatQuery name1 value1 name2 "value two"
+} {name1=value1&name2=value+two}
+
+test http-5.2 {http_formatQuery} {
+ http_formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
+} {name1=%7ebwelch&name2=%a1%a2%a2}
+
+test http-5.3 {http_formatQuery} {
+ http_formatQuery lines "line1\nline2\nline3"
+} {lines=line1%0d%0aline2%0d%0aline3}
+
+test http-6.1 {httpProxyRequired} {
+ update
+ http_config -proxyhost [info hostname] -proxyport $port
+ set token [http_get $url]
+ http_wait $token
+ http_config -proxyhost {} -proxyport {}
+ upvar #0 $token data
+ set data(body)
+} "<html><head><title>HTTP/1.0 TEST</title></head><body>
+<h1>Hello, World!</h1>
+<h2>GET http://$url</h2>
+</body></html>"
+
+unset url
+unset port
+close $listen
diff --git a/contrib/tcl/tests/if.test b/contrib/tcl/tests/if.test
index 8bc288f..03b8bcd 100644
--- a/contrib/tcl/tests/if.test
+++ b/contrib/tcl/tests/if.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) if.test 1.8 97/06/23 18:18:30
+# SCCS: @(#) if.test 1.9 97/07/02 16:40:58
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -27,7 +27,7 @@ test if-1.3 {TclCompileIfCmd: error in if/elseif test} {
} {1 {syntax error in expression "1+"} {syntax error in expression "1+"
("if" test expression)
while compiling
-"if"}}
+"if {1+}"}}
test if-1.4 {TclCompileIfCmd: if/elseif test in braces} {
set a {}
if {1<2} {set a 1}
@@ -65,9 +65,9 @@ test if-1.10 {TclCompileIfCmd: error in "then" body} {
} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
while compiling
"set"
- ("if" body script)
+ ("if" then script line 1)
while compiling
-"if"}}
+"if {$a!="xxx"} then {set}"}}
test if-1.11 {TclCompileIfCmd: error in "then" body} {
list [catch {if 2 then {[error "error in then clause"]}} msg] $msg
} {1 {error in then clause}}
@@ -179,7 +179,7 @@ test if-2.4 {TclCompileIfCmd: error in expression after "elseif"} {
} {1 {syntax error in expression "1>"} {syntax error in expression "1>"
("if" test expression)
while compiling
-"if"}}
+"if 3>4 {set a 1} elseif {1>}"}}
test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long "elseif" body} {
catch {unset i}
set a {}
@@ -307,9 +307,9 @@ test if-3.4 {TclCompileIfCmd: error compiling body after "else"} {
} {wrong # args: should be "set varName ?newValue?"
while compiling
"set"
- ("if" else script)
+ ("if" else script line 1)
while compiling
-"if"}
+"if 2<1 {set a 1} else {set}"}
test if-3.5 {TclCompileIfCmd: extra arguments after "else" argument} {
set a {}
catch {if 2<1 {set a 1} else {set a 2} or something} msg
diff --git a/contrib/tcl/tests/incr.test b/contrib/tcl/tests/incr.test
index 30db386f..e187d41 100644
--- a/contrib/tcl/tests/incr.test
+++ b/contrib/tcl/tests/incr.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) incr.test 1.8 97/06/20 16:53:28
+# SCCS: @(#) incr.test 1.9 97/07/02 16:41:32
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -177,9 +177,9 @@ test incr-1.19 {TclCompileIncrCmd: increment given, but erroneous} {
} {wrong # args: should be "set varName ?newValue?"
while compiling
"set"
- (reading increment)
+ (increment expression)
while compiling
-"incr"}
+"incr i [set]"}
test incr-1.20 {TclCompileIncrCmd: increment given, in quotes} {
set i 25
incr i "-100"
@@ -221,7 +221,7 @@ test incr-1.27 {TclCompileIncrCmd: runtime error, bad variable name} {
while compiling
"set"
while compiling
-"incr"}}
+"incr [set]"}}
test incr-1.28 {TclCompileIncrCmd: runtime error, readonly variable} {
proc readonly args {error "variable is read-only"}
set x 123
diff --git a/contrib/tcl/tests/info.test b/contrib/tcl/tests/info.test
index 7e7a226..784dad1 100644
--- a/contrib/tcl/tests/info.test
+++ b/contrib/tcl/tests/info.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) info.test 1.38 97/05/20 16:35:54
+# SCCS: @(#) info.test 1.39 97/08/01 11:10:24
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -487,25 +487,30 @@ test info-15.3 {info procs option} {
list [catch {info procs 2 3} msg] $msg
} {1 {wrong # args: should be "info procs ?pattern?"}}
+set self info.test
+if {$tcl_platform(os) == "Win32s"} {
+ set self info~1.tes
+}
+
test info-16.1 {info script option} {
list [catch {info script x} msg] $msg
} {1 {wrong # args: should be "info script"}}
test info-16.2 {info script option} {
file tail [info sc]
-} info.test
+} $self
removeFile gorp.info
makeFile "info script\n" gorp.info
test info-16.3 {info script option} {
list [source gorp.info] [file tail [info script]]
-} {gorp.info info.test}
+} [list gorp.info $self]
test info-16.4 {resetting "info script" after errors} {
catch {source ~_nobody_/foo}
file tail [info script]
-} {info.test}
+} $self
test info-16.5 {resetting "info script" after errors} {
catch {source _nonexistent_}
file tail [info script]
-} {info.test}
+} $self
removeFile gorp.info
test info-17.1 {info sharedlibextension option} {
diff --git a/contrib/tcl/tests/interp.test b/contrib/tcl/tests/interp.test
index 85aee32..9127bcb 100644
--- a/contrib/tcl/tests/interp.test
+++ b/contrib/tcl/tests/interp.test
@@ -9,16 +9,16 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) interp.test 1.52 97/06/23 17:29:50
+# SCCS: @(#) interp.test 1.61 97/08/04 19:59:52
if {[string compare test [info procs test]] == 1} then {source defs}
# The set of hidden commands is platform dependent:
if {"$tcl_platform(platform)" == "macintosh"} {
- set hidden_cmds {beep cd echo exit fconfigure file glob load ls open pwd socket source vwait}
+ set hidden_cmds {beep cd echo exit fconfigure file glob load ls open pwd socket source}
} else {
- set hidden_cmds {cd exec exit fconfigure file glob load open pwd socket source vwait}
+ set hidden_cmds {cd exec exit fconfigure file glob load open pwd socket source}
}
foreach i [interp slaves] {
@@ -95,7 +95,27 @@ test interp-2.10 {basic interpreter creation} {
interp create {a x2}
interp create {a x3} -safe
} {a x3}
-
+test interp-2.11 {anonymous interps vs existing procs} {
+ set x [interp create]
+ regexp "interp(\[0-9]+)" $x dummy thenum
+ interp delete $x
+ incr thenum
+ proc interp$thenum {} {}
+ set x [interp create]
+ regexp "interp(\[0-9]+)" $x dummy anothernum
+ expr $anothernum - $thenum
+} 1
+test interp-2.12 {anonymous interps vs existing procs} {
+ set x [interp create -safe]
+ regexp "interp(\[0-9]+)" $x dummy thenum
+ interp delete $x
+ incr thenum
+ proc interp$thenum {} {}
+ set x [interp create -safe]
+ regexp "interp(\[0-9]+)" $x dummy anothernum
+ expr $anothernum - $thenum
+} 1
+
foreach i [interp slaves] {
interp delete $i
}
@@ -362,6 +382,17 @@ test interp-11.5 {testing interp target} {
interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand
list [catch {x1 eval {interp target {x2 x3} xcommand}} msg] $msg
} {1 {target interpreter for alias "xcommand" in path "x2 x3" is not my descendant}}
+test interp-11.6 {testing interp target} {
+ foreach a [interp aliases] {
+ rename $a {}
+ }
+ list [catch {interp target {} foo} msg] $msg
+} {1 {alias "foo" in path "" not found}}
+test interp-11.7 {testing interp target} {
+ catch {interp delete a}
+ interp create a
+ list [catch {interp target a foo} msg] $msg
+} {1 {alias "foo" in path "a" not found}}
# Part 11: testing "interp issafe"
test interp-12.1 {testing interp issafe} {
@@ -555,9 +586,8 @@ test interp-16.5 {testing deletion order, bgerror} {
xxx alias exit kill xxx
proc kill {i} {interp delete $i}
xxx eval after 100 expr a + b
- set x waiting
- after 200 {set x done}
- vwait x
+ after 200
+ update
interp exists xxx
} 0
@@ -1405,6 +1435,49 @@ test interp-20.44 {invokehidden at global level} {
interp delete a
list $r $msg
} {0 91}
+test interp-20.45 {interp hide vs namespaces} {
+ catch {interp delete a}
+ interp create a
+ a eval {
+ namespace eval foo {}
+ proc foo::x {} {}
+ }
+ set l [list [catch {interp hide a foo::x} msg] $msg]
+ interp delete a
+ set l
+} {1 {cannot use namespace qualifiers as hidden commandtoken (rename)}}
+test interp-20.46 {interp hide vs namespaces} {
+ catch {interp delete a}
+ interp create a
+ a eval {
+ namespace eval foo {}
+ proc foo::x {} {}
+ }
+ set l [list [catch {interp hide a foo::x x} msg] $msg]
+ interp delete a
+ set l
+} {1 {can only hide global namespace commands (use rename then hide)}}
+test interp-20.47 {interp hide vs namespaces} {
+ catch {interp delete a}
+ interp create a
+ a eval {
+ proc x {} {}
+ }
+ set l [list [catch {interp hide a x foo::x} msg] $msg]
+ interp delete a
+ set l
+} {1 {cannot use namespace qualifiers as hidden commandtoken (rename)}}
+test interp-20.48 {interp hide vs namespaces} {
+ catch {interp delete a}
+ interp create a
+ a eval {
+ namespace eval foo {}
+ proc foo::x {} {}
+ }
+ set l [list [catch {interp hide a foo::x bar::x} msg] $msg]
+ interp delete a
+ set l
+} {1 {cannot use namespace qualifiers as hidden commandtoken (rename)}}
test interp-21.1 {interp hidden} {
interp hidden {}
@@ -1605,7 +1678,7 @@ test interp-23.2 {testing hiding vs aliases} {pc || unix} {
lappend l [lsort [interp hidden a]]
interp delete a
set l
-} {{cd exec exit fconfigure file glob load open pwd socket source vwait} bar {cd exec exit fconfigure file glob load open pwd socket source vwait} bar {bar cd exec exit fconfigure file glob load open pwd socket source vwait} {} {cd exec exit fconfigure file glob load open pwd socket source vwait}}
+} {{cd exec exit fconfigure file glob load open pwd socket source} bar {cd exec exit fconfigure file glob load open pwd socket source} bar {bar cd exec exit fconfigure file glob load open pwd socket source} {} {cd exec exit fconfigure file glob load open pwd socket source}}
test interp-23.3 {testing hiding vs aliases} {macOnly} {
catch {interp delete a}
@@ -1623,7 +1696,7 @@ test interp-23.3 {testing hiding vs aliases} {macOnly} {
lappend l [lsort [interp hidden a]]
interp delete a
set l
-} {{beep cd echo exit fconfigure file glob load ls open pwd socket source vwait} bar {beep cd echo exit fconfigure file glob load ls open pwd socket source vwait} bar {bar beep cd echo exit fconfigure file glob load ls open pwd socket source vwait} {} {beep cd echo exit fconfigure file glob load ls open pwd socket source vwait}}
+} {{beep cd echo exit fconfigure file glob load ls open pwd socket source} bar {beep cd echo exit fconfigure file glob load ls open pwd socket source} bar {bar beep cd echo exit fconfigure file glob load ls open pwd socket source} {} {beep cd echo exit fconfigure file glob load ls open pwd socket source}}
test interp-24.1 {result resetting on error} {
catch {interp delete a}
@@ -1855,6 +1928,238 @@ test interp-25.1 {testing aliasing of string commands} {
interp delete a
} ""
+
+# Interps result transmission
+test interp-26.1 {result code transmission 1} {knownBug} {
+ # This test currently fails ! (only ok/error are passed, not the other
+ # codes). Fixing the code is thus needed... -- dl
+ # (the only other acceptable result list would be
+ # {-1 0 1 0 3 4 5} because of the way return -code return(=2) works)
+ # test that all the possibles error codes from Tcl get passed
+ catch {interp delete a}
+ interp create a
+ interp eval a {proc ret {code} {return -code $code $code}}
+ set res {}
+ # use a for so if a return -code break 'escapes' we would notice
+ for {set code -1} {$code<=5} {incr code} {
+ lappend res [catch {interp eval a ret $code} msg]
+ }
+ interp delete a
+ set res
+} {-1 0 1 2 3 4 5}
+
+test interp-26.2 {result code transmission 2} {knownBug} {
+ # This test currently fails ! (error is cleared)
+ # Code fixing is needed... -- dl
+ # (the only other acceptable result list would be
+ # {-1 0 1 0 3 4 5} because of the way return -code return(=2) works)
+ # test that all the possibles error codes from Tcl get passed
+ set interp [interp create];
+ proc MyTestAlias {interp args} {
+ global aliasTrace;
+ lappend aliasTrace $args;
+ eval interp invokehidden [list $interp] $args
+ }
+ foreach c {return} {
+ interp hide $interp $c;
+ interp alias $interp $c {} MyTestAlias $interp $c;
+ }
+ interp eval $interp {proc ret {code} {return -code $code $code}}
+ set res {}
+ set aliasTrace {}
+ for {set code -1} {$code<=5} {incr code} {
+ lappend res [catch {interp eval $interp ret $code} msg]
+ }
+ interp delete $interp;
+ list $res
+} {-1 0 1 2 3 4 5}
+
+
+# Interps & Namespaces
+test interp-27.1 {interp aliases & namespaces} {
+ set i [interp create];
+ set aliasTrace {};
+ proc tstAlias {args} {
+ global aliasTrace;
+ lappend aliasTrace [list [namespace current] $args];
+ }
+ $i alias foo::bar tstAlias foo::bar;
+ $i eval foo::bar test
+ interp delete $i
+ set aliasTrace;
+} {{:: {foo::bar test}}}
+
+test interp-27.2 {interp aliases & namespaces} {
+ set i [interp create];
+ set aliasTrace {};
+ proc tstAlias {args} {
+ global aliasTrace;
+ lappend aliasTrace [list [namespace current] $args];
+ }
+ $i alias foo::bar tstAlias foo::bar;
+ $i eval namespace eval foo {bar test}
+ interp delete $i
+ set aliasTrace;
+} {{:: {foo::bar test}}}
+
+test interp-27.3 {interp aliases & namespaces} {
+ set i [interp create];
+ set aliasTrace {};
+ proc tstAlias {args} {
+ global aliasTrace;
+ lappend aliasTrace [list [namespace current] $args];
+ }
+ interp eval $i {namespace eval foo {proc bar {} {error "bar called"}}}
+ interp alias $i foo::bar {} tstAlias foo::bar;
+ interp eval $i {namespace eval foo {bar test}}
+ interp delete $i
+ set aliasTrace;
+} {{:: {foo::bar test}}}
+
+test interp-27.4 {interp aliases & namespaces} {
+ set i [interp create];
+ namespace eval foo2 {
+ variable aliasTrace {};
+ proc bar {args} {
+ variable aliasTrace;
+ lappend aliasTrace [list [namespace current] $args];
+ }
+ }
+ $i alias foo::bar foo2::bar foo::bar;
+ $i eval namespace eval foo {bar test}
+ set r $foo2::aliasTrace;
+ namespace delete foo2;
+ set r
+} {{::foo2 {foo::bar test}}}
+
+# the following tests are commented out while we don't support
+# hiding in namespaces
+
+# test interp-27.5 {interp hidden & namespaces} {
+# set i [interp create];
+# interp eval $i {
+# namespace eval foo {
+# proc bar {args} {
+# return "bar called ([namespace current]) ($args)"
+# }
+# }
+# }
+# set res [list [interp eval $i {namespace eval foo {bar test1}}]]
+# interp hide $i foo::bar;
+# lappend res [list [catch {interp eval $i {namespace eval foo {bar test2}}} msg] $msg]
+# interp delete $i;
+# set res;
+#} {{bar called (::foo) (test1)} {1 {invalid command name "bar"}}}
+
+# test interp-27.6 {interp hidden & aliases & namespaces} {
+# set i [interp create];
+# set v root-master;
+# namespace eval foo {
+# variable v foo-master;
+# proc bar {interp args} {
+# variable v;
+# list "master bar called ($v) ([namespace current]) ($args)"\
+# [interp invokehidden $interp foo::bar $args];
+# }
+# }
+# interp eval $i {
+# namespace eval foo {
+# namespace export *
+# variable v foo-slave;
+# proc bar {args} {
+# variable v;
+# return "slave bar called ($v) ([namespace current]) ($args)"
+# }
+# }
+# }
+# set res [list [interp eval $i {namespace eval foo {bar test1}}]]
+# $i hide foo::bar;
+# $i alias foo::bar foo::bar $i;
+# set res [concat $res [interp eval $i {
+# set v root-slave;
+# namespace eval test {
+# variable v foo-test;
+# namespace import ::foo::*;
+# bar test2
+# }
+# }]]
+# namespace delete foo;
+# interp delete $i;
+# set res
+# } {{slave bar called (foo-slave) (::foo) (test1)} {master bar called (foo-master) (::foo) (test2)} {slave bar called (foo-slave) (::foo) (test2)}}
+
+
+# test interp-27.7 {interp hidden & aliases & imports & namespaces} {
+# set i [interp create];
+# set v root-master;
+# namespace eval mfoo {
+# variable v foo-master;
+# proc bar {interp args} {
+# variable v;
+# list "master bar called ($v) ([namespace current]) ($args)"\
+# [interp invokehidden $interp test::bar $args];
+# }
+# }
+# interp eval $i {
+# namespace eval foo {
+# namespace export *
+# variable v foo-slave;
+# proc bar {args} {
+# variable v;
+# return "slave bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)"
+# }
+# }
+# set v root-slave;
+# namespace eval test {
+# variable v foo-test;
+# namespace import ::foo::*;
+# }
+# }
+# set res [list [interp eval $i {namespace eval test {bar test1}}]]
+# $i hide test::bar;
+# $i alias test::bar mfoo::bar $i;
+# set res [concat $res [interp eval $i {test::bar test2}]];
+# namespace delete mfoo;
+# interp delete $i;
+# set res
+# } {{slave bar called (foo-slave) (bar test1) (::test) (::foo) (test1)} {master bar called (foo-master) (::mfoo) (test2)} {slave bar called (foo-slave) (test::bar test2) (::) (::foo) (test2)}}
+
+#test interp-27.8 {hiding, namespaces and integrity} {
+# namespace eval foo {
+# variable v 3;
+# proc bar {} {variable v; set v}
+# # next command would currently generate an unknown command "bar" error.
+# interp hide {} bar;
+# }
+# namespace delete foo;
+# list [catch {interp invokehidden {} foo} msg] $msg;
+#} {1 {invalid hidden command name "foo"}}
+
+
+test interp-28.1 {getting fooled by slave's namespace ?} {
+ set i [interp create -safe];
+ proc master {interp args} {interp hide $interp list}
+ $i alias master master $i;
+ set r [interp eval $i {
+ namespace eval foo {
+ proc list {args} {
+ return "dummy foo::list";
+ }
+ master;
+ }
+ info commands list
+ }]
+ interp delete $i;
+ set r
+} {}
+
+# more tests needed...
+
+# Interp & stack
+#test interp-29.1 {interp and stack (info level)} {
+#} {}
+
+
foreach i [interp slaves] {
interp delete $i
}
diff --git a/contrib/tcl/tests/io.test b/contrib/tcl/tests/io.test
index c83033b..7392482 100644
--- a/contrib/tcl/tests/io.test
+++ b/contrib/tcl/tests/io.test
@@ -6,12 +6,12 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1994-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.
#
-# SCCS: @(#) io.test 1.119 97/06/23 18:47:01
+# SCCS: @(#) io.test 1.128 97/08/13 10:24:56
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -24,13 +24,6 @@ if {"[info commands testchannel]" != "testchannel"} {
removeFile test1
removeFile pipe
-set testConfig(umask2) 1
-catch {
- if {"[exec umask]" != "002"} {
- set testConfig(umask2) 0
- }
-}
-
# set up a long data file for some of the following tests
set f [open longfile w]
@@ -42,6 +35,28 @@ for { set i 0 } { $i < 100 } { incr i} {
}
close $f
+set f [open cat w]
+puts $f {
+ if {$argv == {}} {
+ set argv -
+ }
+ foreach name $argv {
+ if {$name == "-"} {
+ set f stdin
+ } elseif {[catch {open $name r} f] != 0} {
+ puts stderr $f
+ continue
+ }
+ while {[eof $f] == 0} {
+ puts -nonewline stdout [read $f]
+ }
+ if {$f != "stdin"} {
+ close $f
+ }
+ }
+}
+close $f
+
# These tests are disabled until we decide what to do with "unsupported0".
#
#test io-1.7 {unsupported0 command} {
@@ -51,7 +66,7 @@ close $f
# unsupported0 $f1 $f2
# close $f1
# catch {close $f2}
-# set s1 [file size io.test]
+# set s1 [file size [info script]]
# set s2 [file size test1]
# set x ok
# if {"$s1" != "$s2"} {
@@ -61,7 +76,7 @@ close $f
#} ok
#test io-1.8 {unsupported0 command} {
# removeFile test1
-# set f1 [open io.test]
+# set f1 [open [info script]]
# set f2 [open test1 w]
# unsupported0 $f1 $f2 40
# close $f1
@@ -70,13 +85,13 @@ close $f
#} 40
#test io-1.9 {unsupported0 command} {
# removeFile test1
-# set f1 [open io.test]
+# set f1 [open [info script]]
# set f2 [open test1 w]
# unsupported0 $f1 $f2 -1
# close $f1
# close $f2
# set x ok
-# set s1 [file size io.test]
+# set s1 [file size [info script]]
# set s2 [file size test1]
# if {$s1 != $s2} {
# set x broken
@@ -89,11 +104,11 @@ close $f
# set f1 [open pipe w]
# puts $f1 {puts ready}
# puts $f1 {gets stdin}
-# puts $f1 {set f1 [open io.test r]}
+# puts $f1 {set f1 [open [info script] r]}
# puts $f1 {puts [read $f1 100]}
# puts $f1 {close $f1}
# close $f1
-# set f1 [open "|$tcltest pipe" r+]
+# set f1 [open "|[list $tcltest pipe]" r+]
# gets $f1
# puts $f1 ready
# flush $f1
@@ -135,7 +150,7 @@ test io-1.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} {
interp delete x
set l
} {line line none}
-test io-1.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {unixOrPc} {
+test io-1.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {stdio} {
set f [open test1 w]
puts $f {
close stdin
@@ -152,7 +167,7 @@ test io-1.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {unixOrPc} {
close $f3
}
close $f
- set result [eval exec $tcltest test1]
+ set result [exec $tcltest test1]
set f [open test2 r]
set f2 [open test3 r]
lappend result [read $f] [read $f2]
@@ -180,7 +195,7 @@ test io-1.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {unixOnly} {
close $f3
}
close $f
- set result [eval exec $tcltest test1]
+ set result [exec $tcltest test1]
set f [open test2 r]
set f2 [open test3 r]
lappend result [read $f] [read $f2]
@@ -235,12 +250,12 @@ test io-1.8 {reuse of stdio special channels} {unixOnly} {
puts [gets $f]
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
set c [gets $f]
close $f
set c
} hello
-test io-1.9 {reuse of stdio special channels} {unixOnly} {
+test io-1.9 {reuse of stdio special channels} {stdio} {
removeFile script
removeFile test1
set f [open script w]
@@ -249,11 +264,11 @@ test io-1.9 {reuse of stdio special channels} {unixOnly} {
puts $f hello
close $f
close stderr
- set f [open "|cat test1" r]
+ set f [open "|[list [info nameofexecutable] cat test1]" r]
puts [gets $f]
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
set c [gets $f]
close $f
set c
@@ -500,7 +515,7 @@ test io-4.5 {FlushChannel, implicit flush when buffer fills and on close} {unixO
lappend l [file size test1]
set l
} {0 60 72}
-test io-4.6 {FlushChannel, async flushing, async close} {unixOrPc asyncPipeClose} {
+test io-4.6 {FlushChannel, async flushing, async close} {stdio && asyncPipeClose} {
removeFile pipe
removeFile output
set f [open pipe w]
@@ -520,7 +535,7 @@ test io-4.6 {FlushChannel, async flushing, async close} {unixOrPc asyncPipeClose
}
set f [open output w]
close $f
- set f [open "|$tcltest pipe" w]
+ set f [open "|[list $tcltest pipe]" w]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
@@ -567,7 +582,7 @@ test io-5.2 {CloseChannel called when all references are dropped} {
close $f
set l
} abcdef
-test io-5.3 {CloseChannel, not called before output queue is empty} {unixOrPc asyncPipeClose tempNotPc nonPortable} {
+test io-5.3 {CloseChannel, not called before output queue is empty} {unixOrPc asyncPipeClose nonPortable tempNotPc} {
removeFile pipe
removeFile output
set f [open pipe w]
@@ -595,8 +610,12 @@ test io-5.3 {CloseChannel, not called before output queue is empty} {unixOrPc as
}
set f [open output w]
close $f
- set f [open "|$tcltest pipe" r+]
+ set f [open "|[list $tcltest pipe]" r+]
fconfigure $f -blocking off -eofchar {}
+
+ # Under windows, the first 24576 bytes of $x are copied to $f, and
+ # then the writing fails.
+
puts -nonewline $f $x
close $f
set counter 0
@@ -632,7 +651,7 @@ test io-5.5 {Tcl_Close vs standard handles} {unixOnly} {
puts [testchannel open]
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
set l [gets $f]
close $f
set l
@@ -766,7 +785,7 @@ test io-6.11 {Tcl_Write, no newline, implicit flush} {
close $f2
file size test1
} 377
-test io-6.12 {Tcl_Write on a pipe} {unixOrPc} {
+test io-6.12 {Tcl_Write on a pipe} {stdio} {
removeFile test1
removeFile pipe
set f1 [open pipe w]
@@ -777,7 +796,7 @@ test io-6.12 {Tcl_Write on a pipe} {unixOrPc} {
}
}
close $f1
- set f1 [open "|$tcltest pipe" r]
+ set f1 [open "|[list $tcltest pipe]" r]
set f2 [open longfile r]
set y ok
for {set x 0} {$x < 10} {incr x} {
@@ -791,7 +810,7 @@ test io-6.12 {Tcl_Write on a pipe} {unixOrPc} {
close $f2
set y
} ok
-test io-6.13 {Tcl_Write to a pipe, line buffered} {unixOrPc} {
+test io-6.13 {Tcl_Write to a pipe, line buffered} {stdio} {
removeFile test1
removeFile pipe
set f1 [open pipe w]
@@ -801,7 +820,7 @@ test io-6.13 {Tcl_Write to a pipe, line buffered} {unixOrPc} {
}
close $f1
set y ok
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
fconfigure $f1 -buffering line
set f2 [open longfile r]
set line [gets $f2]
@@ -842,8 +861,8 @@ test io-6.15 {Tcl_Flush, channel not open for writing} {
string compare $x \
[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
-test io-6.16 {Tcl_Flush on pipe opened only for reading} {unixOrPc unixExecs} {
- set fd [open "|cat longfile" r]
+test io-6.16 {Tcl_Flush on pipe opened only for reading} {stdio} {
+ set fd [open "|[list $tcltest cat longfile]" r]
set x [list [catch {flush $fd} msg] $msg]
catch {close $fd}
string compare $x \
@@ -916,21 +935,21 @@ test io-6.20 {Implicit flush when buffer is full} {
lappend z [file size test1]
set z
} {4096 12288 12600}
-test io-6.21 {Tcl_Flush to pipe} {unixOrPc} {
+test io-6.21 {Tcl_Flush to pipe} {stdio} {
removeFile pipe
set f1 [open pipe w]
puts $f1 {set x [read stdin 6]}
puts $f1 {set cnt [string length $x]}
puts $f1 {puts "read $cnt characters"}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
puts $f1 hello
flush $f1
set x [gets $f1]
catch {close $f1}
set x
} "read 6 characters"
-test io-6.22 {Tcl_Flush called at other end of pipe} {unixOrPc} {
+test io-6.22 {Tcl_Flush called at other end of pipe} {stdio} {
removeFile pipe
set f1 [open pipe w]
puts $f1 {
@@ -943,7 +962,7 @@ test io-6.22 {Tcl_Flush called at other end of pipe} {unixOrPc} {
flush stdout
}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
set x ""
lappend x [gets $f1]
lappend x [gets $f1]
@@ -953,7 +972,7 @@ test io-6.22 {Tcl_Flush called at other end of pipe} {unixOrPc} {
close $f1
set x
} {hello hello bye}
-test io-6.23 {Tcl_Flush and line buffering at end of pipe} {unixOrPc} {
+test io-6.23 {Tcl_Flush and line buffering at end of pipe} {stdio} {
removeFile pipe
set f1 [open pipe w]
puts $f1 {
@@ -963,7 +982,7 @@ test io-6.23 {Tcl_Flush and line buffering at end of pipe} {unixOrPc} {
puts bye
}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
set x ""
lappend x [gets $f1]
lappend x [gets $f1]
@@ -989,9 +1008,9 @@ test io-6.24 {Tcl_Write and Tcl_Flush move end of file} {
set x
} {{} {Line 1
Line 2}}
-test io-6.25 {Implicit flush with Tcl_Flush to command pipelines} {unixOrPc unixExecs} {
+test io-6.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio} {
removeFile test3
- set f [open "| cat | cat > test3" w]
+ set f [open "|[list $tcltest cat | $tcltest cat > test3]" w]
puts $f "Line 1"
puts $f "Line 2"
close $f
@@ -1003,20 +1022,20 @@ test io-6.25 {Implicit flush with Tcl_Flush to command pipelines} {unixOrPc unix
} {Line 1
Line 2
}
-test io-6.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {unixOrPc unixExecs} {
- set f [open "| cat -u" r+]
+test io-6.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {unixOrPc && unixExecs && tempNotPc} {
+ set f [open "|[list cat -u]" r+]
puts $f "Line1"
flush $f
set x [gets $f]
close $f
set x
} {Line1}
-test io-6.27 {Tcl_Flush on closed pipeline} {unixOrPc tempNotPc} {
+test io-6.27 {Tcl_Flush on closed pipeline} {stdio && tempNotPc} {
removeFile pipe
set f [open pipe w]
puts $f {exit}
close $f
- set f [open "|$tcltest pipe" r+]
+ set f [open "|[list $tcltest pipe]" r+]
gets $f
puts $f output
after 50
@@ -1065,7 +1084,7 @@ test io-6.30 {Tcl_Write, crlf mode} {
close $f
file size test1
} 25
-test io-6.31 {Tcl_Write, background flush} {unixOrPc} {
+test io-6.31 {Tcl_Write, background flush} {stdio} {
removeFile pipe
removeFile output
set f [open pipe w]
@@ -1085,7 +1104,7 @@ test io-6.31 {Tcl_Write, background flush} {unixOrPc} {
}
set f [open output w]
close $f
- set f [open "|$tcltest pipe" r+]
+ set f [open "|[list $tcltest pipe]" r+]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
@@ -1101,7 +1120,7 @@ test io-6.31 {Tcl_Write, background flush} {unixOrPc} {
set result ok
}
} ok
-test io-6.32 {Tcl_Write, background flush to slow reader} {unixOrPc asyncPipeClose} {
+test io-6.32 {Tcl_Write, background flush to slow reader} {stdio && asyncPipeClose} {
removeFile pipe
removeFile output
set f [open pipe w]
@@ -1122,7 +1141,7 @@ test io-6.32 {Tcl_Write, background flush to slow reader} {unixOrPc asyncPipeClo
}
set f [open output w]
close $f
- set f [open "|$tcltest pipe" r+]
+ set f [open "|[list $tcltest pipe]" r+]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
@@ -1138,7 +1157,7 @@ test io-6.32 {Tcl_Write, background flush to slow reader} {unixOrPc asyncPipeClo
set result ok
}
} ok
-test io-6.33 {Tcl_Flush, implicit flush on exit} {unixOrPc} {
+test io-6.33 {Tcl_Flush, implicit flush on exit} {stdio} {
set f [open script w]
puts $f {
set f [open test1 w]
@@ -1148,7 +1167,7 @@ test io-6.33 {Tcl_Flush, implicit flush on exit} {unixOrPc} {
puts $f strange
}
close $f
- eval exec $tcltest script
+ exec $tcltest script
set f [open test1 r]
set r [read $f]
close $f
@@ -1158,7 +1177,7 @@ bye
strange
}
-test io-6.34 {Tcl_Close, async flush on close, using sockets} {tempNotMac} {
+test io-6.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac} {
set c 0
set x running
set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
@@ -1194,7 +1213,7 @@ test io-6.34 {Tcl_Close, async flush on close, using sockets} {tempNotMac} {
vwait x
set c
} 2000
-test io-6.35 {Tcl_Close vs fileevent vs multiple interpreters} {
+test io-6.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket} {
catch {interp delete x}
catch {interp delete y}
interp create x
@@ -2345,25 +2364,25 @@ test io-9.9 {Tcl_Read, read to end of file} {
}
set x
} ok
-test io-9.10 {Tcl_Read from a pipe} {unixOrPc} {
+test io-9.10 {Tcl_Read from a pipe} {stdio} {
removeFile pipe
set f1 [open pipe w]
puts $f1 {puts [gets stdin]}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
puts $f1 hello
flush $f1
set x [read $f1]
close $f1
set x
} "hello\n"
-test io-9.11 {Tcl_Read from a pipe} {unixOrPc} {
+test io-9.11 {Tcl_Read from a pipe} {stdio} {
removeFile pipe
set f1 [open pipe w]
puts $f1 {puts [gets stdin]}
puts $f1 {puts [gets stdin]}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
puts $f1 hello
flush $f1
set x ""
@@ -2467,12 +2486,12 @@ test io-10.2 {Tcl_Gets into variable} {
close $f1
set z
} ok
-test io-10.3 {Tcl_Gets from pipe} {unixOrPc} {
+test io-10.3 {Tcl_Gets from pipe} {stdio} {
removeFile pipe
set f1 [open pipe w]
puts $f1 {puts [gets stdin]}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
puts $f1 hello
flush $f1
set x [gets $f1]
@@ -2664,8 +2683,8 @@ test io-11.7 {Tcl_Seek to offset from end of file, then to current position} {
close $f1
list $c1 $r1 $c2
} {44 rstuv 49}
-test io-11.8 {Tcl_Seek on pipes: not supported} {unixOrPc} {
- set f1 [open "|$tcltest" r+]
+test io-11.8 {Tcl_Seek on pipes: not supported} {stdio} {
+ set f1 [open "|[list $tcltest]" r+]
set x [list [catch {seek $f1 0 current} msg] $msg]
close $f1
regsub {".*":} $x {"":} x
@@ -2771,14 +2790,14 @@ test io-11.15 {Tcl_Tell combined with seeking} {
close $f1
list $c1 $c2
} {10 20}
-test io-11.16 {Tcl_tell on pipe: always -1} {unixOrPc} {
- set f1 [open "|$tcltest" r+]
+test io-11.16 {Tcl_tell on pipe: always -1} {stdio} {
+ set f1 [open "|[list $tcltest]" r+]
set c [tell $f1]
close $f1
set c
} -1
-test io-11.17 {Tcl_Tell on pipe: always -1} {unixOrPc} {
- set f1 [open "|$tcltest" r+]
+test io-11.17 {Tcl_Tell on pipe: always -1} {stdio} {
+ set f1 [open "|[list $tcltest]" r+]
puts $f1 {puts hello}
flush $f1
set c [tell $f1]
@@ -2854,13 +2873,13 @@ test io-12.1 {Tcl_Eof} {
close $f
set x
} {0 0 0 0 1 1}
-test io-12.2 {Tcl_Eof with pipe} {unixOrPc} {
+test io-12.2 {Tcl_Eof with pipe} {stdio} {
removeFile pipe
set f1 [open pipe w]
puts $f1 {gets stdin}
puts $f1 {puts hello}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
puts $f1 hello
set x [eof $f1]
flush $f1
@@ -2872,13 +2891,13 @@ test io-12.2 {Tcl_Eof with pipe} {unixOrPc} {
close $f1
set x
} {0 0 0 1}
-test io-12.3 {Tcl_Eof with pipe} {unixOrPc} {
+test io-12.3 {Tcl_Eof with pipe} {stdio} {
removeFile pipe
set f1 [open pipe w]
puts $f1 {gets stdin}
puts $f1 {puts hello}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
puts $f1 hello
set x [eof $f1]
flush $f1
@@ -2906,14 +2925,14 @@ test io-12.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} {
close $f
set l
} {{} 1}
-test io-12.5 {Tcl_Eof, eof detection on nonblocking pipe} {unixOrPc} {
+test io-12.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio} {
removeFile pipe
set f [open pipe w]
puts $f {
exit
}
close $f
- set f [open "|$tcltest pipe" r]
+ set f [open "|[list $tcltest pipe]" r]
set l ""
lappend l [gets $f]
lappend l [eof $f]
@@ -3098,7 +3117,7 @@ test io-12.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} {
# Test Tcl_InputBlocked
test io-13.1 {Tcl_InputBlocked on nonblocking pipe} {unixOrPc tempNotPc} {
- set f1 [open "|$tcltest" r+]
+ set f1 [open "|[list $tcltest]" r+]
puts $f1 {puts hello_from_pipe}
flush $f1
gets $f1
@@ -3117,7 +3136,7 @@ test io-13.1 {Tcl_InputBlocked on nonblocking pipe} {unixOrPc tempNotPc} {
set x
} {{} 1 hello 0 {} 1}
test io-13.2 {Tcl_InputBlocked on blocking pipe} {unixOrPc tempNotPc} {
- set f1 [open "|$tcltest" r+]
+ set f1 [open "|[list $tcltest]" r+]
fconfigure $f1 -buffering line
puts $f1 {puts hello_from_pipe}
set x ""
@@ -3375,7 +3394,7 @@ test io-16.10 {Tcl_SetChannelOption, blocking mode} {unixOrPc tempNotPc} {
puts $f1 {gets stdin}
close $f1
set x ""
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
fconfigure $f1 -blocking off -buffering line
lappend x [fconfigure $f1 -blocking]
lappend x [gets $f1]
@@ -3448,7 +3467,7 @@ test io-17.2 {POSIX open access modes: CREAT} {unixOnly} {
close $f
set x
} {0600 {line 1}}
-test io-17.3 {POSIX open access modes: CREAT} {unixOnly nonPortable umask2} {
+test io-17.3 {POSIX open access modes: CREAT} {$testConfig(unix) && ([exec umask] == 2)} {
# This test only works if your umask is 2, like ouster's.
removeFile test3
set f [open test3 {WRONLY CREAT}]
@@ -3639,8 +3658,8 @@ test io-19.2 {Tcl_FileeventCmd: replacing} {
if {($tcl_platform(platform) != "macintosh") && \
($testConfig(unixExecs) == 1)} {
-catch {set f2 [open {|cat -u} r+]}
-catch {set f3 [open {|cat -u} r+]}
+catch {set f2 [open "|[list cat -u]" r+]}
+catch {set f3 [open "|[list cat -u]" r+]}
test io-20.1 {Tcl_FileeventCmd: creating, deleting, querying} {
set result {}
@@ -3715,8 +3734,8 @@ test io-21.4 {FileEventProc procedure: eror in write event} {
rename bgerror {}
list $x [fileevent $f2 writable]
} {bad-write {}}
-test io-21.5 {FileEventProc procedure: end of file} {unixOrPc unixExecs} {
- set f4 [open {|cat << foo} r]
+test io-21.5 {FileEventProc procedure: end of file} {unixOrPc} {
+ set f4 [open "|[list $tcltest cat << foo]" r]
fileevent $f4 readable {
if {[gets $f4 line] < 0} {
lappend x eof
@@ -4012,7 +4031,7 @@ test io-25.3 {testing readability conditions} {unixOnly nonBlockFiles} {
}
}
close $f
- set f [open |$tcltest r+]
+ set f [open "|[list $tcltest]" r+]
fileevent $f readable [list consume $f]
fconfigure $f -buffering line
fconfigure $f -blocking off
@@ -4610,7 +4629,7 @@ test io-27.6 {testing handler deletion vs reentrant calls} {
{first after update}]
} 0
-test io-28.1 {Test old socket deletion on Macintosh} {tempNotMac} {
+test io-28.1 {Test old socket deletion on Macintosh} {socket} {
set x 0
set result ""
proc accept {s a p} {
@@ -4650,7 +4669,7 @@ test io-28.1 {Test old socket deletion on Macintosh} {tempNotMac} {
test io-29.1 {TclCopyChannel} {
removeFile test1
- set f1 [open io.test]
+ set f1 [open [info script]]
set f2 [open test1 w]
fcopy $f1 $f2 -command { # }
catch { fcopy $f1 $f2 } msg
@@ -4660,9 +4679,9 @@ test io-29.1 {TclCopyChannel} {
} {0}
test io-29.2 {TclCopyChannel} {
removeFile test1
- set f1 [open io.test]
+ set f1 [open [info script]]
set f2 [open test1 w]
- set f3 [open io.test]
+ set f3 [open [info script]]
fcopy $f1 $f2 -command { # }
catch { fcopy $f3 $f2 } msg
close $f1
@@ -4672,7 +4691,7 @@ test io-29.2 {TclCopyChannel} {
} {0}
test io-29.3 {TclCopyChannel} {
removeFile test1
- set f1 [open io.test]
+ set f1 [open [info script]]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
@@ -4680,7 +4699,7 @@ test io-29.3 {TclCopyChannel} {
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
- set s1 [file size io.test]
+ set s1 [file size [info script]]
set s2 [file size test1]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
@@ -4689,7 +4708,7 @@ test io-29.3 {TclCopyChannel} {
} {0 0 ok}
test io-29.4 {TclCopyChannel} {
removeFile test1
- set f1 [open io.test]
+ set f1 [open [info script]]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
@@ -4701,7 +4720,7 @@ test io-29.4 {TclCopyChannel} {
} {0 0 40}
test io-29.5 {TclCopyChannel} {
removeFile test1
- set f1 [open io.test]
+ set f1 [open [info script]]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation lf -blocking 0
@@ -4709,7 +4728,7 @@ test io-29.5 {TclCopyChannel} {
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
- set s1 [file size io.test]
+ set s1 [file size [info script]]
set s2 [file size test1]
if {"$s1" == "$s2"} {
lappend result ok
@@ -4718,15 +4737,15 @@ test io-29.5 {TclCopyChannel} {
} {0 0 ok}
test io-29.6 {TclCopyChannel} {
removeFile test1
- set f1 [open io.test]
+ set f1 [open [info script]]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation lf -blocking 0
- set s0 [fcopy $f1 $f2 -size [expr [file size io.test] + 5]]
+ set s0 [fcopy $f1 $f2 -size [expr [file size [info script]] + 5]]
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
- set s1 [file size io.test]
+ set s1 [file size [info script]]
set s2 [file size test1]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
@@ -4735,13 +4754,13 @@ test io-29.6 {TclCopyChannel} {
} {0 0 ok}
test io-29.7 {TclCopyChannel} {
removeFile test1
- set f1 [open io.test]
+ set f1 [open [info script]]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation lf -blocking 0
fcopy $f1 $f2
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
- set s1 [file size io.test]
+ set s1 [file size [info script]]
set s2 [file size test1]
close $f1
close $f2
@@ -4750,23 +4769,27 @@ test io-29.7 {TclCopyChannel} {
}
set result
} {0 0 ok}
-test io-29.8 {TclCopyChannel} {unixOrPc} {
+test io-29.8 {TclCopyChannel} {stdio} {
removeFile test1
removeFile pipe
set f1 [open pipe w]
+ fconfigure $f1 -translation lf
puts $f1 {
puts ready
gets stdin
- set f1 [open io.test r]
+ set f1 [open [info script] r]
+ fconfigure $f1 -translation lf
puts [read $f1 100]
close $f1
}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
+ fconfigure $f1 -translation lf
gets $f1
puts $f1 ready
flush $f1
set f2 [open test1 w]
+ fconfigure $f2 -translation lf
set s0 [fcopy $f1 $f2 -size 40]
catch {close $f1}
close $f2
@@ -4775,7 +4798,7 @@ test io-29.8 {TclCopyChannel} {unixOrPc} {
test io-30.1 {CopyData} {
removeFile test1
- set f1 [open io.test]
+ set f1 [open [info script]]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
@@ -4787,7 +4810,7 @@ test io-30.1 {CopyData} {
} {0 0 0}
test io-30.2 {CopyData} {
removeFile test1
- set f1 [open io.test]
+ set f1 [open [info script]]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
@@ -4796,7 +4819,7 @@ test io-30.2 {CopyData} {
vwait s0
close $f1
close $f2
- set s1 [file size io.test]
+ set s1 [file size [info script]]
set s2 [file size test1]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
@@ -4818,7 +4841,7 @@ test io-30.3 {CopyData: background read underflow} {unixOnly} {
close $f
}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
set result [gets $f1]
puts $f1 line1
flush $f1
@@ -4851,7 +4874,7 @@ test io-30.4 {CopyData: background write overflow} {unixOnly} {
close $f
}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
set result [gets $f1]
fconfigure $f1 -blocking 0
puts $f1 $big
@@ -4885,21 +4908,38 @@ if [catch {socket -server FcopyTestAccept 2828} listen] {
puts stderr "Skipping fcopy error test"
} else {
test io-30.5 {CopyData: error during fcopy} {
- set in [open io.test] ;# 126 K
+ set in [open [info script]] ;# 126 K
set out [socket localhost 2828]
catch {unset fcopyTestDone}
close $listen ;# This means the socket open never really succeeds
fcopy $in $out -command FcopyTestDone
if ![info exists fcopyTestDone] {
- vwait fcopyTestDone
+ vwait fcopyTestDone ;# The error occurs here in the b.g.
}
close $in
close $out
- set fcopyTestDone
+ set fcopyTestDone ;# 1 for error condition
} 1
}
+test io-30.6 {CopyData: error during fcopy} {stdio} {
+ removeFile pipe
+ removeFile test1
+ catch {unset fcopyTestDone}
+ set f1 [open pipe w]
+ puts $f1 "exit 1"
+ close $f1
+ set in [open "|[list $tcltest pipe]" r+]
+ set out [open test1 w]
+ fcopy $in $out -command [list FcopyTestDone]
+ if ![info exists fcopyTestDone] {
+ vwait fcopyTestDone
+ }
+ catch {close $in}
+ close $out
+ set fcopyTestDone ;# 0 for plain end of file
+} {0}
-test io-31.1 {Recursive channel events} {
+test io-31.1 {Recursive channel events} {socket} {
# This test checks to see if file events are delivered during recursive
# event loops when there is buffered data on the channel.
@@ -4951,7 +4991,7 @@ test io-31.1 {Recursive channel events} {
close $cs
list $result $x
} {{{line 1} 1 2} 2}
-test io-31.2 {Testing for busy-wait in recursive channel events} {
+test io-31.2 {Testing for busy-wait in recursive channel events} {socket} {
set s [socket -server accept 3939]
proc accept {s a p} {
global counter
@@ -4998,7 +5038,23 @@ test io-31.2 {Testing for busy-wait in recursive channel events} {
close $s
set counter
} 1
+test io-32.1 {ChannelEventScriptInvoker: deletion} {
+ proc eventScript {fd} {
+ close $fd
+ error "planned error"
+ set ::x whoops
+ }
+ proc bgerror {args} {
+ set ::x got_error
+ }
+ set f [open fooBar w]
+ fileevent $f writable [list eventScript $f]
+ set x not_done
+ vwait x
+ set x
+} {got_error}
+removeFile fooBar
removeFile longfile
removeFile script
removeFile output
@@ -5010,5 +5066,7 @@ removeFile bar
removeFile test2
removeFile test3
+file delete cat
+
set x ""
unset x
diff --git a/contrib/tcl/tests/ioCmd.test b/contrib/tcl/tests/ioCmd.test
index 149d6c7..95a5975 100644
--- a/contrib/tcl/tests/ioCmd.test
+++ b/contrib/tcl/tests/ioCmd.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# "@(#) ioCmd.test 1.47 97/06/23 18:21:31"
+# "@(#) ioCmd.test 1.48 97/08/01 11:11:23"
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -262,13 +262,13 @@ proc iocmdSSHTDWN {} {
}
}
-test iocmd-8.15 {fconfigure command / tcp channel} {
+test iocmd-8.15 {fconfigure command / tcp channel} {socket} {
iocmdSSETUP
set r [list [catch {fconfigure $cli -blah} msg] $msg];
iocmdSSHTDWN
set r;
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, -peername, or -sockname}}
-test iocmd-8.16 {fconfigure command / tcp channel} {
+test iocmd-8.16 {fconfigure command / tcp channel} {socket} {
iocmdSSETUP
set r [expr [lindex [fconfigure $cli -peername] 2]==$port];
iocmdSSHTDWN
@@ -293,8 +293,9 @@ test iocmd-8.18 {fconfigure command / unix tty channel} {nonPortable unixOnly} {
close $tty;
set r;
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, or -mode}}
-test iocmd-8.19 {fconfigure command / win tty channel} {pcOnly} {
- # might fail if com1 is unavailable
+test iocmd-8.19 {fconfigure command / win tty channel} {pcOnly && !win32s} {
+ # None of the com port functions are implemented on Win32s.
+ # Also, might fail if com1 is unavailable
set tty [open com1]
set r [list [catch {fconfigure $tty -blah blih} msg] $msg];
close $tty;
diff --git a/contrib/tcl/tests/misc.test b/contrib/tcl/tests/misc.test
index 5929206..b2168c1 100644
--- a/contrib/tcl/tests/misc.test
+++ b/contrib/tcl/tests/misc.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) misc.test 1.11 97/06/20 16:53:28
+# SCCS: @(#) misc.test 1.12 97/07/02 16:41:34
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -48,10 +48,4 @@ test misc-1.2 {error in variable ref. in command in array reference} {
"
set msg {}
list [catch tstProc msg] $msg $errorInfo
-} [list 1 {missing close-bracket or close-brace} \
-{missing close-bracket or close-brace
- while compiling
-"set"
- (compiling body of proc "tstProc", line 4)
- invoked from within
-"tstProc"}]
+} {1 {missing close-bracket or close-brace} missing\ close-bracket\ or\ close-brace\n\ \ \ \ while\ compiling\n\"set\ tst\ \$a(\[winfo\ name\ \$\{zz)\"\n\ \ \ \ (compiling\ body\ of\ proc\ \"tstProc\",\ line\ 4)\n\ \ \ \ invoked\ from\ within\n\"tstProc\"}
diff --git a/contrib/tcl/tests/namespace.test b/contrib/tcl/tests/namespace.test
index c021d21..e876391 100644
--- a/contrib/tcl/tests/namespace.test
+++ b/contrib/tcl/tests/namespace.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) namespace.test 1.11 97/06/23 18:24:39
+# SCCS: @(#) namespace.test 1.15 97/07/30 15:26:42
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -18,7 +18,7 @@ if {[string compare test [info procs test]] == 1} then {source defs}
catch {eval namespace delete [namespace children :: test_ns_*]}
test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} {
- namespace children ::
+ namespace children :: test_ns_*
} {}
catch {unset l}
@@ -90,10 +90,18 @@ test namespace-6.2 {Tcl_CreateNamespace, odd number of :'s in name is okay} {
list [namespace eval :::test_ns_1::::foo {namespace current}] \
[namespace eval test_ns_2:::::foo {namespace current}]
} {::test_ns_1::foo ::test_ns_2::foo}
-test namespace-6.3 {Tcl_CreateNamespace, bad namespace names} {
+test namespace-6.3 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} {
list [catch {namespace eval test_ns_7::: {namespace current}} msg] $msg
-} {1 {can't create namespace "": invalid name}}
-test namespace-6.4 {Tcl_CreateNamespace, relative ns names now only looked up in current ns} {
+} {0 ::test_ns_7}
+test namespace-6.4 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ namespace eval test_ns_1:: {
+ namespace eval test_ns_2:: {}
+ namespace eval test_ns_3:: {}
+ }
+ namespace children ::test_ns_1
+} {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_3}
+test namespace-6.5 {Tcl_CreateNamespace, relative ns names now only looked up in current ns} {
set trigger {
namespace eval test_ns_2 {namespace current}
}
@@ -297,7 +305,7 @@ test namespace-14.1 {TclGetNamespaceForQualName, absolute names} {
}
namespace eval test_ns_1 {
list $::v $::test_ns_2::v $::test_ns_1::test_ns_2::v \
- [namespace children ::]
+ [namespace children :: test_ns_*]
}
} {10 30 20 {::test_ns_1 ::test_ns_2}}
test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} {
@@ -364,10 +372,18 @@ test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for
proc test_ns_1::test_ns_2:: {args} {return "\{\}: $args"}
lappend l [test_ns_1::test_ns_2:: hello]
} {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}}
-test namespace-14.12 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} {
+test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ namespace eval test_ns_1 {
+ variable {}
+ set test_ns_1::(x) y
+ }
+ set test_ns_1::(x)
+} y
+test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace eval test_ns_1 {proc {} {} {}; namespace eval {} {}; {}}} msg] $msg
-} {1 {can't create namespace "": invalid name}}
+} {1 {can't create namespace "": only global namespace can have empty name}}
test namespace-15.1 {Tcl_FindNamespace, absolute name found} {
catch {eval namespace delete [namespace children :: test_ns_*]}
@@ -604,16 +620,16 @@ test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} {
} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}}
test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} {
list [catch {namespace wombat {}} msg] $msg
-} {1 {bad namespace subcommand "wombat": should be children, code, current, delete, eval, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
+} {1 {bad option "wombat": must be children, code, current, delete, eval, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} {
- namespace ch ::
+ namespace ch :: test_ns_*
} {}
test namespace-21.1 {NamespaceChildrenCmd, no args} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2 {}
- namespace children
-} {::test_ns_1}
+ expr {[string first ::test_ns_1 [namespace children]] != -1}
+} {1}
test namespace-21.2 {NamespaceChildrenCmd, no args} {
namespace eval test_ns_1 {
namespace children
@@ -700,7 +716,7 @@ test namespace-25.1 {NamespaceEvalCmd, bad args} {
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
test namespace-25.2 {NamespaceEvalCmd, bad args} {
list [catch {namespace test_ns_1} msg] $msg
-} {1 {bad namespace subcommand "test_ns_1": should be children, code, current, delete, eval, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
+} {1 {bad option "test_ns_1": must be children, code, current, delete, eval, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
catch {unset v}
test namespace-25.3 {NamespaceEvalCmd, new namespace} {
set v 123
diff --git a/contrib/tcl/tests/obj.test b/contrib/tcl/tests/obj.test
index cc8ea3c..e8ee3b3 100644
--- a/contrib/tcl/tests/obj.test
+++ b/contrib/tcl/tests/obj.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# @(#) obj.test 1.10 97/05/19 14:38:29
+# @(#) obj.test 1.11 97/08/06 08:56:09
if {[info commands testobj] == {}} {
puts "This application hasn't been compiled with the \"testobj\""
@@ -171,7 +171,7 @@ test obj-12.1 {SetBooleanFromAny, int to boolean special case} {
} {1234 0 boolean}
test obj-12.2 {SetBooleanFromAny, double to boolean special case} {
set result ""
- lappend result [format %.6g [testdoubleobj set 1 3.14159]]
+ lappend result [testdoubleobj set 1 3.14159]
lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny
lappend result [testobj type 1]
} {3.14159 0 boolean}
@@ -219,10 +219,10 @@ test obj-13.1 {UpdateStringOfBoolean} {
test obj-14.1 {Tcl_NewDoubleObj} {
set result ""
lappend result [testobj freeallvars]
- lappend result [format %.6g [testdoubleobj set 1 3.1459]]
+ lappend result [testdoubleobj set 1 3.1459]
lappend result [testobj type 1]
lappend result [testobj refcount 1]
-} {{} 3.1459 double 1}
+} {{} 3.1459 double 2}
test obj-15.1 {Tcl_SetDoubleObj, existing "empty string" object} {
set result ""
@@ -236,20 +236,20 @@ test obj-15.2 {Tcl_SetDoubleObj, existing non-"empty string" object} {
set result ""
lappend result [testobj freeallvars]
lappend result [testintobj set 1 98765]
- lappend result [format %.6g [testdoubleobj set 1 27.56]] ;# makes existing obj double
+ lappend result [testdoubleobj set 1 27.56] ;# makes existing obj double
lappend result [testobj type 1]
lappend result [testobj refcount 1]
-} {{} 98765 27.56 double 1}
+} {{} 98765 27.56 double 2}
test obj-16.1 {Tcl_GetDoubleFromObj, existing double object} {
set result ""
- lappend result [format %.6g [testdoubleobj set 1 16.1]]
+ lappend result [testdoubleobj set 1 16.1]
lappend result [testdoubleobj mult10 1] ;# gets existing double rep
} {16.1 161.0}
test obj-16.2 {Tcl_GetDoubleFromObj, convert to double} {
set result ""
lappend result [testintobj set 1 477]
- lappend result [format %.6g [testdoubleobj div10 1]] ;# must convert to bool
+ lappend result [testdoubleobj div10 1] ;# must convert to bool
lappend result [testobj type 1]
} {477 47.7 double}
test obj-16.3 {Tcl_GetDoubleFromObj, error converting to double} {
@@ -267,9 +267,9 @@ test obj-16.4 {Tcl_GetDoubleFromObj, error converting from "empty string"} {
test obj-17.1 {DupDoubleInternalRep} {
set result ""
- lappend result [format %.6g [testdoubleobj set 1 17.1]]
- lappend result [format %.6g [testobj duplicate 1 2]] ;# uses DupDoubleInternalRep
- lappend result [format %.6g [testdoubleobj get 2]]
+ lappend result [testdoubleobj set 1 17.1]
+ lappend result [testobj duplicate 1 2] ;# uses DupDoubleInternalRep
+ lappend result [testdoubleobj get 2]
} {17.1 17.1 17.1}
test obj-18.1 {SetDoubleFromAny, int to double special case} {
@@ -312,9 +312,9 @@ test obj-18.6 {SetDoubleFromAny, error converting from "empty string"} {
test obj-19.1 {UpdateStringOfDouble} {
set result ""
- lappend result [format %.6g [testdoubleobj set 1 3.14159]]
- lappend result [format %.6g [testdoubleobj mult10 1]]
- lappend result [format %.6g [testdoubleobj get 1]] ;# must update string rep
+ lappend result [testdoubleobj set 1 3.14159]
+ lappend result [testdoubleobj mult10 1]
+ lappend result [testdoubleobj get 1] ;# must update string rep
} {3.14159 31.4159 31.4159}
test obj-20.1 {Tcl_NewIntObj} {
diff --git a/contrib/tcl/tests/opt.test b/contrib/tcl/tests/opt.test
new file mode 100644
index 0000000..2f23bc6
--- /dev/null
+++ b/contrib/tcl/tests/opt.test
@@ -0,0 +1,236 @@
+# Package covered: opt0.1/optparse.tcl
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1991-1993 The Regents of the University of California.
+# Copyright (c) 1994-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.
+#
+# SCCS: @(#) opt.test 1.1 97/08/14 00:53:59
+
+if {[string compare test [info procs test]] == 1} then {source defs}
+
+# the package we are going to test
+package require opt 0.1
+
+# we are using implementation specifics to test the package
+
+
+#### functions tests #####
+
+set n $::tcl::OptDescN
+
+test opt-1.1 {OptKeyRegister / check that auto allocation is skipping existing keys} {
+ list [::tcl::OptKeyRegister {} $n] [::tcl::OptKeyRegister {} [expr $n+1]] [::tcl::OptKeyRegister {}]
+} "$n [expr $n+1] [expr $n+2]"
+
+test opt-2.1 {OptKeyDelete} {
+ list [::tcl::OptKeyRegister {} testkey] [::tcl::OptKeyDelete testkey] \
+ [catch {::tcl::OptKeyDelete testkey} msg] $msg;
+} {testkey {} 1 {can't unset "OptDesc(testkey)": no such element in array}}
+
+
+test opt-3.1 {OptParse / temp key is removed} {
+ set n $::tcl::OptDescN
+ set prev [array names ::tcl::OptDesc]
+ ::tcl::OptKeyRegister {} $n
+ list [info exists ::tcl::OptDesc($n)]\
+ [::tcl::OptKeyDelete $n]\
+ [::tcl::OptParse {{-foo}} {}]\
+ [info exists ::tcl::OptDesc($n)]\
+ [expr {"[lsort $prev]"=="[lsort [array names ::tcl::OptDesc]]"}]
+} {1 {} {} 0 1}
+
+
+test opt-3.2 {OptParse / temp key is removed even on errors} {
+ set n $::tcl::OptDescN
+ catch {::tcl::OptKeyDelete $n}
+ list [catch {::tcl::OptParse {{-foo}} {-blah}}] \
+ [info exists ::tcl::OptDesc($n)]
+} {1 0}
+
+test opt-4.1 {OptProc} {
+ ::tcl::OptProc optTest {} {}
+ optTest ;
+ ::tcl::OptKeyDelete optTest
+} {}
+
+
+test opt-5.1 {OptProcArgGiven} {
+ ::tcl::OptProc optTest {{-foo}} {
+ if {[::tcl::OptProcArgGiven "-foo"]} {
+ return 1
+ } else {
+ return 0
+ }
+ }
+ list [optTest] [optTest -f] [optTest -F] [optTest -fOO]
+} {0 1 1 1}
+
+test opt-6.1 {OptKeyParse} {
+ ::tcl::OptKeyRegister {} test;
+ list [catch {::tcl::OptKeyParse test {-help}} msg] $msg
+} {1 {Usage information:
+ Var/FlagName Type Value Help
+ ------------ ---- ----- ----
+ ( -help gives this help )}}
+
+
+test opt-7.1 {OptCheckType} {
+ list \
+ [::tcl::OptCheckType 23 int] \
+ [::tcl::OptCheckType 23 float] \
+ [::tcl::OptCheckType true boolean] \
+ [::tcl::OptCheckType "-blah" any] \
+ [::tcl::OptCheckType {a b c} list] \
+ [::tcl::OptCheckType maYbe choice {yes maYbe no}] \
+ [catch {::tcl::OptCheckType "-blah" string}] \
+ [catch {::tcl::OptCheckType 6 boolean}] \
+ [catch {::tcl::OptCheckType x float}] \
+ [catch {::tcl::OptCheckType "a \{ c" list}] \
+ [catch {::tcl::OptCheckType 2.3 int}] \
+ [catch {::tcl::OptCheckType foo choice {x y Foo z}}]
+} {23 23.0 1 -blah {a b c} maYbe 1 1 1 1 1 1}
+
+
+test opt-8.1 {List utilities} {
+ ::tcl::Lempty {}
+} 1
+test opt-8.2 {List utilities} {
+ ::tcl::Lempty {a b c}
+} 0
+test opt-8.3 {List utilities} {
+ ::tcl::Lget {a {b c d} e} {1 2}
+} d
+
+test opt-8.4 {List utilities} {
+ set l {a {b c d e} f}
+ ::tcl::Lvarset l {1 2} D
+ set l
+} {a {b c D e} f}
+
+test opt-8.5 {List utilities} {
+ set l {a b c}
+ ::tcl::Lvarset1 l 6 X
+ set l
+} {a b c {} {} {} X}
+
+test opt-8.6 {List utilities} {
+ set l {a {b c 7 e} f}
+ ::tcl::Lvarincr l {1 2}
+ set l
+} {a {b c 8 e} f}
+
+test opt-8.7 {List utilities} {
+ set l {a {b c 7 e} f}
+ ::tcl::Lvarincr l {1 2} -9
+ set l
+} {a {b c -2 e} f}
+
+test opt-8.8 {List utilities} {
+ set l {{b c 7 e} f}
+ ::tcl::Lfirst $l
+} {b c 7 e}
+
+
+test opt-8.9 {List utilities} {
+ set l {a {b c 7 e} f}
+ ::tcl::Lrest $l
+} {{b c 7 e} f}
+
+test opt-8.10 {List utilities} {
+ set l {a {b c 7 e} f}
+ ::tcl::Lvarpop l
+ set l
+} {{b c 7 e} f}
+
+test opt-8.11 {List utilities} {
+ set l {a {b c 7 e} f}
+ list [::tcl::Lassign $l u v w x] \
+ $u $v $w [info exists x]
+} {3 a {b c 7 e} f 0}
+
+test opt-9.1 {Misc utilities} {
+ catch {unset v}
+ ::tcl::SetMax v 3
+ ::tcl::SetMax v 7
+ ::tcl::SetMax v 6
+ set v
+} 7
+
+test opt-9.2 {Misc utilities} {
+ catch {unset v}
+ ::tcl::SetMin v 3
+ ::tcl::SetMin v -7
+ ::tcl::SetMin v 1
+ set v
+} -7
+
+#### behaviour tests #####
+
+test opt-10.1 {ambigous flags} {
+ ::tcl::OptProc optTest {{-flag1xyz} {-other} {-flag2xyz} {-flag3xyz}} {}
+ catch {optTest -fL} msg
+ set msg
+} {ambigous option "-fL", choose from:
+ -flag1xyz boolflag (false)
+ -flag2xyz boolflag (false)
+ -flag3xyz boolflag (false) }
+
+test opt-10.2 {non ambigous flags} {
+ ::tcl::OptProc optTest {{-flag1xyz} {-other} {-flag2xyz} {-flag3xyz}} {
+ return $flag2xyz
+ }
+ optTest -fLaG2
+} 1
+
+
+# medium size overall test example: (defined once)
+::tcl::OptProc optTest {
+ {cmd -choice {print save delete} "sub command to choose"}
+ {-allowBoing -boolean true}
+ {arg2 -string "this is help"}
+ {?arg3? 7 "optional number"}
+ {-moreflags}
+} {
+ list $cmd $allowBoing $arg2 $arg3 $moreflags
+}
+
+test opt-10.3 {medium size overall test} {
+ list [catch {optTest} msg] $msg
+} {1 {no value given for parameter "cmd" (use -help for full usage) :
+ cmd choice (print save delete) sub command to choose}}
+
+
+test opt-10.4 {medium size overall test} {
+ list [catch {optTest -help} msg] $msg
+} {1 {Usage information:
+ Var/FlagName Type Value Help
+ ------------ ---- ----- ----
+ ( -help gives this help )
+ cmd choice (print save delete) sub command to choose
+ -allowBoing boolean (true)
+ arg2 string () this is help
+ ?arg3? int (7) optional number
+ -moreflags boolflag (false) }}
+
+test opt-10.5 {medium size overall test} {
+ optTest save tst
+} {save 1 tst 7 0}
+
+test opt-10.6 {medium size overall test} {
+ optTest save -allowBoing false -- 8
+} {save 0 8 7 0}
+
+test opt-10.7 {medium size overall test} {
+ optTest save tst -m --
+} {save 1 tst 7 1}
+
+test opt-10.8 {medium size overall test} {
+ list [catch {optTest save tst foo} msg] [lindex [split $msg "\n"] 0]
+} {1 {too many arguments (unexpected argument(s): foo), usage:}}
+
diff --git a/contrib/tcl/tests/parse.test b/contrib/tcl/tests/parse.test
index 1241262..514ed2a 100644
--- a/contrib/tcl/tests/parse.test
+++ b/contrib/tcl/tests/parse.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) parse.test 1.40 97/06/23 18:19:53
+# SCCS: @(#) parse.test 1.42 97/08/04 11:05:53
if {[string compare test [info procs test]] == 1} then {source defs}
diff --git a/contrib/tcl/tests/pkg.test b/contrib/tcl/tests/pkg.test
index 37a5b9c..e6a99c6 100644
--- a/contrib/tcl/tests/pkg.test
+++ b/contrib/tcl/tests/pkg.test
@@ -9,11 +9,21 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) pkg.test 1.9 96/11/15 17:56:01
+# SCCS: @(#) pkg.test 1.12 97/08/14 01:33:54
+
+if {[string compare test [info procs test]] == 1} then {source defs}
+
+# Do all this in a slave interp to avoid garbaging the
+# package list
+set i [interp create]
+interp eval $i [list set VERBOSE $VERBOSE]
+interp eval $i [list set TESTS $TESTS]
+interp eval $i {
if {[string compare test [info procs test]] == 1} then {source defs}
eval package forget [package names]
+set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
set auto_path ""
@@ -192,7 +202,7 @@ test pkg-2.16 {Tcl_PkgRequire procedure, "package unknown" error} {
} {1 {testing package unknown} {testing package unknown
while executing
"error "testing package unknown""
- (procedure "pkgUnknown" line 1)
+ (procedure "pkgUnknown" line 2)
invoked from within
"pkgUnknown t {}"
("package unknown" script)
@@ -546,4 +556,8 @@ test pkg-6.9 {ComparePkgVersions procedure} {
} {0}
set auto_path $oldPath
+package unknown $oldPkgUnknown
concat
+
+}
+interp delete $i
diff --git a/contrib/tcl/tests/proc-old.test b/contrib/tcl/tests/proc-old.test
index 5da6335..c770edb 100644
--- a/contrib/tcl/tests/proc-old.test
+++ b/contrib/tcl/tests/proc-old.test
@@ -13,7 +13,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) proc-old.test 1.30 97/04/30 14:14:47
+# SCCS: @(#) proc-old.test 1.31 97/07/02 16:41:36
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -316,7 +316,7 @@ test proc-old-5.13 {error conditions} {
} {error in procedure
while executing
"error "error in procedure""
- (procedure "tproc" line 1)
+ (procedure "tproc" line 3)
invoked from within
"tproc"}
test proc-old-5.14 {error conditions} {
@@ -358,7 +358,7 @@ test proc-old-5.16 {error conditions} {
} {1 {Nested error} {Nested error
while executing
"error "Nested error""
- (procedure "tproc" line 1)
+ (procedure "tproc" line 5)
invoked from within
"tproc"} {foo was called: x {} u}}
diff --git a/contrib/tcl/tests/proc.test b/contrib/tcl/tests/proc.test
index 9647399..eeace97 100644
--- a/contrib/tcl/tests/proc.test
+++ b/contrib/tcl/tests/proc.test
@@ -1,8 +1,8 @@
# This file contains tests for the tclProc.c source file. Tests appear in
# the same order as the C code that they test. The set of tests is
-# currently incomplete since it currently includes only new tests for
-# code changed for the addition of Tcl namespaces. Other procedure-
-# related tests appear in other test files including proc-old.test.
+# currently incomplete since it includes only new tests, in particular
+# tests for code changed for the addition of Tcl namespaces. Other
+# procedure-related tests appear in other test files such as proc-old.test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) proc.test 1.9 97/06/20 18:55:03
+# SCCS: @(#) proc.test 1.11 97/08/12 13:31:43
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -143,7 +143,7 @@ test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespa
p
}
} {p in ::}
-test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined} {
+test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
namespace eval test_ns_1::baz {
@@ -151,7 +151,11 @@ test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they we
rename ::test_ns_1::baz::p ::p
list [p] [namespace which p]
}
-} {{p in ::test_ns_1::baz} ::p}
+} {{p in ::} ::p}
+test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} {
+ proc p {x} {info commands 3m}
+ list [catch {p} msg] $msg
+} {1 {no value given for parameter "x" to "p"}}
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
diff --git a/contrib/tcl/tests/pwd.test b/contrib/tcl/tests/pwd.test
new file mode 100644
index 0000000..e283799
--- /dev/null
+++ b/contrib/tcl/tests/pwd.test
@@ -0,0 +1,22 @@
+# Commands covered: pwd
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1991-1993 The Regents of the University of California.
+# Copyright (c) 1994-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.
+#
+# SCCS: @(#) pwd.test 1.2 97/08/13 23:06:41
+
+if {[string compare test [info procs test]] == 1} then {source defs}
+
+test pwd-1.1 {simple pwd} {
+ catch pwd
+} 0
+test pwd-1.2 {simple pwd} {
+ expr [string length pwd]>0
+} 1
diff --git a/contrib/tcl/tests/registry.test b/contrib/tcl/tests/registry.test
index 6a6b99f..605c84b 100644
--- a/contrib/tcl/tests/registry.test
+++ b/contrib/tcl/tests/registry.test
@@ -9,7 +9,7 @@
#
# Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved.
#
-# SCCS: @(#) registry.test 1.3 97/02/11 16:58:43
+# SCCS: @(#) registry.test 1.5 97/08/01 11:14:25
if {$tcl_platform(platform) != "windows"} {
return
@@ -22,6 +22,11 @@ if [catch {package require registry}] {
return
}
+if {$testConfig(win32s)} {
+ puts "Skipping registry tests under Win32s"
+ return
+}
+
switch $tcl_platform(os) {
"Windows NT" {set testConfig(NT) 1}
"Windows 95" {set testConfig(95) 1}
@@ -38,7 +43,7 @@ test registry-1.2 {argument parsing for registry command} {
test registry-1.3 {argument parsing for registry command} {
list [catch {registry d} msg] $msg
-} {1 {wrong # args: should be "registry d keyName ?valueName?"}}
+} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}
test registry-1.4 {argument parsing for registry command} {
list [catch {registry delete} msg] $msg
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}
@@ -48,7 +53,7 @@ test registry-1.5 {argument parsing for registry command} {
test registry-1.6 {argument parsing for registry command} {
list [catch {registry g} msg] $msg
-} {1 {wrong # args: should be "registry g keyName valueName"}}
+} {1 {wrong # args: should be "registry get keyName valueName"}}
test registry-1.7 {argument parsing for registry command} {
list [catch {registry get} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}
@@ -61,7 +66,7 @@ test registry-1.9 {argument parsing for registry command} {
test registry-1.10 {argument parsing for registry command} {
list [catch {registry k} msg] $msg
-} {1 {wrong # args: should be "registry k keyName ?pattern?"}}
+} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}
test registry-1.11 {argument parsing for registry command} {
list [catch {registry keys} msg] $msg
} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}
@@ -71,7 +76,7 @@ test registry-1.12 {argument parsing for registry command} {
test registry-1.13 {argument parsing for registry command} {
list [catch {registry s} msg] $msg
-} {1 {wrong # args: should be "registry s keyName ?valueName data ?type??"}}
+} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
test registry-1.14 {argument parsing for registry command} {
list [catch {registry set} msg] $msg
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
@@ -84,7 +89,7 @@ test registry-1.16 {argument parsing for registry command} {
test registry-1.17 {argument parsing for registry command} {
list [catch {registry t} msg] $msg
-} {1 {wrong # args: should be "registry t keyName valueName"}}
+} {1 {wrong # args: should be "registry type keyName valueName"}}
test registry-1.18 {argument parsing for registry command} {
list [catch {registry type} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}
@@ -97,7 +102,7 @@ test registry-1.20 {argument parsing for registry command} {
test registry-1.21 {argument parsing for registry command} {
list [catch {registry v} msg] $msg
-} {1 {wrong # args: should be "registry v keyName ?pattern?"}}
+} {1 {wrong # args: should be "registry values keyName ?pattern?"}}
test registry-1.22 {argument parsing for registry command} {
list [catch {registry values} msg] $msg
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}
diff --git a/contrib/tcl/tests/resource.test b/contrib/tcl/tests/resource.test
index dc60535..efb3c82 100644
--- a/contrib/tcl/tests/resource.test
+++ b/contrib/tcl/tests/resource.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) resource.test 1.5 97/05/15 17:51:48
+# SCCS: @(#) resource.test 1.6 97/07/23 17:41:51
# Only run this test on Macintosh systems
if {$tcl_platform(platform) != "macintosh"} {
@@ -36,39 +36,130 @@ test resource-2.3 {resource open & close tests} {
} {1 {illegal access mode "bad_perms"}}
test resource-2.4 {resource open & close tests} {
list [catch {resource open _bad_file_} msg] $msg
-} {1 {path doesn't lead to a file}}
+} {1 {file does not exist}}
test resource-2.5 {resource open & close tests} {
testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"}
set id [resource open rsrc.file]
resource close $id
} {}
test resource-2.6 {resource open & close tests} {
+ list [catch {resource close} msg] $msg
+} {1 {wrong # args: should be "resource close resourceRef"}}
+test resource-2.7 {resource open & close tests} {
+ list [catch {resource close foo bar} msg] $msg
+} {1 {wrong # args: should be "resource close resourceRef"}}
+test resource-2.8 {resource open & close tests} {
list [catch {resource close _bad_resource_} msg] $msg
} {1 {invalid resource file reference "_bad_resource_"}}
+# Tests for listing resources
+test resource-3.1 {resource list tests} {
+ list [catch {resource list} msg] $msg
+} {1 {wrong # args: should be "resource list resourceType ?resourceRef?"}}
+test resource-3.2 {resource list tests} {
+ list [catch {resource list _bad_type_} msg] $msg
+} {1 {expected Macintosh OS type but got "_bad_type_"}}
+test resource-3.3 {resource list tests} {
+ list [catch {resource list TEXT _bad_ref_} msg] $msg
+} {1 {invalid resource file reference "_bad_ref_"}}
+test resource-3.4 {resource list tests} {
+ list [catch {resource list TEXT _bad_ref_ extraArg} msg] $msg
+} {1 {wrong # args: should be "resource list resourceType ?resourceRef?"}}
+test resource-3.5 {resource list tests} {
+ catch {file delete rsrc.file}
+ testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"}
+ set id [resource open rsrc.file]
+ catch "resource list TEXT $id" result
+ resource close $id
+ set result
+} {fileRsrcName}
+test resource-3.6 {resource list tests} {
+ # There should be any resource of this type
+ resource list XXXX
+} {}
+test resource-3.7 {resource list tests} {
+ set resourceList [resource list STR#]
+ if {[lsearch $resourceList {Tcl Environment Variables}] == -1} {
+ set result {couldn't find resource that should exist}
+ } else {
+ set result ok
+ }
+} {ok}
+
+# Tests for listing resources
+test resource-4.1 {resource read tests} {
+ list [catch {resource read} msg] $msg
+} {1 {wrong # args: should be "resource read resourceType resourceId ?resourceRef?"}}
+test resource-4.2 {resource read tests} {
+ list [catch {resource read TEXT} msg] $msg
+} {1 {wrong # args: should be "resource read resourceType resourceId ?resourceRef?"}}
+test resource-4.3 {resource read tests} {
+ list [catch {resource read STR# {_non_existant_resource_}} msg] $msg
+} {1 {could not load resource}}
+test resource-4.4 {resource read tests} {
+ # The following resource should exist and load OK without error
+ catch {resource read STR# {Tcl Environment Variables}}
+} {0}
+
+# Tests for getting resource types
+test resource-5.1 {resource types tests} {
+ list [catch {resource types _bad_ref_} msg] $msg
+} {1 {invalid resource file reference "_bad_ref_"}}
+test resource-5.2 {resource types tests} {
+ list [catch {resource types _bad_ref_ extraArg} msg] $msg
+} {1 {wrong # args: should be "resource types ?resourceRef?"}}
+test resource-5.3 {resource types tests} {
+ # This should never cause an error
+ catch {resource types}
+} {0}
+test resource-5.4 {resource types tests} {
+ testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"}
+ set id [resource open rsrc.file]
+ set result [resource types $id]
+ resource close $id
+ set result
+} {TEXT}
+
+# resource write tests
+test resource-6.1 {resource write tests} {
+ list [catch {resource write} msg] $msg
+} {1 {wrong # args: should be "resource write ?-id resourceId? ?-name resourceName? ?-file resourceRef? resourceType data"}}
+test resource-6.2 {resource write tests} {
+ list [catch {resource write _bad_type_ data} msg] $msg
+} {1 {expected Macintosh OS type but got "_bad_type_"}}
+test resource-6.3 {resource write tests} {
+ catch {file delete rsrc2.file}
+ set id [resource open rsrc2.file w]
+ resource write -file $id -name Hello TEXT {set x "our test data"}
+ source -rsrc Hello rsrc2.file
+ resource close $id
+ file delete rsrc2.file
+ set x
+} {our test data}
+
# Tests for the Mac version of the source command
catch {file delete rsrc.file}
testWriteTextResource -rsrc fileRsrcName -rsrcid 128 \
-file rsrc.file {set rsrc_foo 1}
-test resource-3.1 {source command} {
+test resource-7.1 {source command} {
catch {unset rsrc_foo}
source -rsrc fileRsrcName rsrc.file
list [catch {set rsrc_foo} msg] $msg
} {0 1}
-test resource-3.2 {source command} {
+test resource-7.2 {source command} {
catch {unset rsrc_foo}
list [catch {source -rsrc no_resource rsrc.file} msg] $msg
} {1 {The resource "no_resource" could not be loaded from rsrc.file.}}
-test resource-3.3 {source command} {
+test resource-7.3 {source command} {
catch {unset rsrc_foo}
source -rsrcid 128 rsrc.file
list [catch {set rsrc_foo} msg] $msg
} {0 1}
-test resource-3.4 {source command} {
+test resource-7.4 {source command} {
catch {unset rsrc_foo}
list [catch {source -rsrcid bad_int rsrc.file} msg] $msg
} {1 {expected integer but got "bad_int"}}
-test resource-3.5 {source command} {
+test resource-7.5 {source command} {
catch {unset rsrc_foo}
list [catch {source -rsrcid 100 rsrc.file} msg] $msg
} {1 {The resource "ID=100" could not be loaded from rsrc.file.}}
diff --git a/contrib/tcl/tests/safe.test b/contrib/tcl/tests/safe.test
index 702bf8d..d68424b 100644
--- a/contrib/tcl/tests/safe.test
+++ b/contrib/tcl/tests/safe.test
@@ -1,6 +1,6 @@
# safe.test --
#
-# This file contains a collection of tests for security policies, safe Tcl,
+# This file contains a collection of tests for safe Tcl, packages loading,
# and using safe interpreters. Sourcing this file into tcl runs the tests
# and generates output for errors. No output means no errors were found.
#
@@ -9,10 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) safe.test 1.13 97/06/24 17:33:22
-
-# NOTE: The tests in this file only pass if you invoke them from the
-# "tests" directory.
+# SCCS: @(#) safe.test 1.31 97/08/14 00:55:56
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -20,305 +17,387 @@ foreach i [interp slaves] {
interp delete $i
}
+# Force actual loading of the safe package
+# because we use un exported (and thus un-autoindexed) APIs
+# in this test result arguments:
+catch {safe::interpConfigure}
+
proc equiv {x} {return $x}
-test safe-1.1 {creating interpreters, should have no aliases} {
+test safe-1.1 {safe::interpConfigure syntax} {
+ list [catch {safe::interpConfigure} msg] $msg;
+} {1 {no value given for parameter "slave" (use -help for full usage) :
+ slave name () name of the slave}}
+
+test safe-1.2 {safe::interpCreate syntax} {
+ list [catch {safe::interpCreate -help} msg] $msg;
+} {1 {Usage information:
+ Var/FlagName Type Value Help
+ ------------ ---- ----- ----
+ ( -help gives this help )
+ ?slave? name () name of the slave (optional)
+ -accessPath list () access path for the slave
+ -noStatics boolflag (false) prevent loading of statically linked pkgs
+ -nestedLoadOk boolflag (false) allow nested loading
+ -deleteHook script () delete hook}}
+
+test safe-1.3 {safe::interpInit syntax} {
+ list [catch {safe::interpInit -noStatics} msg] $msg;
+} {1 {bad value "-noStatics" for parameter
+ slave name () name of the slave}}
+
+
+test safe-2.1 {creating interpreters, should have no aliases} {
interp aliases
} ""
-test safe-1.2 {creating interpreters, should have no aliases} {
- catch {tcl_safeDeleteInterp a}
+test safe-2.2 {creating interpreters, should have no aliases} {
+ catch {safe::interpDelete a}
interp create a
set l [a aliases]
- interp delete a
+ safe::interpDelete a
set l
} ""
-test safe-1.3 {creating safe interpreters, should have no aliases} {
- catch {tcl_safeDeleteInterp a}
+test safe-2.3 {creating safe interpreters, should have no aliases} {
+ catch {safe::interpDelete a}
interp create a -safe
set l [a aliases]
interp delete a
set l
} ""
-test safe-2.1 {calling tcl_SafeInit is safe} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
+test safe-3.1 {calling safe::interpInit is safe} {
+ catch {safe::interpDelete a}
+ interp create a -safe
+ safe::interpInit a
catch {interp eval a exec ls} msg
- tcl_safeDeleteInterp a
+ safe::interpDelete a
set msg
} {invalid command name "exec"}
-test safe-2.2 {calling tcl_safeCreateInterp on trusted interp} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
+test safe-3.2 {calling safe::interpCreate on trusted interp} {
+ catch {safe::interpDelete a}
+ safe::interpCreate a
set l [lsort [a aliases]]
- tcl_safeDeleteInterp a
+ safe::interpDelete a
set l
-} {exit file load source tclPkgUnknown}
-test safe-2.3 {calling tcl_safeCreateInterp on trusted interp} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
+} {exit file load source}
+test safe-3.3 {calling safe::interpCreate on trusted interp} {
+ catch {safe::interpDelete a}
+ safe::interpCreate a
set x [interp eval a {source [file join $tcl_library init.tcl]}]
- tcl_safeDeleteInterp a
+ safe::interpDelete a
set x
} ""
-test safe-2.4 {calling tcl_safeCreateInterp on trusted interp} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
+test safe-3.4 {calling safe::interpCreate on trusted interp} {
+ catch {safe::interpDelete a}
+ safe::interpCreate a
catch {set x \
[interp eval a {source [file join $tcl_library init.tcl]}]} msg
- tcl_safeDeleteInterp a
+ safe::interpDelete a
list $x $msg
} {{} {}}
-test safe-3.1 {tcl_safeDeleteInterp} {
- catch {tcl_safeDeleteInterp a}
+test safe-4.1 {safe::interpDelete} {
+ catch {safe::interpDelete a}
interp create a
- tcl_safeDeleteInterp a
+ safe::interpDelete a
} ""
-test safe-3.2 {tcl_safeDeleteInterp, indirectly} {
- catch {tcl_safeDeleteInterp a}
+test safe-4.2 {safe::interpDelete, indirectly} {
+ catch {safe::interpDelete a}
interp create a
- a alias exit tcl_safeDeleteInterp a
+ a alias exit safe::interpDelete a
a eval exit
} ""
-test safe-3.3 {tcl_safeDeleteInterp, state array} {
- catch {tcl_safeDeleteInterp a}
- set tclSafea(foo) 33
- tcl_safeDeleteInterp a
- catch {set tclSafea(foo)} msg
- set msg
-} {can't read "tclSafea(foo)": no such variable}
-test safe-3.4 {tcl_safeDeleteInterp, state array, indirectly} {
- catch {tcl_safeDeleteInterp a}
- set tclSafea(foo) 33
- tcl_safeCreateInterp a
+test safe-4.3 {safe::interpDelete, state array (not a public api)} {
+ catch {safe::interpDelete a}
+ namespace eval safe {set [InterpStateName a](foo) 33}
+ # not an error anymore to call it if interp is already
+ # deleted, to make trhings smooth if it's called twice...
+ catch {safe::interpDelete a} m1
+ catch {namespace eval safe {set [InterpStateName a](foo)}} m2
+ list $m1 $m2
+} "{}\
+ {can't read \"[safe::InterpStateName a]\": no such variable}"
+
+
+test safe-4.4 {safe::interpDelete, state array, indirectly (not a public api)} {
+ catch {safe::interpDelete a}
+ safe::interpCreate a
+ namespace eval safe {set [InterpStateName a](foo) 33}
a eval exit
- catch {set tclSafea(foo)} msg
- set msg
-} {can't read "tclSafea(foo)": no such variable}
-test safe-3.5 {tcl_safeDeleteInterp} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
- catch {tcl_safeCreateInterp a} msg
+ catch {namespace eval safe {set [InterpStateName a](foo)}} msg
+} 1
+
+test safe-4.5 {safe::interpDelete} {
+ catch {safe::interpDelete a}
+ safe::interpCreate a
+ catch {safe::interpCreate a} msg
set msg
} {interpreter named "a" already exists, cannot create}
-test safe-3.6 {tcl_safeDeleteInterp, indirectly} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
+test safe-4.6 {safe::interpDelete, indirectly} {
+ catch {safe::interpDelete a}
+ safe::interpCreate a
a eval exit
} ""
-test safe-3.7 {tcl_safeDeleteInterp, state array} {
- catch {tcl_safeDeleteInterp a}
- set tclSafea(foo) 33
- tcl_safeCreateInterp a
- tcl_safeDeleteInterp a
- catch {set tclSafea(foo)} msg
- set msg
-} {can't read "tclSafea(foo)": no such variable}
-test safe-3.8 {tcl_safeDeleteInterp, state array, indirectly} {
- catch {tcl_safeDeleteInterp a}
- set tclSafea(foo) 33
- tcl_safeCreateInterp a
- a eval exit
- catch {set tclSafea(foo)} msg
- set msg
-} {can't read "tclSafea(foo)": no such variable}
-# For the following tests, we need a policyPath; we assume that the
-# test directory has a subdirectory policies, and we will use that.
+# The following test checks whether the definition of tcl_endOfWord can be
+# obtained from auto_loading.
-# Save old value of tcl_PolicyPath so we can restore it once we are
-# done with this test sequence:
+test safe-5.1 {test auto-loading in safe interpreters} {
+ catch {safe::interpDelete a}
+ safe::interpCreate a
+ set r [catch {interp eval a {tcl_endOfWord "" 0}} msg]
+ safe::interpDelete a
+ list $r $msg
+} {0 -1}
-set my_old_auto_path $auto_path
-lappend auto_path [pwd]
+# test safe interps 'information leak'
+proc SI {} {
+ global I
+ set I [interp create -safe];
+}
+proc DI {} {
+ global I;
+ interp delete $I;
+}
+test safe-6.1 {test safe interpreters knowledge of the world} {
+ SI; set r [lsort [$I eval {info globals}]]; DI; set r
+} {tcl_interactive tcl_patchLevel tcl_platform tcl_version}
+test safe-6.2 {test safe interpreters knowledge of the world} {
+ SI; set r [$I eval {info script}]; DI; set r
+} {}
+test safe-6.3 {test safe interpreters knowledge of the world} {
+ SI; set r [lsort [$I eval {array names tcl_platform}]]; DI; set r
+} {byteOrder platform}
-test safe-4.1 {loading a policy from the main directory} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
- set l [a eval {package require globalPolicy}]
- tcl_safeDeleteInterp a
- set l
-} 1.0
-test safe-4.2 {same, loading into safe interpreter} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
- set l [a eval {package require globalPolicy}]
- tcl_safeDeleteInterp a
- set l
-} 1.0
-test safe-4.3 {loading a policy from a subdirectory} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
- set l [a eval {package require policyA}]
- tcl_safeDeleteInterp a
- set l
+# more test should be added to check that hostname, nameofexecutable,
+# aren't leaking infos, but they still do...
+
+# high level general test
+test safe-7.1 {tests that everything works at high level} {
+ set i [safe::interpCreate];
+ # no error shall occur:
+ # (because the default access_path shall include 1st level sub dirs
+ # so package require in a slave works like in the master)
+ set v [interp eval $i {package require http 1}]
+ # no error shall occur:
+ interp eval $i {http_config};
+ safe::interpDelete $i
+ set v
} 1.0
-test safe-4.4 {loading a policy, unloading, reloading -- clean} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
- set l ""
- lappend l [a eval {package require policyA}]
- tcl_safeDeleteInterp a
- tcl_safeCreateInterp a
- lappend l [a eval {package require policyA}]
- tcl_safeDeleteInterp a
- set l
-} {1.0 1.0}
-test safe-4.5 {loading two policies - prevented} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
- set l ""
- lappend l [a eval {package require policyA}]
- lappend l [catch {a eval {package require policyB}} msg]
- lappend l $msg
- tcl_safeDeleteInterp a
- set l
-} {1.0 1 {security policy policyA already loaded}}
-test safe-4.6 {two interpreters can have different policies} {
- catch {tcl_safeDeleteInterp a}
- catch {tcl_safeDeleteInterp b}
- tcl_safeCreateInterp a
- tcl_safeCreateInterp b
- set l ""
- lappend l [a eval {package require policyA}]
- lappend l [b eval {package require policyB}]
- tcl_safeDeleteInterp a
- tcl_safeDeleteInterp b
- set l
-} {1.0 1.0}
-test safe-4.7 {safe, loading policy, unloading, reloading: clean} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
- set l ""
- lappend l [a eval {package require policyA}]
- tcl_safeDeleteInterp a
- tcl_safeCreateInterp a
- lappend l [a eval {package require policyA}]
- tcl_safeDeleteInterp a
- set l
-} {1.0 1.0}
-test safe-4.8 {safe, loading two policies - prevented} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
- set l ""
- lappend l [a eval {package require policyA}]
- lappend l [catch {a eval {package require policyB}} msg]
- lappend l $msg
- tcl_safeDeleteInterp a
- set l
-} {1.0 1 {security policy policyA already loaded}}
-test safe-4.9 {safe, two interpreters have different policies} {
- catch {tcl_safeDeleteInterp a}
- catch {tcl_safeDeleteInterp b}
- tcl_safeCreateInterp a
- tcl_safeCreateInterp b
- set l ""
- lappend l [a eval {package require policyA}]
- lappend l [b eval {package require policyB}]
- tcl_safeDeleteInterp a
- tcl_safeDeleteInterp b
- set l
-} {1.0 1.0}
-
-test safe-5.1 {unloading runs policy cleanup code} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
- set l ""
- lappend l [a eval {package require policyC}]
- tcl_safeDeleteInterp a
- set l ;# the cleanup side-effects the global variable "l"
-} {1.0 bye}
-
-# For the following tests we need an auto_path that has the policies and
-# packages directories in it.
-
-lappend auto_path [file join [pwd] policies] \
- [file join [pwd] policies packages]
-
-proc findPackage {i n} {
- set l [$i eval {package names}]
- if {[lsearch $l $n] > -1} {
- return 1
+
+test safe-7.2 {tests specific path and interpFind/AddToAccessPath} {
+ set i [safe::interpCreate -nostat -nested -accessPath [list [info library]]];
+ # should not add anything (p0)
+ set token1 [safe::interpAddToAccessPath $i [info library]]
+ # should add as p1
+ set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"];
+ # an error shall occur (http is not anymore in the secure 0-level
+ # provided deep path)
+ list $token1 $token2 \
+ [catch {interp eval $i {package require http 1}} msg] $msg \
+ [safe::interpConfigure $i]\
+ [safe::interpDelete $i]
+} "{\$p(:0:)} {\$p(:1:)} 1 {can't find package http 1} {-accessPath {$tcl_library /dummy/unixlike/test/path} -noStatics -nestedLoadOk -deleteHook {}} {}"
+
+
+# test source control on file name
+test safe-8.1 {safe source control on file} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ safe::interpCreate $i;
+ list [catch {$i eval {source}} msg] \
+ $msg \
+ [safe::interpDelete $i] ;
+} {1 {wrong # args: should be "source fileName"} {}}
+
+# test source control on file name
+test safe-8.2 {safe source control on file} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ safe::interpCreate $i;
+ list [catch {$i eval {source}} msg] \
+ $msg \
+ [safe::interpDelete $i] ;
+} {1 {wrong # args: should be "source fileName"} {}}
+
+test safe-8.3 {safe source control on file} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ safe::interpCreate $i;
+ set log {};
+ proc safe-test-log {str} {global log; lappend log $str}
+ set prevlog [safe::setLogCmd];
+ safe::setLogCmd safe-test-log;
+ list [catch {$i eval {source .}} msg] \
+ $msg \
+ $log \
+ [safe::setLogCmd $prevlog; unset log] \
+ [safe::interpDelete $i] ;
+} {1 {permission denied} {{ERROR for slave a : ".": is a directory}} {} {}}
+
+
+test safe-8.4 {safe source control on file} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ safe::interpCreate $i;
+ set log {};
+ proc safe-test-log {str} {global log; lappend log $str}
+ set prevlog [safe::setLogCmd];
+ safe::setLogCmd safe-test-log;
+ list [catch {$i eval {source /abc/def}} msg] \
+ $msg \
+ $log \
+ [safe::setLogCmd $prevlog; unset log] \
+ [safe::interpDelete $i] ;
+} {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}} {} {}}
+
+
+test safe-8.5 {safe source control on file} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ safe::interpCreate $i;
+ set log {};
+ proc safe-test-log {str} {global log; lappend log $str}
+ set prevlog [safe::setLogCmd];
+ safe::setLogCmd safe-test-log;
+ list [catch {$i eval {source [file join [info lib] blah]}} msg] \
+ $msg \
+ $log \
+ [safe::setLogCmd $prevlog; unset log] \
+ [safe::interpDelete $i] ;
+} "1 {blah: must be a *.tcl or tclIndex} {{ERROR for slave a : [file join [info library] blah]:blah: must be a *.tcl or tclIndex}} {} {}"
+
+
+test safe-8.6 {safe source control on file} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ safe::interpCreate $i;
+ set log {};
+ proc safe-test-log {str} {global log; lappend log $str}
+ set prevlog [safe::setLogCmd];
+ safe::setLogCmd safe-test-log;
+ list [catch {$i eval {source [file join [info lib] blah.tcl]}} msg] \
+ $msg \
+ $log \
+ [safe::setLogCmd $prevlog; unset log] \
+ [safe::interpDelete $i] ;
+} "1 {no such file or directory} {{ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory}} {} {}"
+
+
+test safe-8.7 {safe source control on file} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ safe::interpCreate $i;
+ set log {};
+ proc safe-test-log {str} {global log; lappend log $str}
+ set prevlog [safe::setLogCmd];
+ safe::setLogCmd safe-test-log;
+ list [catch {$i eval {source [file join [info lib] xxxxxxxxxxx.tcl]}}\
+ msg] \
+ $msg \
+ $log \
+ [safe::setLogCmd $prevlog; unset log] \
+ [safe::interpDelete $i] ;
+} "1 {xxxxxxxxxxx.tcl: filename too long} {{ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:xxxxxxxxxxx.tcl: filename too long}} {} {}"
+
+test safe-8.8 {safe source forbids -rsrc} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ safe::interpCreate $i;
+ list [catch {$i eval {source -rsrc Init}} msg] \
+ $msg \
+ [safe::interpDelete $i] ;
+} {1 {wrong # args: should be "source fileName"} {}}
+
+
+test safe-9.1 {safe interps' deleteHook} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ set res {}
+ proc testDelHook {args} {
+ global res;
+ # the interp still exists at that point
+ interp eval a {set delete 1}
+ # mark that we've been here (successfully)
+ set res $args;
}
- return 0
-}
+ safe::interpCreate $i -deleteHook "testDelHook arg1 arg2";
+ list [interp eval $i exit] $res
+} {{} {arg1 arg2 a}}
-test safe-6.1 {loading packages still works} {
- catch {tcl_safeDeleteInterp a}
- interp create a
- set l ""
- a eval [list set auto_path $auto_path]
- lappend l [a eval {package require packageA 1.0}]
- lappend l [a eval hoohum]
- lappend l [a eval info proc hoohum]
- tcl_safeDeleteInterp a
- set l
-} {1.0 bazooka hoohum}
-test safe-6.2 {tcl_safeCreateInterp, loading packages} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
- set l ""
- lappend l [a eval {package require packageA 1.0}]
- lappend l [a eval hoohum]
- lappend l [a eval info proc hoohum]
- tcl_safeDeleteInterp a
- set l
-} {1.0 bazooka hoohum}
-test safe-6.3 {policies vs packages} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
- set l ""
- lappend l [a eval {package require policyA}]
- lappend l [a eval {package require packageA}]
- lappend l [findPackage a policyA]
- lappend l [findPackage a packageA]
- lappend l [findPackage a hohum]
- tcl_safeDeleteInterp a
- set l
-} {1.0 1.0 1 1 0}
-test safe-6.4 {policies vs packages} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
- set l ""
- lappend l [a eval {package require policyA}]
- lappend l [a eval {package require packageA}]
- lappend l [findPackage a Tcl]
- lappend l [findPackage a policyA]
- lappend l [findPackage a hohum]
- tcl_safeDeleteInterp a
- set l
-} {1.0 1.0 1 1 0}
-test safe-6.5 {policies vs packages vs policies} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
- set l ""
- lappend l [a eval {package require policyA}]
- lappend l [a eval {package require packageA}]
- catch {a eval {package require policyB}} msg
- lappend l $msg
- lappend l [findPackage a Tcl]
- lappend l [findPackage a policyA]
- lappend l [findPackage a policyB]
- tcl_safeDeleteInterp a
- set l
-} {1.0 1.0 {security policy policyA already loaded} 1 1 0}
+test safe-9.2 {safe interps' error in deleteHook} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ set res {}
+ proc testDelHook {args} {
+ global res;
+ # the interp still exists at that point
+ interp eval a {set delete 1}
+ # mark that we've been here (successfully)
+ set res $args;
+ # create an exception
+ error "being catched";
+ }
+ set log {};
+ proc safe-test-log {str} {global log; lappend log $str}
+ safe::interpCreate $i -deleteHook "testDelHook arg1 arg2";
+ set prevlog [safe::setLogCmd];
+ safe::setLogCmd safe-test-log;
+ list [safe::interpDelete $i] $res \
+ $log \
+ [safe::setLogCmd $prevlog; unset log];
+} {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}} {}}
-# The following test checks whether the definition of tcl_endOfWord can be
-# obtained from auto_loading.
-test safe-7.1 {test auto-loading in safe interpreters} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
- set r [catch {interp eval a {tcl_endOfWord "" 0}} msg]
- tcl_safeDeleteInterp a
- list $r $msg
-} {0 -1}
-# Restore settings to what they were before this file was sourced:
+# features which still need test cases:
+# -nostatics and -nestedloadok which
+# are not easily tested from tclsh, can be
+# tested in wish though (safetk.test)
+# (we'd need a static package)
+# we have Tcltest !
+
+if {[catch {package require Tcltest} msg]} {
+ puts "This application hasn't been compiled with Tcltest"
+ puts "skipping remining safe test that relies on it."
+} else {
-set auto_path $my_old_auto_path
-unset my_old_auto_path
+ # we use the Tcltest package , which has no Safe_Init
-# set auto_path $old_auto_path
-# unset old_auto_path
+test safe-10.1 {testing statics loading} {
+ set i [safe::interpCreate]
+ list \
+ [catch {interp eval $i {load {} Tcltest}} msg] \
+ $msg \
+ [safe::interpDelete $i];
+} {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}}
+
+test safe-10.2 {testing statics loading / -nostatics} {
+ set i [safe::interpCreate -nostatics]
+ list \
+ [catch {interp eval $i {load {} Tcltest}} msg] \
+ $msg \
+ [safe::interpDelete $i];
+} {1 {permission denied (static package)} {}}
+
+
+
+test safe-10.3 {testing nested statics loading / no nested by default} {
+ set i [safe::interpCreate]
+ list \
+ [catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \
+ $msg \
+ [safe::interpDelete $i];
+} {1 {permission denied (nested load)} {}}
+
+
+test safe-10.4 {testing nested statics loading / -nestedloadok} {
+ set i [safe::interpCreate -nested]
+ list \
+ [catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \
+ $msg \
+ [safe::interpDelete $i];
+} {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}}
+
+
+}
diff --git a/contrib/tcl/tests/scan.test b/contrib/tcl/tests/scan.test
index 9f73bf1..50bf876 100644
--- a/contrib/tcl/tests/scan.test
+++ b/contrib/tcl/tests/scan.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) scan.test 1.25 97/01/21 21:16:03
+# SCCS: @(#) scan.test 1.26 97/08/06 08:56:08
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -67,14 +67,12 @@ test scan-1.11 {integer scanning} {nonPortable} {
test scan-2.1 {floating-point scanning} {
set a {}; set b {}; set c {}; set d {}
- list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] \
- [format %.6g $a] [format %.6g $b] [format %.6g $c] $d
-} {3 2.1 -3e+08 0.99962 {}}
+ list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d
+} {3 2.1 -300000000.0 0.99962 {}}
test scan-2.2 {floating-point scanning} {
set a {}; set b {}; set c {}; set d {}
- list [scan "-1.2345 +8.2 9" "%3e %3lf %f %f" a b c d] \
- [format %.6g $a] [format %.6g $b] [format %.6g $c] [format %.6g $d]
-} {4 -1 234 5 8.2}
+ list [scan "-1.2345 +8.2 9" "%3e %3lf %f %f" a b c d] $a $b $c $d
+} {4 -1.0 234.0 5.0 8.2}
test scan-2.3 {floating-point scanning} {
set a {}; set b {}; set c {}
list [scan "1e00004 332E-4 3e+4" "%Lf %*2e %f %f" a b c] $a $c
@@ -89,22 +87,19 @@ test scan-2.4 {floating-point scanning} {nonPortable} {
} {3 1.0 200.0 3.0}
test scan-2.5 {floating-point scanning} {
set a {}; set b {}; set c {}; set d {}
- list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] \
- [format %.6g $a] [format %.6g $b] [format %.6g $c] [format %.6g $d]
-} {4 4.6 99999.7 87.643 118}
+ list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] $a $b $c $d
+} {4 4.6 99999.7 87.643 118.0}
test scan-2.6 {floating-point scanning} {
set a {}; set b {}; set c {}; set d {}
- list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] \
- [format %.6g $a] [format %.6g $b] [format %.6g $c] [format %.6g $d]
-} {4 1.2345 0.697 124 5e-05}
+ list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] $a $b $c $d
+} {4 1.2345 0.697 124.0 5e-05}
test scan-2.7 {floating-point scanning} {
set a {}; set b {}; set c {}; set d {}
- list [scan "4.6abc" "%f %f %f %f" a b c d] [format %.6g $a] $b $c $d
+ list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d
} {1 4.6 {} {} {}}
test scan-2.8 {floating-point scanning} {
set a {}; set b {}; set c {}; set d {}
- list [scan "4.6 5.2" "%f %f %f %f" a b c d] \
- [format %.6g $a] [format %.6g $b] $c $d
+ list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d
} {2 4.6 5.2 {} {}}
test scan-3.1 {string and character scanning} {
diff --git a/contrib/tcl/tests/set-old.test b/contrib/tcl/tests/set-old.test
index 17e67f7..2b4cd62 100644
--- a/contrib/tcl/tests/set-old.test
+++ b/contrib/tcl/tests/set-old.test
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) set-old.test 1.19 96/09/09 18:36:24
+# SCCS: @(#) set-old.test 1.20 97/07/25 17:45:55
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -292,7 +292,7 @@ test set-old-8.6 {array command} {
catch {unset a}
set a(22) 3
list [catch {array gorp a} msg] $msg
-} {1 {bad option "gorp": should be anymore, donesearch, exists, get, names, nextelement, set, size, or startsearch}}
+} {1 {bad option "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, or startsearch}}
test set-old-8.7 {array command, anymore option} {
catch {unset a}
list [catch {array anymore a x} msg] $msg
diff --git a/contrib/tcl/tests/socket.test b/contrib/tcl/tests/socket.test
index 2389016..280db1b 100644
--- a/contrib/tcl/tests/socket.test
+++ b/contrib/tcl/tests/socket.test
@@ -59,10 +59,14 @@
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.
#
-# SCCS: @(#) socket.test 1.75 97/04/30 15:42:58
+# SCCS: @(#) socket.test 1.82 97/08/05 13:30:55
if {[string compare test [info procs test]] == 1} then {source defs}
+if {$testConfig(socket) == 0} {
+ return
+}
+
#
# If remoteServerIP or remoteServerPort are not set, check in the
# environment variables for externally set values.
@@ -104,20 +108,23 @@ if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} {
set remoteProcChan ""
set commandSocket ""
-if {$doTestsWithRemoteServer == 1} {
+if {$doTestsWithRemoteServer} {
catch {close $commandSocket}
if {[catch {set commandSocket [socket $remoteServerIP \
$remoteServerPort]}] != 0} {
if {[info commands exec] == ""} {
set noRemoteTestReason "can't exec"
set doTestsWithRemoteServer 0
+ } elseif {$testConfig(win32s)} {
+ set noRemoteTestReason "\ncan't run multiple instances of tcltest under win32s."
+ set doTestsWithRemoteServer 0
} else {
set remoteServerIP localhost
if {[catch {set remoteProcChan \
- [open "|$tcltest remote.tcl \
+ [open "|[list $tcltest remote.tcl \
-serverIsSilent \
-port $remoteServerPort \
- -address $remoteServerIP" \
+ -address $remoteServerIP]" \
w+]} \
msg] == 0} {
after 1000
@@ -232,7 +239,7 @@ test socket-1.12 {arg parsing for socket command} {
list [catch {socket foo badport} msg] $msg
} {1 {expected integer but got "badport"}}
-test socket-2.1 {tcp connection} {unixOrPc} {
+test socket-2.1 {tcp connection} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -250,7 +257,7 @@ test socket-2.1 {tcp connection} {unixOrPc} {
puts $x
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f x
if {[catch {socket localhost 2828} msg]} {
set x $msg
@@ -268,7 +275,7 @@ if [info exists port] {
} else {
set port [expr 2048 + [pid]%1024]
}
-test socket-2.2 {tcp connection with client port specified} {unixOrPc} {
+test socket-2.2 {tcp connection with client port specified} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -286,7 +293,7 @@ test socket-2.2 {tcp connection with client port specified} {unixOrPc} {
close $f
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f x
global port
if {[catch {socket -myport $port localhost 2828} sock]} {
@@ -302,7 +309,7 @@ test socket-2.2 {tcp connection with client port specified} {unixOrPc} {
close $f
set x
} [list ready "hello $port"]
-test socket-2.3 {tcp connection with client interface specified} {unixOrPc} {
+test socket-2.3 {tcp connection with client interface specified} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -320,7 +327,7 @@ test socket-2.3 {tcp connection with client interface specified} {unixOrPc} {
close $f
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f x
if {[catch {socket -myaddr localhost localhost 2828} sock]} {
set x $sock
@@ -333,7 +340,7 @@ test socket-2.3 {tcp connection with client interface specified} {unixOrPc} {
close $f
set x
} {ready {hello 127.0.0.1}}
-test socket-2.4 {tcp connection with server interface specified} {unixOrPc} {
+test socket-2.4 {tcp connection with server interface specified} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -351,7 +358,7 @@ test socket-2.4 {tcp connection with server interface specified} {unixOrPc} {
close $f
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f x
if {[catch {socket [info hostname] 2828} sock]} {
set x $sock
@@ -364,7 +371,7 @@ test socket-2.4 {tcp connection with server interface specified} {unixOrPc} {
close $f
set x
} {ready hello}
-test socket-2.5 {tcp connection with redundant server port} {unixOrPc} {
+test socket-2.5 {tcp connection with redundant server port} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -382,7 +389,7 @@ test socket-2.5 {tcp connection with redundant server port} {unixOrPc} {
close $f
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f x
if {[catch {socket localhost 2828} sock]} {
set x $sock
@@ -405,7 +412,7 @@ test socket-2.6 {tcp connection} {unixOrPc} {
}
set status
} ok
-test socket-2.7 {echo server, one line} {unixOrPc} {
+test socket-2.7 {echo server, one line} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -432,7 +439,7 @@ test socket-2.7 {echo server, one line} {unixOrPc} {
puts done
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f
set s [socket localhost 2828]
fconfigure $s -buffering line -translation lf
@@ -443,7 +450,7 @@ test socket-2.7 {echo server, one line} {unixOrPc} {
close $f
list $x $y
} {{hello abcdefghijklmnop} done}
-test socket-2.8 {echo server, loop 50 times, single connection} {unixOrPc} {
+test socket-2.8 {echo server, loop 50 times, single connection} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -473,7 +480,7 @@ test socket-2.8 {echo server, loop 50 times, single connection} {unixOrPc} {
puts "done $i"
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f
set s [socket localhost 2828]
fconfigure $s -buffering line
@@ -486,13 +493,13 @@ test socket-2.8 {echo server, loop 50 times, single connection} {unixOrPc} {
close $f
set x
} {done 50}
-test socket-2.9 {socket conflict} {unixOrPc} {
+test socket-2.9 {socket conflict} {stdio} {
set s [socket -server accept 2828]
removeFile script
set f [open script w]
puts $f {set f [socket -server accept 2828]}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f
after 100
set x [list [catch {close $f} msg] $msg]
@@ -500,7 +507,7 @@ test socket-2.9 {socket conflict} {unixOrPc} {
set x
} {1 {couldn't open socket: address already in use
while executing
-"set f [socket -server accept 2828]"
+"socket -server accept 2828"
(file "script" line 1)}}
test socket-2.10 {close on accept, accepted socket lives} {
set done 0
@@ -526,7 +533,7 @@ test socket-2.10 {close on accept, accepted socket lives} {
set done
} 1
-test socket-3.1 {socket conflict} {unixOrPc} {
+test socket-3.1 {socket conflict} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -536,7 +543,7 @@ test socket-3.1 {socket conflict} {unixOrPc} {
close $f
}
close $f
- set f [open "|$tcltest script" r+]
+ set f [open "|[list $tcltest script]" r+]
gets $f
set x [list [catch {socket -server accept 2828} msg] \
$msg]
@@ -544,7 +551,7 @@ test socket-3.1 {socket conflict} {unixOrPc} {
close $f
set x
} {1 {couldn't open socket: address already in use}}
-test socket-3.2 {server with several clients} {unixOrPc} {
+test socket-3.2 {server with several clients} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -578,7 +585,7 @@ test socket-3.2 {server with several clients} {unixOrPc} {
puts $x
}
close $f
- set f [open "|$tcltest script" r+]
+ set f [open "|[list $tcltest script]" r+]
set x [gets $f]
set s1 [socket localhost 2828]
fconfigure $s1 -buffering line
@@ -602,7 +609,7 @@ test socket-3.2 {server with several clients} {unixOrPc} {
set x
} {ready done}
-test socket-4.1 {server with several clients} {unixOrPc} {
+test socket-4.1 {server with several clients} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -618,11 +625,11 @@ test socket-4.1 {server with several clients} {unixOrPc} {
gets stdin
}
close $f
- set p1 [open "|$tcltest script" r+]
+ set p1 [open "|[list $tcltest script]" r+]
fconfigure $p1 -buffering line
- set p2 [open "|$tcltest script" r+]
+ set p2 [open "|[list $tcltest script]" r+]
fconfigure $p2 -buffering line
- set p3 [open "|$tcltest script" r+]
+ set p3 [open "|[list $tcltest script]" r+]
fconfigure $p3 -buffering line
proc accept {s a p} {
fconfigure $s -buffering line
@@ -705,7 +712,7 @@ test socket-5.3 {byte order problems, socket numbers, htons} {unixOnly} {
set x
} {couldn't open socket: not owner}
-test socket-6.1 {accept callback error} {unixOrPc} {
+test socket-6.1 {accept callback error} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -713,7 +720,7 @@ test socket-6.1 {accept callback error} {unixOrPc} {
socket localhost 2848
}
close $f
- set f [open "|$tcltest script" r+]
+ set f [open "|[list $tcltest script]" r+]
proc bgerror args {
global x
set x $args
@@ -730,7 +737,7 @@ test socket-6.1 {accept callback error} {unixOrPc} {
set x
} {{divide by zero}}
-test socket-7.1 {testing socket specific options} {unixOrPc} {
+test socket-7.1 {testing socket specific options} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -745,7 +752,7 @@ test socket-7.1 {testing socket specific options} {unixOrPc} {
after cancel $timer
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f
set s [socket localhost 2820]
set p [fconfigure $s -peername]
@@ -756,7 +763,7 @@ test socket-7.1 {testing socket specific options} {unixOrPc} {
lappend l [string compare [lindex $p 2] 2820]
lappend l [llength $p]
} {0 0 3}
-test socket-7.2 {testing socket specific options} {unixOrPc} {
+test socket-7.2 {testing socket specific options} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -771,7 +778,7 @@ test socket-7.2 {testing socket specific options} {unixOrPc} {
after cancel $timer
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f
set s [socket localhost 2821]
set p [fconfigure $s -sockname]
@@ -884,7 +891,7 @@ test socket-9.1 {testing spurious events} {
close $s
list $spurious $len
} {0 50}
-test socket-9.2 {testing async write, fileevents, flush on close} {
+test socket-9.2 {testing async write, fileevents, flush on close} {tempNotMac} {
set firstblock ""
for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
set secondblock ""
@@ -1024,7 +1031,7 @@ test socket-10.2 {client specifies its port} {
#
# Tests io-10.3, io-10.4 have been removed.
#
-test socket-10.5 {trying to connect, no server} {
+test socket-10.3 {trying to connect, no server} {
set status ok
if {![catch {set s [socket $remoteServerIp 2836]}]} {
if {![catch {gets $s}]} {
@@ -1034,7 +1041,7 @@ test socket-10.5 {trying to connect, no server} {
}
set status
} ok
-test socket-10.6 {remote echo, one line} {
+test socket-10.4 {remote echo, one line} {
sendCommand {
set socket10_6_test_server [socket -server accept 2836]
proc accept {s a p} {
@@ -1058,7 +1065,7 @@ test socket-10.6 {remote echo, one line} {
sendCommand {close $socket10_6_test_server}
set r
} hello
-test socket-10.7 {remote echo, 50 lines} {
+test socket-10.5 {remote echo, 50 lines} {
sendCommand {
set socket10_7_test_server [socket -server accept 2836]
proc accept {s a p} {
@@ -1092,7 +1099,7 @@ if {$tcl_platform(platform) == "macintosh"} {
} else {
set conflictResult {1 {couldn't open socket: address already in use}}
}
-test socket-10.8 {socket conflict} {
+test socket-10.6 {socket conflict} {
set s1 [socket -server accept 2836]
if {[catch {set s2 [socket -server accept 2836]} msg]} {
set result [list 1 $msg]
@@ -1103,7 +1110,7 @@ test socket-10.8 {socket conflict} {
close $s1
set result
} $conflictResult
-test socket-10.9 {server with several clients} {
+test socket-10.7 {server with several clients} {
sendCommand {
set socket10_9_test_server [socket -server accept 2836]
proc accept {s a p} {
@@ -1139,7 +1146,7 @@ test socket-10.9 {server with several clients} {
sendCommand {close $socket10_9_test_server}
set i
} 100
-test socket-10.10 {client with several servers} {
+test socket-10.8 {client with several servers} {
sendCommand {
set s1 [socket -server "accept 4003" 4003]
set s2 [socket -server "accept 4004" 4004]
@@ -1165,7 +1172,7 @@ test socket-10.10 {client with several servers} {
}
set l
} {4003 {} 1 4004 {} 1 4005 {} 1}
-test socket-10.11 {accept callback error} {
+test socket-10.9 {accept callback error} {
set s [socket -server accept 2836]
proc accept {s a p} {expr 10 / 0}
proc bgerror args {
@@ -1187,7 +1194,7 @@ test socket-10.11 {accept callback error} {
rename bgerror {}
set x
} {{divide by zero}}
-test socket-10.12 {testing socket specific options} {
+test socket-10.10 {testing socket specific options} {
sendCommand {
set socket10_12_test_server [socket -server accept 2836]
proc accept {s a p} {close $s}
@@ -1201,7 +1208,7 @@ test socket-10.12 {testing socket specific options} {
sendCommand {close $socket10_12_test_server}
set l
} {2836 3 3}
-test socket-10.13 {testing spurious events} {
+test socket-10.11 {testing spurious events} {
sendCommand {
set socket10_13_test_server [socket -server accept 2836]
proc accept {s a p} {
@@ -1240,7 +1247,7 @@ test socket-10.13 {testing spurious events} {
sendCommand {close $socket10_13_test_server}
list $spurious $len
} {0 2690}
-test socket-10.14 {testing EOF stickyness} {
+test socket-10.12 {testing EOF stickyness} {
set counter 0
set done 0
proc count_up {s} {
@@ -1273,7 +1280,7 @@ test socket-10.14 {testing EOF stickyness} {
sendCommand {close $socket10_14_test_server}
set done
} {EOF is sticky}
-test socket-10.15 {testing async write, async flush, async close} {
+test socket-10.13 {testing async write, async flush, async close} {
proc readit {s} {
global count done
set l [read $s]
diff --git a/contrib/tcl/tests/source.test b/contrib/tcl/tests/source.test
index 2d62284..1e0ff69 100644
--- a/contrib/tcl/tests/source.test
+++ b/contrib/tcl/tests/source.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) source.test 1.24 96/10/22 11:34:29
+# SCCS: @(#) source.test 1.25 97/07/02 16:41:34
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -57,7 +57,7 @@ test source-2.3 {source error conditions} {
} {1 {error in sourced file} {error in sourced file
while executing
"error "error in sourced file""
- (file "source.file" line 1)
+ (file "source.file" line 3)
invoked from within
"source source.file"}}
test source-2.4 {source error conditions} {
diff --git a/contrib/tcl/tests/split.test b/contrib/tcl/tests/split.test
index 2e2af25..a57c714 100644
--- a/contrib/tcl/tests/split.test
+++ b/contrib/tcl/tests/split.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) split.test 1.9 96/12/30 17:10:16
+# SCCS: @(#) split.test 1.10 97/07/07 16:30:07
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -41,10 +41,21 @@ test split-1.8 {basic split commands} {
foreach f [split {]\n} {}] {
append x $f
}
- return $x
+ return $x
}
foo
} {]\n}
+test split-1.9 {basic split commands} {
+ proc foo {} {
+ set x ab\000c
+ set y [split $x {}]
+ return $y
+ }
+ foo
+} "a b \000 c"
+test split-1.10 {basic split commands} {
+ split "a0ab1b2bbb3\000c4" ab\000c
+} {{} 0 {} 1 2 {} {} 3 {} 4}
test split-2.1 {split errors} {
list [catch split msg] $msg $errorCode
diff --git a/contrib/tcl/tests/string.test b/contrib/tcl/tests/string.test
index 08ade64..6643d4f 100644
--- a/contrib/tcl/tests/string.test
+++ b/contrib/tcl/tests/string.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) string.test 1.14 97/03/09 17:47:19
+# SCCS: @(#) string.test 1.15 97/07/02 16:49:27
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -43,9 +43,12 @@ test string-2.4 {string first} {
string first xxx x123xx345xxx789xxx012
} 9
test string-2.5 {string first} {
+ string first "" x123xx345xxx789xxx012
+} -1
+test string-2.6 {string first} {
list [catch {string first a} msg] $msg
} {1 {wrong # args: should be "string first string1 string2"}}
-test string-2.6 {string first} {
+test string-2.7 {string first} {
list [catch {string first a b c} msg] $msg
} {1 {wrong # args: should be "string first string1 string2"}}
diff --git a/contrib/tcl/tests/trace.test b/contrib/tcl/tests/trace.test
index d67c252..b4d02d3 100644
--- a/contrib/tcl/tests/trace.test
+++ b/contrib/tcl/tests/trace.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) trace.test 1.25 96/08/23 11:44:46
+# SCCS: @(#) trace.test 1.27 97/07/23 17:08:38
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -26,6 +26,10 @@ proc traceArray {name1 name2 op} {
global info
set info [list $name1 $name2 $op [catch {uplevel set [set name1]($name2)} msg] $msg]
}
+proc traceArray2 {name1 name2 op} {
+ global info
+ set info [list $name1 $name2 $op]
+}
proc traceProc {name1 name2 op} {
global info
set info [concat $info [list $name1 $name2 $op]]
@@ -80,20 +84,48 @@ test trace-1.5 {trace array element reads} {
trace var x(2) r traceArray
list [catch {set x(2)} msg] $msg $info
} {0 zzz {x 2 r 0 zzz}}
-test trace-1.6 {trace reads on whole arrays} {
+test trace-1.6 {trace array element reads} {
+ catch {unset x}
+ set info {}
+ trace variable x r traceArray2
+ proc p {} {
+ global x
+ set x(2) willi
+ return $x(2)
+ }
+ list [catch {p} msg] $msg $info
+} {0 willi {x 2 r}}
+test trace-1.7 {trace array element reads, create element undefined if nonexistant} {
+ catch {unset x}
+ set info {}
+ trace variable x r q
+ proc q {name1 name2 op} {
+ global info
+ set info [list $name1 $name2 $op]
+ global $name1
+ set ${name1}($name2) wolf
+ }
+ proc p {} {
+ global x
+ set x(X) willi
+ return $x(Y)
+ }
+ list [catch {p} msg] $msg $info
+} {0 wolf {x Y r}}
+test trace-1.8 {trace reads on whole arrays} {
catch {unset x}
set info {}
trace var x r traceArray
list [catch {set x(2)} msg] $msg $info
} {1 {can't read "x(2)": no such variable} {}}
-test trace-1.7 {trace reads on whole arrays} {
+test trace-1.9 {trace reads on whole arrays} {
catch {unset x}
set x(2) zzz
set info {}
trace var x r traceArray
list [catch {set x(2)} msg] $msg $info
} {0 zzz {x 2 r 0 zzz}}
-test trace-1.8 {trace variable reads} {
+test trace-1.10 {trace variable reads} {
catch {unset x}
set x 444
set info {}
diff --git a/contrib/tcl/tests/unixFCmd.test b/contrib/tcl/tests/unixFCmd.test
index 8fc1f2e..6b57e75 100644
--- a/contrib/tcl/tests/unixFCmd.test
+++ b/contrib/tcl/tests/unixFCmd.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) unixFCmd.test 1.11 97/06/23 17:30:25
+# SCCS: @(#) unixFCmd.test 1.14 97/08/15 10:22:11
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -232,10 +232,19 @@ test unixFCmd-17.3 {SetPermissionsAttribute} {
close [open foo.test w]
list [catch {file attributes foo.test -permissions foo} msg] $msg [file delete -force -- foo.test]
} {1 {expected integer but got "foo"} {}}
-
-cleanup
-
-
-
-
-
+test unixFCmd-18.1 { nix pwd} {nonPortable} {
+ # This test is nonportable because SunOS generates a weird error
+ # message when the current directory isn't readable.
+ set cd [pwd]
+ set nd $cd/tstdir
+ file mkdir $nd
+ cd $nd
+ exec chmod 000 $nd
+ set r [list [catch {pwd} res] [string range $res 0 36]];
+ cd $cd;
+ exec chmod 755 $nd
+ file delete $nd
+ set r
+} {1 {error getting working directory name:}}
+
+cleanup
diff --git a/contrib/tcl/tests/util.test b/contrib/tcl/tests/util.test
index e7a3f2f..ee37047 100644
--- a/contrib/tcl/tests/util.test
+++ b/contrib/tcl/tests/util.test
@@ -6,7 +6,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) util.test 1.5 97/06/16 13:21:57
+# SCCS: @(#) util.test 1.8 97/08/12 15:50:02
if {[info commands testobj] == {}} {
puts "This application hasn't been compiled with the \"testobj\""
@@ -42,23 +42,91 @@ test util-3.1 {Tcl_ScanCountedElement procedure - don't leave unmatched braces}
concat $x [llength "{$x}"]
} {\ \\\{\ \\ 1}
-test util-4.1 {Tcl_SetObjErrorCode - one arg} {
+test util-4.1 {Tcl_ConcatObj - backslash-space at end of argument} {
+ concat a {b\ } c
+} {a b\ c}
+test util-4.2 {Tcl_ConcatObj - backslash-space at end of argument} {
+ concat a {b\ } c
+} {a b\ c}
+test util-4.3 {Tcl_ConcatObj - backslash-space at end of argument} {
+ concat a {b\\ } c
+} {a b\\ c}
+test util-4.4 {Tcl_ConcatObj - backslash-space at end of argument} {
+ concat a {b } c
+} {a b c}
+test util-4.5 {Tcl_ConcatObj - backslash-space at end of argument} {
+ concat a { } c
+} {a c}
+
+test util-5.1 {Tcl_SetObjErrorCode - one arg} {
catch {testsetobjerrorcode 1}
list [set errorCode]
} {1}
-test util-4.2 {Tcl_SetObjErrorCode - two args} {
+test util-5.2 {Tcl_SetObjErrorCode - two args} {
catch {testsetobjerrorcode 1 2}
list [set errorCode]
} {{1 2}}
-test util-4.3 {Tcl_SetObjErrorCode - three args} {
+test util-5.3 {Tcl_SetObjErrorCode - three args} {
catch {testsetobjerrorcode 1 2 3}
list [set errorCode]
} {{1 2 3}}
-test util-4.4 {Tcl_SetObjErrorCode - four args} {
+test util-5.4 {Tcl_SetObjErrorCode - four args} {
catch {testsetobjerrorcode 1 2 3 4}
list [set errorCode]
} {{1 2 3 4}}
-test util-4.5 {Tcl_SetObjErrorCode - five args} {
+test util-5.5 {Tcl_SetObjErrorCode - five args} {
catch {testsetobjerrorcode 1 2 3 4 5}
list [set errorCode]
} {{1 2 3 4 5}}
+
+test util-6.1 {Tcl_PrintDouble - using tcl_precision} {
+ concat x[expr 1.4]
+} {x1.4}
+test util-6.2 {Tcl_PrintDouble - using tcl_precision} {
+ concat x[expr 1.39999999999]
+} {x1.39999999999}
+test util-6.3 {Tcl_PrintDouble - using tcl_precision} {
+ concat x[expr 1.399999999999]
+} {x1.4}
+test util-6.4 {Tcl_PrintDouble - using tcl_precision} {
+ set tcl_precision 5
+ concat x[expr 1.123412341234]
+} {x1.1234}
+set tcl_precision 12
+test util-6.4 {Tcl_PrintDouble - make sure there's a decimal point} {
+ concat x[expr 2.0]
+} {x2.0}
+test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} {
+ concat x[expr 3.0e98]
+} {x3e+98}
+
+test util-7.1 {TclPrecTraceProc - unset callbacks} {
+ set tcl_precision 7
+ set x $tcl_precision
+ unset tcl_precision
+ list $x $tcl_precision
+} {7 7}
+test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} {
+ set tcl_precision 12
+ interp create child
+ set x [child eval set tcl_precision]
+ child eval {set tcl_precision 6}
+ interp delete child
+ list $x $tcl_precision
+} {12 6}
+test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} {
+ set tcl_precision 12
+ interp create -safe child
+ set x [child eval {
+ list [catch {set tcl_precision 8} msg] $msg
+ }]
+ interp delete child
+ list $x $tcl_precision
+} {{1 {can't set "tcl_precision": can't modify precision from a safe interpreter}} 12}
+test util-7.3 {TclPrecTraceProc - write traces, bogus values} {
+ set tcl_precision 12
+ list [catch {set tcl_precision abc} msg] $msg $tcl_precision
+} {1 {can't set "tcl_precision": improper value for precision} 12}
+
+set tcl_precision 12
+concat ""
diff --git a/contrib/tcl/tests/var.test b/contrib/tcl/tests/var.test
index a51a47b..6452577 100644
--- a/contrib/tcl/tests/var.test
+++ b/contrib/tcl/tests/var.test
@@ -13,7 +13,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) var.test 1.8 97/06/25 09:02:03
+# SCCS: @(#) var.test 1.10 97/07/28 18:31:47
#
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -277,8 +277,8 @@ test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} {
namespace eval test_ns_var {
variable two
}
- list [info vars test_ns_var::*] [catch {set test_ns_var::two} msg] $msg
-} {::test_ns_var::one 1 {can't read "test_ns_var::two": no such variable}}
+ list [info exists test_ns_var::two] [catch {set test_ns_var::two} msg] $msg
+} {0 1 {can't read "test_ns_var::two": no such variable}}
test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} {
namespace eval test_ns_var {
variable two 2
@@ -333,7 +333,37 @@ test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, l
}
set a
} {8 8}
-test var-7.9 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
+test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} {
+ catch {namespace delete test_ns_var2}
+ set a ""
+ namespace eval test_ns_var2 {
+ variable x 123
+ variable y
+ variable z
+ }
+ lappend a [info vars test_ns_var2::*]
+ lappend a [info exists test_ns_var2::x] [info exists test_ns_var2::y] \
+ [info exists test_ns_var2::z]
+ lappend a [list [catch {set test_ns_var2::y} msg] $msg]
+ lappend a [info vars test_ns_var2::*]
+ lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
+ lappend a [set test_ns_var2::y hello]
+ lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
+ lappend a [list [catch {unset test_ns_var2::y} msg] $msg]
+ lappend a [info vars test_ns_var2::*]
+ lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
+ lappend a [list [catch {unset test_ns_var2::z} msg] $msg]
+ lappend a [namespace delete test_ns_var2]
+ set a
+} {{::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z} 1 0 0\
+{1 {can't read "test_ns_var2::y": no such variable}}\
+{::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z} 0 0\
+hello 1 0\
+{0 {}}\
+{::test_ns_var2::x ::test_ns_var2::z} 0 0\
+{1 {can't unset "test_ns_var2::z": no such variable}}\
+{}}
+test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
namespace eval test_ns_var {
proc p {} {
variable eight
@@ -342,14 +372,14 @@ test var-7.9 {Tcl_VariableObjCmd, variable cmd inside proc creates local link va
p
}
} {8 eight}
-test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
+test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
proc p {} { ;# note this proc is at global :: scope
variable test_ns_var::eight
list [set eight] [info vars]
}
p
} {8 eight}
-test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
+test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
namespace eval test_ns_var {
variable {} {My name is empty}
}
@@ -402,18 +432,18 @@ test var-9.6 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} {
set arr(1) 1;
list [catch {testsetnoerr arr 2} res] $res;
} {1 {before set}}
-test var-9.6 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} {
+test var-9.7 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} {
catch {unset arr}
set arr(1) 1;
list [catch {testsetnoerr arr 2} res] $res;
} {1 {before set}}
-test var-9.7 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} {
+test var-9.8 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} {
# this test currently fails, should not...
# (some namespace function resets the interp while it should not)
catch {namespace delete ns}
list [catch {testsetnoerr ns::v 1} res] $res;
} {1 {before set}}
-test var-9.8 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} {
+test var-9.9 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} {
proc readonly args {error "read-only"}
set v 456
trace var v w readonly
@@ -426,6 +456,7 @@ catch {unset v}
catch {rename p ""}
catch {namespace delete test_ns_var}
+catch {namespace delete test_ns_var2}
catch {unset xx}
catch {unset x}
catch {unset y}
diff --git a/contrib/tcl/tests/while.test b/contrib/tcl/tests/while.test
index 3cb43d0..8642747 100644
--- a/contrib/tcl/tests/while.test
+++ b/contrib/tcl/tests/while.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) @(#) while.test 1.8 97/06/24 10:36:56
+# SCCS: @(#) @(#) while.test 1.9 97/07/02 16:41:35
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -29,7 +29,7 @@ test while-1.2 {TclCompileWhileCmd: error in test expression} {
} {syntax error in expression "$i<"
("while" test expression)
while compiling
-"while"}
+"while {$i<}"}
test while-1.3 {TclCompileWhileCmd: error in test expression} {
set err [catch {while {"a"+"b"} {error "loop aborted"}} msg]
list $err $msg
@@ -71,7 +71,7 @@ test while-1.8 {TclCompileWhileCmd: error compiling command body} {
"set"
("while" body line 1)
while compiling
-"while"}
+"while {$i < 5} {set}"}
test while-1.9 {TclCompileWhileCmd: simple command body} {
set a {}
set i 1
diff --git a/contrib/tcl/tests/winFCmd.test b/contrib/tcl/tests/winFCmd.test
index 83691b0..bca8c4b 100644
--- a/contrib/tcl/tests/winFCmd.test
+++ b/contrib/tcl/tests/winFCmd.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) winFCmd.test 1.8 97/05/21 14:49:13
+# SCCS: @(#) winFCmd.test 1.10 97/08/05 11:44:57
#
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -44,9 +44,6 @@ proc cleanup {args} {
}
}
-set testConfig(32s) 0
-set testConfig(95) 0
-set testConfig(NT) 0
set testConfig(cdrom) 0
set testConfig(exdev) 0
set testConfig(UNCPath} 0
@@ -104,12 +101,6 @@ if {[file exists c:/] && [file exists d:/]} {
}
}
-switch $tcl_platform(os) {
- "Windows NT" {set testConfig(NT) 1}
- "Windows 95" {set testConfig(95) 1}
- "Win32s" {set testConfig(32s) 1}
-}
-
if {[file exists //bisque/icepick]} {
set testConfig(UNCPath) 1
}
@@ -149,7 +140,10 @@ test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} {
file mkdir td2
list [catch {testfile mv td2 td1/td2} msg] $msg
} {1 EEXIST}
-test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} {
+test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} {!$testConfig(win32s) || ("[lindex [file split [pwd]] end]" == "C:/")} {
+ # Don't run this test under Win32s on a drive mounted from an NT
+ # machine; it causes the NT machine to die.
+
cleanup
list [catch {testfile mv / td1} msg] $msg
} {1 EINVAL}
@@ -214,7 +208,7 @@ test winFCmd-1.14 {TclpRenameFile: errno: EACCES} {95} {
createfile tf1
list [catch {testfile mv tf1 nul} msg] $msg
} {1 EACCES}
-test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {NT} {
+test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {nt} {
cleanup
createfile tf1
list [catch {testfile mv tf1 nul} msg] $msg
@@ -235,18 +229,22 @@ test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} {
} {1 ENOENT}
test winFCmd-1.19 {TclpRenameFile: errno == EACCES} {
cleanup
- list [catch {testfile mv nul g} msg] $msg
+ list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
-# under 95, this would actually move the current dir out from under yourself.
-test winFCmd-1.20 {TclpRenameFile: src is dir} {NT} {
+# under 95, this would actually succed and move the current dir out from
+# under yourself.
+test winFCmd-1.20 {TclpRenameFile: src is dir} {!95} {
cleanup
file delete /tf1
list [catch {testfile mv [pwd] /tf1} msg] $msg
} {1 EACCES}
-test winFCmd-1.21 {TclpRenameFile: obscenely long src} {
+test winFCmd-1.21 {TclpRenameFile: obscenely long src} {!win32s} {
+ # Really long file names cause all the file system calls to lock up,
+ # endlessly throwing an access violation and retrying the operation.
+
list [catch {testfile mv $longname tf1} msg] $msg
} {1 ENAMETOOLONG}
-test winFCmd-1.22 {TclpRenameFile: obscenely long dst} {NT} {
+test winFCmd-1.22 {TclpRenameFile: obscenely long dst} {nt} {
# return ENOENT if name is too long!
cleanup
createfile tf1
@@ -262,7 +260,10 @@ test winFCmd-1.24 {TclpRenameFile: move dir into self} {
file mkdir td1
list [catch {testfile mv [pwd]/td1 td1/td2} msg] $msg
} {1 EINVAL}
-test winFCmd-1.25 {TclpRenameFile: move a root dir} {
+test winFCmd-1.25 {TclpRenameFile: move a root dir} {!$testConfig(win32s) || ("[lindex [file split [pwd]] end]" == "C:/")} {
+ # Don't run this test under Win32s on a drive mounted from an NT
+ # machine; it causes the NT machine to die.
+
cleanup
list [catch {testfile mv / c:/} msg] $msg
} {1 EINVAL}
@@ -371,7 +372,7 @@ test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} {
createfile tf1
list [catch {testfile cp tf1 ""} msg] $msg
} {1 ENOENT}
-test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {95} {
+test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {!nt} {
cleanup
createfile tf1
set fd [open tf2 w]
@@ -379,7 +380,7 @@ test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {95} {
close $fd
set msg
} {1 EACCES}
-test winFCmd-2.8 {TclpCopyFile: errno: EACCES} {NT} {
+test winFCmd-2.8 {TclpCopyFile: errno: EACCES} {nt} {
cleanup
list [catch {testfile cp nul tf1} msg] $msg
} {1 EACCES}
@@ -509,7 +510,7 @@ test winFCmd-3.11 {TclpDeleteFile: still can't remove path} {
set msg
} {1 EACCES}
-test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} {cdrom NT} {
+test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} {cdrom nt} {
list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg
} {1 EACCES}
test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} {cdrom 95} {
@@ -584,15 +585,15 @@ test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} {
testfile rmdir td1
file exists td1
} {0}
-test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {95} {
+test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {!nt} {
cleanup
list [catch {testfile rmdir nul} msg] $msg
} {1 {nul EACCES}}
-test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} {NT} {
+test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} {nt} {
cleanup
list [catch {testfile rmdir /} msg] $msg
} {1 {\ EACCES}}
-test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} {95} {
+test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} {!nt} {
cleanup
createfile tf1
list [catch {testfile rmdir tf1} msg] $msg
@@ -604,7 +605,7 @@ test winFCmd-6.13 {TclpRemoveDirectory: write-protected} {
testfile rmdir td1
file exists td1
} {0}
-test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} {95} {
+test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} {!nt} {
cleanup
file mkdir td1/td2
list [catch {testfile rmdir td1} msg] $msg
@@ -670,10 +671,10 @@ test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} {
testfile cpdir td1 td2
contents td2/tf1
} {tf1}
-test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} {95 cdrom} {
+test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} {!nt && cdrom} {
list [catch {testfile rmdir $cdrom/} msg] $msg
} "1 {$cdrom\\ EEXIST}"
-test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} {NT cdrom} {
+test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} {nt cdrom} {
list [catch {testfile rmdir $cdrom/} msg] $msg
} "1 {$cdrom\\ EACCES}"
test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} {
@@ -701,12 +702,12 @@ test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} {
testfile cpdir td1 td2
contents td2/tf1
} {tf1}
-test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} {95} {
+test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} {!nt} {
cleanup
file mkdir td1
list [catch {testfile cpdir td1 /} msg] $msg
} {1 {\ EEXIST}}
-test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} {NT} {
+test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} {nt} {
cleanup
file mkdir td1
list [catch {testfile cpdir td1 /} msg] $msg
@@ -832,45 +833,45 @@ test winFCmd-11.4 {GetWinFileAttributes} {
test winFCmd-12.1 {ConvertFileNameFormat} {
cleanup
close [open td1 w]
- list [catch {file attributes td1 -longname} msg] $msg [cleanup]
+ list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
test winFCmd-12.2 {ConvertFileNameFormat} {
cleanup
file mkdir td1
close [open td1/td1 w]
- list [catch {file attributes td1/td1 -longname} msg] $msg [cleanup]
+ list [catch {string tolower [file attributes td1/td1 -longname]} msg] $msg [cleanup]
} {0 td1/td1 {}}
test winFCmd-12.3 {ConvertFileNameFormat} {
cleanup
file mkdir td1
file mkdir td1/td2
close [open td1/td3 w]
- list [catch {file attributes td1/td2/../td3 -longname} msg] $msg [cleanup]
+ list [catch {string tolower [file attributes td1/td2/../td3 -longname]} msg] $msg [cleanup]
} {0 td1/td2/../td3 {}}
test winFCmd-12.4 {ConvertFileNameFormat} {
cleanup
close [open td1 w]
- list [catch {file attributes ./td1 -longname} msg] $msg [cleanup]
+ list [catch {string tolower [file attributes ./td1 -longname]} msg] $msg [cleanup]
} {0 ./td1 {}}
test winFCmd-12.5 {ConvertFileNameFormat} {
catch {file delete -force -- c:/td1}
close [open c:/td1 w]
- list [catch {file attributes c:/td1 -longname} msg] $msg [file delete -force -- c:/td1]
+ list [catch {string tolower [file attributes c:/td1 -longname]} msg] $msg [file delete -force -- c:/td1]
} {0 c:/td1 {}}
test winFCmd-12.6 {ConvertFileNameFormat} {UNCPath} {
catch {file delete -force -- //bisque/icepick/test/td1}
close [open //bisque/icepick/test/td1 w]
- list [catch {file attributes //bisque/icepick/test/td1 -longname} msg] $msg [file delete -force -- //bisque/icepick/test/td1]
+ list [catch {string tolower [file attributes //bisque/icepick/test/td1 -longname]} msg] $msg [file delete -force -- //bisque/icepick/test/td1]
} {0 //bisque/icepick/test/td1 {}}
test winFCmd-12.7 {ConvertFileNameFormat} {longFileNames} {
cleanup
close [open td1 w]
- list [catch {file attributes td1 -longname} msg] $msg [cleanup]
+ list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
-test winFCmd-12.8 {ConvertFileNameFormat} {32s} {
+test winFCmd-12.8 {ConvertFileNameFormat} {win32s} {
cleanup
close [open td1 w]
- list [catch {file attributes td1 -longname} msg] $msg [cleanup]
+ list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
test winFCmd-12.9 {ConvertFileNameFormat} {longFileNames} {
cleanup
@@ -880,19 +881,19 @@ test winFCmd-12.9 {ConvertFileNameFormat} {longFileNames} {
test winFCmd-12.10 {ConvertFileNameFormat} {longFileNames} {
cleanup
close [open td1 w]
- list [catch {file attributes td1 -shortname} msg] $msg [cleanup]
+ list [catch {string tolower [file attributes td1 -shortname]} msg] $msg [cleanup]
} {0 td1 {}}
test winFCmd-13.1 {GetWinFileLongName} {
cleanup
close [open td1 w]
- list [catch {file attributes td1 -longname} msg] $msg [cleanup]
+ list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
test winFCmd-14.1 {GetWinFileShortName} {
cleanup
close [open td1 w]
- list [catch {file attributes td1 -shortname} msg] $msg [cleanup]
+ list [catch {string tolower [file attributes td1 -shortname]} msg] $msg [cleanup]
} {0 td1 {}}
test winFCmd-15.1 {SetWinFileAttributes} {
diff --git a/contrib/tcl/tests/winPipe.test b/contrib/tcl/tests/winPipe.test
index af26db4..483dfec 100644
--- a/contrib/tcl/tests/winPipe.test
+++ b/contrib/tcl/tests/winPipe.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) winPipe.test 1.7 97/06/23 17:30:41
+# SCCS: @(#) winPipe.test 1.9 97/08/05 11:44:28
if {$tcl_platform(platform) != "windows"} {
return
@@ -51,7 +51,7 @@ proc contents {file} {
set r
}
-if [file exists $cat32] {
+if {$testConfig(stdio) && [file exists $cat32]} {
test winpipe-1.1 {32 bit comprehensive tests: from little file} {
exec $cat32 < little > stdout 2> stderr
list [contents stdout] [contents stderr]
@@ -166,15 +166,19 @@ test winpipe-1.25 {32 bit comprehensive tests: to socket} {
} {}
}
+set stderr16 "stderr16"
+if {$tcl_platform(os) == "Win32s"} {
+ set stderr16 "{}"
+}
if [file exists $cat16] {
test winpipe-2.1 {16 bit comprehensive tests: from little file} {
exec $cat16 < little > stdout 2> stderr
list [contents stdout] [contents stderr]
-} "little stderr16"
+} "little $stderr16"
test winpipe-2.2 {16 bit comprehensive tests: from big file} {
exec $cat16 < big > stdout 2> stderr
list [contents stdout] [contents stderr]
-} "{$big} stderr16"
+} "{$big} $stderr16"
test winpipe-2.3 {16 bit comprehensive tests: a little from pipe} {nt} {
exec more < little | $cat16 > stdout 2> stderr
list [contents stdout] [contents stderr]
@@ -210,21 +214,21 @@ test winpipe-2.11 {16 bit comprehensive tests: from file handle} {
exec $cat16 <@$f > stdout 2> stderr
close $f
list [contents stdout] [contents stderr]
-} "little stderr16"
+} "little $stderr16"
test winpipe-2.12 {16 bit comprehensive tests: read from application} {
set f [open "|$cat16 < little" r]
gets $f line
catch {close $f} msg
list $line $msg
-} {little stderr16}
+} "little $stderr16"
test winpipe-2.13 {16 bit comprehensive tests: a little to file} {
exec $cat16 < little > stdout 2> stderr
list [contents stdout] [contents stderr]
-} "little stderr16"
+} "little $stderr16"
test winpipe-2.14 {16 bit comprehensive tests: a lot to file} {
exec $cat16 < big > stdout 2> stderr
list [contents stdout] [contents stderr]
-} "{$big} stderr16"
+} "{$big} $stderr16"
test winpipe-2.15 {16 bit comprehensive tests: a little to pipe} {nt} {
catch {exec $cat16 < little | more > stdout 2> stderr}
list [contents stdout] [contents stderr]
@@ -244,7 +248,7 @@ test winpipe-2.18 {16 bit comprehensive tests: a lot to pipe} {95} {
test winpipe-2.19 {16 bit comprehensive tests: to console} {
catch {exec $cat16 << "You should see this\n" >@stdout} msg
set msg
-} stderr16
+} [lindex $stderr16 0]
test winpipe-2.20 {16 bit comprehensive tests: to NUL} {nt} {
# some apps hang when sending a large amount to NUL. cat16 isn't one.
catch {exec $cat16 < big > nul} msg
@@ -260,8 +264,8 @@ test winpipe-2.22 {16 bit comprehensive tests: to file handle} {
close $f1
close $f2
list [contents stdout] [contents stderr]
-} "little stderr16"
-test winpipe-2.23 {16 bit comprehensive tests: write to application} {
+} "little $stderr16"
+test winpipe-2.23 {16 bit comprehensive tests: write to application} {!win32s} {
set f [open "|$cat16 > stdout" w]
puts -nonewline $f "foo"
catch {close $f} msg
@@ -281,3 +285,5 @@ test winpipe-2.25 {16 bit comprehensive tests: to socket} {
} {}
}
+file delete big little
+
diff --git a/contrib/tcl/unix/Makefile.in b/contrib/tcl/unix/Makefile.in
index 3d992a1..8d2d7c8 100644
--- a/contrib/tcl/unix/Makefile.in
+++ b/contrib/tcl/unix/Makefile.in
@@ -5,7 +5,7 @@
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
-# SCCS: @(#) Makefile.in 1.174 97/06/26 17:58:32
+# SCCS: @(#) Makefile.in 1.187 97/08/15 10:23:55
# Current Tcl version; used in various names.
@@ -73,7 +73,12 @@ MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann
# To change the compiler switches, for example to change from -O
# to -g, change the following line:
+# On systems where both getcwd(3) and getwd(3) exist, check the man
+# page and if getcwd, like on Solaris, uses popen to pwd(1)
+# add -DUSEGETWD to the flags so getwd will be used instead.
CFLAGS = -O
+# Solaris recommended:
+#CFLAGS = -O -DUSEGETWD
# To disable ANSI-C procedure prototypes reverse the comment characters
# on the following lines:
@@ -314,12 +319,23 @@ all: ${TCL_LIB_FILE} tclsh
# The following target is configured by autoconf to generate either
# a shared library or non-shared library for Tcl.
-
${TCL_LIB_FILE}: ${OBJS}
rm -f ${TCL_LIB_FILE}
@MAKE_LIB@
$(RANLIB) ${TCL_LIB_FILE}
+# Make target which outputs the list of the .o contained in the Tcl lib
+# usefull to build a single big shared library containing Tcl and other
+# extensions. used for the Tcl Plugin. -- dl
+# The dependency on OBJS is not there because we just want the list
+# of objects here, not actually building them
+tclLibObjs:
+ @echo ${OBJS}
+# This targets actually build the objects needed for the lib in the above
+# case
+objs: ${OBJS}
+
+
tclsh: ${TCLSH_OBJS} ${TCL_LIB_FILE}
${CC} @LD_FLAGS@ ${TCLSH_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \
@TCL_LD_SEARCH_FLAGS@ -o tclsh
@@ -344,6 +360,12 @@ test: tcltest
TCL_LIBRARY=${TOP_DIR}/library; export TCL_LIBRARY; \
( echo cd $(TOP_DIR)/tests\; source all ) | ./tcltest
+# Useful target to launch a built tcltest with the proper path,...
+runtest:
+ LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \
+ TCL_LIBRARY=${TOP_DIR}/library; export TCL_LIBRARY; \
+ ./tcltest
+
# The following target outputs the name of the top-level source directory
# for Tcl (it is used by Tk's configure script, for example). The
# .NO_PARALLEL line is needed to avoid problems under Sun's "pmake".
@@ -423,7 +445,7 @@ install-libraries:
else true; \
fi; \
done;
- @for i in http1.0 ; \
+ @for i in http2.0 http1.0 opt0.1; \
do \
if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
@@ -439,7 +461,7 @@ install-libraries:
echo "Installing $$i"; \
$(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR); \
done;
- @for i in http1.0 ; \
+ @for i in http2.0 http1.0 opt0.1; \
do \
for j in $(TOP_DIR)/library/$$i/*.tcl ; \
do \
@@ -826,7 +848,7 @@ dist: $(UNIX_DIR)/configure
mkdir $(DISTDIR)/library
cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \
$(TOP_DIR)/library/tclIndex $(DISTDIR)/library
- for i in http1.0; \
+ for i in http2.0 http1.0 opt0.1; \
do \
mkdir $(DISTDIR)/library/$$i ;\
cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \
@@ -843,8 +865,6 @@ dist: $(UNIX_DIR)/configure
cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \
$(TOP_DIR)/tests/all $(TOP_DIR)/tests/remote.tcl \
$(TOP_DIR)/tests/defs $(DISTDIR)/tests
- cp -r -p $(TOP_DIR)/tests/policies $(DISTDIR)/tests/policies
- find $(DISTDIR)/tests/policies -name SCCS -exec rm -rf {} \;
mkdir $(DISTDIR)/win
cp -p $(TOP_DIR)/win/*.c $(TOP_DIR)/win/*.h $(TOP_DIR)/win/*.rc \
$(DISTDIR)/win
@@ -862,6 +882,7 @@ dist: $(UNIX_DIR)/configure
cp -p $(TOP_DIR)/mac/porting.notes $(TOP_DIR)/mac/README $(DISTDIR)/mac
cp -p $(TOP_DIR)/mac/*.exp $(TOP_DIR)/mac/*.pch $(DISTDIR)/mac
cp -p $(TOP_DIR)/mac/*.doc $(DISTDIR)/mac
+ cp -p $(TOP_DIR)/mac/*.html $(DISTDIR)/mac
cp -p $(TOP_DIR)/license.terms $(DISTDIR)/mac
mkdir $(DISTDIR)/unix/dltest
cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \
@@ -874,7 +895,7 @@ alldist: dist
/proj/tcl/dist/$(DISTNAME).tar.gz \
/proj/tcl/dist/$(ZIPNAME)
cd /proj/tcl/dist; tar cf $(DISTNAME).tar $(DISTNAME); \
- gzip -c $(DISTNAME).tar > $(DISTNAME).tar.gz; \
+ gzip -9 -c $(DISTNAME).tar > $(DISTNAME).tar.gz; \
compress $(DISTNAME).tar; zip -r8 $(ZIPNAME) $(DISTNAME)
#
diff --git a/contrib/tcl/unix/configure b/contrib/tcl/unix/configure
index d2cc578..0609faf 100755
--- a/contrib/tcl/unix/configure
+++ b/contrib/tcl/unix/configure
@@ -404,12 +404,12 @@ else
fi
-# SCCS: @(#) configure.in 1.135 97/06/10 17:28:19
+# SCCS: @(#) configure.in 1.140 97/08/12 10:36:18
TCL_VERSION=8.0
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=0
-TCL_PATCH_LEVEL=b2
+TCL_PATCH_LEVEL=""
VERSION=${TCL_VERSION}
if test "${prefix}" = "NONE"; then
@@ -565,14 +565,73 @@ echo "$ac_t""$ac_cv_c_cross" 1>&6
# set flags so Tcl uses alternate procedures.
#--------------------------------------------------------------------
-for ac_func in getcwd opendir strstr
+# Check if Posix compliant getcwd exists, if not we'll use getwd.
+for ac_func in getcwd
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 576 "configure"
+#line 577 "configure"
+#include "confdefs.h"
+/* System header to define __stub macros and hopefully few prototypes,
+ which can conflict with char $ac_func(); below. */
+#include <assert.h>
+/* Override any gcc2 internal prototype to avoid an error. */
+char $ac_func();
+
+int main() { return 0; }
+int t() {
+
+/* The GNU C library defines this for functions which it implements
+ to always fail with ENOSYS. Some functions are actually named
+ something starting with __ and the normal name is an alias. */
+#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
+choke me
+#else
+$ac_func();
+#endif
+
+; return 0; }
+EOF
+if eval $ac_link; then
+ rm -rf conftest*
+ eval "ac_cv_func_$ac_func=yes"
+else
+ rm -rf conftest*
+ eval "ac_cv_func_$ac_func=no"
+fi
+rm -f conftest*
+
+fi
+if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
+ cat >> confdefs.h <<EOF
+#define $ac_tr_func 1
+EOF
+
+else
+ echo "$ac_t""no" 1>&6
+cat >> confdefs.h <<\EOF
+#define USEGETWD 1
+EOF
+
+fi
+done
+
+# Nb: if getcwd uses popen and pwd(1) (like Solaris) we should really
+# define USEGETWD even if the posix getcwd exists. Add a test ?
+
+for ac_func in opendir strstr
+do
+echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
+if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 635 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
@@ -614,6 +673,7 @@ fi
done
+
for ac_func in strtol tmpnam waitpid
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
@@ -621,7 +681,7 @@ if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 625 "configure"
+#line 685 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
@@ -668,7 +728,7 @@ if eval "test \"`echo '$''{'ac_cv_func_strerror'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 672 "configure"
+#line 732 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strerror(); below. */
@@ -716,7 +776,7 @@ if eval "test \"`echo '$''{'ac_cv_func_getwd'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 720 "configure"
+#line 780 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char getwd(); below. */
@@ -764,7 +824,7 @@ if eval "test \"`echo '$''{'ac_cv_func_wait3'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 768 "configure"
+#line 828 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char wait3(); below. */
@@ -812,7 +872,7 @@ if eval "test \"`echo '$''{'ac_cv_func_uname'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 816 "configure"
+#line 876 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char uname(); below. */
@@ -868,7 +928,7 @@ if eval "test \"`echo '$''{'ac_cv_func_sin'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 872 "configure"
+#line 932 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char sin(); below. */
@@ -915,7 +975,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-lieee $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 919 "configure"
+#line 979 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -958,7 +1018,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-lbsd $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 962 "configure"
+#line 1022 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -1000,7 +1060,7 @@ fi
echo $ac_n "checking dirent.h""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 1004 "configure"
+#line 1064 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <dirent.h>
@@ -1058,7 +1118,7 @@ else
# On the NeXT, cc -E runs the code through the compiler's parser,
# not just through cpp.
cat > conftest.$ac_ext <<EOF
-#line 1062 "configure"
+#line 1122 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
@@ -1072,7 +1132,7 @@ else
rm -rf conftest*
CPP="${CC-cc} -E -traditional-cpp"
cat > conftest.$ac_ext <<EOF
-#line 1076 "configure"
+#line 1136 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
@@ -1103,7 +1163,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1107 "configure"
+#line 1167 "configure"
#include "confdefs.h"
#include <errno.h>
EOF
@@ -1136,7 +1196,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1140 "configure"
+#line 1200 "configure"
#include "confdefs.h"
#include <float.h>
EOF
@@ -1169,7 +1229,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1173 "configure"
+#line 1233 "configure"
#include "confdefs.h"
#include <values.h>
EOF
@@ -1202,7 +1262,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1206 "configure"
+#line 1266 "configure"
#include "confdefs.h"
#include <limits.h>
EOF
@@ -1235,7 +1295,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1239 "configure"
+#line 1299 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
@@ -1260,7 +1320,7 @@ tcl_ok=0
fi
cat > conftest.$ac_ext <<EOF
-#line 1264 "configure"
+#line 1324 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
@@ -1274,7 +1334,7 @@ fi
rm -f conftest*
cat > conftest.$ac_ext <<EOF
-#line 1278 "configure"
+#line 1338 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
@@ -1288,7 +1348,7 @@ fi
rm -f conftest*
cat > conftest.$ac_ext <<EOF
-#line 1292 "configure"
+#line 1352 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
@@ -1313,7 +1373,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1317 "configure"
+#line 1377 "configure"
#include "confdefs.h"
#include <string.h>
EOF
@@ -1338,7 +1398,7 @@ tcl_ok=0
fi
cat > conftest.$ac_ext <<EOF
-#line 1342 "configure"
+#line 1402 "configure"
#include "confdefs.h"
#include <string.h>
EOF
@@ -1352,7 +1412,7 @@ fi
rm -f conftest*
cat > conftest.$ac_ext <<EOF
-#line 1356 "configure"
+#line 1416 "configure"
#include "confdefs.h"
#include <string.h>
EOF
@@ -1377,7 +1437,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1381 "configure"
+#line 1441 "configure"
#include "confdefs.h"
#include <sys/wait.h>
EOF
@@ -1410,7 +1470,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1414 "configure"
+#line 1474 "configure"
#include "confdefs.h"
#include <dlfcn.h>
EOF
@@ -1445,7 +1505,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1449 "configure"
+#line 1509 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
@@ -1485,7 +1545,7 @@ if test "$cross_compiling" = yes; then
tk_ok=no
else
cat > conftest.$ac_ext <<EOF
-#line 1489 "configure"
+#line 1549 "configure"
#include "confdefs.h"
#include <termios.h>
@@ -1519,7 +1579,7 @@ if test "$cross_compiling" = yes; then
tk_ok=no
else
cat > conftest.$ac_ext <<EOF
-#line 1523 "configure"
+#line 1583 "configure"
#include "confdefs.h"
#include <termio.h>
@@ -1552,7 +1612,7 @@ if test "$cross_compiling" = yes; then
tk_ok=none
else
cat > conftest.$ac_ext <<EOF
-#line 1556 "configure"
+#line 1616 "configure"
#include "confdefs.h"
#include <sgtty.h>
@@ -1598,7 +1658,7 @@ echo "$ac_t""$tk_ok" 1>&6
echo $ac_n "checking fd_set and sys/select""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 1602 "configure"
+#line 1662 "configure"
#include "confdefs.h"
#include <sys/types.h>
int main() { return 0; }
@@ -1617,7 +1677,7 @@ rm -f conftest*
if test $tk_ok = no; then
cat > conftest.$ac_ext <<EOF
-#line 1621 "configure"
+#line 1681 "configure"
#include "confdefs.h"
#include <sys/select.h>
EOF
@@ -1655,7 +1715,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1659 "configure"
+#line 1719 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
@@ -1688,7 +1748,7 @@ if eval "test \"`echo '$''{'ac_cv_header_time'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1692 "configure"
+#line 1752 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/time.h>
@@ -1721,7 +1781,7 @@ if eval "test \"`echo '$''{'ac_cv_struct_tm'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1725 "configure"
+#line 1785 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <time.h>
@@ -1753,7 +1813,7 @@ if eval "test \"`echo '$''{'ac_cv_struct_tm_zone'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1757 "configure"
+#line 1817 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <$ac_cv_struct_tm>
@@ -1784,7 +1844,7 @@ if eval "test \"`echo '$''{'ac_cv_var_tzname'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1788 "configure"
+#line 1848 "configure"
#include "confdefs.h"
#include <time.h>
#ifndef tzname /* For SGI. */
@@ -1817,7 +1877,7 @@ fi
echo $ac_n "checking tm_tzadj in struct tm""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 1821 "configure"
+#line 1881 "configure"
#include "confdefs.h"
#include <time.h>
int main() { return 0; }
@@ -1841,7 +1901,7 @@ rm -f conftest*
echo $ac_n "checking tm_gmtoff in struct tm""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 1845 "configure"
+#line 1905 "configure"
#include "confdefs.h"
#include <time.h>
int main() { return 0; }
@@ -1870,7 +1930,7 @@ rm -f conftest*
have_timezone=no
echo $ac_n "checking long timezone variable""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 1874 "configure"
+#line 1934 "configure"
#include "confdefs.h"
#include <time.h>
int main() { return 0; }
@@ -1901,7 +1961,7 @@ rm -f conftest*
if test "$have_timezone" = no; then
echo $ac_n "checking time_t timezone variable""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 1905 "configure"
+#line 1965 "configure"
#include "confdefs.h"
#include <time.h>
int main() { return 0; }
@@ -1949,7 +2009,7 @@ if test "$cross_compiling" = yes; then
tcl_ok=no
else
cat > conftest.$ac_ext <<EOF
-#line 1953 "configure"
+#line 2013 "configure"
#include "confdefs.h"
extern int strstr();
@@ -1985,7 +2045,7 @@ if eval "test \"`echo '$''{'ac_cv_func_strtoul'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1989 "configure"
+#line 2049 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strtoul(); below. */
@@ -2029,7 +2089,7 @@ if test "$cross_compiling" = yes; then
tcl_ok=0
else
cat > conftest.$ac_ext <<EOF
-#line 2033 "configure"
+#line 2093 "configure"
#include "confdefs.h"
extern int strtoul();
@@ -2068,7 +2128,7 @@ if eval "test \"`echo '$''{'ac_cv_func_strtod'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2072 "configure"
+#line 2132 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strtod(); below. */
@@ -2112,7 +2172,7 @@ if test "$cross_compiling" = yes; then
tcl_ok=0
else
cat > conftest.$ac_ext <<EOF
-#line 2116 "configure"
+#line 2176 "configure"
#include "confdefs.h"
extern double strtod();
@@ -2153,7 +2213,7 @@ if eval "test \"`echo '$''{'ac_cv_func_strtod'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2157 "configure"
+#line 2217 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strtod(); below. */
@@ -2199,7 +2259,7 @@ if test "$tcl_strtod" = 1; then
tcl_ok=0
else
cat > conftest.$ac_ext <<EOF
-#line 2203 "configure"
+#line 2263 "configure"
#include "confdefs.h"
extern double strtod();
@@ -2244,7 +2304,7 @@ if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2248 "configure"
+#line 2308 "configure"
#include "confdefs.h"
#include <stdlib.h>
#include <stdarg.h>
@@ -2266,7 +2326,7 @@ rm -f conftest*
if test $ac_cv_header_stdc = yes; then
# SunOS 4.x string.h does not declare mem*, contrary to ANSI.
cat > conftest.$ac_ext <<EOF
-#line 2270 "configure"
+#line 2330 "configure"
#include "confdefs.h"
#include <string.h>
EOF
@@ -2284,7 +2344,7 @@ fi
if test $ac_cv_header_stdc = yes; then
# ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.
cat > conftest.$ac_ext <<EOF
-#line 2288 "configure"
+#line 2348 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
@@ -2305,7 +2365,7 @@ if test "$cross_compiling" = yes; then
ac_cv_header_stdc=no
else
cat > conftest.$ac_ext <<EOF
-#line 2309 "configure"
+#line 2369 "configure"
#include "confdefs.h"
#include <ctype.h>
#define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
@@ -2339,7 +2399,7 @@ if eval "test \"`echo '$''{'ac_cv_type_mode_t'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2343 "configure"
+#line 2403 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
@@ -2370,7 +2430,7 @@ if eval "test \"`echo '$''{'ac_cv_type_pid_t'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2374 "configure"
+#line 2434 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
@@ -2401,7 +2461,7 @@ if eval "test \"`echo '$''{'ac_cv_type_size_t'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2405 "configure"
+#line 2465 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
@@ -2432,7 +2492,7 @@ if eval "test \"`echo '$''{'ac_cv_type_uid_t'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2436 "configure"
+#line 2496 "configure"
#include "confdefs.h"
#include <sys/types.h>
EOF
@@ -2472,7 +2532,7 @@ if eval "test \"`echo '$''{'ac_cv_func_opendir'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2476 "configure"
+#line 2536 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char opendir(); below. */
@@ -2526,7 +2586,7 @@ fi
echo $ac_n "checking union wait""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 2530 "configure"
+#line 2590 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/wait.h>
@@ -2563,7 +2623,7 @@ fi
echo $ac_n "checking matherr support""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 2567 "configure"
+#line 2627 "configure"
#include "confdefs.h"
#include <math.h>
int main() { return 0; }
@@ -2605,7 +2665,7 @@ if eval "test \"`echo '$''{'ac_cv_func_vfork'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2609 "configure"
+#line 2669 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char vfork(); below. */
@@ -2651,7 +2711,7 @@ if test "$tcl_ok" = 1; then
tcl_ok=0
else
cat > conftest.$ac_ext <<EOF
-#line 2655 "configure"
+#line 2715 "configure"
#include "confdefs.h"
#include <stdio.h>
@@ -2712,7 +2772,7 @@ if eval "test \"`echo '$''{'ac_cv_func_strncasecmp'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2716 "configure"
+#line 2776 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strncasecmp(); below. */
@@ -2760,7 +2820,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-lsocket $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 2764 "configure"
+#line 2824 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -2796,7 +2856,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-linet $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 2800 "configure"
+#line 2860 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -2844,7 +2904,7 @@ if eval "test \"`echo '$''{'ac_cv_func_BSDgettimeofday'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2848 "configure"
+#line 2908 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char BSDgettimeofday(); below. */
@@ -2889,7 +2949,7 @@ if eval "test \"`echo '$''{'ac_cv_func_gettimeofday'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2893 "configure"
+#line 2953 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char gettimeofday(); below. */
@@ -2936,7 +2996,7 @@ fi
echo $ac_n "checking for gettimeofday declaration""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 2940 "configure"
+#line 3000 "configure"
#include "confdefs.h"
#include <sys/time.h>
EOF
@@ -2969,7 +3029,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-linet $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 2973 "configure"
+#line 3033 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -3001,7 +3061,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3005 "configure"
+#line 3065 "configure"
#include "confdefs.h"
#include <net/errno.h>
EOF
@@ -3041,7 +3101,7 @@ else
if test "$GCC" = yes; then
# GCC predefines this symbol on systems where it applies.
cat > conftest.$ac_ext <<EOF
-#line 3045 "configure"
+#line 3105 "configure"
#include "confdefs.h"
#ifdef __CHAR_UNSIGNED__
yes
@@ -3063,7 +3123,7 @@ if test "$cross_compiling" = yes; then
{ echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; }
else
cat > conftest.$ac_ext <<EOF
-#line 3067 "configure"
+#line 3127 "configure"
#include "confdefs.h"
/* volatile prevents gcc2 from optimizing the test away on sparcs. */
#if !defined(__STDC__) || __STDC__ != 1
@@ -3093,7 +3153,7 @@ fi
echo $ac_n "checking signed char declarations""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 3097 "configure"
+#line 3157 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -3145,7 +3205,7 @@ if eval "test \"`echo '$''{'ac_cv_func_connect'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3149 "configure"
+#line 3209 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char connect(); below. */
@@ -3193,7 +3253,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-lsocket $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 3197 "configure"
+#line 3257 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -3229,7 +3289,7 @@ if eval "test \"`echo '$''{'ac_cv_func_accept'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3233 "configure"
+#line 3293 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char accept(); below. */
@@ -3275,7 +3335,7 @@ if eval "test \"`echo '$''{'ac_cv_func_gethostbyname'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3279 "configure"
+#line 3339 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char gethostbyname(); below. */
@@ -3319,7 +3379,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-lnsl $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 3323 "configure"
+#line 3383 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -3435,7 +3495,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-ldl $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 3439 "configure"
+#line 3499 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -3472,7 +3532,7 @@ TCL_LIB_VERSIONS_OK=ok
case $system in
AIX-4.[2-9])
SHLIB_CFLAGS=""
- SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512"
+ SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
@@ -3484,7 +3544,7 @@ case $system in
;;
AIX-*)
SHLIB_CFLAGS=""
- SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512"
+ SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o tclLoadAix.o"
@@ -3521,7 +3581,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-ldld $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 3525 "configure"
+#line 3585 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -3607,7 +3667,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3611 "configure"
+#line 3671 "configure"
#include "confdefs.h"
#include <dld.h>
EOF
@@ -3665,7 +3725,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3669 "configure"
+#line 3729 "configure"
#include "confdefs.h"
#include <dlfcn.h>
EOF
@@ -3848,7 +3908,7 @@ fi
echo $ac_n "checking for ld accepts -Bexport flag""... $ac_c" 1>&6
LDFLAGS="${LDFLAGS} -Wl,-Bexport"
cat > conftest.$ac_ext <<EOF
-#line 3852 "configure"
+#line 3912 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -3898,7 +3958,7 @@ esac
if test "x$DL_OBJS" = "xtclLoadAout.o" ; then
echo $ac_n "checking sys/exec.h""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 3902 "configure"
+#line 3962 "configure"
#include "confdefs.h"
#include <sys/exec.h>
int main() { return 0; }
@@ -3935,7 +3995,7 @@ EOF
else
echo $ac_n "checking a.out.h""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 3939 "configure"
+#line 3999 "configure"
#include "confdefs.h"
#include <a.out.h>
int main() { return 0; }
@@ -3972,7 +4032,7 @@ EOF
else
echo $ac_n "checking sys/exec_aout.h""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 3976 "configure"
+#line 4036 "configure"
#include "confdefs.h"
#include <sys/exec_aout.h>
int main() { return 0; }
@@ -4083,7 +4143,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4087 "configure"
+#line 4147 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
@@ -4119,7 +4179,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4123 "configure"
+#line 4183 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
@@ -4219,6 +4279,7 @@ else
fi
if test "$tcl_ok" = "yes" -a "${SHLIB_SUFFIX}" != "" ; then
+ TCL_SHARED_BUILD=1
TCL_SHLIB_CFLAGS="${SHLIB_CFLAGS}"
TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}"
eval "TCL_LIB_FILE=libtcl${TCL_SHARED_LIB_SUFFIX}"
@@ -4229,6 +4290,7 @@ if test "$tcl_ok" = "yes" -a "${SHLIB_SUFFIX}" != "" ; then
RANLIB=":"
fi
else
+ TCL_SHARED_BUILD=0
case $system in
BSD/OS*)
;;
@@ -4297,6 +4359,7 @@ fi
+
trap '' 1 2 15
cat > confcache <<\EOF
# This file is a shell script that caches the results of configure
@@ -4435,6 +4498,7 @@ s%@TCL_MINOR_VERSION@%$TCL_MINOR_VERSION%g
s%@TCL_PACKAGE_PATH@%$TCL_PACKAGE_PATH%g
s%@TCL_PATCH_LEVEL@%$TCL_PATCH_LEVEL%g
s%@TCL_SHARED_LIB_SUFFIX@%$TCL_SHARED_LIB_SUFFIX%g
+s%@TCL_SHARED_BUILD@%$TCL_SHARED_BUILD%g
s%@TCL_SHLIB_CFLAGS@%$TCL_SHLIB_CFLAGS%g
s%@TCL_SRC_DIR@%$TCL_SRC_DIR%g
s%@TCL_UNSHARED_LIB_SUFFIX@%$TCL_UNSHARED_LIB_SUFFIX%g
diff --git a/contrib/tcl/unix/configure.in b/contrib/tcl/unix/configure.in
index 61605dc..27fa8b1 100755
--- a/contrib/tcl/unix/configure.in
+++ b/contrib/tcl/unix/configure.in
@@ -2,12 +2,12 @@ dnl This file is an input file used by the GNU "autoconf" program to
dnl generate the file "configure", which is run during Tcl installation
dnl to configure the system for the local environment.
AC_INIT(../generic/tcl.h)
-# SCCS: @(#) configure.in 1.135 97/06/10 17:28:19
+# SCCS: @(#) configure.in 1.140 97/08/12 10:36:18
TCL_VERSION=8.0
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=0
-TCL_PATCH_LEVEL=b2
+TCL_PATCH_LEVEL=""
VERSION=${TCL_VERSION}
if test "${prefix}" = "NONE"; then
@@ -34,7 +34,13 @@ AC_C_CROSS
# set flags so Tcl uses alternate procedures.
#--------------------------------------------------------------------
-AC_REPLACE_FUNCS(getcwd opendir strstr)
+# Check if Posix compliant getcwd exists, if not we'll use getwd.
+AC_CHECK_FUNCS(getcwd, , AC_DEFINE(USEGETWD))
+# Nb: if getcwd uses popen and pwd(1) (like Solaris) we should really
+# define USEGETWD even if the posix getcwd exists. Add a test ?
+
+AC_REPLACE_FUNCS(opendir strstr)
+
AC_REPLACE_FUNCS(strtol tmpnam waitpid)
AC_CHECK_FUNC(strerror, , AC_DEFINE(NO_STRERROR))
AC_CHECK_FUNC(getwd, , AC_DEFINE(NO_GETWD))
@@ -646,7 +652,7 @@ TCL_LIB_VERSIONS_OK=ok
case $system in
AIX-4.[[2-9]])
SHLIB_CFLAGS=""
- SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512"
+ SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
@@ -658,7 +664,7 @@ case $system in
;;
AIX-*)
SHLIB_CFLAGS=""
- SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512"
+ SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o tclLoadAix.o"
@@ -1136,6 +1142,7 @@ AC_ARG_ENABLE(shared,
[ --enable-shared build libtcl as a shared library],
[tcl_ok=$enableval], [tcl_ok=no])
if test "$tcl_ok" = "yes" -a "${SHLIB_SUFFIX}" != "" ; then
+ TCL_SHARED_BUILD=1
TCL_SHLIB_CFLAGS="${SHLIB_CFLAGS}"
TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}"
eval "TCL_LIB_FILE=libtcl${TCL_SHARED_LIB_SUFFIX}"
@@ -1146,6 +1153,7 @@ if test "$tcl_ok" = "yes" -a "${SHLIB_SUFFIX}" != "" ; then
RANLIB=":"
fi
else
+ TCL_SHARED_BUILD=0
case $system in
BSD/OS*)
;;
@@ -1209,6 +1217,7 @@ AC_SUBST(TCL_MINOR_VERSION)
AC_SUBST(TCL_PACKAGE_PATH)
AC_SUBST(TCL_PATCH_LEVEL)
AC_SUBST(TCL_SHARED_LIB_SUFFIX)
+AC_SUBST(TCL_SHARED_BUILD)
AC_SUBST(TCL_SHLIB_CFLAGS)
AC_SUBST(TCL_SRC_DIR)
AC_SUBST(TCL_UNSHARED_LIB_SUFFIX)
diff --git a/contrib/tcl/unix/mkLinks b/contrib/tcl/unix/mkLinks
index 21d9f1c..b4da360 100755
--- a/contrib/tcl/unix/mkLinks
+++ b/contrib/tcl/unix/mkLinks
@@ -27,6 +27,10 @@ rm xyzzyTe*
if test "$x" != "xyzzyTestingAVeryLongFileName.foo"; then
exit
fi
+if test -r safe.n; then
+ rm -f Base.n
+ ln safe.n Base.n
+fi
if test -r http.n; then
rm -f Http.n
ln http.n Http.n
@@ -755,6 +759,10 @@ if test -r RecordEval.3; then
rm -f Tcl_RecordAndEval.3
ln RecordEval.3 Tcl_RecordAndEval.3
fi
+if test -r RecEvalObj.3; then
+ rm -f Tcl_RecordAndEvalObj.3
+ ln RecEvalObj.3 Tcl_RecordAndEvalObj.3
+fi
if test -r RegExp.3; then
rm -f Tcl_RegExpCompile.3
ln RegExp.3 Tcl_RegExpCompile.3
diff --git a/contrib/tcl/unix/tclConfig.sh.in b/contrib/tcl/unix/tclConfig.sh.in
index f75782e..905aa84 100644
--- a/contrib/tcl/unix/tclConfig.sh.in
+++ b/contrib/tcl/unix/tclConfig.sh.in
@@ -9,7 +9,7 @@
#
# The information in this file is specific to a single platform.
#
-# SCCS: @(#) tclConfig.sh.in 1.19 96/12/17 09:08:29
+# SCCS: @(#) tclConfig.sh.in 1.20 97/07/01 11:40:19
# Tcl's version number.
TCL_VERSION='@TCL_VERSION@'
@@ -23,6 +23,9 @@ TCL_CC='@CC@'
# -D flags for use with the C compiler.
TCL_DEFS='@DEFS@'
+# Flag, 1: we built a shared lib, 0 we didn't
+TCL_SHARED_BUILD=@TCL_SHARED_BUILD@
+
# The name of the Tcl library (may be either a .a file or a shared library):
TCL_LIB_FILE=@TCL_LIB_FILE@
diff --git a/contrib/tcl/unix/tclUnixFile.c b/contrib/tcl/unix/tclUnixFile.c
index 3819ed5..eb11006 100644
--- a/contrib/tcl/unix/tclUnixFile.c
+++ b/contrib/tcl/unix/tclUnixFile.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclUnixFile.c 1.45 97/05/14 13:24:19
+ * SCCS: @(#) tclUnixFile.c 1.48 97/07/07 16:38:11
*/
#include "tclInt.h"
@@ -169,6 +169,16 @@ TclGetCwd(interp)
currentDirExitHandlerSet = 1;
Tcl_CreateExitHandler(FreeCurrentDir, (ClientData) NULL);
}
+#ifdef USEGETWD
+ if ((int)getwd(buffer) == (int)NULL) {
+ if (interp != NULL) {
+ Tcl_AppendResult(interp,
+ "error getting working directory name: ",
+ buffer, (char *)NULL);
+ }
+ return NULL;
+ }
+#else
if (getcwd(buffer, MAXPATHLEN+1) == NULL) {
if (interp != NULL) {
if (errno == ERANGE) {
@@ -183,6 +193,7 @@ TclGetCwd(interp)
}
return NULL;
}
+#endif
currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1));
strcpy(currentDir, buffer);
}
@@ -273,6 +284,9 @@ Tcl_FindExecutable(argv0)
name = Tcl_DStringValue(&buffer);
goto gotName;
}
+ if (*p == 0) {
+ break;
+ }
p++;
}
goto done;
diff --git a/contrib/tcl/unix/tclUnixInit.c b/contrib/tcl/unix/tclUnixInit.c
index 930568b..91d866f 100644
--- a/contrib/tcl/unix/tclUnixInit.c
+++ b/contrib/tcl/unix/tclUnixInit.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclUnixInit.c 1.25 97/06/24 17:28:56
+ * SCCS: @(#) tclUnixInit.c 1.26 97/08/05 20:09:25
*/
#include "tclInt.h"
@@ -74,12 +74,13 @@ static char initScript[] =
lappend dirs $parentDir/library\n\
foreach i $dirs {\n\
set tcl_library $i\n\
- if {[file exists $i/init.tcl]} {\n\
+ set tclfile [file join $i init.tcl]\n\
+ if {[file exists $tclfile]} {\n\
lappend tcl_pkgPath [file dirname $i]\n\
- if ![catch {uplevel #0 source $i/init.tcl} msg] {\n\
+ if ![catch {uplevel #0 [list source $tclfile]} msg] {\n\
return\n\
} else {\n\
- append errors \"$i/init.tcl: $msg\n$errorInfo\n\"\n\
+ append errors \"$tclfile: $msg\n$errorInfo\n\"\n\
}\n\
}\n\
}\n\
diff --git a/contrib/tcl/unix/tclUnixNotfy.c b/contrib/tcl/unix/tclUnixNotfy.c
index 74c0ffc..857454c 100644
--- a/contrib/tcl/unix/tclUnixNotfy.c
+++ b/contrib/tcl/unix/tclUnixNotfy.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclUnixNotfy.c 1.41 97/06/02 16:45:24
+ * SCCS: @(#) tclUnixNotfy.c 1.42 97/07/02 20:55:44
*/
#include "tclInt.h"
@@ -208,7 +208,7 @@ Tcl_CreateFileHandler(fd, mask, proc, clientData)
}
}
if (filePtr == NULL) {
- filePtr = (FileHandler*) ckalloc(sizeof(FileHandler));
+ filePtr = (FileHandler*) ckalloc(sizeof(FileHandler)); /* MLK */
filePtr->fd = fd;
filePtr->readyMask = 0;
filePtr->nextPtr = notifier.firstFileHandlerPtr;
diff --git a/contrib/tcl/unix/tclUnixPort.h b/contrib/tcl/unix/tclUnixPort.h
index c0d590a..186de21 100644
--- a/contrib/tcl/unix/tclUnixPort.h
+++ b/contrib/tcl/unix/tclUnixPort.h
@@ -19,7 +19,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclUnixPort.h 1.47 97/05/22 10:57:36
+ * SCCS: @(#) tclUnixPort.h 1.49 97/07/30 14:11:59
*/
#ifndef _TCLUNIXPORT
@@ -429,13 +429,6 @@ EXTERN int gettimeofday _ANSI_ARGS_((struct timeval *tp,
#define MASK_SIZE howmany(FD_SETSIZE, NFDBITS)
/*
- * The following function is declared in tclInt.h but doesn't do anything
- * on Unix systems.
- */
-
-#define TclSetSystemEnv(a,b)
-
-/*
* The following implements the Unix method for exiting the process.
*/
#define TclPlatformExit(status) exit(status)
diff --git a/contrib/tcl/unix/tclUnixSock.c b/contrib/tcl/unix/tclUnixSock.c
index 4301889..b917832 100644
--- a/contrib/tcl/unix/tclUnixSock.c
+++ b/contrib/tcl/unix/tclUnixSock.c
@@ -8,21 +8,38 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclUnixSock.c 1.6 96/08/08 08:48:51
+ * SCCS: @(#) tclUnixSock.c 1.7 97/07/24 17:54:02
*/
#include "tcl.h"
#include "tclPort.h"
/*
- * The following variable holds the network name of this host.
+ * There is no portable macro for the maximum length
+ * of host names returned by gethostbyname(). We should only
+ * trust SYS_NMLN if it is at least 255 + 1 bytes to comply with DNS
+ * host name limits.
+ *
+ * Note: SYS_NMLN is a restriction on "uname" not on gethostbyname!
+ *
+ * For example HP-UX 10.20 has SYS_NMLN == 9, while gethostbyname()
+ * can return a fully qualified name from DNS of up to 255 bytes.
+ *
+ * Fix suggested by Viktor Dukhovni (viktor@esm.com)
*/
-#ifndef SYS_NMLN
-# define SYS_NMLN 100
+#if defined(SYS_NMLN) && SYS_NMLEN >= 256
+#define TCL_HOSTNAME_LEN SYS_NMLEN
+#else
+#define TCL_HOSTNAME_LEN 256
#endif
-static char hostname[SYS_NMLN + 1];
+
+/*
+ * The following variable holds the network name of this host.
+ */
+
+static char hostname[TCL_HOSTNAME_LEN + 1];
static int hostnameInited = 0;
/*
OpenPOWER on IntegriCloud