aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPaul Traina <pst@FreeBSD.org>1997-11-27 19:49:05 +0000
committerPaul Traina <pst@FreeBSD.org>1997-11-27 19:49:05 +0000
commitf25b19db8d50748d4f75272ae324cad27788d9b3 (patch)
treecef0bba69f1833802f43364a0cde6945601e665a
parent539e1e66ff6f99c987c8e03872ddaea5260db8f7 (diff)
downloadsrc-vendor/tcl.tar.gz
src-vendor/tcl.zip
Import TCL v8.0 PL2.vendor/tcl
Notes
Notes: svn path=/vendor/tcl/dist/; revision=31434
-rw-r--r--contrib/tcl/README30
-rw-r--r--contrib/tcl/changes184
-rw-r--r--contrib/tcl/doc/CrtInterp.34
-rw-r--r--contrib/tcl/doc/ListObj.36
-rw-r--r--contrib/tcl/doc/OpenFileChnl.34
-rw-r--r--contrib/tcl/doc/PrintDbl.35
-rw-r--r--contrib/tcl/doc/SetVar.323
-rw-r--r--contrib/tcl/doc/TraceVar.321
-rw-r--r--contrib/tcl/doc/array.n5
-rw-r--r--contrib/tcl/doc/binary.n6
-rw-r--r--contrib/tcl/doc/clock.n11
-rw-r--r--contrib/tcl/doc/close.n6
-rw-r--r--contrib/tcl/doc/expr.n9
-rw-r--r--contrib/tcl/doc/interp.n48
-rw-r--r--contrib/tcl/doc/load.n4
-rw-r--r--contrib/tcl/doc/lsort.n6
-rw-r--r--contrib/tcl/doc/man.macros12
-rw-r--r--contrib/tcl/doc/pkgMkIndex.n6
-rw-r--r--contrib/tcl/doc/resource.n41
-rw-r--r--contrib/tcl/doc/safe.n285
-rw-r--r--contrib/tcl/doc/socket.n4
-rw-r--r--contrib/tcl/doc/source.n6
-rw-r--r--contrib/tcl/doc/switch.n8
-rw-r--r--contrib/tcl/doc/tclvars.n8
-rw-r--r--contrib/tcl/doc/vwait.n4
-rw-r--r--contrib/tcl/generic/tcl.h6
-rw-r--r--contrib/tcl/generic/tclBinary.c94
-rw-r--r--contrib/tcl/generic/tclCmdAH.c5
-rw-r--r--contrib/tcl/generic/tclCmdIL.c64
-rw-r--r--contrib/tcl/generic/tclCmdMZ.c76
-rw-r--r--contrib/tcl/generic/tclCompExpr.c55
-rw-r--r--contrib/tcl/generic/tclCompile.c139
-rw-r--r--contrib/tcl/generic/tclEnv.c31
-rw-r--r--contrib/tcl/generic/tclExecute.c208
-rw-r--r--contrib/tcl/generic/tclFileName.c11
-rw-r--r--contrib/tcl/generic/tclIO.c66
-rw-r--r--contrib/tcl/generic/tclIOUtil.c20
-rw-r--r--contrib/tcl/generic/tclInterp.c10
-rw-r--r--contrib/tcl/generic/tclNotify.c21
-rw-r--r--contrib/tcl/generic/tclObj.c6
-rw-r--r--contrib/tcl/generic/tclPosixStr.c6
-rw-r--r--contrib/tcl/generic/tclProc.c4
-rw-r--r--contrib/tcl/generic/tclStringObj.c6
-rw-r--r--contrib/tcl/generic/tclTest.c128
-rw-r--r--contrib/tcl/generic/tclVar.c120
-rw-r--r--contrib/tcl/library/http1.0/http.tcl8
-rw-r--r--contrib/tcl/library/http2.0/http.tcl8
-rw-r--r--contrib/tcl/library/init.tcl147
-rw-r--r--contrib/tcl/library/opt0.1/optparse.tcl43
-rw-r--r--contrib/tcl/library/opt0.1/pkgIndex.tcl2
-rw-r--r--contrib/tcl/library/safe.tcl285
-rw-r--r--contrib/tcl/library/tclIndex5
-rw-r--r--contrib/tcl/tests/append.test18
-rw-r--r--contrib/tcl/tests/basic.test7
-rw-r--r--contrib/tcl/tests/binary.test99
-rw-r--r--contrib/tcl/tests/clock.test30
-rw-r--r--contrib/tcl/tests/cmdIL.test41
-rw-r--r--contrib/tcl/tests/env.test41
-rw-r--r--contrib/tcl/tests/expr-old.test24
-rw-r--r--contrib/tcl/tests/expr.test45
-rw-r--r--contrib/tcl/tests/fCmd.test50
-rw-r--r--contrib/tcl/tests/fileName.test28
-rw-r--r--contrib/tcl/tests/format.test22
-rw-r--r--contrib/tcl/tests/get.test55
-rw-r--r--contrib/tcl/tests/init.test149
-rw-r--r--contrib/tcl/tests/interp.test95
-rw-r--r--contrib/tcl/tests/io.test73
-rw-r--r--contrib/tcl/tests/ioCmd.test6
-rw-r--r--contrib/tcl/tests/join.test12
-rw-r--r--contrib/tcl/tests/linsert.test13
-rw-r--r--contrib/tcl/tests/lreplace.test11
-rw-r--r--contrib/tcl/tests/obj.test6
-rw-r--r--contrib/tcl/tests/opt.test37
-rw-r--r--contrib/tcl/tests/resource.test196
-rw-r--r--contrib/tcl/tests/safe.test50
-rw-r--r--contrib/tcl/tests/set-old.test154
-rw-r--r--contrib/tcl/tests/socket.test6
-rw-r--r--contrib/tcl/tests/source.test11
-rw-r--r--contrib/tcl/tests/unixFCmd.test23
-rw-r--r--contrib/tcl/tests/unixNotfy.test11
-rw-r--r--contrib/tcl/tests/upvar.test14
-rw-r--r--contrib/tcl/tests/winFCmd.test17
-rw-r--r--contrib/tcl/tests/winPipe.test86
-rw-r--r--contrib/tcl/unix/Makefile.in32
-rwxr-xr-xcontrib/tcl/unix/configure135
-rwxr-xr-xcontrib/tcl/unix/configure.in12
-rw-r--r--contrib/tcl/unix/porting.notes30
-rw-r--r--contrib/tcl/unix/tclUnixChan.c10
-rw-r--r--contrib/tcl/unix/tclUnixFCmd.c29
-rw-r--r--contrib/tcl/unix/tclUnixNotfy.c11
-rw-r--r--contrib/tcl/unix/tclUnixPipe.c10
-rw-r--r--contrib/tcl/unix/tclUnixSock.c8
-rw-r--r--contrib/tcl/unix/tclUnixTest.c6
-rw-r--r--contrib/tcl/unix/tclUnixTime.c4
-rw-r--r--contrib/tcl/unix/tclXtTest.c4
95 files changed, 3026 insertions, 1015 deletions
diff --git a/contrib/tcl/README b/contrib/tcl/README
index 640f075d2ba1..13eed9c3f414 100644
--- a/contrib/tcl/README
+++ b/contrib/tcl/README
@@ -1,21 +1,23 @@
Tcl
-SCCS: @(#) README 1.49 97/08/14 08:47:31
+SCCS: @(#) README 1.52 97/11/20 12:43:16
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.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.0p2, which is the second patch update 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. This patch release fixes various bugs in
+Tcl 8.0; there are no feature changes relative to Tcl 8.0.
2. Documentation
----------------
@@ -23,12 +25,12 @@ still supported. See below for more details.
The best way to get started with Tcl is to read one of the introductory
books on Tcl:
+ Practical Programming in Tcl and Tk, 2nd Edition, by Brent Welch,
+ Prentice-Hall, 1997, ISBN 0-13-616830-2
+
Tcl and the Tk Toolkit, by John Ousterhout,
Addison-Wesley, 1994, ISBN 0-201-63337-X
- Practical Programming in Tcl and Tk, by Brent Welch,
- Prentice-Hall, 1995, ISBN 0-13-182007-9
-
Exploring Expect, by Don Libes,
O'Reilly and Associates, 1995, ISBN 1-56592-090-2
@@ -80,7 +82,7 @@ Before trying to compile Tcl you should do the following things:
without changing any features, so you should normally use the
latest patch release for the version of Tcl that you want.
Patch releases are available in two forms. A file like
- tcl8.0p1.tar.Z is a complete release for patch level 1 of Tcl
+ tcl8.0p2.tar.Z is a complete release for patch level 2 of Tcl
version 8.0. If there is a file with a higher patch level than
this release, just fetch the file with the highest patch level
and use it.
diff --git a/contrib/tcl/changes b/contrib/tcl/changes
index c54526b8a1d6..b8672ef6c62e 100644
--- a/contrib/tcl/changes
+++ b/contrib/tcl/changes
@@ -1,6 +1,6 @@
Recent user-visible changes to Tcl:
-SCCS: @(#) changes 1.293 97/08/13 17:50:35
+SCCS: @(#) changes 1.338 97/11/25 08:30:52
1. No more [command1] [command2] construct for grouping multiple
commands on a single command line.
@@ -3101,7 +3101,7 @@ 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)
+for SunOS 4 (because getcwd on SunOS 4 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)
@@ -3272,4 +3272,182 @@ 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 -----------------------
+----------------- Released 8.0, 8/18/97 -----------------------
+
+8/19/97 (bug fix) Minimal fix for glob -nocomplain bugs:
+"glob -nocomplain unreadableDir/*" was generating an anonymous
+error. More in depth fixes will come with 8.1. (DL).
+
+8/20/97 (bug fix) Removed check for FLT_MIN in binary command so
+underflow conditions are handled by the compiler automatic
+conversions. (SS)
+
+8/20/97 (bug fixes) Fixed several compilation-related bugs:
+ - Array cmd wasn't detecting arrays that, while compiled, do not yet
+ exist (e.g., are marked undefined since they haven't been assigned
+ to yet).
+ - The GetToken procedure in tclCompExpr.c wasn't recognizing properly
+ whether an integer token was invalid. For example, "0x$" is not
+ a valid integer.
+ - Performance bug in TclExecuteByteCode: the size of its stack frame
+ was reduced by over 20% by moving errorInfo code elsewhere.
+ - Uninitialized memory read error in tclCompile.c. (BL)
+
+8/21/97 (bug fix) safe::interpConfigure now behave like Tk widget's
+configure : it changes only the options you provide and you can get
+the current value of any single option. New ?-nested boolean? and
+?-statics boolean? for all safe::interp* commands but we still
+accept (upward compatibility) the previously defined non valued
+flags ?-noStatics? and ?-nestedLoadOk?. Improved the documentation. (DL).
+
+8/22/97 (bug fix) Updated PrintDbl.3 to reflect the fact that the
+tcl_precision variable is still used and that it is now shared by all
+interpreters. (BL)
+
+8/25/97 (bug fix) Fixed array access bug in IllegalExprOperandType
+procedure in tclExecute.c: it was not properly supporting the || and &&
+operators. (BL)
+
+8/27/97 (bug fix) In cases where a channel handler was created with an
+empty event mask while data was still buffered in the channel, the
+channel code would get stuck spinning on a timer that would starve
+idle handlers. This mostly happened in Tk when reading from stdin. (SS)
+
+9/4/97 (bug fix) Slave interps now inherit the maximum recursion limit
+of their parent instead of starting back at the default. {nb: this still
+does not prevent stack overflow by multi-interps recursion or aliasing} (DL)
+
+9/11/97 (bug fix) An uninitialized variable in Tcl_WaitPid caused
+pipes to fail to report eof properly under Windows. (SS)
+
+9/12/97 (bug fix) "exec" was misidentifying some DOS executables as not
+executable. (CCS)
+
+9/14/97 (bug fix) Was using the wrong structure in sizeof operation in
+tclUnixChan.c. (JL)
+
+9/15/97 (bug fix) Fixed notifier to break out of do-one-event loop if
+Tcl_WaitForEvent returns 1, so that callers of Tcl_DoOneEvent will get
+a chance to check whether the event just handled is significant. This
+affected mainly recursive calls to Tcl_VWaitCmd; these did not get a
+chance to notice that the variable they were waiting for has been set
+and thus they didn't terminate the vwait. (JL, DL, SS)
+
+9/15/97 (bug fix) Alignment problems in "binary format" would cause a
+crash on some platforms when formatting floating point numbers. (SS)
+
+9/15/97 (bug fix) Fixed bug in Macintosh socket code. Now passes all
+tests in socket.test that are not platform specific. (Thanks to Mark
+Roseman for the pointer on the fix.) (RJ)
+
+9/18/97 (bug fix) Fixed bug -dictionary option of lsort that could
+cause the compare function to run off the end of an array if the
+number only contained 0's. (Thanks to Greg Couch for the report.) (RJ)
+
+9/18/97 (bug fix) TclFinalizeEnvironment was not cleaning up
+properly. (DL, JI)
+
+9/18/97 (bug fix) Fixed long-standing bug where an "array get" command
+did not trigger traces on the array or its elements. (BL)
+
+9/18/97 (bug fixes) Fixed compilation-related bugs:
+ - Fixed errorInfo traceback information for toplevel coomands that
+ contain nested commands.
+ - In the expr command, && and || now accept boolean operands as well
+ as numeric ones. (BL)
+
+9/22/97 (bug fix) Fixed bug that prevented translation modes from being
+set independently for input and output on sockets if input was "auto". (JL)
+
+9/24/97 (bug fix) Tcl_EvalFile(3) and thus source(n) now works fine on
+files containing NUL chars. (DL)
+
+9/26/97 (bug fix) Fixed use of uninitialized memory in the environ array
+that later could cause random core dumps. Applies to all platforms. (JL)
+
+9/26/97 (bug fix) Fixed use of uninitialized memory in socket address data
+structure under some circumstances. This could cause random core dumps.
+This applies only to Unix. (JL)
+
+9/26/97 (bug fix) Opening files on PC-NFS volumes would cause a hang
+until the system timed after the file was closed. (SS)
+
+10/6/97 (bug fix) The join(n) command, though objectified, was loosing
+NULs in the joinString and in list elements after the 2nd one.
+Now you can "join $list \0" for instance. (DL)
+
+10/9/97 (bug fix) Under windows, if env(TMP) or env(TEMP) referred to a
+non-existent directory, exec would fail when trying to create its temporary
+files. (CCS)
+
+10/9/97 (bug fix) Under mac and windows, "info hostname" would crash if
+sockets were installed but the hostname could not be determined anyhow.
+Tcl_GetHostName() was returning NULL when it should have been returning
+an empty string. (CCS)
+
+10/10/97 (bug fix) "file attribute /" returned error on windows. (CCS)
+
+10/10/97 (bug fix) Fixed the auto_load procedure to handle procedures
+defined in namespaces better. Also fixed pgk_mkIndex so it sees procedures
+defined in nested namespaces. Index entries are still only made for
+exported procedures. (BW)
+
+10/13/97 (bug fix) On unix, for files with unknown group or owner
+attributes, querying the "file attributes" would return an error rather than
+returning the group's or owner's id number, although tha command accepts
+numbers when setting the file's group or owner. (CCS)
+
+10/22/97 (bug fix) "fcopy" did not eval the callback script at the
+global scope. (SS)
+
+10/22/97 (bug fix) Fixed the signature of the CopyDone callback used in
+the http package(s) so they can handle error cases properly. (BW)
+
+10/28/97 (bug fixes) Fixed a problem where lappend would free the Tcl object
+in a variable if a Tcl_ObjSetVar2 failed because of an error calling a trace
+on the variable. (BL)
+
+10/28/97 (bug fix) Changed binary scan to properly handle sign
+extension of integers on 64-bit or larger machines. (SS)
+
+11/3/97 (bug fixes) Fixed several bugs:
+ - expressions such as "expr ($x)" must be compiled out-of-line
+ (call the expr command procedure at runtime) to ensure the correct
+ behavior when "$x" is an expression such as "5+10".
+ - "array set a {}" now creates a new array var with an empty array
+ value if the var didn't already exist.
+ - "lreplace $foo end end" no longer returns an error (just an empty
+ list) if foo is empty.
+ - upvar will no longer create a variable in a namespace that refers
+ to a variable in a procedure.
+ - deleting a command trace within a command trace callback would
+ make the code that calls traces to reference freed memory.
+ - significantly sped up "string first" and "string last" (fix from
+ darrel@gemstone.com).
+ - seg fault in Tcl_NewStringObj() when a NULL is passed as the byte
+ pointer argument and Tcl is compiled with -DTCL_MEM_DEBUG.
+ - documentation and error msg fixes. (BL)
+
+11/3/97 (bug fix) Fixed a number of I/O bugs related to word sizes on
+64-bit machines. (SS)
+
+11/6/97 (bug fix) The exit code of the first process created by Tcl
+on Windows was not properly reported due to an initialization
+problem. (SS)
+
+----------------- Released 8.0p1, 11/7/97 -----------------------
+
+11/19/97 (bug fix) Fixed bug in linsert where it sometimes accidently
+cleared out a shared argument list object. (BL).
+
+11/19/97 (bug fix) Autoloading in namespaces was not working properly.
+auto_mkindex is still not really namespace aware but most common
+cases should now be handled properly (see init.test). (BW, DL)
+
+11/20/97 (enhancement) Made the changes required by the new Apple
+Universal Headers V.3.0, so that Tcl will compile with CW Pro 2.
+
+11/24/97 (bug fix) Fixed tests in clock test suite that needed the
+-gmt flag set. Thanks to Jan Nijtmans for reporting the problem. (RJ)
+
+----------------- Released 8.0p2, 11/25/97 -----------------------
diff --git a/contrib/tcl/doc/CrtInterp.3 b/contrib/tcl/doc/CrtInterp.3
index bcca39d5def5..7a3aeda896d7 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.15 97/07/09 14:53:31
+'\" SCCS: @(#) CrtInterp.3 1.17 97/10/31 13:05:51
'\"
.so man.macros
.TH Tcl_CreateInterp 3 7.5 Tcl "Tcl Library Procedures"
@@ -102,7 +102,7 @@ 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\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.
+\fBTcl_DeleteInterp\fR before calling \fBTcl_Release\fR in your own code.
Do not call \fBTcl_DeleteInterp\fR on an interpreter for which
\fBTcl_InterpDeleted\fR returns nonzero.
.TP
diff --git a/contrib/tcl/doc/ListObj.3 b/contrib/tcl/doc/ListObj.3
index 1e304297633c..c19e2344ba09 100644
--- a/contrib/tcl/doc/ListObj.3
+++ b/contrib/tcl/doc/ListObj.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: @(#) @(#) ListObj.3 1.9 97/06/03 13:51:42
+'\" SCCS: @(#) @(#) ListObj.3 1.10 97/10/08 11:36:58
'\"
.so man.macros
.TH Tcl_ListObj 3 8.0 Tcl "Tcl Library Procedures"
@@ -96,8 +96,8 @@ a pointer to the resulting list element object.
Index of the starting list element that \fBTcl_ListObjReplace\fR
is to replace.
The list's first element has index 0.
-.AP int last in
-Index of the final list element that \fBTcl_ListObjReplace\fR
+.AP int count in
+The number of elements that \fBTcl_ListObjReplace\fR
is to replace.
.BE
diff --git a/contrib/tcl/doc/OpenFileChnl.3 b/contrib/tcl/doc/OpenFileChnl.3
index 09768d931223..6cf9b803b375 100644
--- a/contrib/tcl/doc/OpenFileChnl.3
+++ b/contrib/tcl/doc/OpenFileChnl.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: @(#) OpenFileChnl.3 1.39 97/05/09 18:14:49
+'\" SCCS: @(#) OpenFileChnl.3 1.40 97/09/29 11:22:49
.so man.macros
.TH Tcl_OpenFileChannel 3 8.0 Tcl "Tcl Library Procedures"
.BS
@@ -62,7 +62,7 @@ int
\fBTcl_Tell\fR(\fIchannel\fR)
.sp
int
-\fBTcl_GetChannelOption\fR(\fIchannel, optionName, optionValue\fR)
+\fBTcl_GetChannelOption\fR(\fIinterp, channel, optionName, optionValue\fR)
.sp
int
\fBTcl_SetChannelOption\fR(\fIinterp, channel, optionName, newValue\fR)
diff --git a/contrib/tcl/doc/PrintDbl.3 b/contrib/tcl/doc/PrintDbl.3
index e4a4c7eba050..a77b1b990bdb 100644
--- a/contrib/tcl/doc/PrintDbl.3
+++ b/contrib/tcl/doc/PrintDbl.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: @(#) PrintDbl.3 1.8 97/02/18 16:34:51
+'\" SCCS: @(#) PrintDbl.3 1.9 97/08/22 13:30:22
'\"
.so man.macros
.TH Tcl_PrintDouble 3 8.0 Tcl "Tcl Library Procedures"
@@ -23,7 +23,8 @@ Tcl_PrintDouble \- Convert floating value to string
.VS
Before Tcl 8.0, the \fBtcl_precision\fR variable in this interpreter
controlled the conversion. As of Tcl 8.0, this argument is ignored and
-17 digits of precision are always used for conversion.
+the conversion is controlled by the \fBtcl_precision\fR variable
+that is now shared by all interpreters.
.VE
.AP double value in
Floating-point value to be converted.
diff --git a/contrib/tcl/doc/SetVar.3 b/contrib/tcl/doc/SetVar.3
index 10850ae4d29d..32e7a4c64e5a 100644
--- a/contrib/tcl/doc/SetVar.3
+++ b/contrib/tcl/doc/SetVar.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: @(#) SetVar.3 1.29 97/05/19 17:35:05
+'\" SCCS: @(#) SetVar.3 1.30 97/10/10 16:10:36
'\"
.so man.macros
.TH Tcl_SetVar 3 7.4 Tcl "Tcl Library Procedures"
@@ -107,8 +107,9 @@ zero it means that a scalar variable is being referenced.
.PP
The \fIflags\fR argument may be used to specify any of several
options to the procedures.
-It consists of an OR-ed combination of any of the following
-bits:
+It consists of an OR-ed combination of the following bits.
+Note that the flag bit TCL_PARSE_PART1 is only meaningful
+for the procedures Tcl_SetVar2 and Tcl_GetVar2.
.TP
\fBTCL_GLOBAL_ONLY\fR
Under normal circumstances the procedures look up variables as follows:
@@ -152,6 +153,18 @@ A separator space is appended before the new list element unless
the list element is going to be the first element in a list or
sublist (i.e. the variable's current value is empty, or contains
the single character ``{'', or ends in `` }'').
+.TP
+\fBTCL_PARSE_PART1\fR
+If this bit is set when calling \fITcl_SetVar2\fR and \fITcl_GetVar2\fR,
+\fIname1\fR may contain both an array and an element name:
+if the name contains an open parenthesis and ends with a
+close parenthesis, then the value between the parentheses is
+treated as an element name (which can have any string value) and
+the characters before the first open
+parenthesis are treated as the name of an array variable.
+If the flag TCL_PARSE_PART1 is given,
+\fIname2\fR should be NULL since the array and element names
+are taken from \fIname1\fR.
.PP
\fBTcl_GetVar\fR and \fBTcl_GetVar2\fR
return the current value of a variable.
@@ -161,10 +174,12 @@ Under normal circumstances, the return value is a pointer
to the variable's value (which is stored in Tcl's variable
structure and will not change before the next call to \fBTcl_SetVar\fR
or \fBTcl_SetVar2\fR).
-The only bits of \fIflags\fR that are used are TCL_GLOBAL_ONLY
+\fBTcl_GetVar\fR and \fBTcl_GetVar2\fR use the flag bits TCL_GLOBAL_ONLY
and TCL_LEAVE_ERR_MSG, both of
which have
the same meaning as for \fBTcl_SetVar\fR.
+In addition, \fBTcl_GetVar2\fR uses the bit TCL_PARSE_PART1,
+which has the same meaning as for \fBTcl_SetVar2\fR.
If an error occurs in reading the variable (e.g. the variable
doesn't exist or an array element is specified for a scalar
variable), then NULL is returned.
diff --git a/contrib/tcl/doc/TraceVar.3 b/contrib/tcl/doc/TraceVar.3
index 665a3a7d2b2e..976be4f212de 100644
--- a/contrib/tcl/doc/TraceVar.3
+++ b/contrib/tcl/doc/TraceVar.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: @(#) TraceVar.3 1.26 96/08/26 12:59:52
+'\" SCCS: @(#) TraceVar.3 1.27 97/10/10 15:05:37
'\"
.so man.macros
.TH Tcl_TraceVar 3 7.4 Tcl "Tcl Library Procedures"
@@ -44,7 +44,8 @@ must be in writable memory: Tcl will make temporary modifications
to it while looking up the name.
.AP int flags in
OR-ed combination of the values TCL_TRACE_READS, TCL_TRACE_WRITES, and
-TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. Not all flags are used by all
+TCL_TRACE_UNSETS, TCL_PARSE_PART1, and TCL_GLOBAL_ONLY.
+Not all flags are used by all
procedures. See below for more information.
.AP Tcl_VarTraceProc *proc in
Procedure to invoke whenever one of the traced operations occurs.
@@ -171,15 +172,23 @@ traces for a given variable that have the same \fIproc\fR.
The procedures \fBTcl_TraceVar2\fR, \fBTcl_UntraceVar2\fR, and
\fBTcl_VarTraceInfo2\fR are identical to \fBTcl_TraceVar\fR,
\fBTcl_UntraceVar\fR, and \fBTcl_VarTraceInfo\fR, respectively,
-except that the name of the variable has already been
-separated by the caller into two parts.
+except that the name of the variable consists of two parts.
\fIName1\fR gives the name of a scalar variable or array,
-and \fIname2\fR gives the name of an element within an
-array.
+and \fIname2\fR gives the name of an element within an array.
If \fIname2\fR is NULL it means that either the variable is
a scalar or the trace is to be set on the entire array rather
than an individual element (see WHOLE-ARRAY TRACES below for
more information).
+As a special case, if the flag TCL_PARSE_PART1 is specified,
+\fIname1\fR may contain both an array and an element name:
+if the name contains an open parenthesis and ends with a
+close parenthesis, then the value between the parentheses is
+treated as an element name (which can have any string value) and
+the characters before the first open
+parenthesis are treated as the name of an array variable.
+If the flag TCL_PARSE_PART1 is given,
+\fIname2\fR should be NULL since the array and element names
+are taken from \fIname1\fR.
.SH "ACCESSING VARIABLES DURING TRACES"
.PP
diff --git a/contrib/tcl/doc/array.n b/contrib/tcl/doc/array.n
index a6e88172b7ca..0de8aa710b13 100644
--- a/contrib/tcl/doc/array.n
+++ b/contrib/tcl/doc/array.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: @(#) array.n 1.8 96/08/26 12:59:53
+'\" SCCS: @(#) array.n 1.9 97/10/29 14:10:13
'\"
.so man.macros
.TH array n 7.4 Tcl "Tcl Built-In Commands"
@@ -91,6 +91,9 @@ consisting of an even number of elements.
Each odd-numbered element in \fIlist\fR is treated as an element
name within \fIarrayName\fR, and the following element in \fIlist\fR
is used as a new value for that array element.
+If the variable \fIarrayName\fR does not already exist
+and \fIlist\fR is empty,
+\fIarrayName\fR is created with an empty array value.
.TP
\fBarray size \fIarrayName\fR
Returns a decimal string giving the number of elements in the
diff --git a/contrib/tcl/doc/binary.n b/contrib/tcl/doc/binary.n
index 17d938071b83..067c52e3346d 100644
--- a/contrib/tcl/doc/binary.n
+++ b/contrib/tcl/doc/binary.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: @(#) binary.n 1.5 97/06/10 17:52:46
+'\" SCCS: @(#) binary.n 1.7 97/11/11 19:08:47
'\"
.so man.macros
.TH binary n 8.0 Tcl "Tcl Built-In Commands"
@@ -206,8 +206,8 @@ representation in the output string. This representation is not
portable across architectures, so it should not be used to communicate
floating point numbers across the network. The size of a floating
point number may vary across architectures, so the number of bytes
-that are generated may vary. If the value is out of range for the
-machine's native representation, then the value of FLT_MIN or FLT_MAX
+that are generated may vary. If the value overflows the
+machine's native representation, then the value of FLT_MAX
as defined by the system will be used instead. Because Tcl uses
double-precision floating-point numbers internally, there may be some
loss of precision in the conversion to single-precision. For example,
diff --git a/contrib/tcl/doc/clock.n b/contrib/tcl/doc/clock.n
index c7777a63cd7f..2f2786121420 100644
--- a/contrib/tcl/doc/clock.n
+++ b/contrib/tcl/doc/clock.n
@@ -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: @(#) clock.n 1.17 97/02/03 16:34:17
+'\" SCCS: @(#) clock.n 1.18 97/09/10 13:31:23
'\"
.so man.macros
.TH clock n 7.4 Tcl "Tcl Built-In Commands"
@@ -150,10 +150,11 @@ A specific month and day with optional year. The
acceptable formats are \fImm/dd\fR?\fI/yy\fR?, \fImonthname dd\fR
?, \fIyy\fR?, \fIdd monthname \fR?\fIyy\fR? and \fIday, dd monthname
yy\fR. The default year is the current year. If the year is less
-then 100, we treat the years 00-38 as 2000-2038 and the years 70-99
-as 1970-1999. The years 39-70 are undefined and may not be valid on
-certain platforms. (For thos platforms where it is defined then the
-years 69-99 match to 1969-1999.)
+.VS
+than 100, we treat the years 00-68 as 2000-2068 and the years 69-99
+as 1969-1999. Not all platforms can represent the years 38-70, so
+an error may result if these years are used.
+.VE
.TP
\fIrelative time\fR
A specification relative to the current time. The format is \fInumber
diff --git a/contrib/tcl/doc/close.n b/contrib/tcl/doc/close.n
index 0ed5a1f89c35..4ee53eade8bc 100644
--- a/contrib/tcl/doc/close.n
+++ b/contrib/tcl/doc/close.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: @(#) close.n 1.10 96/02/15 20:01:34
+'\" SCCS: @(#) close.n 1.11 97/08/22 18:50:48
'\"
.so man.macros
.TH close n 7.5 Tcl "Tcl Built-In Commands"
@@ -25,7 +25,7 @@ or \fBsocket\fR command.
All buffered output is flushed to the channel's output device,
any buffered input is discarded, the underlying file or device is closed,
and \fIchannelId\fR becomes unavailable for use.
-.VS br
+.VS "" br
.PP
If the channel is blocking, the command does not return until all output
is flushed.
@@ -37,7 +37,7 @@ channel will be closed when all the flushing is complete.
.PP
If \fIchannelId\fR is a blocking channel for a command pipeline then
\fBclose\fR waits for the child processes to complete.
-.VS br
+.VS "" br
.PP
If the channel is shared between interpreters, then \fBclose\fR
makes \fIchannelId\fR unavailable in the invoking interpreter but has no
diff --git a/contrib/tcl/doc/expr.n b/contrib/tcl/doc/expr.n
index f4532cc18a7a..f0969ceda161 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.27 97/08/12 11:31:30
+'\" SCCS: @(#) expr.n 1.28 97/09/18 18:21:30
'\"
.so man.macros
.TH expr n 8.0 Tcl "Tcl Built-In Commands"
@@ -144,12 +144,13 @@ Bit-wise exclusive OR. Valid for integer operands only.
Bit-wise OR. Valid for integer operands only.
.TP 20
\fB&&\fR
-Logical AND. Produces a 1 result if both operands are non-zero, 0 otherwise.
-Valid for numeric operands only (integers or floating-point).
+Logical AND. Produces a 1 result if both operands are non-zero,
+0 otherwise.
+Valid for boolean and numeric (integers or floating-point) operands only.
.TP 20
\fB||\fR
Logical OR. Produces a 0 result if both operands are zero, 1 otherwise.
-Valid for numeric operands only (integers or floating-point).
+Valid for boolean and numeric (integers or floating-point) operands only.
.TP 20
\fIx\fB?\fIy\fB:\fIz\fR
If-then-else, as in C. If \fIx\fR
diff --git a/contrib/tcl/doc/interp.n b/contrib/tcl/doc/interp.n
index 023681833e0d..6229623364d3 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.35 97/07/31 18:04:06
+'\" SCCS: @(#) interp.n 1.37 97/10/31 12:51:11
'\"
.so man.macros
.TH interp n 7.6 Tcl "Tcl Built-In Commands"
@@ -84,21 +84,21 @@ slave interpreters, and to share or transfer
channels between interpreters. It can have any of several forms, depending
on the \fIoption\fR argument:
.TP
-\fBinterp \fBalias \fIsrcPath \fIsrcCmd\fR
+\fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcCmd\fR
Returns a Tcl list whose elements are the \fItargetCmd\fR and
\fIarg\fRs associated with the alias named \fIsrcCmd\fR
(all of these are the values specified when the alias was
created; it is possible that the actual source command in the
slave is different from \fIsrcCmd\fR if it was renamed).
.TP
-\fBinterp \fBalias \fIsrcPath \fIsrcCmd\fR \fB{}\fR
+\fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcCmd\fR \fB{}\fR
Deletes the alias for \fIsrcCmd\fR in the slave interpreter identified by
\fIsrcPath\fR.
\fIsrcCmd\fR refers to the name under which the alias
was created; if the source command has been renamed, the renamed
command will be deleted.
.TP
-\fBinterp \fBalias \fIsrcPath \fIsrcCmd\fR \fItargetPath \fItargetCmd \fR?\fIarg arg ...\fR?
+\fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcCmd\fR \fItargetPath\fR \fItargetCmd \fR?\fIarg arg ...\fR?
This command creates an alias between one slave and another (see the
\fBalias\fR slave command below for creating aliases between a slave
and its master). In this command, either of the slave interpreters
@@ -122,11 +122,11 @@ in the target interpreter whenever the given source command is
invoked in the source interpreter. See ALIAS INVOCATION below for
more details.
.TP
-\fBinterp \fBaliases \fR?\fIpath\fR?
+\fBinterp\fR \fBaliases \fR?\fIpath\fR?
This command returns a Tcl list of the names of all the source commands for
aliases defined in the interpreter identified by \fIpath\fR.
.TP
-\fBinterp \fBcreate \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR?
+\fBinterp\fR \fBcreate \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR?
Creates a slave interpreter identified by \fIpath\fR and a new command,
called a \fIslave command\fR. The name of the slave command is the last
component of \fIpath\fR. The new slave interpreter and the slave command
@@ -148,14 +148,14 @@ new interpreter. The name of a slave interpreter must be unique among all
the slaves for its master; an error occurs if a slave interpreter by the
given name already exists in this master.
.TP
-\fBinterp \fBdelete \fR?\fIpath ...?\fR
+\fBinterp\fR \fBdelete \fR?\fIpath ...?\fR
Deletes zero or more interpreters given by the optional \fIpath\fR
arguments, and for each interpreter, it also deletes its slaves. The
command also deletes the slave command for each interpreter deleted.
For each \fIpath\fR argument, if no interpreter by that name
exists, the command raises an error.
.TP
-\fBinterp \fBeval \fIpath arg \fR?\fIarg ...\fR?
+\fBinterp\fR \fBeval\fR \fIpath arg \fR?\fIarg ...\fR?
This command concatenates all of the \fIarg\fR arguments in the same
fashion as the \fBconcat\fR command, then evaluates the resulting string as
a Tcl script in the slave interpreter identified by \fIpath\fR. The result
@@ -163,13 +163,13 @@ of this evaluation (including error information such as the \fBerrorInfo\fR
and \fBerrorCode\fR variables, if an error occurs) is returned to the
invoking interpreter.
.TP
-\fBinterp \fBexists \fIpath\fR
+\fBinterp exists \fIpath\fR
Returns \fB1\fR if a slave interpreter by the specified \fIpath\fR
exists in this master, \fB0\fR otherwise. If \fIpath\fR is omitted, the
invoking interpreter is used.
-.VS BR
+.VS "" BR
.TP
-\fBinterp \fBexpose \fIpath\fR \fIhiddenName\fR ?\fIexposedCmdName\fR?
+\fBinterp expose \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 ::),
@@ -179,7 +179,7 @@ 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?
+\fBinterp\fR \fBhide\fR \fIpath\fR \fIexposedCmdName\fR ?\fIhiddenCmdName\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
@@ -194,11 +194,11 @@ 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
+\fBinterp\fR \fBhidden\fR \fIpath\fR
Returns a list of the names of all hidden commands in the interpreter
identified by \fIpath\fR.
.TP
-\fBinterp \fBinvokehidden\fR \fIpath\fR ?\fB-global\fR \fIhiddenCmdName\fR ?\fIarg ...\fR?
+\fBinterp\fR \fBinvokehidden\fR \fIpath\fR ?\fB-global\fR \fIhiddenCmdName\fR ?\fIarg ...\fR?
Invokes the hidden command \fIhiddenCmdName\fR with the arguments supplied
in the interpreter denoted by \fIpath\fR. No substitutions or evaluation
are applied to the arguments.
@@ -209,12 +209,12 @@ frames.
Hidden commands are explained in more detail in HIDDEN COMMANDS, below.
.VE
.TP
-\fBinterp \fBissafe\fR ?\fIpath\fR?
+\fBinterp issafe\fR ?\fIpath\fR?
Returns \fB1\fR if the interpreter identified by the specified \fIpath\fR
is safe, \fB0\fR otherwise.
-.VS BR
+.VS "" BR
.TP
-\fBinterp \fBmarktrusted\fR \fIpath\fR
+\fBinterp marktrusted\fR \fIpath\fR
Marks the interpreter identified by \fIpath\fR as trusted. Does
not expose the hidden commands. This command can only be invoked from a
trusted interpreter.
@@ -222,7 +222,7 @@ The command has no effect if the interpreter identified by \fIpath\fR is
already trusted.
.VE
.TP
-\fBinterp \fBshare\fR \fIsrcPath channelId destPath\fR
+\fBinterp\fR \fBshare\fR \fIsrcPath channelId destPath\fR
Causes the IO channel identified by \fIchannelId\fR to become shared
between the interpreter identified by \fIsrcPath\fR and the interpreter
identified by \fIdestPath\fR. Both interpreters have the same permissions
@@ -231,12 +231,12 @@ Both interpreters must close it to close the underlying IO channel; IO
channels accessible in an interpreter are automatically closed when an
interpreter is destroyed.
.TP
-\fBinterp \fBslaves\fR ?\fIpath\fR?
+\fBinterp\fR \fBslaves\fR ?\fIpath\fR?
Returns a Tcl list of the names of all the slave interpreters associated
with the interpreter identified by \fIpath\fR. If \fIpath\fR is omitted,
the invoking interpreter is used.
.TP
-\fBinterp \fBtarget \fIpath alias\fR
+\fBinterp\fR \fBtarget\fR \fIpath alias\fR
Returns a Tcl list describing the target interpreter for an alias. The
alias is specified with an interpreter path and source command name, just
as in \fBinterp alias\fR above. The name of the target interpreter is
@@ -246,7 +246,7 @@ empty list is returned. If the target interpreter for the alias is not the
invoking interpreter or one of its descendants then an error is generated.
The target command does not have to be defined at the time of this invocation.
.TP
-\fBinterp \fBtransfer\fR \fIsrcPath channelId destPath\fR
+\fBinterp\fR \fBtransfer\fR \fIsrcPath channelId destPath\fR
Causes the IO channel identified by \fIchannelId\fR to become available in
the interpreter identified by \fIdestPath\fR and unavailable in the
interpreter identified by \fIsrcPath\fR.
@@ -300,7 +300,7 @@ the resulting string as a Tcl script in \fIslave\fR.
The result of this evaluation (including error information
such as the \fBerrorInfo\fR and \fBerrorCode\fR variables, if an
error occurs) is returned to the invoking interpreter.
-.VS BR
+.VS "" BR
.TP
\fIslave \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR?
This command exposes the hidden command \fIhiddenName\fR, eventually bringing
@@ -341,7 +341,7 @@ COMMANDS, below.
.TP
\fIslave \fBissafe\fR
Returns \fB1\fR if the slave interpreter is safe, \fB0\fR otherwise.
-.VS BR
+.VS "" BR
.TP
\fIslave \fBmarktrusted\fR
Marks the slave interpreter as trusted. Can only be invoked by a
@@ -391,7 +391,7 @@ split string subst switch
tell trace unset update
uplevel upvar vwait while\fR
.DE
-.VS BR
+.VS "" BR
The following commands are hidden by \fBinterp create\fR when it
creates a safe interpreter:
.DS
diff --git a/contrib/tcl/doc/load.n b/contrib/tcl/doc/load.n
index 096081f47cc7..0d5e6e8888b9 100644
--- a/contrib/tcl/doc/load.n
+++ b/contrib/tcl/doc/load.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: @(#) load.n 1.8 96/12/20 09:23:23
+'\" SCCS: @(#) load.n 1.9 97/08/22 18:51:18
'\"
.so man.macros
.TH load n 7.5 Tcl "Tcl Built-In Commands"
@@ -93,7 +93,7 @@ alphabetic and underline characters as the module name.
For example, the command \fBload libxyz4.2.so\fR uses the module
name \fBxyz\fR and the command \fBload bin/last.so {}\fR uses the
module name \fBlast\fR.
-.VS br
+.VS "" br
.PP
If \fIfileName\fR is an empty string, then \fIpackageName\fR must
be specified.
diff --git a/contrib/tcl/doc/lsort.n b/contrib/tcl/doc/lsort.n
index 8184663093ff..828cad8c63b6 100644
--- a/contrib/tcl/doc/lsort.n
+++ b/contrib/tcl/doc/lsort.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: @(#) lsort.n 1.9 97/03/24 20:51:09
+'\" SCCS: @(#) lsort.n 1.10 97/08/22 18:50:53
'\"
.so man.macros
.TH lsort n 8.0 Tcl "Tcl Built-In Commands"
@@ -29,7 +29,7 @@ control the sorting process (unique abbreviations are accepted):
\fB\-ascii\fR
Use string comparison with ASCII collation order. This is
the default.
-.VS br
+.VS 8.0 br
.TP 20
\fB\-dictionary\fR
Use dictionary-style comparison. This is the same as \fB\-ascii\fR
@@ -62,7 +62,7 @@ This is the default.
.TP 20
\fB\-decreasing\fR
Sort the list in decreasing order (``largest'' items first).
-.VS br
+.VS 8.0 br
.TP 20
\fB\-index\0\fIindex\fR
If this option is specified, each of the elements of \fIlist\fR must
diff --git a/contrib/tcl/doc/man.macros b/contrib/tcl/doc/man.macros
index 67e601275521..3af2da929343 100644
--- a/contrib/tcl/doc/man.macros
+++ b/contrib/tcl/doc/man.macros
@@ -26,10 +26,12 @@
'\" .CE
'\" End code excerpt.
'\"
-'\" .VS ?br?
+'\" .VS ?version? ?br?
'\" Begin vertical sidebar, for use in marking newly-changed parts
-'\" of man pages. If an argument is present, then a line break is
-'\" forced before starting the sidebar.
+'\" of man pages. The first argument is ignored and used for recording
+'\" the version when the .VS was added, so that the sidebars can be
+'\" found and removed when they reach a certain age. If another argument
+'\" is present, then a line break is forced before starting the sidebar.
'\"
'\" .VE
'\" End of vertical sidebar.
@@ -57,7 +59,7 @@
'\" .UL arg1 arg2
'\" Print arg1 underlined, then print arg2 normally.
'\"
-'\" SCCS: @(#) man.macros 1.8 96/02/15 20:02:24
+'\" SCCS: @(#) man.macros 1.9 97/08/22 18:50:59
'\"
'\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages.
.if t .wh -1.3i ^B
@@ -131,7 +133,7 @@
'\" # ^Y = starting y location
'\" # ^v = 1 (for troff; for nroff this doesn't matter)
.de VS
-.if !"\\$1"" .br
+.if !"\\$2"" .br
.mk ^Y
.ie n 'mc \s12\(br\s0
.el .nr ^v 1u
diff --git a/contrib/tcl/doc/pkgMkIndex.n b/contrib/tcl/doc/pkgMkIndex.n
index a0f32fd42ce1..702c6572e062 100644
--- a/contrib/tcl/doc/pkgMkIndex.n
+++ b/contrib/tcl/doc/pkgMkIndex.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: @(#) pkgMkIndex.n 1.6 96/10/04 11:31:53
+'\" SCCS: @(#) pkgMkIndex.n 1.8 97/10/31 12:51:13
'\"
.so man.macros
.TH pkg_mkIndex n 7.6 Tcl "Tcl Built-In Commands"
@@ -14,7 +14,7 @@
pkg_mkIndex \- Build an index for automatic loading of packages
.SH SYNOPSIS
.nf
-\fBpkg_mkIndex \fIdir \fIpattern \fR?\fIpattern pattern ...\fR?
+\fBpkg_mkIndex \fIdir\fR \fIpattern \fR?\fIpattern pattern ...\fR?
.fi
.BE
@@ -46,7 +46,7 @@ It does this by loading each file and seeing what packages
and new commands appear (this is why it is essential to have
\fBpackage provide\fR commands or \fBTcl_PkgProvide\fR calls
in the files, as described above).
-.VS br
+.VS "" br
.IP [3]
Install the package as a subdirectory of one of the directories given by
the \fBtcl_pkgPath\fR variable. If \fB$tcl_pkgPath\fR contains more
diff --git a/contrib/tcl/doc/resource.n b/contrib/tcl/doc/resource.n
index 1ccd50cc065d..0062992f3b2e 100644
--- a/contrib/tcl/doc/resource.n
+++ b/contrib/tcl/doc/resource.n
@@ -3,7 +3,7 @@
'\"
'\" 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
+'\" SCCS: @(#) resource.n 1.4 97/09/10 15:22:18
'\"
.so man.macros
.TH resource n 8.0 Tcl "Tcl Built-In Commands"
@@ -32,6 +32,40 @@ Closes the given resource reference (obtained from \fBresource
open\fR). Resources from that resource file will no longer be
available.
.TP
+\fBresource delete\fR ?\fIoptions\fR? \fIresourceType\fR
+This command will delete the resource specified by \fIoptions\fR and
+type \fIresourceType\fR (see RESOURCE TYPES below). The options
+give you several ways to specify the resource to be deleted.
+.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 to specify the resource to be deleted. 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 named
+\fIresourceName\fR will be deleted. If the \fB-id\fR is also
+provided, then there must be a resource with BOTH this name and
+this id. If no name is provided, then the id will be used regardless
+of the name of the actual resource.
+.TP
+\fB\-file\fR \fIresourceRef\fR
+If the \fB-file\fR option is specified then the resource will be
+deleted from the file pointed to by \fIresourceRef\fR. Otherwise the
+first resource with the given \fIresourceName\fR and or
+\fIresourceId\fR which is found on the resource file path will be
+deleted. To inspect the file path, use the \fIresource files\fB command.
+.RE
+.TP
+\fBresource files ?\fIresourceRef\fR?
+If \fIresourceRef\fRis not provided, this command returns a Tcl list
+of the resource references for all the currently open resource files.
+The list is in the normal Macintosh search order for resources. If
+\fIresourceRef\fR is specified, the command will
+return the path to the file whose resource fork is represented by that
+token.
+.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
@@ -88,6 +122,11 @@ name.
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.
+.TP
+\fB\-force\fR
+If the target resource already exists, then by default Tcl will not
+overwrite it, but raise an error instead. Use the -force flag to
+force overwriting the extant resource.
.RE
.SH "RESOURCE TYPES"
diff --git a/contrib/tcl/doc/safe.n b/contrib/tcl/doc/safe.n
index 03adf0f38b63..3be9c5f7b261 100644
--- a/contrib/tcl/doc/safe.n
+++ b/contrib/tcl/doc/safe.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: @(#) safe.n 1.3 97/08/13 12:44:45
+'\" SCCS: @(#) safe.n 1.11 97/10/31 12:51:13
'\"
.so man.macros
.TH "Safe Tcl" n 8.0 Tcl "Tcl Built-In Commands"
@@ -29,7 +29,10 @@ Safe Base \- A mechanism for creating and manipulating safe interpreters.
\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?
+?\fB\-accessPath\fR \fIpathList\fR?
+?\fB\-statics\fR \fIboolean\fR? ?\fB\-noStatics\fR?
+?\fB\-nested\fR \fIboolean\fR? ?\fB\-nestedLoadOk\fR?
+?\fB\-deleteHook\fR \fIscript\fR?
.BE
.SH DESCRIPTION
@@ -54,95 +57,23 @@ 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.
+master interpreter transparently
+translates the token into a real directory name and executes the
+requested operation (see the section \fBSECURITY\fR below for details).
Different levels of security can be selected by using the optional flags
of the commands described below.
.PP
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
-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
-\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 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
+the \fBsafe\fR namespace:
+
.SH COMMANDS
-.PP
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
+See the \fBOPTIONS\fR section below for a description of the
optional arguments.
If the \fIslave\fR argument is omitted, a name will be generated.
\fB::safe::interpCreate\fR always returns the interpreter name.
@@ -150,18 +81,36 @@ If the \fIslave\fR argument is omitted, a name will be generated.
\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.
+other means, like \fBinterp 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.
+named safe interpreter as a list of options and their current values
+for that \fIslave\fR.
+If a single additional argument is provided,
+it will return a list of 2 elements \fIname\fR and \fIvalue\fR where
+\fIname\fR is the full name of that option and \fIvalue\fR the current value
+for that option and the \fIslave\fR.
+If more than two additional arguments are provided, it will reconfigure the
+safe interpreter and change each and only the provided options.
+See the section on \fBOPTIONS\fR below for options description.
+Example of use:
+.RS
+.CS
+# Create a new interp with the same configuration as "$i0" :
+set i1 [eval safe::interpCreate [safe::interpConfigure $i0]]
+# Get the current deleteHook
+set dh [safe::interpConfigure $i0 \-del]
+# Change (only) the statics loading ok attribute of an interp
+# and its deleteHook (leaving the rest unchanged) :
+safe::interpConfigure $i0 \-delete {foo bar} \-statics 0 ;
+.CE
+.RE
.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
+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
@@ -170,9 +119,11 @@ 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:
+.RS
.CS
$slave eval [list set tk_library [::safe::interpFindInAccessPath $name $tk_library]]
.CE
+.RE
.TP
\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR
This command adds \fIdirectory\fR to the virtual path maintained for the
@@ -181,13 +132,15 @@ 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:
+.RS
.CS
$slave eval [list set tk_library [::safe::interpAddToAccessPath $name $tk_library]]
.CE
+.RE
.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.
+life cycle 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.
@@ -224,75 +177,165 @@ Any option name can be abbreviated to its minimal
non-ambiguous name.
Option names are not case sensitive.
.TP
-\fB\-accessPath\fR ?\fIdirectoryList\fR?
+\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
+can \fBsource\fR and \fBload\fR files.
+If this option is not specified, or if it is given as the
+empty list, the safe interpreter will use the same directories as 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
+\fB\-statics\fR \fIboolean\fR
+This option specifies if the safe interpreter will be allowed
to load statically linked packages (like \fBload {} Tk\fR).
-The default is that safe interpreters are allowed to load statically linked
-packages.
+The default value is \fBtrue\fR :
+safe interpreters are allowed to load statically linked packages.
+.TP
+\fB\-noStatics\fR
+This option is a convenience shortcut for \fB-statics false\fR and
+thus specifies that the safe interpreter will not be allowed
+to load statically linked packages.
+.TP
+\fB\-nested\fR \fIboolean\fR
+This option specifies if the safe interpreter will be allowed
+to load packages into its own sub-interpreters.
+The default value is \fBfalse\fR :
+safe interpreters are not allowed to load packages into
+their own sub-interpreters.
.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.
+This option is a convenience shortcut for \fB-nested true\fR and
+thus specifies the safe interpreter will be allowed
+to load packages into its own sub-interpreters.
.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.
+\fB\-deleteHook\fR \fIscript\fR
+When this option is given an non empty \fIscript\fR, it will be
+evaluated in the master with the name of
+the safe interpreter as an additional argument
+just before actually deleting the safe interpreter.
+Giving an empty value removes any currently installed deletion hook
+script for that safe interpreter.
+The default value (\fB{}\fR) is not to have any deletion call back.
+.SH ALIASES
+The following aliases are provided in a safe interpreter:
+.TP
+\fBsource\fR \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, is 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 ?\fIsubCmd args...\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.
.SH SECURITY
-.PP
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
+These attacks, while aggravating, are deemed to be of lesser importance
in general than integrity and privacy attacks that the Safe Base
is to prevent.
-
+.PP
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.
+The safe interpreter can also auto-load code and it can request that
+packages be loaded.
+.PP
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
+To prevent this, commands that 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.
+This virtual path system is maintained in the master interpreter for each safe
+interpreter created by \fB::safe::interpCreate\fR or initialized by
+\fB::safe::interpInit\fR and
+the path maps tokens accessible in the safe interpreter into real path
+names on the local file system thus preventing safe interpreters
+from gaining knowledge about the
+structure of the file system of the host on which the interpreter is
+executing.
+The only valid file names arguments
+for the \fBsource\fR and \fBload\fR aliases provided to the slave
+are path in the form of
+\fB[file join \fR\fItoken filename\fR\fB]\fR (ie, when using the
+native file path formats: \fItoken\fR\fB/\fR\fIfilename\fR
+on Unix, \fItoken\fR\fB\\\fIfilename\fR on Windows,
+and \fItoken\fR\fB:\fR\fIfilename\fR on the Mac),
+where \fItoken\fR is representing one of the directories
+of the \fIaccessPath\fR list and \fIfilename\fR is
+one file in that directory (no sub directories access are allowed).
+.PP
+When a token is used in a safe interpreter in a request to source or
+load a file, the token is checked and
+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.
.PP
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.
+interpreter, the \fBsource\fR alias restricts access to files
+meeting the following constraints: the file name must
+fourteen characters or shorter, must not contain more than one dot ("\fB.\fR"),
+must end up with the extension \fB.tcl\fR or be called \fBtclIndex\fR.
+.PP
+Each element of the initial access path
+list will be assigned a token that will be set in
+the slave \fBauto_path\fR and the first element of that list will be set as
+the \fBtcl_library\fR for that slave.
.PP
-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.
+If the access path argument is not given or is the empty list,
+the default behavior is to let the slave access the same packages
+as the master has access to (Or to be more precise:
+only packages written in Tcl (which by definition can't be dangerous
+as they run in the slave interpreter) and C extensions that
+provides a Safe_Init entry point). For that purpose, the master's
+\fBauto_path\fR will be used to construct the slave access path.
+In order that the slave successfully loads the Tcl library files
+(which includes the auto-loading mechanism itself) the \fBtcl_library\fR will be
+added or moved to the first position if necessary, in the
+slave access path, so the slave
+\fBtcl_library\fR will be the same as the master's (its real
+path will still be invisible to the slave though).
+In order that auto-loading works the same for the slave and
+the master in this by default case, the first-level
+sub directories of each directory in the master \fBauto_path\fR will
+also be added (if not already included) to the slave access path.
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.
+.PP
+When the \fIaccessPath\fR is changed after the first creation or
+initialization (ie through \fBinterpConfigure -accessPath \fR\fIlist\fR),
+an \fBauto_reset\fR is automatically evaluated in the safe interpreter
+to synchronize its \fBauto_index\fR with the new token list.
.SH "SEE ALSO"
interp(n), library(n), load(n), package(n), source(n), unknown(n)
diff --git a/contrib/tcl/doc/socket.n b/contrib/tcl/doc/socket.n
index 13774976156b..f7666600d175 100644
--- a/contrib/tcl/doc/socket.n
+++ b/contrib/tcl/doc/socket.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: @(#) socket.n 1.13 96/04/05 12:05:26
+'\" SCCS: @(#) socket.n 1.14 97/10/31 12:51:12
.so man.macros
.TH socket n 7.5 Tcl "Tcl Built-In Commands"
.BS
@@ -15,7 +15,7 @@ socket \- Open a TCP network connection
.sp
\fBsocket \fR?\fIoptions\fR? \fIhost port\fR
.sp
-\fBsocket \fB\-server \fIcommand\fR ?\fIoptions\fR? \fIport\fR
+\fBsocket\fR \fB\-server \fIcommand\fR ?\fIoptions\fR? \fIport\fR
.BE
.SH DESCRIPTION
diff --git a/contrib/tcl/doc/source.n b/contrib/tcl/doc/source.n
index 4b153b978b47..122c79340547 100644
--- a/contrib/tcl/doc/source.n
+++ b/contrib/tcl/doc/source.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: @(#) source.n 1.7 96/04/15 13:07:38
+'\" SCCS: @(#) source.n 1.8 97/10/31 12:51:10
'\"
.so man.macros
.TH source n "" Tcl "Tcl Built-In Commands"
@@ -16,9 +16,9 @@ source \- Evaluate a file or resource as a Tcl script
.SH SYNOPSIS
\fBsource \fIfileName\fR
.sp
-\fBsource \fB\-rsrc \fIresourceName \fR?\fIfileName\fR?
+\fBsource\fR \fB\-rsrc \fIresourceName \fR?\fIfileName\fR?
.sp
-\fBsource \fB\-rsrcid \fIresourceId \fR?\fIfileName\fR?
+\fBsource\fR \fB\-rsrcid \fIresourceId \fR?\fIfileName\fR?
.BE
.SH DESCRIPTION
diff --git a/contrib/tcl/doc/switch.n b/contrib/tcl/doc/switch.n
index f92540dcdaf1..b2754ca0581e 100644
--- a/contrib/tcl/doc/switch.n
+++ b/contrib/tcl/doc/switch.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: @(#) switch.n 1.8 96/03/25 20:24:31
+'\" SCCS: @(#) switch.n 1.10 97/10/31 13:05:55
'\"
.so man.macros
.TH switch n 7.0 Tcl "Tcl Built-In Commands"
@@ -14,9 +14,9 @@
.SH NAME
switch \- Evaluate one of several scripts, depending on a given value
.SH SYNOPSIS
-\fBswitch\fI \fR?\fIoptions\fR?\fI string \fIpattern body \fR?\fIpattern body \fR...?
+\fBswitch \fR?\fIoptions\fR?\fI string pattern body \fR?\fIpattern body \fR...?
.sp
-\fBswitch\fI \fR?\fIoptions\fR?\fI string \fR{\fIpattern body \fR?\fIpattern body \fR...?}
+\fBswitch \fR?\fIoptions\fR?\fI string \fR{\fIpattern body \fR?\fIpattern body \fR...?}
.BE
.SH DESCRIPTION
diff --git a/contrib/tcl/doc/tclvars.n b/contrib/tcl/doc/tclvars.n
index 9a7fa6ca2b34..b689a4fff26f 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.33 97/08/13 17:50:20
+'\" SCCS: @(#) tclvars.n 1.34 97/08/22 18:51:04
'\"
.so man.macros
.TH tclvars n 8.0 Tcl "Tcl Built-In Commands"
@@ -37,12 +37,14 @@ If the entire \fBenv\fR array is unset then Tcl will stop
monitoring \fBenv\fR accesses and will not update environment
variables.
.RS
-Under Windows, the environment variables PATH, COMSPEC, and WINDIR in any
+.VS 8.0
+Under Windows, the environment variables PATH and COMSPEC in any
capitalization are converted automatically to upper case. For instance, the
PATH variable could be exported by the operating system as ``path'',
``Path'', ``PaTh'', etc., causing otherwise simple Tcl code to have to
support many special cases. All other environment variables inherited by
Tcl are left unmodified.
+.VE
.RE
.RS
On the Macintosh, the environment variable is constructed by Tcl as no
@@ -213,7 +215,7 @@ hold a string giving the current patch level for Tcl, such as
\fB7.4b4\fR for the fourth beta release of Tcl 7.4.
The value of this variable is returned by the \fBinfo patchlevel\fR
command.
-.VS br
+.VS 8.0 br
.TP
\fBtcl_pkgPath\fR
This variable holds a list of directories indicating where packages are
diff --git a/contrib/tcl/doc/vwait.n b/contrib/tcl/doc/vwait.n
index 868f5dc064f0..4780b722dd3b 100644
--- a/contrib/tcl/doc/vwait.n
+++ b/contrib/tcl/doc/vwait.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: @(#) vwait.n 1.3 96/03/25 20:27:21
+'\" SCCS: @(#) vwait.n 1.4 97/09/29 11:31:18
'\"
.so man.macros
.TH vwait n 7.5 Tcl "Tcl Built-In Commands"
@@ -13,7 +13,7 @@
.SH NAME
vwait \- Process events until a variable is written
.SH SYNOPSIS
-\fBvwait\fR ?\fIvarName\fR?
+\fBvwait\fR \fIvarName\fR
.BE
.SH DESCRIPTION
diff --git a/contrib/tcl/generic/tcl.h b/contrib/tcl/generic/tcl.h
index 2d773da703ab..0a80e52d53b2 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.324 97/08/07 10:26:49
+ * SCCS: @(#) tcl.h 1.326 97/11/20 12:40:43
*/
#ifndef _TCL
@@ -38,10 +38,10 @@
#define TCL_MAJOR_VERSION 8
#define TCL_MINOR_VERSION 0
#define TCL_RELEASE_LEVEL 2
-#define TCL_RELEASE_SERIAL 0
+#define TCL_RELEASE_SERIAL 2
#define TCL_VERSION "8.0"
-#define TCL_PATCH_LEVEL "8.0"
+#define TCL_PATCH_LEVEL "8.0p2"
/*
* The following definitions set up the proper options for Windows
diff --git a/contrib/tcl/generic/tclBinary.c b/contrib/tcl/generic/tclBinary.c
index c20d03dcd88d..e15fe4c7f51b 100644
--- a/contrib/tcl/generic/tclBinary.c
+++ b/contrib/tcl/generic/tclBinary.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: @(#) tclBinary.c 1.20 97/08/11 18:43:09
+ * SCCS: @(#) tclBinary.c 1.26 97/11/05 13:02:05
*/
#include <math.h>
@@ -867,13 +867,20 @@ FormatNumber(interp, type, src, cursorPtr)
char cmd = (char)type;
if (cmd == 'd' || cmd == 'f') {
+ /*
+ * For floating point types, we need to copy the data using
+ * memcpy to avoid alignment issues.
+ */
+
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
return TCL_ERROR;
}
if (cmd == 'd') {
- *((double *)(*cursorPtr)) = dvalue;
+ memcpy((*cursorPtr), &dvalue, sizeof(double));
(*cursorPtr) += sizeof(double);
} else {
+ float fvalue;
+
/*
* Because some compilers will generate floating point exceptions
* on an overflow cast (e.g. Borland), we restrict the values
@@ -881,13 +888,11 @@ FormatNumber(interp, type, src, cursorPtr)
*/
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;
+ fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
} else {
- *((float *)(*cursorPtr)) = (float) dvalue;
+ fvalue = (float) dvalue;
}
+ memcpy((*cursorPtr), &fvalue, sizeof(float));
(*cursorPtr) += sizeof(float);
}
} else {
@@ -938,44 +943,71 @@ FormatNumber(interp, type, src, cursorPtr)
static Tcl_Obj *
ScanNumber(buffer, type)
char *buffer; /* Buffer to scan number from. */
- int type; /* Type of number to scan. */
+ int type; /* Format character from "binary scan" */
{
- int c;
+ int value;
+
+ /*
+ * We cannot rely on the compiler to properly sign extend integer values
+ * when we cast from smaller values to larger values because we don't know
+ * the exact size of the integer types. So, we have to handle sign
+ * extension explicitly by checking the high bit and padding with 1's as
+ * needed.
+ */
switch ((char) type) {
case 'c':
- /*
- * Characters need special handling. We want to produce a
- * signed result, but on some platforms (such as AIX) chars
- * are unsigned. To deal with this, check for a value that
- * should be negative but isn't.
- */
+ value = buffer[0];
- c = buffer[0];
- if (c > 127) {
- c -= 256;
+ if (value & 0x80) {
+ value |= -0x100;
}
- return Tcl_NewIntObj(c);
+ return Tcl_NewLongObj((long)value);
case 's':
- return Tcl_NewIntObj((short)(((unsigned char)buffer[0])
- + ((unsigned char)buffer[1] << 8)));
+ value = (((unsigned char)buffer[0])
+ + ((unsigned char)buffer[1] << 8));
+ goto shortValue;
case 'S':
- return Tcl_NewIntObj((short)(((unsigned char)buffer[1])
- + ((unsigned char)buffer[0] << 8)));
+ value = (((unsigned char)buffer[1])
+ + ((unsigned char)buffer[0] << 8));
+ shortValue:
+ if (value & 0x8000) {
+ value |= -0x10000;
+ }
+ return Tcl_NewLongObj((long)value);
case 'i':
- return Tcl_NewIntObj((long) (((unsigned char)buffer[0])
+ value = (((unsigned char)buffer[0])
+ ((unsigned char)buffer[1] << 8)
+ ((unsigned char)buffer[2] << 16)
- + ((unsigned char)buffer[3] << 24)));
+ + ((unsigned char)buffer[3] << 24));
+ goto intValue;
case 'I':
- return Tcl_NewIntObj((long) (((unsigned char)buffer[3])
+ value = (((unsigned char)buffer[3])
+ ((unsigned char)buffer[2] << 8)
+ ((unsigned char)buffer[1] << 16)
- + ((unsigned char)buffer[0] << 24)));
- case 'f':
- return Tcl_NewDoubleObj(*(float*)buffer);
- case 'd':
- return Tcl_NewDoubleObj(*(double*)buffer);
+ + ((unsigned char)buffer[0] << 24));
+ intValue:
+ /*
+ * Check to see if the value was sign extended properly on
+ * systems where an int is more than 32-bits.
+ */
+
+ if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
+ value -= (((unsigned int)1)<<31);
+ value -= (((unsigned int)1)<<31);
+ }
+
+ return Tcl_NewLongObj((long)value);
+ case 'f': {
+ float fvalue;
+ memcpy(&fvalue, buffer, sizeof(float));
+ return Tcl_NewDoubleObj(fvalue);
+ }
+ case 'd': {
+ double dvalue;
+ memcpy(&dvalue, buffer, sizeof(double));
+ return Tcl_NewDoubleObj(dvalue);
+ }
}
return NULL;
}
diff --git a/contrib/tcl/generic/tclCmdAH.c b/contrib/tcl/generic/tclCmdAH.c
index 79968d343c5a..4c5fd0ab6ef2 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.156 97/08/12 18:10:15
+ * SCCS: @(#) tclCmdAH.c 1.159 97/10/31 13:06:07
*/
#include "tclInt.h"
@@ -590,6 +590,7 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv)
Tcl_SetObjResult(interp, resultPtr);
Tcl_DecrRefCount(resultPtr); /* done with the result object */
}
+ return result;
}
/*
@@ -1670,7 +1671,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
# define MAX_FLOAT_SIZE 320
Tcl_Obj *resultPtr; /* Where result is stored finally. */
- char staticBuf[MAX_FLOAT_SIZE];
+ char staticBuf[MAX_FLOAT_SIZE + 1];
/* A static buffer to copy the format results
* into */
char *dst = staticBuf; /* The buffer that sprintf writes into each
diff --git a/contrib/tcl/generic/tclCmdIL.c b/contrib/tcl/generic/tclCmdIL.c
index 6503d351b5ac..44e4270c167e 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.168 97/07/29 12:52:40
+ * SCCS: @(#) tclCmdIL.c 1.173 97/11/18 13:55:01
*/
#include "tclInt.h"
@@ -987,13 +987,21 @@ InfoHostnameCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
+ char *name;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
- Tcl_SetStringObj(Tcl_GetObjResult(interp), Tcl_GetHostName(), -1);
- return TCL_OK;
+ name = Tcl_GetHostName();
+ if (name) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1);
+ return TCL_OK;
+ } else {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp),
+ "unable to determine name of host", -1);
+ return TCL_ERROR;
+ }
}
/*
@@ -1748,6 +1756,7 @@ Tcl_JoinObjCmd(dummy, interp, objc, objv)
char *joinString, *bytes;
int joinLength, listLen, length, i, result;
Tcl_Obj **elemPtrs;
+ Tcl_Obj *resObjPtr;
if (objc == 2) {
joinString = " ";
@@ -1774,14 +1783,14 @@ Tcl_JoinObjCmd(dummy, interp, objc, objv)
* directly into the interpreter's result object.
*/
+ resObjPtr = Tcl_GetObjResult(interp);
+
for (i = 0; i < listLen; i++) {
bytes = Tcl_GetStringFromObj(elemPtrs[i], &length);
if (i > 0) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), joinString,
- bytes, (char *) NULL);
- } else {
- Tcl_AppendToObj(Tcl_GetObjResult(interp), bytes, length);
+ Tcl_AppendToObj(resObjPtr, joinString, joinLength);
}
+ Tcl_AppendToObj(resObjPtr, bytes, length);
}
return TCL_OK;
}
@@ -1895,8 +1904,8 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Obj *listPtr, *resultPtr;
- int index, isDuplicate;
- int result;
+ Tcl_ObjType *typePtr;
+ int index, isDuplicate, len, result;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?");
@@ -1923,16 +1932,29 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv)
listPtr = objv[1];
isDuplicate = 0;
if (Tcl_IsShared(listPtr)) {
+ /*
+ * The following code must reflect the logic in Tcl_DuplicateObj()
+ * except that it must duplicate the list object directly into the
+ * interpreter's result.
+ */
+
Tcl_ResetResult(interp);
resultPtr = Tcl_GetObjResult(interp);
- if (listPtr->typePtr != NULL) {
- Tcl_InvalidateStringRep(resultPtr);
- listPtr->typePtr->dupIntRepProc(listPtr, resultPtr);
- } else if (listPtr->bytes != NULL) {
- int len = listPtr->length;
-
+ typePtr = listPtr->typePtr;
+ if (listPtr->bytes == NULL) {
+ resultPtr->bytes = NULL;
+ } else if (listPtr->bytes != tclEmptyStringRep) {
+ len = listPtr->length;
TclInitStringRep(resultPtr, listPtr->bytes, len);
}
+ if (typePtr != NULL) {
+ if (typePtr->dupIntRepProc == NULL) {
+ resultPtr->internalRep = listPtr->internalRep;
+ resultPtr->typePtr = typePtr;
+ } else {
+ (*typePtr->dupIntRepProc)(listPtr, resultPtr);
+ }
+ }
listPtr = resultPtr;
isDuplicate = 1;
}
@@ -2164,7 +2186,9 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Tcl_Obj *listPtr;
- int createdNewObj, first, last, listLen, numToDelete, result;
+ int createdNewObj, first, last, listLen, numToDelete;
+ int firstArgLen, result;
+ char *firstArg;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -2201,6 +2225,7 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
if (result != TCL_OK) {
goto errorReturn;
}
+ firstArg = Tcl_GetStringFromObj(objv[2], &firstArgLen);
result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
&last);
@@ -2211,7 +2236,8 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
if (first < 0) {
first = 0;
}
- if (first >= listLen) {
+ if ((first >= listLen) && (listLen > 0)
+ && (strncmp(firstArg, "end", (unsigned) firstArgLen) != 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"list doesn't contain element ",
Tcl_GetStringFromObj(objv[2], (int *) NULL), (int *) NULL);
@@ -2821,11 +2847,11 @@ DictionaryCompare(left, right)
*/
zeros = 0;
- while (*right == '0') {
+ while ((*right == '0') && (*(right + 1) != '\0')) {
right++;
zeros--;
}
- while (*left == '0') {
+ while ((*left == '0') && (*(left + 1) != '\0')) {
left++;
zeros++;
}
diff --git a/contrib/tcl/generic/tclCmdMZ.c b/contrib/tcl/generic/tclCmdMZ.c
index 9ab2c826a656..4dc272f64778 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.102 97/08/13 10:06:58
+ * SCCS: @(#) tclCmdMZ.c 1.104 97/10/31 13:06:19
*/
#include "tclInt.h"
@@ -1054,7 +1054,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int index, first, left, right;
+ int index, left, right;
Tcl_Obj *resultPtr;
char *string1, *string2;
int length1, length2;
@@ -1103,8 +1103,37 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
break;
}
case STR_FIRST: {
- first = 1;
- goto firstlast;
+ register char *p, *end;
+ int match;
+
+ if (objc != 4) {
+ badFirstLastArgs:
+ Tcl_WrongNumArgs(interp, 2, objv, "string1 string2");
+ return TCL_ERROR;
+ }
+
+ match = -1;
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ string2 = Tcl_GetStringFromObj(objv[3], &length2);
+ if (length1 > 0) {
+ end = string2 + length2 - length1 + 1;
+ for (p = string2; p < end; p++) {
+ /*
+ * Scan forward to find the first character.
+ */
+
+ p = memchr(p, *string1, (unsigned) (end - p));
+ if (p == NULL) {
+ break;
+ }
+ if (memcmp(string1, p, (unsigned) length1) == 0) {
+ match = p - string2;
+ break;
+ }
+ }
+ }
+ Tcl_SetIntObj(resultPtr, match);
+ break;
}
case STR_INDEX: {
int index;
@@ -1124,28 +1153,28 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
break;
}
case STR_LAST: {
- char *p, *end;
+ register char *p;
int match;
- first = 0;
-
- firstlast:
if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "string1 string2");
- return TCL_ERROR;
+ goto badFirstLastArgs;
}
match = -1;
string1 = Tcl_GetStringFromObj(objv[2], &length1);
string2 = Tcl_GetStringFromObj(objv[3], &length2);
if (length1 > 0) {
- end = string2 + length2 - length1 + 1;
- for (p = string2; p < end; p++) {
+ for (p = string2 + length2 - length1; p >= string2; p--) {
+ /*
+ * Scan backwards to find the first character.
+ */
+
+ while ((p != string2) && (*p != *string1)) {
+ p--;
+ }
if (memcmp(string1, p, (unsigned) length1) == 0) {
match = p - string2;
- if (first) {
- break;
- }
+ break;
}
}
}
@@ -1202,7 +1231,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
break;
}
case STR_TOLOWER: {
- char *p, *end;
+ register char *p, *end;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "string");
@@ -1228,7 +1257,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
break;
}
case STR_TOUPPER: {
- char *p, *end;
+ register char *p, *end;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "string");
@@ -1255,7 +1284,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
}
case STR_TRIM: {
char ch;
- char *p, *end, *check, *checkEnd;
+ register char *p, *end;
+ char *check, *checkEnd;
left = 1;
right = 1;
@@ -1563,9 +1593,12 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
switchObjc = objc-1;
switchObjv = objv+1;
mode = EXACT;
-
- string = Tcl_GetStringFromObj(switchObjv[0], &length);
- while ((switchObjc > 0) && (*string == '-')) {
+
+ while (switchObjc > 0) {
+ string = Tcl_GetStringFromObj(switchObjv[0], &length);
+ if (*string != '-') {
+ break;
+ }
if (Tcl_GetIndexFromObj(interp, switchObjv[0], switches,
"option", 0, &index) != TCL_OK) {
return TCL_ERROR;
@@ -1587,7 +1620,6 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
}
switchObjc--;
switchObjv++;
- string = Tcl_GetStringFromObj(switchObjv[0], &length);
}
doneWithSwitches:
diff --git a/contrib/tcl/generic/tclCompExpr.c b/contrib/tcl/generic/tclCompExpr.c
index 74b12c171e6f..6bae02b063e6 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.31 97/08/07 10:14:07
+ * SCCS: @(#) tclCompExpr.c 1.34 97/11/03 14:29:18
*/
#include "tclInt.h"
@@ -1596,7 +1596,7 @@ CompilePrimaryExpr(interp, infoPtr, flags, envPtr)
HERE("primaryExpr", 13);
theToken = infoPtr->token;
- if (theToken != DOLLAR) {
+ if ((theToken != DOLLAR) && (theToken != OPEN_PAREN)) {
infoPtr->exprIsJustVarRef = 0;
}
switch (theToken) {
@@ -1995,27 +1995,28 @@ GetToken(interp, infoPtr, envPtr)
(char *) NULL);
return TCL_ERROR;
}
-
- /*
- * Find/create an object in envPtr's object array that contains
- * the integer.
- */
-
- savedChar = *termPtr;
- *termPtr = '\0';
- objIndex = TclObjIndexForString(src, termPtr - src,
- /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr);
- *termPtr = savedChar; /* restore the saved char */
-
- objPtr = envPtr->objArrayPtr[objIndex];
- Tcl_InvalidateStringRep(objPtr);
- objPtr->internalRep.longValue = longValue;
- objPtr->typePtr = &tclIntType;
+ if (termPtr != src) {
+ /*
+ * src was the start of a valid integer. Find/create an
+ * object in envPtr's object array to contain the integer.
+ */
- infoPtr->token = LITERAL;
- infoPtr->objIndex = objIndex;
- infoPtr->next = termPtr;
- return TCL_OK;
+ savedChar = *termPtr;
+ *termPtr = '\0';
+ objIndex = TclObjIndexForString(src, termPtr - src,
+ /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr);
+ *termPtr = savedChar; /* restore the saved char */
+
+ objPtr = envPtr->objArrayPtr[objIndex];
+ Tcl_InvalidateStringRep(objPtr);
+ objPtr->internalRep.longValue = longValue;
+ objPtr->typePtr = &tclIntType;
+
+ infoPtr->token = LITERAL;
+ infoPtr->objIndex = objIndex;
+ infoPtr->next = termPtr;
+ return TCL_OK;
+ }
} else if (startsWithDigit || (*src == '.')
|| (*src == 'n') || (*src == 'N')) {
errno = 0;
@@ -2057,7 +2058,8 @@ GetToken(interp, infoPtr, envPtr)
if (*src == '{') {
int level = 0; /* The {} nesting level. */
int hasBackslashNL = 0; /* Nonzero if '\newline' was found. */
- char *string = src+1; /* Points just after the starting '{'. */
+ char *string = src; /* Set below to point just after the
+ * starting '{'. */
char *last; /* Points just before terminating '}'. */
int numChars; /* Number of chars in braced string. */
char savedChar; /* Holds the character from string
@@ -2069,7 +2071,7 @@ GetToken(interp, infoPtr, envPtr)
* Check first for any backslash-newlines, since we must treat
* backslash-newlines specially (they must be replaced by spaces).
*/
-
+
while (1) {
if (src == infoPtr->lastChar) {
Tcl_ResetResult(interp);
@@ -2099,13 +2101,14 @@ GetToken(interp, infoPtr, envPtr)
}
/*
- * Create a string object for the braced string. This starts at
+ * Create a string object for the braced string. This will start at
* "string" and ends just after "last" (which points to the final
* character before the terminating '}'). If backslash-newlines were
* found, we copy characters one at a time into a heap-allocated
* buffer and do backslash-newline substitutions.
*/
-
+
+ string++;
numChars = (last - string + 1);
savedChar = string[numChars];
string[numChars] = '\0';
diff --git a/contrib/tcl/generic/tclCompile.c b/contrib/tcl/generic/tclCompile.c
index d4fad0c74c7d..3291b3d5d2a6 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.76 97/08/12 13:35:43
+ * SCCS: @(#) tclCompile.c 1.80 97/09/18 18:23:30
*/
#include "tclInt.h"
@@ -727,7 +727,7 @@ TclPrintInstruction(codePtr, pc)
if ((i == 0) && ((opCode == INST_JUMP1)
|| (opCode == INST_JUMP_TRUE1)
|| (opCode == INST_JUMP_FALSE1))) {
- fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
+ fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
} else {
fprintf(stdout, "%d", opnd);
}
@@ -737,7 +737,7 @@ TclPrintInstruction(codePtr, pc)
if ((i == 0) && ((opCode == INST_JUMP4)
|| (opCode == INST_JUMP_TRUE4)
|| (opCode == INST_JUMP_FALSE4))) {
- fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
+ fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
} else {
fprintf(stdout, "%d", opnd);
}
@@ -979,18 +979,16 @@ TclCleanupByteCode(codePtr)
*
* DupByteCodeInternalRep --
*
- * Part of the bytecode Tcl object type implementation. Initializes the
- * internal representation of a bytecode Tcl_Obj to a copy of the
- * internal representation of an existing bytecode object.
+ * Part of the bytecode Tcl object type implementation. However, it
+ * does not copy the internal representation of a bytecode Tcl_Obj, but
+ * instead leaves the new object untyped (with a NULL type pointer).
+ * Code will be compiled for the new object only if necessary.
*
* Results:
* None.
*
* Side effects:
- * "copyPtr"s internal rep is set to the bytecode sequence
- * corresponding to "srcPtr"s internal rep. Ref counts for objects
- * in the existing bytecode object's object array are incremented
- * the bytecode copy now also refers to them.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -1000,90 +998,7 @@ DupByteCodeInternalRep(srcPtr, copyPtr)
Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
Tcl_Obj *copyPtr; /* Object with internal rep to set. */
{
- ByteCode *codePtr = (ByteCode *) srcPtr->internalRep.otherValuePtr;
- register ByteCode *dupPtr;
- register AuxData *srcAuxDataPtr, *dupAuxDataPtr;
- size_t objArrayBytes, exceptArrayBytes, cmdLocBytes, auxDataBytes;
- register size_t size;
- register char *p;
- 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.
- */
-
- 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 += sizeof(ByteCode);
- dupPtr->codeStart = (unsigned char *) p;
-
- p += TCL_ALIGN(codeBytes); /* object array is aligned */
- dupPtr->objArrayPtr = (Tcl_Obj **) p;
-
- p += TCL_ALIGN(objArrayBytes); /* exception range array is aligned */
- dupPtr->excRangeArrayPtr = (ExceptionRange *) p;
-
- 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
- * creating new references for them in the copied object array.
- */
-
- for (i = 0; i < numObjects; i++) {
- Tcl_IncrRefCount(dupPtr->objArrayPtr[i]);
- }
-
- /*
- * Duplicate any auxiliary data items.
- */
-
- srcAuxDataPtr = codePtr->auxDataArrayPtr;
- dupAuxDataPtr = dupPtr->auxDataArrayPtr;
- for (i = 0; i < codePtr->numAuxDataItems; i++) {
- if (srcAuxDataPtr->dupProc != NULL) {
- dupAuxDataPtr->clientData =
- srcAuxDataPtr->dupProc(srcAuxDataPtr->clientData);
- } else {
- dupAuxDataPtr->clientData = srcAuxDataPtr->clientData;
- }
- srcAuxDataPtr++;
- dupAuxDataPtr++;
- }
-
- copyPtr->internalRep.otherValuePtr = (VOID *) dupPtr;
- copyPtr->typePtr = &tclByteCodeType;
-
-#ifdef TCL_COMPILE_STATS
- tclCurrentSourceBytes += (double) codePtr->numSrcChars;
- tclCurrentCodeBytes += (double) codePtr->totalSize;
-#endif /* TCL_COMPILE_STATS */
+ return;
}
/*
@@ -1431,6 +1346,7 @@ TclInitByteCodeObj(objPtr, envPtr)
codePtr->numObjects = numObjects;
codePtr->numExcRanges = envPtr->excRangeArrayNext;
codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
+ codePtr->auxDataArrayPtr = NULL;
codePtr->numCmdLocBytes = cmdLocBytes;
codePtr->maxExcRangeDepth = envPtr->maxExcRangeDepth;
codePtr->maxStackDepth = envPtr->maxStackDepth;
@@ -1724,13 +1640,14 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
* warning. */
int cmdIndex; /* The index of the current command in the
* compilation environment's command
- * location table. Initialized to avoid
- * compiler warning. */
+ * location table. */
+ int lastTopLevelCmdIndex = -1;
+ /* Index of most recent toplevel command in
+ * the command location table. Initialized
+ * to avoid compiler warning. */
int cmdCodeOffset = -1; /* Offset of first byte of current command's
* code. Initialized to avoid compiler
* warning. */
- int cmdCodeBytes; /* Number of code bytes for current
- * command. */
int cmdWords; /* Number of words in current command. */
Tcl_Command cmd; /* Used to search for commands. */
Command *cmdPtr; /* Points to command's Command structure if
@@ -1827,14 +1744,11 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
/*
* We are compiling a top level command. Update the number
* of code bytes for the last command to account for the pop
- * instruction we just emitted.
+ * instruction.
*/
- int lastCmdIndex = (envPtr->numCommands - 1);
- cmdCodeBytes =
- (envPtr->codeNext - envPtr->codeStart - cmdCodeOffset);
- (envPtr->cmdMapPtr[lastCmdIndex]).numCodeBytes =
- cmdCodeBytes;
+ (envPtr->cmdMapPtr[lastTopLevelCmdIndex]).numCodeBytes =
+ (envPtr->codeNext-envPtr->codeStart) - cmdCodeOffset;
}
}
@@ -1848,14 +1762,17 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
* starting source and object information for the command.
*/
+ envPtr->numCommands++;
+ cmdIndex = (envPtr->numCommands - 1);
+ if (!(flags & TCL_BRACKET_TERM)) {
+ lastTopLevelCmdIndex = cmdIndex;
+ }
+
cmdSrcStart = src;
cmdCodeOffset = (envPtr->codeNext - envPtr->codeStart);
cmdWords = 0;
-
- envPtr->numCommands++;
- cmdIndex = (envPtr->numCommands - 1);
- EnterCmdStartData(envPtr, cmdIndex,
- (cmdSrcStart - envPtr->source), cmdCodeOffset);
+ EnterCmdStartData(envPtr, cmdIndex, src-envPtr->source,
+ cmdCodeOffset);
if ((!(flags & TCL_BRACKET_TERM))
&& (tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
@@ -2131,8 +2048,8 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
*/
finishCommand:
- cmdCodeBytes = envPtr->codeNext - envPtr->codeStart - cmdCodeOffset;
- EnterCmdExtentData(envPtr, cmdIndex, src-cmdSrcStart, cmdCodeBytes);
+ EnterCmdExtentData(envPtr, cmdIndex, src-cmdSrcStart,
+ (envPtr->codeNext-envPtr->codeStart) - cmdCodeOffset);
isFirstCmd = 0;
envPtr->termOffset = (src - string);
diff --git a/contrib/tcl/generic/tclEnv.c b/contrib/tcl/generic/tclEnv.c
index 8027f5ed76d2..8b46bb2289fc 100644
--- a/contrib/tcl/generic/tclEnv.c
+++ b/contrib/tcl/generic/tclEnv.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: @(#) tclEnv.c 1.49 97/08/11 20:22:40
+ * SCCS: @(#) tclEnv.c 1.54 97/10/27 17:47:52
*/
#include "tclInt.h"
@@ -244,15 +244,6 @@ TclSetEnv(name, value)
/*
- * 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.
*/
@@ -276,6 +267,16 @@ TclSetEnv(name, value)
*/
ReplaceString(oldValue, p);
+
+ /*
+ * 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);
+ }
+
}
/*
@@ -597,11 +598,15 @@ ReplaceString(oldStr, newStr)
environCache[cacheSize-1] = NULL;
}
} else {
+ int allocatedSize = (cacheSize + 5) * sizeof(char *);
+
/*
* We need to grow the cache in order to hold the new string.
*/
- newCache = (char **) ckalloc((cacheSize + 5) * sizeof(char *));
+ newCache = (char **) ckalloc((size_t) allocatedSize);
+ (VOID *) memset(newCache, (int) 0, (size_t) allocatedSize);
+
if (environCache) {
memcpy((VOID *) newCache, (VOID *) environCache,
(size_t) (cacheSize * sizeof(char*)));
@@ -690,5 +695,9 @@ TclFinalizeEnvironment()
if (environCache) {
ckfree((char *) environCache);
environCache = NULL;
+ cacheSize = 0;
+#ifndef USE_PUTENV
+ environSize = 0;
+#endif
}
}
diff --git a/contrib/tcl/generic/tclExecute.c b/contrib/tcl/generic/tclExecute.c
index 4c1243793093..c6cea084a90f 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.95 97/08/12 17:06:49
+ * SCCS: @(#) tclExecute.c 1.102 97/11/06 11:36:35
*/
#include "tclInt.h"
@@ -96,7 +96,7 @@ static char *opName[256];
*/
static char *operatorStrings[] = {
- "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
+ "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
"+", "-", "*", "/", "%", "+", "-", "~", "!",
"BUILTIN FUNCTION", "FUNCTION"
};
@@ -292,6 +292,8 @@ static void IllegalExprOperandType _ANSI_ARGS_((
static void InitByteCodeExecution _ANSI_ARGS_((
Tcl_Interp *interp));
static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
+static void RecordTracebackInfo _ANSI_ARGS_((Tcl_Interp *interp,
+ unsigned char *pc, ByteCode *codePtr));
static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
#ifdef TCL_COMPILE_DEBUG
@@ -809,7 +811,6 @@ TclExecuteByteCode(interp, codePtr)
/* Instruction offset computed during
* break, continue, error processing.
* Init. to avoid compiler warning. */
- Trace *tracePtr;
Tcl_Command cmd;
#ifdef TCL_COMPILE_DEBUG
int isUnknownCmd = 0;
@@ -884,17 +885,23 @@ TclExecuteByteCode(interp, codePtr)
/*
* Call any trace procedures.
*/
-
- for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
- tracePtr = tracePtr->nextPtr) {
- if (iPtr->numLevels <= tracePtr->level) {
- int numChars;
- char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
- if (cmd != NULL) {
- DECACHE_STACK_INFO();
- CallTraceProcedure(interp, tracePtr, cmdPtr,
- cmd, numChars, objc, objv);
- CACHE_STACK_INFO();
+
+ if (iPtr->tracePtr != NULL) {
+ Trace *tracePtr, *nextTracePtr;
+
+ for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
+ tracePtr = nextTracePtr) {
+ nextTracePtr = tracePtr->nextPtr;
+ if (iPtr->numLevels <= tracePtr->level) {
+ int numChars;
+ char *cmd = GetSrcInfoForPc(pc, codePtr,
+ &numChars);
+ if (cmd != NULL) {
+ DECACHE_STACK_INFO();
+ CallTraceProcedure(interp, tracePtr, cmdPtr,
+ cmd, numChars, objc, objv);
+ CACHE_STACK_INFO();
+ }
}
}
}
@@ -1764,12 +1771,12 @@ TclExecuteByteCode(interp, codePtr)
case INST_LAND:
{
/*
- * Operands must be numeric, but no int->double conversions
- * are performed.
+ * Operands must be boolean or numeric. No int->double
+ * conversions are performed.
*/
- long i2, iResult;
- double d1;
+ int i1, i2;
+ int iResult;
char *s;
Tcl_ObjType *t1Ptr, *t2Ptr;
@@ -1778,20 +1785,20 @@ TclExecuteByteCode(interp, codePtr)
t1Ptr = valuePtr->typePtr;
t2Ptr = value2Ptr->typePtr;
- if (t1Ptr == &tclIntType) {
- i = (valuePtr->internalRep.longValue != 0);
+ if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
+ i1 = (valuePtr->internalRep.longValue != 0);
} else if (t1Ptr == &tclDoubleType) {
- i = (valuePtr->internalRep.doubleValue != 0.0);
+ i1 = (valuePtr->internalRep.doubleValue != 0.0);
} else { /* FAILS IF NULL STRING REP */
s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
if (TclLooksLikeInt(s)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
- i = (i != 0);
+ i1 = (i != 0);
} else {
- result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
- valuePtr, &d1);
- i = (d1 != 0.0);
+ result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
+ valuePtr, &i1);
+ i1 = (i1 != 0);
}
if (result != TCL_OK) {
TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",
@@ -1804,7 +1811,7 @@ TclExecuteByteCode(interp, codePtr)
}
}
- if (t2Ptr == &tclIntType) {
+ if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
i2 = (value2Ptr->internalRep.longValue != 0);
} else if (t2Ptr == &tclDoubleType) {
i2 = (value2Ptr->internalRep.doubleValue != 0.0);
@@ -1812,12 +1819,12 @@ TclExecuteByteCode(interp, codePtr)
s = Tcl_GetStringFromObj(value2Ptr, (int *) NULL);
if (TclLooksLikeInt(s)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
+ value2Ptr, &i);
+ i2 = (i != 0);
+ } else {
+ result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
value2Ptr, &i2);
i2 = (i2 != 0);
- } else {
- result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
- value2Ptr, &d1);
- i2 = (d1 != 0.0);
}
if (result != TCL_OK) {
TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",
@@ -1835,17 +1842,17 @@ TclExecuteByteCode(interp, codePtr)
*/
if (opCode == INST_LOR) {
- iResult = (i || i2);
+ iResult = (i1 || i2);
} else {
- iResult = (i && i2);
+ iResult = (i1 && i2);
}
if (Tcl_IsShared(valuePtr)) {
PUSH_OBJECT(Tcl_NewLongObj(iResult));
- TRACE(("%s %.20s %.20s => %ld\n", opName[opCode],
+ TRACE(("%s %.20s %.20s => %d\n", opName[opCode],
O2S(valuePtr), O2S(value2Ptr), iResult));
TclDecrRefCount(valuePtr);
} else { /* reuse the valuePtr object */
- TRACE(("%s %.20s %.20s => %ld\n",
+ TRACE(("%s %.20s %.20s => %d\n",
opName[opCode], /* NB: stack top is off by 1 */
O2S(valuePtr), O2S(value2Ptr), iResult));
Tcl_SetLongObj(valuePtr, iResult);
@@ -2915,45 +2922,8 @@ TclExecuteByteCode(interp, codePtr)
checkForCatch:
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
- int numChars;
- char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
- char buf[200];
- register char *p;
- char *ellipsis = "";
-
- /*
- * Print the command in the error message (up to a certain
- * number of characters, or up to the first newline).
- */
-
- 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, cmd, ellipsis);
- } else {
- sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
- numChars, cmd, ellipsis);
- }
- Tcl_AddObjErrorInfo(interp, buf, -1);
- iPtr->flags |= ERR_ALREADY_LOGGED;
- }
- }
+ RecordTracebackInfo(interp, pc, codePtr);
+ }
rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 1, codePtr);
if (rangePtr == NULL) {
TRACE((" ... no enclosing catch, returning %s\n",
@@ -3172,12 +3142,12 @@ IllegalExprOperandType(interp, opCode, opndPtr)
if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't use empty string as operand of \"",
- operatorStrings[opCode - INST_BITOR], "\"", (char *) NULL);
+ operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
} else {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "can't use ", ((opndPtr->typePtr == &tclDoubleType) ?
- "floating-point value" : "non-numeric string"),
- " as operand of \"", operatorStrings[opCode - INST_BITOR],
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
+ ((opndPtr->typePtr == &tclDoubleType) ?
+ "floating-point value" : "non-numeric string"),
+ " as operand of \"", operatorStrings[opCode - INST_LOR],
"\"", (char *) NULL);
}
}
@@ -3254,6 +3224,76 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
/*
*----------------------------------------------------------------------
*
+ * RecordTracebackInfo --
+ *
+ * Procedure called by TclExecuteByteCode to record information
+ * about what was being executed when the error occurred.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Appends information about the command being executed to the
+ * "errorInfo" variable. Sets the errorLine field in the interpreter
+ * to the line number of that command. Sets the ERR_ALREADY_LOGGED
+ * bit in the interpreter's execution flags.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+RecordTracebackInfo(interp, pc, codePtr)
+ Tcl_Interp *interp; /* The interpreter in which the error
+ * occurred. */
+ unsigned char *pc; /* The program counter value where the error * occurred. This points to a bytecode
+ * instruction in codePtr's code. */
+ ByteCode *codePtr; /* The bytecode sequence being executed. */
+{
+ register Interp *iPtr = (Interp *) interp;
+ char *cmd, *ellipsis;
+ char buf[200];
+ register char *p;
+ int numChars;
+
+ /*
+ * Record the command in errorInfo (up to a certain number of
+ * characters, or up to the first newline).
+ */
+
+ iPtr->errorLine = 1;
+ cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
+ 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++;
+ }
+ }
+
+ ellipsis = "";
+ if (numChars > 150) {
+ numChars = 150;
+ ellipsis = "...";
+ }
+ if (!(iPtr->flags & ERR_IN_PROGRESS)) {
+ sprintf(buf, "\n while executing\n\"%.*s%s\"",
+ numChars, cmd, ellipsis);
+ } else {
+ sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
+ numChars, cmd, ellipsis);
+ }
+ Tcl_AddObjErrorInfo(interp, buf, -1);
+ iPtr->flags |= ERR_ALREADY_LOGGED;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* GetSrcInfoForPc --
*
* Given a program counter value, finds the closest command in the
@@ -3281,7 +3321,7 @@ GetSrcInfoForPc(pc, codePtr, lengthPtr)
* 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
+ 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
@@ -3948,6 +3988,16 @@ ExprRandFunc(interp, eePtr, clientData)
if (iPtr->randSeed < 0) {
iPtr->randSeed += RAND_IM;
}
+
+ /*
+ * On 64-bit architectures we need to mask off the upper bits to
+ * ensure we only have a 32-bit range. The constant has the
+ * bizarre form below in order to make sure that it doesn't
+ * get sign-extended (the rules for sign extension are very
+ * concat, particularly on 64-bit machines).
+ */
+
+ iPtr->randSeed &= ((((unsigned long) 0xfffffff) << 4) | 0xf);
dResult = iPtr->randSeed * (1.0/RAND_IM);
/*
diff --git a/contrib/tcl/generic/tclFileName.c b/contrib/tcl/generic/tclFileName.c
index 69d825cdac41..2024b61ce350 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.31 97/08/05 15:23:04
+ * SCCS: @(#) tclFileName.c 1.32 97/08/19 18:44:03
*/
#include "tclInt.h"
@@ -1229,7 +1229,16 @@ Tcl_GlobCmd(dummy, interp, argc, argv)
result = TclDoGlob(interp, separators, &buffer, tail);
if (result != TCL_OK) {
if (noComplain) {
+ /*
+ * We should in fact pass down the nocomplain flag
+ * or save the interp result or use another mecanism
+ * so the interp result is not mangled on errors in that case.
+ * but that would a bigger change than reasonable for a patch
+ * release.
+ * (see fileName.test 15.2-15.4 for expected behaviour)
+ */
Tcl_ResetResult(interp);
+ result = TCL_OK;
continue;
} else {
goto done;
diff --git a/contrib/tcl/generic/tclIO.c b/contrib/tcl/generic/tclIO.c
index 2b13e2d60ad3..73ff65f3d8d9 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.268 97/07/28 14:20:36
+ * SCCS: @(#) tclIO.c 1.272 97/10/22 10:27:53
*/
#include "tclInt.h"
@@ -4352,7 +4352,7 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue)
if (writeMode) {
if (*writeMode == '\0') {
/* Do nothing. */
- } else if (strcmp(argv[0], "auto") == 0) {
+ } else if (strcmp(writeMode, "auto") == 0) {
/*
* This is a hack to get TCP sockets to produce output
* in CRLF mode if they are being set into AUTO mode.
@@ -4614,6 +4614,7 @@ ChannelTimerProc(clientData)
Channel *chanPtr = (Channel *) clientData;
if (!(chanPtr->flags & CHANNEL_GETS_BLOCKED)
+ && (chanPtr->interestMask & TCL_READABLE)
&& (chanPtr->inQueueHead != (ChannelBuffer *) NULL)
&& (chanPtr->inQueueHead->nextRemoved <
chanPtr->inQueueHead->nextAdded)) {
@@ -5458,9 +5459,11 @@ TclTestChannelEventCmd(dummy, interp, argc, argv)
mask = TCL_READABLE;
} else if (strcmp(argv[3], "writable") == 0) {
mask = TCL_WRITABLE;
- } else {
+ } else if (strcmp(argv[3], "none") == 0) {
+ mask = 0;
+ } else {
Tcl_AppendResult(interp, "bad event name \"", argv[3],
- "\": must be readable or writable", (char *) NULL);
+ "\": must be readable, writable, or none", (char *) NULL);
return TCL_ERROR;
}
@@ -5536,8 +5539,14 @@ TclTestChannelEventCmd(dummy, interp, argc, argv)
for (esPtr = chanPtr->scriptRecordPtr;
esPtr != (EventScriptRecord *) NULL;
esPtr = esPtr->nextPtr) {
- Tcl_AppendElement(interp,
- esPtr->mask == TCL_READABLE ? "readable" : "writable");
+ char *event;
+ if (esPtr->mask) {
+ event = ((esPtr->mask == TCL_READABLE)
+ ? "readable" : "writable");
+ } else {
+ event = "none";
+ }
+ Tcl_AppendElement(interp, event);
Tcl_AppendElement(interp, esPtr->script);
}
return TCL_OK;
@@ -5562,8 +5571,49 @@ TclTestChannelEventCmd(dummy, interp, argc, argv)
return TCL_OK;
}
+ if ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) {
+ if (argc != 5) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " channelName delete index event\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if (index < 0) {
+ Tcl_AppendResult(interp, "bad event index: ", argv[3],
+ ": must be nonnegative", (char *) NULL);
+ return TCL_ERROR;
+ }
+ for (i = 0, esPtr = chanPtr->scriptRecordPtr;
+ (i < index) && (esPtr != (EventScriptRecord *) NULL);
+ i++, esPtr = esPtr->nextPtr) {
+ /* Empty loop body. */
+ }
+ if (esPtr == (EventScriptRecord *) NULL) {
+ Tcl_AppendResult(interp, "bad event index ", argv[3],
+ ": out of range", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ if (strcmp(argv[4], "readable") == 0) {
+ mask = TCL_READABLE;
+ } else if (strcmp(argv[4], "writable") == 0) {
+ mask = TCL_WRITABLE;
+ } else if (strcmp(argv[4], "none") == 0) {
+ mask = 0;
+ } else {
+ Tcl_AppendResult(interp, "bad event name \"", argv[4],
+ "\": must be readable, writable, or none", (char *) NULL);
+ return TCL_ERROR;
+ }
+ esPtr->mask = mask;
+ Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
+ ChannelEventScriptInvoker, (ClientData) esPtr);
+ return TCL_OK;
+ }
Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ",
- "add, delete, list, or removeall", (char *) NULL);
+ "add, delete, list, set, or removeall", (char *) NULL);
return TCL_ERROR;
}
@@ -5856,7 +5906,7 @@ CopyData(csPtr, mask)
if (errObj) {
Tcl_ListObjAppendElement(interp, cmdPtr, errObj);
}
- if (Tcl_EvalObj(interp, cmdPtr) != TCL_OK) {
+ if (Tcl_GlobalEvalObj(interp, cmdPtr) != TCL_OK) {
Tcl_BackgroundError(interp);
result = TCL_ERROR;
}
diff --git a/contrib/tcl/generic/tclIOUtil.c b/contrib/tcl/generic/tclIOUtil.c
index cb2bd94c017f..7d4cff869e88 100644
--- a/contrib/tcl/generic/tclIOUtil.c
+++ b/contrib/tcl/generic/tclIOUtil.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: @(#) tclIOUtil.c 1.132 97/04/23 16:21:42
+ * SCCS: @(#) tclIOUtil.c 1.133 97/09/24 16:38:57
*/
#include "tclInt.h"
@@ -220,6 +220,7 @@ Tcl_EvalFile(interp, fileName)
Tcl_DString buffer;
char *nativeName;
Tcl_Channel chan;
+ Tcl_Obj *cmdObjPtr;
Tcl_ResetResult(interp);
oldScriptFile = iPtr->scriptFile;
@@ -268,7 +269,21 @@ Tcl_EvalFile(interp, fileName)
goto error;
}
- result = Tcl_Eval(interp, cmdBuffer);
+ /*
+ * Transfer the buffer memory allocated above to the object system.
+ * Tcl_EvalObj will own this new string object if needed,
+ * so past the Tcl_EvalObj point, we must not ckfree(cmdBuffer)
+ * but rather use the reference counting mechanism.
+ * (Nb: and we must not thus not use goto error after this point)
+ */
+ cmdObjPtr = Tcl_NewObj();
+ cmdObjPtr->bytes = cmdBuffer;
+ cmdObjPtr->length = result;
+
+ Tcl_IncrRefCount(cmdObjPtr);
+ result = Tcl_EvalObj(interp, cmdObjPtr);
+ Tcl_DecrRefCount(cmdObjPtr);
+
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
@@ -283,7 +298,6 @@ Tcl_EvalFile(interp, fileName)
Tcl_AddErrorInfo(interp, msg);
}
iPtr->scriptFile = oldScriptFile;
- ckfree(cmdBuffer);
Tcl_DStringFree(&buffer);
return result;
diff --git a/contrib/tcl/generic/tclInterp.c b/contrib/tcl/generic/tclInterp.c
index ae5171a0a388..6cf3f668d208 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.125 97/08/05 15:22:51
+ * SCCS: @(#) tclInterp.c 1.128 97/11/05 09:35:12
*/
#include <stdio.h>
@@ -580,6 +580,12 @@ CreateSlave(interp, masterPtr, slavePath, safe)
Tcl_SetHashValue(hPtr, (ClientData) slavePtr);
Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
+ /*
+ * Inherit the recursion limit.
+ */
+ ((Interp *)slaveInterp)->maxNestingDepth =
+ ((Interp *)masterInterp)->maxNestingDepth ;
+
if (safe) {
if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) {
goto error;
@@ -606,6 +612,8 @@ error:
Tcl_ResetResult(slaveInterp);
(void) Tcl_DeleteCommand(masterInterp, slavePath);
+
+ ckfree((char *) argv);
return (Tcl_Interp *) NULL;
}
diff --git a/contrib/tcl/generic/tclNotify.c b/contrib/tcl/generic/tclNotify.c
index 19f38f3282ed..939624881527 100644
--- a/contrib/tcl/generic/tclNotify.c
+++ b/contrib/tcl/generic/tclNotify.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: @(#) tclNotify.c 1.15 97/06/18 17:14:04
+ * SCCS: @(#) tclNotify.c 1.16 97/09/15 15:12:52
*/
#include "tclInt.h"
@@ -761,6 +761,25 @@ Tcl_DoOneEvent(flags)
if (flags & TCL_DONT_WAIT) {
break;
}
+
+ /*
+ * If Tcl_WaitForEvent has returned 1,
+ * indicating that one system event has been dispatched
+ * (and thus that some Tcl code might have been indirectly executed),
+ * we break out of the loop.
+ * We do this to give VwaitCmd for instance a chance to check
+ * if that system event had the side effect of changing the
+ * variable (so the vwait can return and unwind properly).
+ *
+ * NB: We will process idle events if any first, because
+ * otherwise we might never do the idle events if the notifier
+ * always gets system events.
+ */
+
+ if (result) {
+ break;
+ }
+
}
notifier.serviceMode = oldMode;
diff --git a/contrib/tcl/generic/tclObj.c b/contrib/tcl/generic/tclObj.c
index bc697f391f87..62f892c56168 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.45 97/07/07 18:26:00
+ * SCCS: @(#) tclObj.c 1.47 97/10/30 13:39:00
*/
#include "tclInt.h"
@@ -2092,7 +2092,7 @@ Tcl_DbDecrRefCount(objPtr, file, line)
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
- panic("Trying to increment refCount of previously disposed object.");
+ panic("Trying to decrement refCount of previously disposed object.");
}
#endif
if (--(objPtr)->refCount <= 0) {
@@ -2134,7 +2134,7 @@ Tcl_DbIsShared(objPtr, file, line)
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
- panic("Trying to increment refCount of previously disposed object.");
+ panic("Trying to check whether previously disposed object is shared.");
}
#endif
return ((objPtr)->refCount > 1);
diff --git a/contrib/tcl/generic/tclPosixStr.c b/contrib/tcl/generic/tclPosixStr.c
index 162021fca5ef..9e4588f8cfe3 100644
--- a/contrib/tcl/generic/tclPosixStr.c
+++ b/contrib/tcl/generic/tclPosixStr.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: @(#) tclPosixStr.c 1.32 96/10/10 10:09:42
+ * SCCS: @(#) tclPosixStr.c 1.33 97/10/08 12:40:12
*/
#include "tclInt.h"
@@ -974,7 +974,7 @@ Tcl_SignalId(sig)
#ifdef SIGKILL
case SIGKILL: return "SIGKILL";
#endif
-#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF))
+#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO))
case SIGLOST: return "SIGLOST";
#endif
#ifdef SIGPIPE
@@ -1106,7 +1106,7 @@ Tcl_SignalMsg(sig)
#ifdef SIGKILL
case SIGKILL: return "kill signal";
#endif
-#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG))
+#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO))
case SIGLOST: return "resource lost";
#endif
#ifdef SIGPIPE
diff --git a/contrib/tcl/generic/tclProc.c b/contrib/tcl/generic/tclProc.c
index 7cd94ec865e2..c9039dfee5f8 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.115 97/08/12 13:36:11
+ * SCCS: @(#) tclProc.c 1.116 97/10/29 18:33:24
*/
#include "tclInt.h"
@@ -784,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->cmdPtr->nsPtr;
+ varPtr->nsPtr = NULL;
varPtr->hPtr = NULL;
varPtr->refCount = 0;
varPtr->tracePtr = NULL;
diff --git a/contrib/tcl/generic/tclStringObj.c b/contrib/tcl/generic/tclStringObj.c
index beed142d2e83..6b1f2afd7a2f 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.30 97/07/24 18:53:30
+ * SCCS: @(#) tclStringObj.c 1.31 97/10/30 13:56:35
*/
#include "tclInt.h"
@@ -98,7 +98,7 @@ Tcl_NewStringObj(bytes, length)
register Tcl_Obj *objPtr;
if (length < 0) {
- length = bytes ? strlen(bytes) : 0 ;
+ length = (bytes? strlen(bytes) : 0);
}
TclNewObj(objPtr);
TclInitStringRep(objPtr, bytes, length);
@@ -154,7 +154,7 @@ Tcl_DbNewStringObj(bytes, length, file, line)
register Tcl_Obj *objPtr;
if (length < 0) {
- length = strlen(bytes);
+ length = (bytes? strlen(bytes) : 0);
}
TclDbNewObj(objPtr, file, line);
TclInitStringRep(objPtr, bytes, length);
diff --git a/contrib/tcl/generic/tclTest.c b/contrib/tcl/generic/tclTest.c
index ecc2abfdd429..80cfb9c40cc3 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.115 97/08/13 10:27:26
+ * SCCS: @(#) tclTest.c 1.119 97/10/31 15:57:28
*/
#define TCL_TEST
@@ -59,6 +59,13 @@ static TestAsyncHandler *firstHandler = NULL;
static Tcl_DString dstring;
/*
+ * The command trace below is used by the "testcmdtraceCmd" command
+ * to test the command tracing facilities.
+ */
+
+static Tcl_Trace cmdTrace;
+
+/*
* One of the following structures exists for each command created
* by TestdelCmd:
*/
@@ -84,6 +91,11 @@ 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 CmdTraceDeleteProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ int level, char *command, Tcl_CmdProc *cmdProc,
+ ClientData cmdClientData, int argc,
+ char **argv));
static void CmdTraceProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int level, char *command,
Tcl_CmdProc *cmdProc, ClientData cmdClientData,
@@ -167,6 +179,9 @@ static int TestsetobjerrorcodeCmd _ANSI_ARGS_((
int objc, Tcl_Obj *CONST objv[]));
static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
+static int TestsetrecursionlimitCmd _ANSI_ARGS_((
+ ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]));
static int TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy,
@@ -274,6 +289,9 @@ Tcltest_Init(interp)
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testsetrecursionlimit",
+ TestsetrecursionlimitCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testtranslatefilename",
@@ -661,28 +679,42 @@ TestcmdtraceCmd(dummy, interp, argc, argv)
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
- Tcl_Trace trace;
Tcl_DString buffer;
int result;
- if (argc != 2) {
+ if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " script\"", (char *) NULL);
+ " option 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);
+ if (strcmp(argv[1], "tracetest") == 0) {
+ Tcl_DStringInit(&buffer);
+ cmdTrace = Tcl_CreateTrace(interp, 50000,
+ (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
+ result = Tcl_Eval(interp, argv[2]);
+ if (result == TCL_OK) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
+ }
+ Tcl_DeleteTrace(interp, cmdTrace);
+ Tcl_DStringFree(&buffer);
+ } else if (strcmp(argv[1], "deletetest") == 0) {
+ /*
+ * Create a command trace then eval a script to check whether it is
+ * called. Note that this trace procedure removes itself as a
+ * further check of the robustness of the trace proc calling code in
+ * TclExecuteByteCode.
+ */
+
+ cmdTrace = Tcl_CreateTrace(interp, 50000,
+ (Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL);
+ result = Tcl_Eval(interp, argv[2]);
+ } else {
+ Tcl_AppendResult(interp, "bad option \"", argv[1],
+ "\": must be tracetest or deletetest", (char *) NULL);
+ return TCL_ERROR;
}
-
- Tcl_DeleteTrace(interp, trace);
- Tcl_DStringFree(&buffer);
return TCL_OK;
}
@@ -713,6 +745,29 @@ CmdTraceProc(clientData, interp, level, command, cmdProc, cmdClientData,
}
Tcl_DStringEndSublist(bufPtr);
}
+
+static void
+CmdTraceDeleteProc(clientData, interp, level, command, cmdProc,
+ cmdClientData, argc, argv)
+ ClientData clientData; /* Unused. */
+ 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. */
+{
+ /*
+ * Remove ourselves to test whether calling Tcl_DeleteTrace within
+ * a trace callback causes the for loop in TclExecuteByteCode that
+ * calls traces to reference freed memory.
+ */
+
+ Tcl_DeleteTrace(interp, cmdTrace);
+}
/*
*----------------------------------------------------------------------
@@ -1794,6 +1849,47 @@ TestsetplatformCmd(clientData, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
+ * TestsetrecursionlimitCmd --
+ *
+ * This procedure implements the "testsetrecursionlimit" command. It is
+ * used to change the interp recursion limit (to test the effects
+ * of Tcl_SetRecursionLimit).
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Sets the interp's recursion limit.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestsetrecursionlimitCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* The argument objects. */
+{
+ int value;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "integer");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ value = Tcl_SetRecursionLimit(interp, value);
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), value);
+ return TCL_OK;
+}
+
+
+
+/*
+ *----------------------------------------------------------------------
+ *
* TeststaticpkgCmd --
*
* This procedure implements the "teststaticpkg" command.
@@ -2164,7 +2260,7 @@ TestchmodCmd(dummy, interp, argc, argv)
}
mode = (int) strtol(argv[1], &rest, 8);
- if (*rest != '\0') {
+ if ((rest == argv[1]) || (*rest != '\0')) {
goto usage;
}
diff --git a/contrib/tcl/generic/tclVar.c b/contrib/tcl/generic/tclVar.c
index 587eca9dd70e..f013e6559b34 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.125 97/08/06 14:47:55
+ * SCCS: @(#) tclVar.c 1.130 97/10/29 18:26:16
*/
#include "tclInt.h"
@@ -2630,7 +2630,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv)
Tcl_Obj *varValuePtr, *newValuePtr;
register List *listRepPtr;
register Tcl_Obj **elemPtrs;
- int numElems, numRequired, createdNewObj, i, j;
+ int numElems, numRequired, createdNewObj, createVar, i, j;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
@@ -2666,10 +2666,30 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv)
*/
createdNewObj = 0;
+ createVar = 1;
varValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL,
TCL_PARSE_PART1);
- if (varValuePtr == NULL) { /* no old value: append to new obj */
- varValuePtr = Tcl_NewObj();
+ if (varValuePtr == NULL) {
+ /*
+ * We couldn't read the old value: either the var doesn't yet
+ * exist or it's an array element. If it's new, we will try to
+ * create it with Tcl_ObjSetVar2 below.
+ */
+
+ char *name, *p;
+ int nameBytes, i;
+
+ name = TclGetStringFromObj(objv[1], &nameBytes);
+ for (i = 0, p = name; i < nameBytes; i++, p++) {
+ if (*p == '(') {
+ p = (name + nameBytes-1);
+ if (*p == ')') { /* last char is ')' => array ref */
+ createVar = 0;
+ }
+ break;
+ }
+ }
+ varValuePtr = Tcl_NewObj();
createdNewObj = 1;
} else if (Tcl_IsShared(varValuePtr)) {
varValuePtr = Tcl_DuplicateObj(varValuePtr);
@@ -2732,13 +2752,13 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv)
/*
* Now store the list object back into the variable. If there is an
* error setting the new value, decrement its ref count if it
- * was new.
+ * was new and we didn't create the variable.
*/
newValuePtr = Tcl_ObjSetVar2(interp, objv[1], (Tcl_Obj *) NULL,
varValuePtr, (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1));
if (newValuePtr == NULL) {
- if (createdNewObj) {
+ if (createdNewObj && !createVar) {
Tcl_DecrRefCount(varValuePtr); /* free unneeded obj */
}
return TCL_ERROR;
@@ -2779,8 +2799,8 @@ 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",
+ static char *arrayOptions[] = {"anymore", "donesearch", "exists",
+ "get", "names", "nextelement", "set", "size", "startsearch",
(char *) NULL};
Var *varPtr, *arrayPtr;
Tcl_HashEntry *hPtr;
@@ -2804,19 +2824,17 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
* 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) {
+ if ((varPtr == NULL) || !TclIsVarArray(varPtr)
+ || TclIsVarUndefined(varPtr)) {
notArray = 1;
- } else {
- if (!TclIsVarArray(varPtr)) {
- notArray = 1;
- }
}
-
+
switch (index) {
case 0: { /* anymore */
ArraySearch *searchPtr;
@@ -2921,22 +2939,23 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
}
namePtr = Tcl_NewStringObj(name, -1);
- result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr);
+ result = Tcl_ListObjAppendElement(interp, resultPtr,
+ namePtr);
if (result != TCL_OK) {
- Tcl_DecrRefCount(namePtr); /* free unneeded name object */
+ Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
return result;
}
-
- if (varPtr2->value.objPtr == NULL) {
- TclNewObj(valuePtr);
- } else {
- valuePtr = varPtr2->value.objPtr;
+
+ valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr,
+ TCL_LEAVE_ERR_MSG);
+ if (valuePtr == NULL) {
+ Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
+ return result;
}
- result = Tcl_ListObjAppendElement(interp, resultPtr, valuePtr);
+ result = Tcl_ListObjAppendElement(interp, resultPtr,
+ valuePtr);
if (result != TCL_OK) {
- if (varPtr2->value.objPtr == NULL) {
- Tcl_DecrRefCount(valuePtr); /* free unneeded object */
- }
+ Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
return result;
}
}
@@ -3037,11 +3056,37 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
"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;
+ if (listLen > 0) {
+ 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;
+ }
+ }
+ } else if (varPtr == NULL) {
+ /*
+ * The list is empty and the array variable doesn't
+ * exist yet: create the variable with an empty array
+ * as the value.
+ */
+
+ Tcl_Obj *namePtr, *valuePtr;
+
+ namePtr = Tcl_NewStringObj("tempElem", -1);
+ valuePtr = Tcl_NewObj();
+ if (Tcl_ObjSetVar2(interp, objv[2], namePtr, valuePtr,
+ /* flags*/ 0) == NULL) {
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(valuePtr);
+ return TCL_ERROR;
+ }
+ result = Tcl_UnsetVar2(interp, varName, "tempElem",
+ TCL_LEAVE_ERR_MSG);
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(valuePtr);
+ return result;
}
}
return result;
@@ -3206,6 +3251,21 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags)
myName, "\": unknown namespace", (char *) NULL);
return TCL_ERROR;
}
+
+ /*
+ * Check that we are not trying to create a namespace var linked to
+ * a local variable in a procedure. If we allowed this, the local
+ * variable in the shorter-lived procedure frame could go away
+ * leaving the namespace var's reference invalid.
+ */
+
+ if (otherPtr->nsPtr == NULL) {
+ Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
+ myName, "\": upvar won't create namespace variable that refers to procedure variable",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
hPtr = Tcl_CreateHashEntry(&nsPtr->varTable, tail, &new);
if (new) {
varPtr = NewVar();
diff --git a/contrib/tcl/library/http1.0/http.tcl b/contrib/tcl/library/http1.0/http.tcl
index 450d6430cf5d..f6dd35131259 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.8 97/07/22 13:37:20
+# SCCS: @(#) http.tcl 1.10 97/10/29 16:12:55
#
# See the http.n man page for documentation
@@ -279,14 +279,16 @@ proc http_size {token} {
httpFinish $token $err
}
}
- proc httpCopyDone {token count} {
+ proc httpCopyDone {token count {error {}}} {
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] {
+ if {([string length $error] != 0)} {
+ httpFinish $token $error
+ } elseif {[eof $s]} {
httpEof $token
} else {
httpCopyStart $s $token
diff --git a/contrib/tcl/library/http2.0/http.tcl b/contrib/tcl/library/http2.0/http.tcl
index 80fbfc672412..79c83c3885b3 100644
--- a/contrib/tcl/library/http2.0/http.tcl
+++ b/contrib/tcl/library/http2.0/http.tcl
@@ -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: @(#) http.tcl 1.6 97/08/07 16:48:32
+# SCCS: @(#) http.tcl 1.8 97/10/28 16:23:30
package provide http 2.0 ;# This uses Tcl namespaces
@@ -352,7 +352,7 @@ proc http::size {token} {
Finish $token $err
}
}
- proc http::CopyDone {token count} {
+ proc http::CopyDone {token count {error {}}} {
variable $token
upvar 0 $token state
set s $state(sock)
@@ -360,7 +360,9 @@ proc http::size {token} {
if [info exists state(-progress)] {
eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
}
- if [::eof $s] {
+ if {([string length $error] != 0)} {
+ Finish $token $error
+ } elseif {[::eof $s]} {
Eof $token
} else {
CopyStart $s $token
diff --git a/contrib/tcl/library/init.tcl b/contrib/tcl/library/init.tcl
index 19852248363d..ebf1913a79af 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.86 97/08/08 10:37:39
+# SCCS: @(#) init.tcl 1.95 97/11/19 17:16:34
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -19,6 +19,7 @@ package require -exact Tcl 8.0
# Compute the auto path to use in this interpreter.
# (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 ""
@@ -28,17 +29,20 @@ if {[lsearch -exact $auto_path [info library]] < 0} {
lappend auto_path [info library]
}
catch {
- foreach dir $tcl_pkgPath {
- if {[lsearch -exact $auto_path $dir] < 0} {
- lappend auto_path $dir
+ foreach __dir $tcl_pkgPath {
+ if {[lsearch -exact $auto_path $__dir] < 0} {
+ lappend auto_path $__dir
}
}
- unset dir
+ unset __dir
}
-# Conditionalize for presence of exec.
+# Setup the unknown package handler
package unknown tclPkgUnknown
+
+# Conditionalize for presence of exec.
+
if {[info commands exec] == ""} {
# Some machines, such as the Macintosh, do not have exec. Also, on all
@@ -58,6 +62,11 @@ if {[info commands tclLog] == ""} {
}
}
+# The procs defined in this file that have a leading space
+# are 'hidden' from auto_mkindex because they are not
+# auto-loadable.
+
+
# unknown --
# This procedure is called when a Tcl command is invoked that doesn't
# exist in the interpreter. It takes the following steps to make the
@@ -78,7 +87,7 @@ if {[info commands tclLog] == ""} {
# args - A list whose elements are the words of the original
# command, including the command name.
-proc unknown args {
+ proc unknown args {
global auto_noexec auto_noload env unknown_pending tcl_interactive
global errorCode errorInfo
@@ -97,7 +106,7 @@ proc unknown args {
return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
}
set unknown_pending($name) pending;
- set ret [catch {auto_load $name} msg]
+ set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg]
unset unknown_pending($name);
if {$ret != 0} {
return -code $ret -errorcode $errorCode \
@@ -125,6 +134,7 @@ proc unknown args {
}
}
}
+
if {([info level] == 1) && ([info script] == "") \
&& [info exists tcl_interactive] && $tcl_interactive} {
if ![info exists auto_noexec] {
@@ -186,11 +196,21 @@ proc unknown args {
#
# Arguments:
# cmd - Name of the command to find and load.
+# namespace (optional) The namespace where the command is being used - must be
+# a canonical namespace as returned [namespace current]
+# for instance. If not given, namespace current is used.
-proc auto_load cmd {
+ proc auto_load {cmd {namespace {}}} {
global auto_index auto_oldpath auto_path env errorInfo errorCode
- foreach name [list $cmd ::$cmd] {
+ if {[string length $namespace] == 0} {
+ set namespace [uplevel {namespace current}]
+ }
+ set nameList [auto_qualify $cmd $namespace]
+ # workaround non canonical auto_index entries that might be around
+ # from older auto_mkindex versions
+ lappend nameList $cmd
+ foreach name $nameList {
if [info exists auto_index($name)] {
uplevel #0 $auto_index($name)
return [expr {[info commands $name] != ""}]
@@ -246,15 +266,76 @@ proc auto_load cmd {
}
}
}
- if [info exists auto_index($cmd)] {
- uplevel #0 $auto_index($cmd)
- if {[info commands $cmd] != ""} {
- return 1
+ foreach name $nameList {
+ if [info exists auto_index($name)] {
+ uplevel #0 $auto_index($name)
+ if {[info commands $name] != ""} {
+ return 1
+ }
}
}
return 0
}
+# auto_qualify --
+# compute a fully qualified names list for use in the auto_index array.
+# For historical reasons, commands in the global namespace do not have leading
+# :: in the index key. The list has two elements when the command name is
+# relative (no leading ::) and the namespace is not the global one. Otherwise
+# only one name is returned (and searched in the auto_index).
+#
+# Arguments -
+# cmd The command name. Can be any name accepted for command
+# invocations (Like "foo::::bar").
+# namespace The namespace where the command is being used - must be
+# a canonical namespace as returned by [namespace current]
+# for instance.
+
+ proc auto_qualify {cmd namespace} {
+
+ # count separators and clean them up
+ # (making sure that foo:::::bar will be treated as foo::bar)
+ set n [regsub -all {::+} $cmd :: cmd]
+
+ # Ignore namespace if the name starts with ::
+ # Handle special case of only leading ::
+
+ # Before each return case we give an example of which category it is
+ # with the following form :
+ # ( inputCmd, inputNameSpace) -> output
+
+ if {[regexp {^::(.*)$} $cmd x tail]} {
+ if {$n > 1} {
+ # ( ::foo::bar , * ) -> ::foo::bar
+ return [list $cmd]
+ } else {
+ # ( ::global , * ) -> global
+ return [list $tail]
+ }
+ }
+
+ # Potentially returning 2 elements to try :
+ # (if the current namespace is not the global one)
+
+ if {$n == 0} {
+ if {[string compare $namespace ::] == 0} {
+ # ( nocolons , :: ) -> nocolons
+ return [list $cmd]
+ } else {
+ # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
+ return [list ${namespace}::$cmd $cmd]
+ }
+ } else {
+ if {[string compare $namespace ::] == 0} {
+ # ( foo::bar , :: ) -> ::foo::bar
+ return [list ::$cmd]
+ } else {
+ # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
+ return [list ${namespace}::$cmd ::$cmd]
+ }
+ }
+}
+
if {[string compare $tcl_platform(platform) windows] == 0} {
# auto_execok --
@@ -382,7 +463,7 @@ proc auto_reset {} {
foreach p [info procs] {
if {[info exists auto_index($p)] && ![string match auto_* $p]
&& ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup
- tclPkgUnknown} $p] < 0)} {
+ tclMacPkgSearch tclPkgUnknown} $p] < 0)} {
rename $p {}
}
}
@@ -395,7 +476,9 @@ proc auto_reset {} {
# Regenerate a tclIndex file from Tcl source files. Takes as argument
# the name of the directory in which the tclIndex file is to be placed,
# followed by any number of glob patterns to use in that directory to
-# locate all of the relevant files.
+# locate all of the relevant files. It does not parse or source the file
+# so the generated index will not contain the appropriate namespace qualifiers
+# if you don't explicitly specify it.
#
# Arguments:
# dir - Name of the directory in which to create an index.
@@ -424,6 +507,7 @@ proc auto_mkindex {dir args} {
set f [open $file]
while {[gets $f line] >= 0} {
if [regexp {^proc[ ]+([^ ]*)} $line match procName] {
+ set procName [lindex [auto_qualify $procName "::"] 0]
append index "set [list auto_index($procName)]"
append index " \[list source \[file join \$dir [list $file]\]\]\n"
}
@@ -515,6 +599,13 @@ proc pkg_mkIndex {dir args} {
default { eval package-orig {$what} $args }
}
}
+ proc pkgGetAllNamespaces {{root {}}} {
+ set list $root
+ foreach ns [namespace children $root] {
+ eval lappend list [pkgGetAllNamespaces $ns]
+ }
+ return $list
+ }
package unknown dummy
set origCmds [info commands]
set dir "" ;# in case file is pkgIndex.tcl
@@ -540,7 +631,7 @@ proc pkg_mkIndex {dir args} {
source $file
set type source
}
- foreach ns [namespace children] {
+ foreach ns [pkgGetAllNamespaces] {
namespace import ${ns}::*
}
foreach i [info commands] {
@@ -633,7 +724,7 @@ proc tclMacPkgSearch {dir} {
foreach y [resource list TEXT $res] {
if {$y == "pkgIndex"} {source -rsrc pkgIndex}
}
- resource close $res
+ catch {resource close $res}
}
}
}
@@ -652,14 +743,11 @@ proc tclMacPkgSearch {dir} {
# exact - Either "-exact" or omitted. Not used.
proc tclPkgUnknown {name version {exact {}}} {
- global auto_path tcl_platform env dir
+ global auto_path tcl_platform env
if ![info exists auto_path] {
return
}
- if {[info exists dir]} {
- set save_dir $dir
- }
for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
# we can't use glob in safe interps, so enclose the following
# in a catch statement
@@ -686,17 +774,12 @@ proc tclPkgUnknown {name version {exact {}}} {
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]} {
- set dir $save_dir
- } else {
- unset dir
- }
}
diff --git a/contrib/tcl/library/opt0.1/optparse.tcl b/contrib/tcl/library/opt0.1/optparse.tcl
index ee5b399ee6eb..12135da0ff60 100644
--- a/contrib/tcl/library/opt0.1/optparse.tcl
+++ b/contrib/tcl/library/opt0.1/optparse.tcl
@@ -13,9 +13,9 @@
# 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
+# SCCS: @(#) optparse.tcl 1.13 97/08/21 11:50:42
-package provide opt 0.1
+package provide opt 0.2
namespace eval ::tcl {
@@ -166,8 +166,12 @@ proc ::tcl::OptKeyRegister {desc {key ""}} {
# are we processing flags (which makes a single program step)
set inflags 0;
+
set state {};
+ # flag used to detect that we just have a single (flags set) subprogram.
+ set empty 1;
+
foreach item $desc {
if {$state == "args"} {
# more items after 'args'...
@@ -187,6 +191,7 @@ proc ::tcl::OptKeyRegister {desc {key ""}} {
# put the other regular stuff
lappend program $res;
set inflags 0;
+ set empty 0;
}
} else {
if {$state == "flags"} {
@@ -195,11 +200,18 @@ proc ::tcl::OptKeyRegister {desc {key ""}} {
set flagsprg [list [list "P" 1] $res];
} else {
lappend program $res;
+ set empty 0;
}
}
}
if {$inflags} {
- lappend program $flagsprg;
+ if {$empty} {
+ # We just have the subprogram, optimize and remove
+ # unneeded level:
+ set program $flagsprg;
+ } else {
+ lappend program $flagsprg;
+ }
}
set OptDesc($key) $program;
@@ -629,12 +641,27 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
set hits 0
set hitems {}
set i 1;
+
+ set larg [string tolower $arg];
+ set len [string length $larg];
+ set last [expr $len-1];
+
foreach item [lrange $desc 1 end] {
set flag [OptName $item]
# lets try to match case insensitively
- if {[string match [string tolower $arg*] [string tolower $flag]]} {
- lappend hitems $i;
- incr hits;
+ # (string length ought to be cheap)
+ set lflag [string tolower $flag];
+ if {$len == [string length $lflag]} {
+ if {[string compare $larg $lflag]==0} {
+ # Exact match case
+ OptSetPrgCounter desc $i;
+ return 1;
+ }
+ } else {
+ if {[string compare $larg [string range $lflag 0 $last]]==0} {
+ lappend hitems $i;
+ incr hits;
+ }
}
incr i;
}
@@ -845,8 +872,8 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
[list $item]
}
-proc ::tcl::OptKeyError {prefix descKey} {
- OptError $prefix [OptKeyGetDesc $descKey];
+proc ::tcl::OptKeyError {prefix descKey {header 0}} {
+ OptError $prefix [OptKeyGetDesc $descKey] $header;
}
# determine string length for nice tabulated output
diff --git a/contrib/tcl/library/opt0.1/pkgIndex.tcl b/contrib/tcl/library/opt0.1/pkgIndex.tcl
index 4e660cd69872..7a7ad90cc054 100644
--- a/contrib/tcl/library/opt0.1/pkgIndex.tcl
+++ b/contrib/tcl/library/opt0.1/pkgIndex.tcl
@@ -4,4 +4,4 @@
# 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]]
+package ifneeded opt 0.2 [list source [file join $dir optparse.tcl]]
diff --git a/contrib/tcl/library/safe.tcl b/contrib/tcl/library/safe.tcl
index e923cc630d04..9b9352370092 100644
--- a/contrib/tcl/library/safe.tcl
+++ b/contrib/tcl/library/safe.tcl
@@ -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: @(#) safe.tcl 1.21 97/08/13 15:37:22
+# SCCS: @(#) safe.tcl 1.26 97/08/21 11:57:20
#
# The implementation is based on namespaces. These naming conventions
@@ -22,13 +22,13 @@
#
# Needed utilities package
-package require opt 0.1;
+package require opt 0.2;
# Create the safe namespace
namespace eval ::safe {
# Exported API:
- namespace export interp \
+ namespace export interpCreate interpInit interpConfigure interpDelete \
interpAddToAccessPath interpFindInAccessPath \
setLogCmd ;
@@ -36,67 +36,245 @@ namespace eval ::safe {
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)"}
+ ####
+ #
+ # Setup the arguments parsing
+ #
+ ####
+
+ # Share the descriptions
+ set temp [::tcl::OptKeyRegister {
{-accessPath -list {} "access path for the slave"}
{-noStatics "prevent loading of statically linked pkgs"}
+ {-statics true "loading of statically linked pkgs"}
{-nestedLoadOk "allow nested loading"}
+ {-nested false "nested loading"}
{-deleteHook -script {} "delete hook"}
- } {
+ }]
+
+ # create case (slave is optional)
+ ::tcl::OptKeyRegister {
+ {?slave? -name {} "name of the slave (optional)"}
+ } ::safe::interpCreate ;
+ # adding the flags sub programs to the command program
+ # (relying on Opt's internal implementation details)
+ lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp);
+
+ # init and configure (slave is needed)
+ ::tcl::OptKeyRegister {
+ {slave -name {} "name of the slave"}
+ } ::safe::interpIC;
+ # adding the flags sub programs to the command program
+ # (relying on Opt's internal implementation details)
+ lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp);
+ # temp not needed anymore
+ ::tcl::OptKeyDelete $temp;
+
+
+ # Helper function to resolve the dual way of specifying staticsok
+ # (either by -noStatics or -statics 0)
+ proc InterpStatics {} {
+ foreach v {Args statics noStatics} {
+ upvar $v $v
+ }
+ set flag [::tcl::OptProcArgGiven -noStatics];
+ if {$flag && ($noStatics == $statics)
+ && ([::tcl::OptProcArgGiven -statics])} {
+ return -code error\
+ "conflicting values given for -statics and -noStatics";
+ }
+ if {$flag} {
+ return [expr {!$noStatics}];
+ } else {
+ return $statics
+ }
+ }
+
+ # Helper function to resolve the dual way of specifying nested loading
+ # (either by -nestedLoadOk or -nested 1)
+ proc InterpNested {} {
+ foreach v {Args nested nestedLoadOk} {
+ upvar $v $v
+ }
+ set flag [::tcl::OptProcArgGiven -nestedLoadOk];
+ # note that the test here is the opposite of the "InterpStatics"
+ # one (it is not -noNested... because of the wanted default value)
+ if {$flag && ($nestedLoadOk != $nested)
+ && ([::tcl::OptProcArgGiven -nested])} {
+ return -code error\
+ "conflicting values given for -nested and -nestedLoadOk";
+ }
+ if {$flag} {
+ # another difference with "InterpStatics"
+ return $nestedLoadOk
+ } else {
+ return $nested
+ }
+ }
+
+ ####
+ #
+ # API entry points that needs argument parsing :
+ #
+ ####
+
+
+ # Interface/entry point function and front end for "Create"
+ proc interpCreate {args} {
+ set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
InterpCreate $slave $accessPath \
- [expr {!$noStatics}] $nestedLoadOk $deleteHook;
+ [InterpStatics] [InterpNested] $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"}
- } {
+ proc interpInit {args} {
+ set Args [::tcl::OptKeyParse ::safe::interpIC $args]
+ if {![::interp exists $slave]} {
+ return -code error \
+ "\"$slave\" is not an interpreter";
+ }
InterpInit $slave $accessPath \
- [expr {!$noStatics}] $nestedLoadOk $deleteHook;
+ [InterpStatics] [InterpNested] $deleteHook;
+ }
+
+ proc CheckInterp {slave} {
+ if {![IsInterp $slave]} {
+ return -code error \
+ "\"$slave\" is not an interpreter managed by ::safe::" ;
+ }
}
# Interface/entry point function and front end for "Configure"
- ::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";
+ # This code is awfully pedestrian because it would need
+ # more coupling and support between the way we store the
+ # configuration values in safe::interp's and the Opt package
+ # Obviously we would like an OptConfigure
+ # to avoid duplicating all this code everywhere. -> TODO
+ # (the app should share or access easily the program/value
+ # stored by opt)
+ # This is even more complicated by the boolean flags with no values
+ # that we had the bad idea to support for the sake of user simplicity
+ # in create/init but which makes life hard in configure...
+ # So this will be hopefully written and some integrated with opt1.0
+ # (hopefully for tcl8.1 ?)
+ proc interpConfigure {args} {
+ switch [llength $args] {
+ 1 {
+ # If we have exactly 1 argument
+ # the semantic is to return all the current configuration
+ # We still call OptKeyParse though we know that "slave"
+ # is our given argument because it also checks
+ # for the "-help" option.
+ set Args [::tcl::OptKeyParse ::safe::interpIC $args];
+ CheckInterp $slave;
+ set res {}
+ lappend res [list -accessPath [Set [PathListName $slave]]]
+ lappend res [list -statics [Set [StaticsOkName $slave]]]
+ lappend res [list -nested [Set [NestedOkName $slave]]]
+ lappend res [list -deleteHook [Set [DeleteHookName $slave]]]
+ join $res
}
- } 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"
+ 2 {
+ # If we have exactly 2 arguments
+ # the semantic is a "configure get"
+ ::tcl::Lassign $args slave arg;
+ # get the flag sub program (we 'know' about Opt's internal
+ # representation of data)
+ set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]
+ set hits [::tcl::OptHits desc $arg];
+ if {$hits > 1} {
+ return -code error [::tcl::OptAmbigous $desc $arg]
+ } elseif {$hits == 0} {
+ return -code error [::tcl::OptFlagUsage $desc $arg]
+ }
+ CheckInterp $slave;
+ set item [::tcl::OptCurDesc $desc];
+ set name [::tcl::OptName $item];
+ switch -exact -- $name {
+ -accessPath {
+ return [list -accessPath [Set [PathListName $slave]]]
+ }
+ -statics {
+ return [list -statics [Set [StaticsOkName $slave]]]
+ }
+ -nested {
+ return [list -nested [Set [NestedOkName $slave]]]
+ }
+ -deleteHook {
+ return [list -deleteHook [Set [DeleteHookName $slave]]]
+ }
+ -noStatics {
+ # it is most probably a set in fact
+ # but we would need then to jump to the set part
+ # and it is not *sure* that it is a set action
+ # that the user want, so force it to use the
+ # unambigous -statics ?value? instead:
+ return -code error\
+ "ambigous query (get or set -noStatics ?)\
+ use -statics instead";
+ }
+ -nestedLoadOk {
+ return -code error\
+ "ambigous query (get or set -nestedLoadOk ?)\
+ use -nested instead";
+ }
+ default {
+ return -code error "unknown flag $name (bug)";
+ }
+ }
}
- if {[Set [NestedOkName $slave]]} {
- lappend res "-nestedLoadOk"
+ default {
+ # Otherwise we want to parse the arguments like init and create
+ # did
+ set Args [::tcl::OptKeyParse ::safe::interpIC $args];
+ CheckInterp $slave;
+ # Get the current (and not the default) values of
+ # whatever has not been given:
+ if {![::tcl::OptProcArgGiven -accessPath]} {
+ set doreset 1
+ set accessPath [Set [PathListName $slave]]
+ } else {
+ set doreset 0
+ }
+ if { (![::tcl::OptProcArgGiven -statics])
+ && (![::tcl::OptProcArgGiven -noStatics]) } {
+ set statics [Set [StaticsOkName $slave]]
+ } else {
+ set statics [InterpStatics]
+ }
+ if { ([::tcl::OptProcArgGiven -nested])
+ || ([::tcl::OptProcArgGiven -nestedLoadOk]) } {
+ set nested [InterpNested]
+ } else {
+ set nested [Set [NestedOkName $slave]]
+ }
+ if {![::tcl::OptProcArgGiven -deleteHook]} {
+ set deleteHook [Set [DeleteHookName $slave]]
+ }
+ # we can now reconfigure :
+ InterpSetConfig $slave $accessPath \
+ $statics $nested $deleteHook;
+ # auto_reset the slave (to completly synch the new access_path)
+ if {$doreset} {
+ if {[catch {::interp eval $slave {auto_reset}} msg]} {
+ Log $slave "auto_reset failed: $msg";
+ } else {
+ Log $slave "successful auto_reset" NOTICE;
+ }
+ }
}
- lappend res [list -deleteHook [Set [DeleteHookName $slave]]]
- join $res
}
}
+ ####
+ #
+ # Functions that actually implements the exported APIs
+ #
+ ####
+
+
#
# safe::InterpCreate : doing the real job
#
@@ -139,7 +317,7 @@ proc ::safe::interpDelete {} {}
#
- # InterpConfigure (was setAccessPath) :
+ # InterpSetConfig (was setAccessPath) :
# Sets up slave virtual auto_path and corresponding structure
# within the master. Also sets the tcl_library in the slave
# to be the first directory in the path.
@@ -147,7 +325,7 @@ proc ::safe::interpDelete {} {}
# 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\
+ proc ::safe::InterpSetConfig {slave access_path staticsok\
nestedok deletehook} {
# determine and store the access path if empty
@@ -259,7 +437,7 @@ proc ::safe::interpAddToAccessPath {slave path} {
# Configure will generate an access_path when access_path is
# empty.
- InterpConfigure $slave $access_path $staticsok $nestedok $deletehook;
+ InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook;
# These aliases let the slave load files to define new commands
@@ -336,7 +514,7 @@ proc ::safe::interpAddToAccessPath {slave path} {
# This procedure deletes a safe slave managed by Safe Tcl and
# cleans up associated state:
- proc ::safe::interpDelete {slave} {
+proc ::safe::interpDelete {slave} {
Log $slave "About to delete" NOTICE;
@@ -395,7 +573,6 @@ proc ::safe::setLogCmd {args} {
# ------------------- 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.
@@ -413,12 +590,18 @@ proc ::safe::setLogCmd {args} {
# 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.
+ # We add the S prefix to avoid that a slave interp called "Log"
+ # would smash our "Log" variable.
proc InterpStateName {slave} {
return "S$slave";
}
+ # Check that the given slave is "one of us"
+ proc IsInterp {slave} {
+ expr { ([Exists [InterpStateName $slave]])
+ && ([::interp exists $slave])}
+ }
+
# returns the virtual token for directory number N
# if the slave argument is given,
# it will return the corresponding master global variable name
diff --git a/contrib/tcl/library/tclIndex b/contrib/tcl/library/tclIndex
index 7ef95630ceb5..e923ec9aa995 100644
--- a/contrib/tcl/library/tclIndex
+++ b/contrib/tcl/library/tclIndex
@@ -6,9 +6,6 @@
# element name is the name of a command and the value is
# a script that loads the command.
-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]]
set auto_index(auto_execok) [list source [file join $dir init.tcl]]
set auto_index(auto_reset) [list source [file join $dir init.tcl]]
set auto_index(auto_mkindex) [list source [file join $dir init.tcl]]
@@ -26,8 +23,8 @@ 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::interpDelete) [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/append.test b/contrib/tcl/tests/append.test
index 6733454ee100..f89ade5bd4c9 100644
--- a/contrib/tcl/tests/append.test
+++ b/contrib/tcl/tests/append.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: @(#) append.test 1.16 97/04/09 11:29:33
+# SCCS: @(#) append.test 1.17 97/10/28 15:45:52
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -156,3 +156,19 @@ test append-6.2 {lappend errors} {
set x ""
list [catch {lappend x(0) 44} msg] $msg
} {1 {can't set "x(0)": variable isn't array}}
+
+test append-7.1 {lappend-created var and error in trace on that var} {
+ catch {rename foo ""}
+ catch {unset x}
+ trace variable x w foo
+ proc foo {} {global x; unset x}
+ catch {lappend x 1}
+ proc foo {args} {global x; unset x}
+ info exists x
+ set x
+ lappend x 1
+ list [info exists x] [catch {set x} msg] $msg
+} {0 1 {can't read "x": no such variable}}
+
+catch {unset x}
+catch {rename foo ""}
diff --git a/contrib/tcl/tests/basic.test b/contrib/tcl/tests/basic.test
index a0b6ea0b2fef..502e3e5f4d55 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.18 97/08/07 10:36:59
+# SCCS: @(#) basic.test 1.19 97/10/31 16:02:26
#
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -381,8 +381,11 @@ test basic-11.1 {TclObjInvoke, lookup of "unknown" command} {
} {newAlias 0 {global unknown} {}}
test basic-12.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
- testcmdtrace {set stuff [info tclversion]}
+ testcmdtrace tracetest {set stuff [info tclversion]}
} {{info tclversion} {info tclversion} {set stuff [info tclversion]} {set stuff 8.0}}
+test basic-12.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
+ testcmdtrace deletetest {set stuff [info tclversion]}
+} 8.0
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {namespace delete george}
diff --git a/contrib/tcl/tests/binary.test b/contrib/tcl/tests/binary.test
index f64b2bbd75e4..dcc5cf640fc3 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.10 97/08/06 08:56:11
+# SCCS: @(#) binary.test 1.13 97/09/11 18:50:30
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -443,18 +443,24 @@ test binary-13.12 {Tcl_BinaryObjCmd: float overflow} {nonPortable macOrUnix} {
test binary-13.13 {Tcl_BinaryObjCmd: float overflow} {nonPortable pcOnly} {
binary format f -3.402825e+38
} \xff\xff\x7f\xff
-test binary-13.14 {Tcl_BinaryObjCmd: format} {
+test binary-13.14 {Tcl_BinaryObjCmd: float underflow} {nonPortable macOrUnix} {
+ binary format f -3.402825e-100
+} \x80\x00\x00\x00
+test binary-13.15 {Tcl_BinaryObjCmd: float underflow} {nonPortable pcOnly} {
+ binary format f -3.402825e-100
+} \x00\x00\x00\x80
+test binary-13.16 {Tcl_BinaryObjCmd: format} {
list [catch {binary format f2 {1.6}} msg] $msg
} {1 {number of elements in list does not match count}}
-test binary-13.15 {Tcl_BinaryObjCmd: format} {
+test binary-13.17 {Tcl_BinaryObjCmd: format} {
set a {1.6 3.4}
list [catch {binary format f $a} msg] $msg
} [list 1 "expected floating-point number but got \"1.6 3.4\""]
-test binary-13.16 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
+test binary-13.18 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
set a {1.6 3.4}
binary format f1 $a
} \x3f\xcc\xcc\xcd
-test binary-13.17 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
+test binary-13.19 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
set a {1.6 3.4}
binary format f1 $a
} \xcd\xcc\xcc\x3f
@@ -1312,7 +1318,7 @@ test binary-37.8 {GetFormatSpec: numbers} {
set arg1 foo
list [binary scan abcdef "a0x3" arg1] $arg1
} {1 {}}
-test binary-37.8 {GetFormatSpec: numbers} {
+test binary-37.9 {GetFormatSpec: numbers} {
# test format of neg numbers
# bug report/fix provided by Harald Kirsch
set x [binary format f* {1 -1 2 -2 0}]
@@ -1320,37 +1326,61 @@ test binary-37.8 {GetFormatSpec: numbers} {
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} {
+test binary-38.1 {FormatNumber: word alignment} {
+ set x [binary format c1s1 1 1]
+} \x01\x01\x00
+test binary-38.2 {FormatNumber: word alignment} {
+ set x [binary format c1S1 1 1]
+} \x01\x00\x01
+test binary-38.3 {FormatNumber: word alignment} {
+ set x [binary format c1i1 1 1]
+} \x01\x01\x00\x00\x00
+test binary-38.4 {FormatNumber: word alignment} {
+ set x [binary format c1I1 1 1]
+} \x01\x00\x00\x00\x01
+test binary-38.5 {FormatNumber: word alignment} {nonPortable macOrUnix} {
+ set x [binary format c1d1 1 1.6]
+} \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a
+test binary-38.6 {FormatNumber: word alignment} {nonPortable pcOnly} {
+ set x [binary format c1d1 1 1.6]
+} \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f
+test binary-38.7 {FormatNumber: word alignment} {nonPortable macOrUnix} {
+ set x [binary format c1f1 1 1.6]
+} \x01\x3f\xcc\xcc\xcd
+test binary-38.8 {FormatNumber: word alignment} {nonPortable pcOnly} {
+ set x [binary format c1f1 1 1.6]
+} \x01\xcd\xcc\xcc\x3f
+
+test binary-39.1 {ScanNumber: sign extension} {
catch {unset arg1}
list [binary scan \x52\xa3 c2 arg1] $arg1
} {1 {82 -93}}
-test binary-38.2 {ScanNumber: sign extension} {
+test binary-39.2 {ScanNumber: sign extension} {
catch {unset arg1}
list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 s4 arg1] $arg1
} {1 {513 -32511 386 -32127}}
-test binary-38.3 {ScanNumber: sign extension} {
+test binary-39.3 {ScanNumber: sign extension} {
catch {unset arg1}
list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 S4 arg1] $arg1
} {1 {258 385 -32255 -32382}}
-test binary-38.4 {ScanNumber: sign extension} {
+test binary-39.4 {ScanNumber: sign extension} {
catch {unset arg1}
list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 i5 arg1] $arg1
} {1 {33620225 16843137 16876033 25297153 -2130640639}}
-test binary-38.5 {ScanNumber: sign extension} {
+test binary-39.5 {ScanNumber: sign extension} {
catch {unset arg1}
list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 I5 arg1] $arg1
} {1 {16843010 -2130640639 25297153 16876033 16843137}}
-test binary-39.1 {ScanNumber: floating point overflow} {nonPortable unixOnly} {
+test binary-40.1 {ScanNumber: floating point overflow} {nonPortable unixOnly} {
catch {unset arg1}
list [binary scan \xff\xff\xff\xff f1 arg1] $arg1
} {1 -NaN}
-test binary-39.2 {ScanNumber: floating point overflow} {nonPortable macOnly} {
+test binary-40.2 {ScanNumber: floating point overflow} {nonPortable macOnly} {
catch {unset arg1}
list [binary scan \xff\xff\xff\xff f1 arg1] $arg1
} {1 -NAN(255)}
-test binary-39.3 {ScanNumber: floating point overflow} {nonPortable pcOnly} {
+test binary-40.3 {ScanNumber: floating point overflow} {nonPortable pcOnly} {
catch {unset arg1}
set result [binary scan \xff\xff\xff\xff f1 arg1]
if {([string compare $arg1 -1.\#QNAN] == 0)
@@ -1360,15 +1390,15 @@ test binary-39.3 {ScanNumber: floating point overflow} {nonPortable pcOnly} {
lappend result failure
}
} {1 success}
-test binary-39.4 {ScanNumber: floating point overflow} {nonPortable unixOnly} {
+test binary-40.4 {ScanNumber: floating point overflow} {nonPortable unixOnly} {
catch {unset arg1}
list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d1 arg1] $arg1
} {1 -NaN}
-test binary-39.5 {ScanNumber: floating point overflow} {nonPortable macOnly} {
+test binary-40.5 {ScanNumber: floating point overflow} {nonPortable macOnly} {
catch {unset arg1}
list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d1 arg1] $arg1
} {1 -NAN(255)}
-test binary-39.6 {ScanNumber: floating point overflow} {nonPortable pcOnly} {
+test binary-40.6 {ScanNumber: floating point overflow} {nonPortable pcOnly} {
catch {unset arg1}
set result [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d1 arg1]
if {([string compare $arg1 -1.\#QNAN] == 0)
@@ -1378,3 +1408,36 @@ test binary-39.6 {ScanNumber: floating point overflow} {nonPortable pcOnly} {
lappend result failure
}
} {1 success}
+
+test binary-41.1 {ScanNumber: word alignment} {
+ catch {unset arg1; unset arg2}
+ list [binary scan \x01\x01\x00 c1s1 arg1 arg2] $arg1 $arg2
+} {2 1 1}
+test binary-41.2 {ScanNumber: word alignment} {
+ catch {unset arg1; unset arg2}
+ list [binary scan \x01\x00\x01 c1S1 arg1 arg2] $arg1 $arg2
+} {2 1 1}
+test binary-41.3 {ScanNumber: word alignment} {
+ catch {unset arg1; unset arg2}
+ list [binary scan \x01\x01\x00\x00\x00 c1i1 arg1 arg2] $arg1 $arg2
+} {2 1 1}
+test binary-41.4 {ScanNumber: word alignment} {
+ catch {unset arg1; unset arg2}
+ list [binary scan \x01\x00\x00\x00\x01 c1I1 arg1 arg2] $arg1 $arg2
+} {2 1 1}
+test binary-41.5 {ScanNumber: word alignment} {nonPortable macOrUnix} {
+ catch {unset arg1; unset arg2}
+ list [binary scan \x01\x3f\xcc\xcc\xcd c1f1 arg1 arg2] $arg1 $arg2
+} {2 1 1.60000002384}
+test binary-41.6 {ScanNumber: word alignment} {nonPortable pcOnly} {
+ catch {unset arg1; unset arg2}
+ list [binary scan \x01\xcd\xcc\xcc\x3f c1f1 arg1 arg2] $arg1 $arg2
+} {2 1 1.60000002384}
+test binary-41.7 {ScanNumber: word alignment} {nonPortable macOrUnix} {
+ catch {unset arg1; unset arg2}
+ list [binary scan \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a c1d1 arg1 arg2] $arg1 $arg2
+} {2 1 1.6}
+test binary-41.8 {ScanNumber: word alignment} {nonPortable pcOnly} {
+ catch {unset arg1; unset arg2}
+ list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2
+} {2 1 1.6}
diff --git a/contrib/tcl/tests/clock.test b/contrib/tcl/tests/clock.test
index b75ee32f4b24..95f73ac3cbaa 100644
--- a/contrib/tcl/tests/clock.test
+++ b/contrib/tcl/tests/clock.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: @(#) clock.test 1.14 97/06/02 10:18:12
+# SCCS: @(#) clock.test 1.17 97/11/24 15:05:38
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -145,3 +145,31 @@ test clock-6.4 {clock roll over dates} {
set time [clock scan "2/29/2000" -gmt true]
clock format [expr $time + $day] -format {%b %d,%Y %H:%M GMT} -gmt true
} {Mar 01,2000 00:00 GMT}
+test clock-6.5 {clock roll over dates} {
+ set time [clock scan "January 1, 2000" -gmt true]
+ clock format $time -format %A -gmt true
+} {Saturday}
+test clock-6.6 {clock roll over dates} {
+ set time [clock scan "January 1, 2000" -gmt true]
+ clock format $time -format %j -gmt true
+} {001}
+test clock-6.7 {clock roll over dates} {
+ set time [clock scan "February 29, 2000" -gmt true]
+ clock format $time -format %A -gmt true
+} {Tuesday}
+test clock-6.8 {clock roll over dates} {
+ set time [clock scan "February 29, 2000" -gmt true]
+ clock format $time -format %j -gmt true
+} {060}
+test clock-6.9 {clock roll over dates} {
+ set time [clock scan "March 1, 2000" -gmt true]
+ clock format $time -format %A -gmt true
+} {Wednesday}
+test clock-6.10 {clock roll over dates} {
+ set time [clock scan "March 1, 2000" -gmt true]
+ clock format $time -format %j -gmt true
+} {061}
+test clock-6.11 {clock roll over dates} {
+ set time [clock scan "March 1, 2001" -gmt true]
+ clock format $time -format %j -gmt true
+} {060}
diff --git a/contrib/tcl/tests/cmdIL.test b/contrib/tcl/tests/cmdIL.test
index ceeb86b0dc81..5b561054addc 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.17 97/07/11 15:33:16
+# SCCS: @(#) cmdIL.test 1.18 97/09/18 11:42:12
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -194,57 +194,60 @@ test cmdIL-4.3 {DictionaryCompare procedure, numerics, leading zeros} {
test cmdIL-4.4 {DictionaryCompare procedure, numerics, leading zeros} {
lsort -dictionary {a3b a03B}
} {a3b a03B}
-test cmdIL-4.5 {DictionaryCompare procedure, numerics, different lengths} {
+test cmdIL-4.5 {DictionaryCompare procedure, numerics, leading zeros} {
+ lsort -dictionary {00000 000}
+} {000 00000}
+test cmdIL-4.6 {DictionaryCompare procedure, numerics, different lengths} {
lsort -dictionary {a321b a03210b}
} {a321b a03210b}
-test cmdIL-4.6 {DictionaryCompare procedure, numerics, different lengths} {
+test cmdIL-4.7 {DictionaryCompare procedure, numerics, different lengths} {
lsort -dictionary {a03210b a321b}
} {a321b a03210b}
-test cmdIL-4.7 {DictionaryCompare procedure, numerics} {
+test cmdIL-4.8 {DictionaryCompare procedure, numerics} {
lsort -dictionary {48 6a 18b 22a 21aa 35 36}
} {6a 18b 21aa 22a 35 36 48}
-test cmdIL-4.8 {DictionaryCompare procedure, numerics} {
+test cmdIL-4.9 {DictionaryCompare procedure, numerics} {
lsort -dictionary {a123x a123b}
} {a123b a123x}
-test cmdIL-4.9 {DictionaryCompare procedure, numerics} {
+test cmdIL-4.10 {DictionaryCompare procedure, numerics} {
lsort -dictionary {a123b a123x}
} {a123b a123x}
-test cmdIL-4.10 {DictionaryCompare procedure, numerics} {
+test cmdIL-4.11 {DictionaryCompare procedure, numerics} {
lsort -dictionary {a1b aab}
} {a1b aab}
-test cmdIL-4.11 {DictionaryCompare procedure, numerics} {
+test cmdIL-4.12 {DictionaryCompare procedure, numerics} {
lsort -dictionary {a1b a!b}
} {a!b a1b}
-test cmdIL-4.12 {DictionaryCompare procedure, numerics} {
+test cmdIL-4.13 {DictionaryCompare procedure, numerics} {
lsort -dictionary {a1b2c a1b1c}
} {a1b1c a1b2c}
-test cmdIL-4.13 {DictionaryCompare procedure, numerics} {
+test cmdIL-4.14 {DictionaryCompare procedure, numerics} {
lsort -dictionary {a1b2c a1b3c}
} {a1b2c a1b3c}
-test cmdIL-4.14 {DictionaryCompare procedure, long numbers} {
+test cmdIL-4.15 {DictionaryCompare procedure, long numbers} {
lsort -dictionary {a7654884321988762b a7654884321988761b}
} {a7654884321988761b a7654884321988762b}
-test cmdIL-4.15 {DictionaryCompare procedure, long numbers} {
+test cmdIL-4.16 {DictionaryCompare procedure, long numbers} {
lsort -dictionary {a8765488432198876b a7654884321988761b}
} {a7654884321988761b a8765488432198876b}
-test cmdIL-4.16 {DictionaryCompare procedure, case} {
+test cmdIL-4.17 {DictionaryCompare procedure, case} {
lsort -dictionary {aBCd abcc}
} {abcc aBCd}
-test cmdIL-4.17 {DictionaryCompare procedure, case} {
+test cmdIL-4.18 {DictionaryCompare procedure, case} {
lsort -dictionary {aBCd abce}
} {aBCd abce}
-test cmdIL-4.18 {DictionaryCompare procedure, case} {
+test cmdIL-4.19 {DictionaryCompare procedure, case} {
lsort -dictionary {abcd ABcc}
} {ABcc abcd}
-test cmdIL-4.19 {DictionaryCompare procedure, case} {
+test cmdIL-4.20 {DictionaryCompare procedure, case} {
lsort -dictionary {abcd ABce}
} {abcd ABce}
-test cmdIL-4.20 {DictionaryCompare procedure, case} {
+test cmdIL-4.21 {DictionaryCompare procedure, case} {
lsort -dictionary {abCD ABcd}
} {ABcd abCD}
-test cmdIL-4.21 {DictionaryCompare procedure, case} {
+test cmdIL-4.22 {DictionaryCompare procedure, case} {
lsort -dictionary {ABcd aBCd}
} {ABcd aBCd}
-test cmdIL-4.22 {DictionaryCompare procedure, case} {
+test cmdIL-4.23 {DictionaryCompare procedure, case} {
lsort -dictionary {ABcd AbCd}
} {ABcd AbCd}
diff --git a/contrib/tcl/tests/env.test b/contrib/tcl/tests/env.test
index e76ad7d58720..1bfc8ddaf1f3 100644
--- a/contrib/tcl/tests/env.test
+++ b/contrib/tcl/tests/env.test
@@ -10,10 +10,35 @@
# 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.13 97/08/05 11:40:30
+# SCCS: @(#) env.test 1.14 97/10/31 17:00:03
if {[string compare test [info procs test]] == 1} then {source defs}
+#
+# These tests will run on any platform (and indeed crashed
+# on the Mac). So put them before you test for the existance
+# of exec.
+#
+test env-1.1 {propagation of env values to child interpreters} {
+ catch {interp delete child}
+ catch {unset env(test)}
+ interp create child
+ set env(test) garbage
+ set return [child eval {set env(test)}]
+ interp delete child
+ unset env(test)
+ set return
+} {garbage}
+#
+# This one crashed on Solaris under Tcl8.0, so we only
+# want to make sure it runs.
+#
+test env-1.2 {lappend to env value} {
+ catch {unset env(test)}
+ set env(test) aaaaaaaaaaaaaaaa
+ append env(test) bbbbbbbbbbbbbb
+ unset env(test)
+} {}
if {[info commands exec] == ""} {
puts "exec not implemented for this machine"
return
@@ -76,42 +101,42 @@ foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH} {
}
}
-test env-1.1 {adding environment variables} {
+test env-2.1 {adding environment variables} {
getenv
} {}
set env(NAME1) "test string"
-test env-1.2 {adding environment variables} {
+test env-2.2 {adding environment variables} {
getenv
} {NAME1=test string}
set env(NAME2) "more"
-test env-1.3 {adding environment variables} {
+test env-2.3 {adding environment variables} {
getenv
} {NAME1=test string
NAME2=more}
set env(XYZZY) "garbage"
-test env-1.4 {adding environment variables} {
+test env-2.4 {adding environment variables} {
getenv
} {NAME1=test string
NAME2=more
XYZZY=garbage}
set env(NAME2) "new value"
-test env-2.1 {changing environment variables} {
+test env-3.1 {changing environment variables} {
getenv
} {NAME1=test string
NAME2=new value
XYZZY=garbage}
unset env(NAME2)
-test env-3.1 {unsetting environment variables} {
+test env-4.1 {unsetting environment variables} {
getenv
} {NAME1=test string
XYZZY=garbage}
unset env(NAME1)
-test env-3.2 {unsetting environment variables} {
+test env-4.2 {unsetting environment variables} {
getenv
} {XYZZY=garbage}
diff --git a/contrib/tcl/tests/expr-old.test b/contrib/tcl/tests/expr-old.test
index b2f577e6af4a..8fb8ad9f996c 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.61 97/08/13 10:26:38
+# SCCS: @(#) expr-old.test 1.63 97/10/31 17:23:24
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -78,6 +78,12 @@ test expr-old-1.49 {integer operators} {expr -36%-5} -1
test expr-old-1.50 {integer operators} {expr +36} 36
test expr-old-1.51 {integer operators} {expr +--++36} 36
test expr-old-1.52 {integer operators} {expr +36%+5} 1
+test expr-old-1.53 {integer operators} {
+ catch {unset x}
+ set x yes
+ list [expr {1 && $x}] [expr {$x && 1}] \
+ [expr {0 || $x}] [expr {$x || 0}]
+} {1 1 1 1}
# Check the floating-point operators individually, along with
# automatic conversion to integers where needed.
@@ -694,9 +700,19 @@ test expr-old-32.23 {math functions in expressions} {
test expr-old-32.24 {math functions in expressions} {
format %.6g [expr abs(66)]
} {66}
-test expr-old-32.25 {math functions in expressions} {nonPortable} {
- list [catch {expr abs(0x80000000)} msg] $msg
-} {1 {integer value too large to represent}}
+
+# The following test is different for 32-bit versus 64-bit architectures.
+
+if {0x80000000 > 0} {
+ test expr-old-32.25 {math functions in expressions} {nonPortable} {
+ list [catch {expr abs(0x8000000000000000)} msg] $msg
+ } {1 {integer value too large to represent}}
+} else {
+ test expr-old-32.25 {math functions in expressions} {nonPortable} {
+ list [catch {expr abs(0x80000000)} msg] $msg
+ } {1 {integer value too large to represent}}
+}
+
test expr-old-32.26 {math functions in expressions} {
expr double(1)
} {1.0}
diff --git a/contrib/tcl/tests/expr.test b/contrib/tcl/tests/expr.test
index e0825f971fa2..3c4779fc9b76 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.33 97/08/07 10:45:57
+# SCCS: @(#) expr.test 1.39 97/11/03 16:04:47
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -292,9 +292,19 @@ test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8
-test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} {
- expr {1<<31}
-} -2147483648
+
+# The following test is different for 32-bit versus 64-bit
+# architectures because LONG_MIN is different
+
+if {0x80000000 > 0} {
+ test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} {
+ expr {1<<63}
+ } -9223372036854775808
+} else {
+ test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} {
+ expr {1<<31}
+ } -2147483648
+}
test expr-9.6 {CompileRelationalExpr: error in shift expr} {
catch {expr x>>3} msg
set msg
@@ -540,7 +550,11 @@ test expr-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} {
} {syntax error in expression "2+(3*(4+5)"
while executing
"expr 2+(3*(4+5)"}
-test expr-14.31 {CompilePrimaryExpr: unexpected token} {
+test expr-14.31 {CompilePrimaryExpr: just var ref in subexpression primary} {
+ set i "5+10"
+ list "[expr $i] == 15" "[expr ($i)] == 15" "[eval expr ($i)] == 15"
+} {{15 == 15} {15 == 15} {15 == 15}}
+test expr-14.32 {CompilePrimaryExpr: unexpected token} {
catch {expr @} msg
set errorInfo
} {syntax error in expression "@"
@@ -602,9 +616,22 @@ if $gotT1 {
} -17.5
}
+test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
+ catch {unset a}
+ set a(VALUE) ff15
+ set i 123
+ if {[expr 0x$a(VALUE)] & 16} {
+ set i {}
+ }
+ set i
+} {}
+test expr-16.2 {GetToken: check for string literal in braces} {
+ expr {{1}}
+} {1}
+
# Check "expr" and computed command names.
-test expr-16.1 {expr and computed command names} {
+test expr-17.1 {expr and computed command names} {
set i 0
set z expr
$z 1+2
@@ -614,7 +641,7 @@ test expr-16.1 {expr and computed command names} {
# an integer, convert to integer. Otherwise, if the string looks like a
# double, convert to double.
-test expr-17.1 {expr and conversion of operands to numbers} {
+test expr-18.1 {expr and conversion of operands to numbers} {
set x [lindex 11 0]
catch {expr int($x)}
expr {$x}
@@ -623,7 +650,7 @@ test expr-17.1 {expr and conversion of operands to numbers} {
# Check "expr" and interpreter result object resetting before appending
# an error msg during evaluation of exprs not in {}s
-test expr-18.1 {expr and interpreter result object resetting} {
+test expr-19.1 {expr and interpreter result object resetting} {
proc p {} {
set t 10.0
set x 2.0
@@ -639,3 +666,5 @@ test expr-18.1 {expr and interpreter result object resetting} {
}
p
} 3
+
+unset a
diff --git a/contrib/tcl/tests/fCmd.test b/contrib/tcl/tests/fCmd.test
index e7d2279ef194..ae2b8b08cf9a 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.31 97/08/05 11:42:09
+# SCCS: @(#) fCmd.test 1.33 97/11/03 15:58:08
#
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -304,10 +304,15 @@ test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} {
file mkdir td1
list $x [file exist td1]
} {0 1}
-test fCmd-4.14 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {unixOnly nonPortable} {
+test fCmd-4.14 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {unixOnly} {
cleanup
- list [catch {file mkdir /tf1} msg] $msg
-} {1 {can't create directory "/tf1": permission denied}}
+ file delete -force foo
+ file mkdir foo
+ file attr foo -perm 040000
+ set result [list [catch {file mkdir foo/tf1} msg] $msg]
+ file delete -force foo
+ set result
+} {1 {can't create directory "foo/tf1": permission denied}}
test fCmd-4.15 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {macOnly} {
list [catch {file mkdir ${root}:} msg] $msg
} [subst {1 {can't create directory "${root}:": no such file or directory}}]
@@ -568,15 +573,17 @@ test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} {unixOnly xdev} {
file rename td1 /tmp
glob td* /tmp/td1/t*
} {/tmp/td1/td2}
-test fCmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} {unixOnly nonPortable} {
+test fCmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} {unixOnly} {
cleanup
- if [file exists /kernel] {
- set msg [list [catch {file rename /kernel td1} msg] $msg]
- set a1 {1 {can't unlink "/kernel": permission denied}}
- expr {$msg == $a1}
- } else {
- list 1
- }
+ file mkdir foo/bar
+ file attr foo -perm 040555
+ set msg [list [catch {file rename foo/bar /tmp} msg] $msg]
+ set a1 {1 {can't unlink "foo/bar": permission denied}}
+ set result [expr {$msg == $a1}]
+ catch {file delete /tmp/bar}
+ catch {file attr foo -perm 040777}
+ catch {file delete -force foo}
+ set result
} {1}
test fCmd-6.31 {CopyRenameOneFile: TclpDeleteFile passed} {unixOnly xdev} {
catch {cleanup /tmp}
@@ -618,15 +625,24 @@ test fCmd-7.5 {FileForceOption: multiple times through loop} {
list [catch {glob -- -- -force} msg] $msg
} {1 {no files matched glob patterns "-- -force"}}
-test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} {unixOnly nonPortable} {
- list [catch {file rename ~$user /} msg] $msg
-} "1 {error renaming \"~$user\" to \"/[file tail ~$user]\": permission denied}"
+test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} {unixOnly} {
+ file mkdir td1
+ file attr td1 -perm 040000
+ set result [list [catch {file rename ~$user td1} msg] $msg]
+ file delete -force td1
+ set result
+} "1 {error renaming \"~$user\" to \"td1/[file tail ~$user]\": permission denied}"
test fCmd-9.1 {file rename: comprehensive: EACCES} {unixOnly} {
cleanup
file mkdir td1
- list [catch {file rename td1 /} msg] $msg
-} {1 {error renaming "td1" to "/td1": permission denied}}
+ file mkdir td2
+ file attr td2 -perm 040000
+ set result [list [catch {file rename td1 td2/} msg] $msg]
+ file delete -force td2
+ file delete -force td1
+ set result
+} {1 {error renaming "td1" to "td2/td1": permission denied}}
test fCmd-9.2 {file rename: comprehensive: source doesn't exist} {
cleanup
list [catch {file rename tf1 tf2} msg] $msg
diff --git a/contrib/tcl/tests/fileName.test b/contrib/tcl/tests/fileName.test
index f6be5acc3550..e0f7260f2cee 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.30 97/08/01 11:13:27
+# SCCS: @(#) fileName.test 1.31 97/08/19 18:45:07
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -1313,16 +1313,30 @@ if {$tcl_platform(platform) == "unix"} {
# On some systems, like AFS, "000" protection doesn't prevent
# access by owner, so the following test is not portable.
- exec chmod 000 globTest
+ exec chmod 000 globTest/a1
test filename-15.1 {unix specific globbing} {nonPortable} {
- 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} {
+ string tolower [list [catch {glob globTest/a1/*} msg] $msg $errorCode]
+ } {1 {couldn't read directory "globtest/a1": permission denied} {posix eacces {permission denied}}}
+ test filename-15.2 {unix specific no complain: no errors} {nonPortable} {
+ glob -nocomplain globTest/a1/*
+ } {}
+ test filename-15.3 {unix specific no complain: no errors, good result} {nonPortable knownBug} {
+ # test fails because if an error occur , the interp's result
+ # is reset...
+ glob -nocomplain globTest/a2 globTest/a1/* globTest/a3
+ } {globTest/a2 globTest/a3}
+ exec chmod 755 globTest/a1
+ test filename-15.4 {unix specific no complain: no errors, good result} {nonPortable knownBug} {
+ # test fails because if an error occur , the interp's result
+ # is reset... (or you don't run at sunscript where the
+ # outser and demailly's users exists
+ glob -nocomplain ~ouster ~foo ~demailly
+ } {/home/ouster /home/demailly}
+ test filename-15.5 {unix specific globbing} {nonPortable} {
glob ~ouster/.csh*
} "/home/ouster/.cshrc"
close [open globTest/odd\\\[\]*?\{\}name w]
- test filename-15.3 {unix specific globbing} {
+ test filename-15.6 {unix specific globbing} {
global env
set temp $env(HOME)
set env(HOME) $env(HOME)/globTest/odd\\\[\]*?\{\}name
diff --git a/contrib/tcl/tests/format.test b/contrib/tcl/tests/format.test
index 680b626af0b0..758825ba293c 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.28 97/08/11 14:45:15
+# SCCS: @(#) format.test 1.29 97/09/03 15:51:02
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -411,6 +411,26 @@ test format-12.5 {tcl_precision fuzzy comparison} {
set c [expr $a + $b]
format {%0.10f %0.12f %0.15f} $c $c $c
} {1.4444444444 1.444444444444 1.444444444443990}
+test format-13.1 {testing MAX_FLOAT_SIZE for 0 and 1} {
+ format {%s} ""
+} {}
+test format-13.2 {testing MAX_FLOAT_SIZE for 0 and 1} {
+ format {%s} "a"
+} {a}
+
+set a "0123456789"
+set b ""
+for {set i 0} {$i < 290} {incr i} {
+ append b $a
+}
+for {set i 290} {$i < 400} {incr i} {
+ test format-14.[expr $i -290] {testing MAX_FLOAT_SIZE} {
+ format {%s} $b
+ } $b
+ append b "x"
+}
+
+
catch {unset a}
catch {unset b}
catch {unset c}
diff --git a/contrib/tcl/tests/get.test b/contrib/tcl/tests/get.test
index 50e68bb03112..5155b95e2d3d 100644
--- a/contrib/tcl/tests/get.test
+++ b/contrib/tcl/tests/get.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: @(#) get.test 1.6 96/10/08 17:39:21
+# SCCS: @(#) get.test 1.7 97/10/31 17:23:00
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -39,24 +39,43 @@ test get-1.6 {Tcl_GetInt procedure} {
} {1 {expected integer but got "16 x"}}
# The following tests are non-portable because they depend on
-# word size.
+# word size. 18446744073709551614
-test get-1.7 {Tcl_GetInt procedure} {nonPortable unixOnly} {
- set x 44
- list [catch {incr x 4294967296} msg] $msg $errorCode
-} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
-test get-1.8 {Tcl_GetInt procedure} {nonPortable} {
- set x 0
- list [catch {incr x 4294967294} msg] $msg
-} {0 -2}
-test get-1.9 {Tcl_GetInt procedure} {nonPortable} {
- set x 0
- list [catch {incr x +4294967294} msg] $msg
-} {0 -2}
-test get-1.10 {Tcl_GetInt procedure} {nonPortable} {
- set x 0
- list [catch {incr x -4294967294} msg] $msg
-} {0 2}
+if {0x80000000 > 0} {
+ test get-1.7 {Tcl_GetInt procedure} {nonPortable unixOnly} {
+ set x 44
+ list [catch {incr x 18446744073709551616} msg] $msg $errorCode
+ } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
+ test get-1.8 {Tcl_GetInt procedure} {nonPortable} {
+ set x 0
+ list [catch {incr x 18446744073709551614} msg] $msg
+ } {0 -2}
+ test get-1.9 {Tcl_GetInt procedure} {nonPortable} {
+ set x 0
+ list [catch {incr x +18446744073709551614} msg] $msg
+ } {0 -2}
+ test get-1.10 {Tcl_GetInt procedure} {nonPortable} {
+ set x 0
+ list [catch {incr x -18446744073709551614} msg] $msg
+ } {0 2}
+} else {
+ test get-1.7 {Tcl_GetInt procedure} {nonPortable unixOnly} {
+ set x 44
+ list [catch {incr x 4294967296} msg] $msg $errorCode
+ } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
+ test get-1.8 {Tcl_GetInt procedure} {nonPortable} {
+ set x 0
+ list [catch {incr x 4294967294} msg] $msg
+ } {0 -2}
+ test get-1.9 {Tcl_GetInt procedure} {nonPortable} {
+ set x 0
+ list [catch {incr x +4294967294} msg] $msg
+ } {0 -2}
+ test get-1.10 {Tcl_GetInt procedure} {nonPortable} {
+ set x 0
+ list [catch {incr x -4294967294} msg] $msg
+ } {0 2}
+}
test get-2.1 {Tcl_GetInt procedure} {
format %g 1.23
diff --git a/contrib/tcl/tests/init.test b/contrib/tcl/tests/init.test
new file mode 100644
index 000000000000..2d6e068412b6
--- /dev/null
+++ b/contrib/tcl/tests/init.test
@@ -0,0 +1,149 @@
+# Functionality covered: this file contains a collection of tests for the
+# auto loading and namespaces.
+#
+# Sourcing this file into Tcl runs the tests and generates output for
+# errors. No output means no errors were found.
+#
+# 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: @(#) init.test 1.5 97/11/19 18:08:20
+
+
+if {[string compare test [info procs test]] == 1} then {source defs}
+
+# Clear out any namespaces called test_ns_*
+catch {eval namespace delete [namespace children :: test_ns_*]}
+
+# Six cases - white box testing
+
+test init-1.1 {auto_qualify - absolute cmd - namespace} {
+ auto_qualify ::foo::bar ::blue
+} ::foo::bar
+
+test init-1.2 {auto_qualify - absolute cmd - global} {
+ auto_qualify ::global ::sub
+} global
+
+test init-1.3 {auto_qualify - no colons cmd - global} {
+ auto_qualify nocolons ::
+} nocolons
+
+test init-1.4 {auto_qualify - no colons cmd - namespace} {
+ auto_qualify nocolons ::sub
+} {::sub::nocolons nocolons}
+
+test init-1.5 {auto_qualify - colons in cmd - global} {
+ auto_qualify foo::bar ::
+} ::foo::bar
+
+test init-1.6 {auto_qualify - colons in cmd - namespace} {
+ auto_qualify foo::bar ::sub
+} {::sub::foo::bar ::foo::bar}
+
+# Some additional tests
+
+test init-1.7 {auto_qualify - multiples colons 1} {
+ auto_qualify :::foo::::bar ::blue
+} ::foo::bar
+
+test init-1.8 {auto_qualify - multiple colons 2} {
+ auto_qualify :::foo ::bar
+} foo
+
+
+# we use a sub interp and auto_reset and double the tests because there is 2
+# places where auto_loading occur (before loading the indexes files and after)
+
+set testInterp [interp create]
+interp eval $testInterp [list set VERBOSE $VERBOSE]
+interp eval $testInterp [list set TESTS $TESTS]
+
+interp eval $testInterp {
+
+if {[string compare test [info procs test]] == 1} then {source defs}
+
+auto_reset
+catch {rename parray {}}
+
+test init-2.0 {load parray - stage 1} {
+ set ret [catch {namespace eval ::test {parray}} error]
+ rename parray {} ; # remove it, for the next test - that should not fail.
+ list $ret $error
+} {1 {no value given for parameter "a" to "parray"}}
+
+
+test init-2.1 {load parray - stage 2} {
+ set ret [catch {namespace eval ::test {parray}} error]
+ list $ret $error
+} {1 {no value given for parameter "a" to "parray"}}
+
+
+auto_reset
+catch {rename ::safe::setLogCmd {}}
+#unset auto_index(::safe::setLogCmd)
+#unset auto_oldpath
+
+test init-2.2 {load ::safe::setLogCmd - stage 1} {
+ ::safe::setLogCmd
+ rename ::safe::setLogCmd {} ; # should not fail
+} {}
+
+test init-2.3 {load ::safe::setLogCmd - stage 2} {
+ ::safe::setLogCmd
+ rename ::safe::setLogCmd {} ; # should not fail
+} {}
+
+auto_reset
+catch {rename ::safe::setLogCmd {}}
+
+test init-2.4 {load safe:::setLogCmd - stage 1} {
+ safe:::setLogCmd ; # intentionally 3 :
+ rename ::safe::setLogCmd {} ; # should not fail
+} {}
+
+test init-2.5 {load safe:::setLogCmd - stage 2} {
+ safe:::setLogCmd ; # intentionally 3 :
+ rename ::safe::setLogCmd {} ; # should not fail
+} {}
+
+auto_reset
+catch {rename ::safe::setLogCmd {}}
+
+test init-2.6 {load setLogCmd from safe:: - stage 1} {
+ namespace eval safe setLogCmd
+ rename ::safe::setLogCmd {} ; # should not fail
+} {}
+
+test init-2.7 {oad setLogCmd from safe:: - stage 2} {
+ namespace eval safe setLogCmd
+ rename ::safe::setLogCmd {} ; # should not fail
+} {}
+
+
+auto_reset
+package require http 2.0
+catch {rename ::http::geturl {}}
+
+test init-2.8 {load http::geturl (package)} {
+ # 3 ':' on purpose
+ set ret [catch {namespace eval ::test {http:::geturl}} error]
+ # removing it, for the next test. should not fail.
+ rename ::http::geturl {} ;
+ list $ret $error
+} {1 {no value given for parameter "url" to "http:::geturl"}}
+
+
+test init-3.0 {random stuff in the auto_index, should still work} {
+ set auto_index(foo:::bar::blah) {
+ namespace eval foo {namespace eval bar {proc blah {} {return 1}}}
+ }
+ foo:::bar::blah
+} 1
+
+}
+
+interp delete $testInterp
+
diff --git a/contrib/tcl/tests/interp.test b/contrib/tcl/tests/interp.test
index 9127bcb54bcf..919774f7bb32 100644
--- a/contrib/tcl/tests/interp.test
+++ b/contrib/tcl/tests/interp.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: @(#) interp.test 1.61 97/08/04 19:59:52
+# SCCS: @(#) interp.test 1.64 97/09/04 16:02:23
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -1974,6 +1974,43 @@ test interp-26.2 {result code transmission 2} {knownBug} {
list $res
} {-1 0 1 2 3 4 5}
+test interp-26.3 {errorInfo transmission : regular interps} {
+ set interp [interp create];
+ proc MyError {secret} {
+ return -code error "msg"
+ }
+ proc MyTestAlias {interp args} {
+ MyError "some secret"
+ }
+ interp alias $interp test {} MyTestAlias $interp;
+ set res [interp eval $interp {catch test;set errorInfo}]
+ interp delete $interp;
+ set res
+} {msg
+ while executing
+"MyError "some secret""
+ (procedure "test" line 2)
+ invoked from within
+"catch test"}
+
+test interp-26.4 {errorInfo transmission : safe interps} {knownBug} {
+ # this test fails because the errorInfo is fully transmitted
+ # whether the interp is safe or not. this is maybe a feature
+ # and not a bug.
+ set interp [interp create -safe];
+ proc MyError {secret} {
+ return -code error "msg"
+ }
+ proc MyTestAlias {interp args} {
+ MyError "some secret"
+ }
+ interp alias $interp test {} MyTestAlias $interp;
+ set res [interp eval $interp {catch test;set errorInfo}]
+ interp delete $interp;
+ set res
+} {msg
+ while executing
+"catch test"}
# Interps & Namespaces
test interp-27.1 {interp aliases & namespaces} {
@@ -2153,12 +2190,68 @@ test interp-28.1 {getting fooled by slave's namespace ?} {
set r
} {}
+# Tests of recursionlimit
+# We need testsetrecursionlimit so we need Tcltest package
+if {[catch {package require Tcltest} msg]} {
+ puts "This application hasn't been compiled with Tcltest"
+ puts "skipping remining interp tests that relies on it."
+} else {
+ #
+test interp-29.1 {recursion limit} {
+ set i [interp create]
+ load {} Tcltest $i
+ set r [interp eval $i {
+ testsetrecursionlimit 50
+ proc p {} {incr ::i; p}
+ set i 0
+ catch p
+ set i
+ }]
+ interp delete $i
+ set r
+} 49
+
+test interp-29.2 {recursion limit inheritance} {
+ set i [interp create]
+ load {} Tcltest $i
+ set ii [interp eval $i {
+ testsetrecursionlimit 50
+ interp create
+ }]
+ set r [interp eval [list $i $ii] {
+ proc p {} {incr ::i; p}
+ set i 0
+ catch p
+ set i
+ }]
+ interp delete $i
+ set r
+} 49
+
+# # Deep recursion (into interps when the regular one fails):
+# # still crashes...
+# proc p {} {
+# if {[catch p ret]} {
+# catch {
+# set i [interp create]
+# interp eval $i [list proc p {} [info body p]]
+# interp eval $i p
+# }
+# interp delete $i
+# return ok
+# }
+# return $ret
+# }
+# p
+
# 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 739248281a6d..2b6670fb9e20 100644
--- a/contrib/tcl/tests/io.test
+++ b/contrib/tcl/tests/io.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: @(#) io.test 1.128 97/08/13 10:24:56
+# SCCS: @(#) io.test 1.131 97/09/22 11:15:05
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -3439,6 +3439,58 @@ test io-16.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} {
close $f
set x
} 40000
+test io-16.14 {Tcl_SetChannelOption, setting read mode independently} \
+ {socket} {
+ proc accept {s a p} {close $s}
+ set s1 [socket -server accept 0]
+ set port [lindex [fconfigure $s1 -sockname] 2]
+ set s2 [socket localhost $port]
+ update
+ fconfigure $s2 -translation {auto lf}
+ set modes [fconfigure $s2 -translation]
+ close $s1
+ close $s2
+ set modes
+} {auto lf}
+test io-16.15 {Tcl_SetChannelOption, setting read mode independently} \
+ {socket} {
+ proc accept {s a p} {close $s}
+ set s1 [socket -server accept 0]
+ set port [lindex [fconfigure $s1 -sockname] 2]
+ set s2 [socket localhost $port]
+ update
+ fconfigure $s2 -translation {auto crlf}
+ set modes [fconfigure $s2 -translation]
+ close $s1
+ close $s2
+ set modes
+} {auto crlf}
+test io-16.16 {Tcl_SetChannelOption, setting read mode independently} \
+ {socket} {
+ proc accept {s a p} {close $s}
+ set s1 [socket -server accept 0]
+ set port [lindex [fconfigure $s1 -sockname] 2]
+ set s2 [socket localhost $port]
+ update
+ fconfigure $s2 -translation {auto cr}
+ set modes [fconfigure $s2 -translation]
+ close $s1
+ close $s2
+ set modes
+} {auto cr}
+test io-16.17 {Tcl_SetChannelOption, setting read mode independently} \
+ {socket} {
+ proc accept {s a p} {close $s}
+ set s1 [socket -server accept 0]
+ set port [lindex [fconfigure $s1 -sockname] 2]
+ set s2 [socket localhost $port]
+ update
+ fconfigure $s2 -translation {auto auto}
+ set modes [fconfigure $s2 -translation]
+ close $s1
+ close $s2
+ set modes
+} {auto crlf}
test io-17.1 {POSIX open access modes: RDWR} {
removeFile test3
@@ -5054,6 +5106,25 @@ test io-32.1 {ChannelEventScriptInvoker: deletion} {
set x
} {got_error}
+test io-33.1 {ChannelTimerProc} {
+ set f [open fooBar w]
+ puts $f "this is a test"
+ close $f
+ set f [open fooBar r]
+ testchannelevent $f add readable {
+ read $f 1
+ incr x
+ }
+ set x 0
+ vwait x
+ vwait x
+ set result $x
+ testchannelevent $f set 0 none
+ after idle {set y done}
+ vwait y
+ lappend result $y
+} {2 done}
+
removeFile fooBar
removeFile longfile
removeFile script
diff --git a/contrib/tcl/tests/ioCmd.test b/contrib/tcl/tests/ioCmd.test
index 95a5975594e4..fd39263a0ed4 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.48 97/08/01 11:11:23"
+# "@(#) ioCmd.test 1.49 97/10/31 17:23:22"
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -281,11 +281,11 @@ test iocmd-8.17 {fconfigure command / tcp channel} {nonPortable} {
update;
puts $cli "blah"; flush $cli; # that flush could/should fail too
update;
- set r [list [catch {fconfigure $cli -peername} msg] $msg];
+ set r [catch {fconfigure $cli -peername} msg]
iocmdSSHTDWN
regsub -all {can([^:])+: } $r {} r;
set r
-} {1 {connection reset by peer}}
+} 1
test iocmd-8.18 {fconfigure command / unix tty channel} {nonPortable unixOnly} {
# might fail if /dev/ttya is unavailable
set tty [open /dev/ttya]
diff --git a/contrib/tcl/tests/join.test b/contrib/tcl/tests/join.test
index 4023de2cab6a..62af644fa088 100644
--- a/contrib/tcl/tests/join.test
+++ b/contrib/tcl/tests/join.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: @(#) join.test 1.6 96/02/16 08:56:02
+# SCCS: @(#) join.test 1.7 97/10/06 13:04:59
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -36,3 +36,13 @@ test join-2.2 {join errors} {
test join-2.3 {join errors} {
list [catch {join "a \{ c" 111} msg] $msg $errorCode
} {1 {unmatched open brace in list} NONE}
+
+test join-3.1 {joinString is binary ok} {
+ string length [join {a b c} a\0b]
+} 9
+
+test join-3.2 {join is binary ok} {
+ string length [join "a\0b a\0b a\0b"]
+} 11
+
+
diff --git a/contrib/tcl/tests/linsert.test b/contrib/tcl/tests/linsert.test
index 6611394a6182..86a47f5290df 100644
--- a/contrib/tcl/tests/linsert.test
+++ b/contrib/tcl/tests/linsert.test
@@ -10,10 +10,13 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) linsert.test 1.13 97/02/27 16:53:19
+# SCCS: @(#) linsert.test 1.14 97/11/18 13:54:18
if {[string compare test [info procs test]] == 1} then {source defs}
+catch {unset lis}
+catch {rename p ""}
+
test linsert-1.1 {linsert command} {
linsert {1 2 3 4 5} 0 a
} {a 1 2 3 4 5}
@@ -92,3 +95,11 @@ test linsert-3.1 {linsert won't modify shared argument objects} {
}
p
} "a b c"
+test linsert-3.2 {linsert won't modify shared argument objects} {
+ catch {unset lis}
+ set lis [format "a \"%s\" c" "b"]
+ linsert $lis 0 [string length $lis]
+} "7 a b c"
+
+catch {unset lis}
+catch {rename p ""}
diff --git a/contrib/tcl/tests/lreplace.test b/contrib/tcl/tests/lreplace.test
index 197084e7bd21..44e8ee17525f 100644
--- a/contrib/tcl/tests/lreplace.test
+++ b/contrib/tcl/tests/lreplace.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: @(#) lreplace.test 1.15 96/12/16 21:43:57
+# SCCS: @(#) lreplace.test 1.16 97/10/29 16:32:39
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -89,6 +89,13 @@ test lreplace-1.24 {lreplace command} {
test lreplace-1.25 {lreplace command} {
concat \"[lreplace {\}\ hello} end end]\"
} {"\}\ "}
+test lreplace-1.26 {lreplace command} {
+ catch {unset foo}
+ set foo {a b}
+ list [set foo [lreplace $foo end end]] \
+ [set foo [lreplace $foo end end]] \
+ [set foo [lreplace $foo end end]]
+} {a {} {}}
test lreplace-2.1 {lreplace errors} {
@@ -120,3 +127,5 @@ test lreplace-3.1 {lreplace won't modify shared argument objects} {
}
p
} "a b c"
+
+catch {unset foo}
diff --git a/contrib/tcl/tests/obj.test b/contrib/tcl/tests/obj.test
index e8ee3b32f94f..08f230b542be 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.11 97/08/06 08:56:09
+# @(#) obj.test 1.12 97/10/31 17:23:23
if {[info commands testobj] == {}} {
puts "This application hasn't been compiled with the \"testobj\""
@@ -411,10 +411,10 @@ test obj-24.5 {SetIntFromAny, error parsing string} {
} {x17 1 {expected integer but got "x17"}}
test obj-24.6 {SetIntFromAny, integer too large} {nonPortable} {
set result ""
- lappend result [teststringobj set 1 12345678901234567890]
+ lappend result [teststringobj set 1 123456789012345678901]
lappend result [catch {testintobj mult10 1} msg]
lappend result $msg
-} {12345678901234567890 1 {integer value too large to represent}}
+} {123456789012345678901 1 {integer value too large to represent}}
test obj-24.7 {SetIntFromAny, error converting from "empty string"} {
set result ""
lappend result [testobj newobj 1]
diff --git a/contrib/tcl/tests/opt.test b/contrib/tcl/tests/opt.test
index 2f23bc6890dc..0b35b764a451 100644
--- a/contrib/tcl/tests/opt.test
+++ b/contrib/tcl/tests/opt.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: @(#) opt.test 1.1 97/08/14 00:53:59
+# SCCS: @(#) opt.test 1.2 97/08/20 15:57:18
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -149,6 +149,7 @@ test opt-8.10 {List utilities} {
} {{b c 7 e} f}
test opt-8.11 {List utilities} {
+ catch {unset x}
set l {a {b c 7 e} f}
list [::tcl::Lassign $l u v w x] \
$u $v $w [info exists x]
@@ -173,11 +174,11 @@ test opt-9.2 {Misc utilities} {
#### behaviour tests #####
test opt-10.1 {ambigous flags} {
- ::tcl::OptProc optTest {{-flag1xyz} {-other} {-flag2xyz} {-flag3xyz}} {}
+ ::tcl::OptProc optTest {{-fla} {-other} {-flag2xyz} {-flag3xyz}} {}
catch {optTest -fL} msg
set msg
} {ambigous option "-fL", choose from:
- -flag1xyz boolflag (false)
+ -fla boolflag (false)
-flag2xyz boolflag (false)
-flag3xyz boolflag (false) }
@@ -188,6 +189,24 @@ test opt-10.2 {non ambigous flags} {
optTest -fLaG2
} 1
+test opt-10.3 {non ambigous flags because of exact match} {
+ ::tcl::OptProc optTest {{-flag1x} {-other} {-flag1} {-flag1xy}} {
+ return $flag1
+ }
+ optTest -flAg1
+} 1
+
+test opt-10.4 {ambigous flags, not exact match} {
+ ::tcl::OptProc optTest {{-flag1xy} {-other} {-flag1} {-flag1xyz}} {
+ return $flag1
+ }
+ catch {optTest -fLag1X} msg
+ set msg
+} {ambigous option "-fLag1X", choose from:
+ -flag1xy boolflag (false)
+ -flag1xyz boolflag (false) }
+
+
# medium size overall test example: (defined once)
::tcl::OptProc optTest {
@@ -200,13 +219,13 @@ test opt-10.2 {non ambigous flags} {
list $cmd $allowBoing $arg2 $arg3 $moreflags
}
-test opt-10.3 {medium size overall test} {
+test opt-10.5 {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} {
+test opt-10.6 {medium size overall test} {
list [catch {optTest -help} msg] $msg
} {1 {Usage information:
Var/FlagName Type Value Help
@@ -218,19 +237,19 @@ test opt-10.4 {medium size overall test} {
?arg3? int (7) optional number
-moreflags boolflag (false) }}
-test opt-10.5 {medium size overall test} {
+test opt-10.7 {medium size overall test} {
optTest save tst
} {save 1 tst 7 0}
-test opt-10.6 {medium size overall test} {
+test opt-10.8 {medium size overall test} {
optTest save -allowBoing false -- 8
} {save 0 8 7 0}
-test opt-10.7 {medium size overall test} {
+test opt-10.9 {medium size overall test} {
optTest save tst -m --
} {save 1 tst 7 1}
-test opt-10.8 {medium size overall test} {
+test opt-10.10 {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/resource.test b/contrib/tcl/tests/resource.test
index efb3c8270a77..e815ef8c494d 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.6 97/07/23 17:41:51
+# SCCS: @(#) resource.test 1.8 97/11/06 12:36:32
# Only run this test on Macintosh systems
if {$tcl_platform(platform) != "macintosh"} {
@@ -22,7 +22,7 @@ test resource-1.1 {resource tests} {
} {1 {wrong # args: should be "resource option ?arg ...?"}}
test resource-1.2 {resource tests} {
list [catch {resource _bad_} msg] $msg
-} {1 {bad option "_bad_": must be close, list, open, read, types, or write}}
+} {1 {bad option "_bad_": must be close, delete, files, list, open, read, types, or write}}
# resource open & close tests
test resource-2.1 {resource open & close tests} {
@@ -41,16 +41,34 @@ 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
+ file delete rsrc.file
} {}
test resource-2.6 {resource open & close tests} {
+ catch {file delete rsrc.file}
+ testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"}
+ set id [resource open rsrc.file]
+ set result [string compare [resource open rsrc.file] $id]
+ resource close $id
+ file delete rsrc.file
+ set result
+} {0}
+test resource-2.7 {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} {
+test resource-2.8 {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} {
+test resource-2.9 {resource open & close tests} {
list [catch {resource close _bad_resource_} msg] $msg
} {1 {invalid resource file reference "_bad_resource_"}}
+test resource-2.10 {resource open & close tests} {
+ set result [catch {resource close System} mssg]
+ lappend result $mssg
+} {1 {can't close "System" resource file}}
+test resource-2.11 {resource open & close tests} {
+ set result [catch {resource close application} mssg]
+ lappend result $mssg
+} {1 {can't close "application" resource file}}
# Tests for listing resources
test resource-3.1 {resource list tests} {
@@ -74,7 +92,7 @@ test resource-3.5 {resource list tests} {
set result
} {fileRsrcName}
test resource-3.6 {resource list tests} {
- # There should be any resource of this type
+ # There should not be any resource of this type
resource list XXXX
} {}
test resource-3.7 {resource list tests} {
@@ -86,7 +104,7 @@ test resource-3.7 {resource list tests} {
}
} {ok}
-# Tests for listing resources
+# Tests for reading resources
test resource-4.1 {resource read tests} {
list [catch {resource read} msg] $msg
} {1 {wrong # args: should be "resource read resourceType resourceId ?resourceRef?"}}
@@ -123,43 +141,197 @@ test resource-5.4 {resource types tests} {
# 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"}}
+} {1 {wrong # args: should be "resource write ?-id resourceId? ?-name resourceName? ?-file resourceRef? ?-force? 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 close $id
+ set id [resource open rsrc2.file r]
+ set result [catch {resource write -file $id -name Hello TEXT foo} errMsg]
+ lappend result [string compare $errMsg "cannot write to resource file \"$id\", it was opened read only"]
+ lappend result [lsearch [resource list TEXT $id] Hello]
+ resource close $id
+ file delete rsrc2.file
+ set result
+} {1 0 -1}
+test resource-6.4 {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}
+test resource-6.5 {resource write tests} {
+ catch {file delete rsrc2.file}
+ set id [resource open rsrc2.file w]
+ resource write -file $id -id 256 TEXT {HAHAHAHAHAHAHA}
+ set result [catch {resource write -file $id -id 256 TEXT {HOHOHOHOHOHO}} mssg]
+ resource close $id
+ file delete rsrc2.file
+ lappend result $mssg
+} {1 {the resource 256 already exists, use "-force" to overwrite it.}}
+test resource-6.6 {resource write tests} {
+ catch {file delete rsrc2.file}
+ testWriteTextResource -rsrc fileRsrcName -rsrcid 256 -file rsrc2.file -protected {error "don't tread on me"}
+ set id [resource open rsrc2.file w]
+ set result [catch {resource write -id 256 -force -file $id TEXT {NAHNAHNANAHNAH}} mssg]
+ resource close $id
+ file delete rsrc2.file
+ lappend result $mssg
+} {1 {could not write resource id 256 of type TEXT, it was protected.}}
+test resource-6.7 {resource write tests} {
+ catch {file delete rsrc2.file}
+ set id [resource open rsrc2.file w]
+ resource write -file $id -id 256 -name FOO TEXT {set x [list "our first test data"]}
+ resource write -file $id -id 256 -name BAR -force TEXT {set x [list "our second test data"]}
+ source -rsrcid 256 rsrc2.file
+ lappend x [resource list TEXT $id]
+ resource close $id
+ file delete rsrc2.file
+ set x
+} {{our second test data} BAR}
+#Tests for listing open resource files
+test resource-7.1 {resource file tests} {
+ catch {resource files foo bar} mssg
+ set mssg
+} {wrong # args: should be "resource files ?resourceId?"}
+test resource-7.2 {resource file tests} {
+ catch {file delete rsrc2.file}
+ set rsrcFiles [resource files]
+ set id [resource open rsrc2.file w]
+ set result [string compare $rsrcFiles [lrange [resource files] 1 end]]
+ lappend result [string compare $id [lrange [resource files] 0 0]]
+ resource close $id
+ file delete rsrc2.file
+ set result
+} {0 0}
+test resource-7.3 {resource file tests} {
+ set result 0
+ foreach file [resource files] {
+ if {[catch {resource types $file}] != 0} {
+ set result 1
+ }
+ }
+ set result
+} {0}
+test resource-7.4 {resource file tests} {
+ catch {resource files __NO_SUCH_RESOURCE__} mssg
+ set mssg
+} {invalid resource file reference "__NO_SUCH_RESOURCE__"}
+test resource-7.5 {resource file tests} {
+ set sys [resource files System]
+ string compare $sys [file join $env(SYS_FOLDER) System]
+} {0}
+test resource-7.6 {resource file tests} {
+ set app [resource files application]
+ string compare $app [info nameofexecutable]
+} {0}
+
+#Tests for the resource delete command
+test resource-8.1 {resource delete tests} {
+ list [catch {resource delete} msg] $msg
+} {1 {wrong # args: should be "resource delete ?-id resourceId? ?-name resourceName? ?-file resourceRef? resourceType"}}
+test resource-8.2 {resource delete tests} {
+ list [catch {resource delete TEXT} msg] $msg
+} {1 {you must specify either "-id" or "-name" or both to "resource delete"}}
+test resource-8.3 {resource delete tests} {
+ set result [catch {resource delete -file ffffff -id 128 TEXT} mssg]
+ lappend result $mssg
+} {1 {invalid resource file reference "ffffff"}}
+test resource-8.4 {resource delete tests} {
+ catch {file delete rsrc2.file}
+ testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
+ set id [resource open rsrc2.file r]
+ set result [catch {resource delete -id 128 -file $id TEXT} mssg]
+ resource close $id
+ file delete rsrc2.file
+ lappend result [string compare $mssg "cannot delete from resource file \"$id\", it was opened read only"]
+} {1 0}
+test resource-8.5 {resource delete tests} {
+ catch {file delete rsrc2.file}
+ testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
+ set id [resource open rsrc2.file w]
+ set result [catch {resource delete -id 128 -file $id _bad_type_} mssg]
+ resource close $id
+ file delete rsrc2.file
+ lappend result $mssg
+} {1 {expected Macintosh OS type but got "_bad_type_"}}
+test resource-8.5 {resource delete tests} {
+ catch {file delete rsrc2.file}
+ set id [resource open rsrc2.file w]
+ set result [catch {resource delete -id 128 -file $id TEXT} mssg]
+ resource close $id
+ file delete rsrc2.file
+ lappend result $mssg
+} {1 {resource not found}}
+test resource-8.6 {resource delete tests} {
+ catch {file delete rsrc2.file}
+ set id [resource open rsrc2.file w]
+ set result [catch {resource delete -name foo -file $id TEXT} mssg]
+ resource close $id
+ file delete rsrc2.file
+ lappend result $mssg
+} {1 {resource not found}}
+test resource-8.7 {resource delete tests} {
+ catch {file delete rsrc2.file}
+ set id [resource open rsrc2.file w]
+ resource write -file $id -name foo -id 128 TEXT {some stuff}
+ resource write -file $id -name bar -id 129 TEXT {some stuff}
+ set result [catch {resource delete -name foo -id 129 -file $id TEXT} mssg]
+ resource close $id
+ file delete rsrc2.file
+ lappend result $mssg
+} {1 {"-id" and "-name" values do not point to the same resource}}
+test resource-8.8 {resource delete tests} {
+ catch {file delete rsrc2.file}
+ testWriteTextResource -rsrc fileRsrcName -rsrcid 256 -file rsrc2.file -protected {error "don't tread on me"}
+ set id [resource open rsrc2.file w]
+ set result [catch {resource delete -id 256 -file $id TEXT } mssg]
+ resource close $id
+ file delete rsrc2.file
+ lappend result $mssg
+} {1 {resource cannot be deleted: it is protected.}}
+test resource-8.9 {resource delete tests} {
+ catch {file delete rsrc2.file}
+ testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
+ set id [resource open rsrc2.file w]
+ set result [resource list TEXT $id]
+ resource delete -id 128 -file $id TEXT
+ lappend result [resource list TEXT $id]
+ resource close $id
+ file delete rsrc2.file
+ set result
+} {fileRsrcName {}}
+
# 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-7.1 {source command} {
+test resource-9.1 {source command} {
catch {unset rsrc_foo}
source -rsrc fileRsrcName rsrc.file
list [catch {set rsrc_foo} msg] $msg
} {0 1}
-test resource-7.2 {source command} {
+test resource-9.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-7.3 {source command} {
+test resource-9.3 {source command} {
catch {unset rsrc_foo}
source -rsrcid 128 rsrc.file
list [catch {set rsrc_foo} msg] $msg
} {0 1}
-test resource-7.4 {source command} {
+test resource-9.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-7.5 {source command} {
+test resource-9.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 d68424bdf404..c23f06aa18c8 100644
--- a/contrib/tcl/tests/safe.test
+++ b/contrib/tcl/tests/safe.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: @(#) safe.test 1.31 97/08/14 00:55:56
+# SCCS: @(#) safe.test 1.34 97/11/19 14:59:13
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -38,7 +38,9 @@ test safe-1.2 {safe::interpCreate syntax} {
?slave? name () name of the slave (optional)
-accessPath list () access path for the slave
-noStatics boolflag (false) prevent loading of statically linked pkgs
+ -statics boolean (true) loading of statically linked pkgs
-nestedLoadOk boolflag (false) allow nested loading
+ -nested boolean (false) nested loading
-deleteHook script () delete hook}}
test safe-1.3 {safe::interpInit syntax} {
@@ -186,7 +188,7 @@ test safe-7.1 {tests that everything works at high level} {
} 1.0
test safe-7.2 {tests specific path and interpFind/AddToAccessPath} {
- set i [safe::interpCreate -nostat -nested -accessPath [list [info library]]];
+ set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]];
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p1
@@ -197,7 +199,7 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath} {
[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 {}} {}"
+} "{\$p(:0:)} {\$p(:1:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library /dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}"
# test source control on file name
@@ -349,13 +351,41 @@ test safe-9.2 {safe interps' error in deleteHook} {
} {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}} {}}
+test safe-9.3 {dual specification of statics} {
+ list [catch {safe::interpCreate -stat true -nostat} msg] $msg
+} {1 {conflicting values given for -statics and -noStatics}}
-# 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 !
+test safe-9.4 {dual specification of statics} {
+ # no error shall occur
+ safe::interpDelete [safe::interpCreate -stat false -nostat]
+} {}
+
+test safe-9.5 {dual specification of nested} {
+ list [catch {safe::interpCreate -nested 0 -nestedload} msg] $msg
+} {1 {conflicting values given for -nested and -nestedLoadOk}}
+
+test safe-9.6 {interpConfigure widget like behaviour} {
+ # this test shall work, don't try to "fix it" unless
+ # you *really* know what you are doing (ie you are me :p) -- dl
+ list [set i [safe::interpCreate \
+ -noStatics \
+ -nestedLoadOk \
+ -deleteHook {foo bar}];
+ safe::interpConfigure $i -accessPath /foo/bar ;
+ safe::interpConfigure $i]\
+ [safe::interpConfigure $i -aCCess]\
+ [safe::interpConfigure $i -nested]\
+ [safe::interpConfigure $i -statics]\
+ [safe::interpConfigure $i -DEL]\
+ [safe::interpConfigure $i -accessPath /blah -statics 1;
+ safe::interpConfigure $i]\
+ [safe::interpConfigure $i -deleteHook toto -nosta -nested 0;
+ safe::interpConfigure $i]
+} {{-accessPath /foo/bar -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath /foo/bar} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath /blah -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath /blah -statics 0 -nested 0 -deleteHook toto}}
+
+
+# testing that nested and statics do what is advertised
+# (we use a static package : Tcltest)
if {[catch {package require Tcltest} msg]} {
puts "This application hasn't been compiled with Tcltest"
@@ -392,7 +422,7 @@ test safe-10.3 {testing nested statics loading / no nested by default} {
test safe-10.4 {testing nested statics loading / -nestedloadok} {
- set i [safe::interpCreate -nested]
+ set i [safe::interpCreate -nestedloadok]
list \
[catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \
$msg \
diff --git a/contrib/tcl/tests/set-old.test b/contrib/tcl/tests/set-old.test
index 2b4cd620f1fe..a101e7bb4290 100644
--- a/contrib/tcl/tests/set-old.test
+++ b/contrib/tcl/tests/set-old.test
@@ -7,12 +7,12 @@
# 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.
+# 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: @(#) set-old.test 1.20 97/07/25 17:45:55
+# SCCS: @(#) set-old.test 1.22 97/10/29 14:05:07
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -297,45 +297,72 @@ test set-old-8.7 {array command, anymore option} {
catch {unset a}
list [catch {array anymore a x} msg] $msg
} {1 {"a" isn't an array}}
-test set-old-8.8 {array command, donesearch option} {
+test set-old-8.8 {array command, anymore option, array doesn't exist yet but has compiler-allocated procedure slot} {
+ proc foo {x} {
+ if {$x==1} {
+ return [array anymore a x]
+ }
+ set a(x) 123
+ }
+ list [catch {foo 1} msg] $msg
+} {1 {"a" isn't an array}}
+test set-old-8.9 {array command, donesearch option} {
catch {unset a}
list [catch {array donesearch a x} msg] $msg
} {1 {"a" isn't an array}}
-test set-old-8.9 {array command, exists option} {
+test set-old-8.10 {array command, donesearch option, array doesn't exist yet but has compiler-allocated procedure slot} {
+ proc foo {x} {
+ if {$x==1} {
+ return [array donesearch a x]
+ }
+ set a(x) 123
+ }
+ list [catch {foo 1} msg] $msg
+} {1 {"a" isn't an array}}
+test set-old-8.11 {array command, exists option} {
list [catch {array exists a b} msg] $msg
} {1 {wrong # args: should be "array exists arrayName"}}
-test set-old-8.10 {array command, exists option} {
+test set-old-8.12 {array command, exists option} {
catch {unset a}
array exists a
} {0}
-test set-old-8.11 {array command, exists option} {
+test set-old-8.13 {array command, exists option} {
catch {unset a}
set a(0) 1
array exists a
} {1}
-test set-old-8.12 {array command, get option} {
+test set-old-8.14 {array command, exists option, array doesn't exist yet but has compiler-allocated procedure slot} {
+ proc foo {x} {
+ if {$x==1} {
+ return [array exists a]
+ }
+ set a(x) 123
+ }
+ list [catch {foo 1} msg] $msg
+} {0 0}
+test set-old-8.15 {array command, get option} {
list [catch {array get} msg] $msg
} {1 {wrong # args: should be "array option arrayName ?arg ...?"}}
-test set-old-8.13 {array command, get option} {
+test set-old-8.16 {array command, get option} {
list [catch {array get a b c} msg] $msg
} {1 {wrong # args: should be "array get arrayName ?pattern?"}}
-test set-old-8.14 {array command, get option} {
+test set-old-8.17 {array command, get option} {
catch {unset a}
array get a
} {}
-test set-old-8.15 {array command, get option} {
+test set-old-8.18 {array command, get option} {
catch {unset a}
set a(22) 3
set {a(long name)} {}
array get a
} {22 3 {long name} {}}
-test set-old-8.16 {array command, get option (unset variable)} {
+test set-old-8.19 {array command, get option (unset variable)} {
catch {unset a}
set a(x) 3
trace var a(y) w ignore
array get a
} {x 3}
-test set-old-8.17 {array command, get option, with pattern} {
+test set-old-8.20 {array command, get option, with pattern} {
catch {unset a}
set a(x1) 3
set a(x2) 4
@@ -344,7 +371,16 @@ test set-old-8.17 {array command, get option, with pattern} {
set a(b2) 25
array get a x*
} {x1 3 x2 4 x3 5}
-test set-old-8.18 {array command, names option} {
+test set-old-8.21 {array command, get option, array doesn't exist yet but has compiler-allocated procedure slot} {
+ proc foo {x} {
+ if {$x==1} {
+ return [array get a]
+ }
+ set a(x) 123
+ }
+ list [catch {foo 1} msg] $msg
+} {0 {}}
+test set-old-8.22 {array command, names option} {
catch {unset a}
set a(22) 3
list [catch {array names a 4 5} msg] $msg
@@ -353,25 +389,25 @@ test set-old-8.19 {array command, names option} {
catch {unset a}
array names a
} {}
-test set-old-8.20 {array command, names option} {
+test set-old-8.23 {array command, names option} {
catch {unset a}
set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx
list [catch {lsort [array names a]} msg] $msg
} {0 {22 Textual_name {name with spaces}}}
-test set-old-8.21 {array command, names option} {
+test set-old-8.24 {array command, names option} {
catch {unset a}
set a(22) 3; set a(33) 44;
trace var a(xxx) w ignore
list [catch {lsort [array names a]} msg] $msg
} {0 {22 33}}
-test set-old-8.22 {array command, names option} {
+test set-old-8.25 {array command, names option} {
catch {unset a}
set a(22) 3; set a(33) 44;
trace var a(xxx) w ignore
set a(xxx) value
list [catch {lsort [array names a]} msg] $msg
} {0 {22 33 xxx}}
-test set-old-8.23 {array command, names option} {
+test set-old-8.26 {array command, names option} {
catch {unset a}
set a(axy) 3
set a(bxy) 44
@@ -379,64 +415,119 @@ test set-old-8.23 {array command, names option} {
set a(xxx) value
list [lsort [array names a *xy]] [lsort [array names a]]
} {{axy bxy} {axy bxy no xxx}}
-test set-old-8.24 {array command, nextelement option} {
+test set-old-8.27 {array command, names option, array doesn't exist yet but has compiler-allocated procedure slot} {
+ proc foo {x} {
+ if {$x==1} {
+ return [array names a]
+ }
+ set a(x) 123
+ }
+ list [catch {foo 1} msg] $msg
+} {0 {}}
+test set-old-8.28 {array command, nextelement option} {
list [catch {array nextelement a} msg] $msg
} {1 {wrong # args: should be "array nextelement arrayName searchId"}}
-test set-old-8.25 {array command, nextelement option} {
+test set-old-8.29 {array command, nextelement option} {
catch {unset a}
list [catch {array nextelement a b} msg] $msg
} {1 {"a" isn't an array}}
-test set-old-8.26 {array command, set option} {
+test set-old-8.30 {array command, nextelement option, array doesn't exist yet but has compiler-allocated procedure slot} {
+ proc foo {x} {
+ if {$x==1} {
+ return [array nextelement a b]
+ }
+ set a(x) 123
+ }
+ list [catch {foo 1} msg] $msg
+} {1 {"a" isn't an array}}
+test set-old-8.31 {array command, set option} {
list [catch {array set a} msg] $msg
} {1 {wrong # args: should be "array set arrayName list"}}
-test set-old-8.27 {array command, set option} {
+test set-old-8.32 {array command, set option} {
list [catch {array set a 1 2} msg] $msg
} {1 {wrong # args: should be "array set arrayName list"}}
-test set-old-8.28 {array command, set option} {
+test set-old-8.33 {array command, set option} {
list [catch {array set a "a \{ c"} msg] $msg
} {1 {unmatched open brace in list}}
-test set-old-8.29 {array command, set option} {
+test set-old-8.34 {array command, set option} {
catch {unset a}
set a 44
list [catch {array set a {a b c d}} msg] $msg
} {1 {can't set "a(a)": variable isn't array}}
-test set-old-8.30 {array command, set option} {
+test set-old-8.35 {array command, set option} {
catch {unset a}
set a(xx) yy
array set a {b c d e}
array get a
} {d e xx yy b c}
-test set-old-8.31 {array command, size option} {
+test set-old-8.36 {array command, set option, array doesn't exist yet but has compiler-allocated procedure slot} {
+ proc foo {x} {
+ if {$x==1} {
+ return [array set a {x 0}]
+ }
+ set a(x)
+ }
+ list [catch {foo 1} msg] $msg
+} {0 {}}
+test set-old-8.37 {array command, set option} {
+ catch {unset aVaRnAmE}
+ array set aVaRnAmE {}
+ list [info exists aVaRnAmE] [catch {set aVaRnAmE} msg] $msg
+} {1 1 {can't read "aVaRnAmE": variable is array}}
+test set-old-8.38 {array command, size option} {
+ catch {unset a}
+ array size a
+} {0}
+test set-old-8.39 {array command, size option} {
list [catch {array size a 4} msg] $msg
} {1 {wrong # args: should be "array size arrayName"}}
-test set-old-8.32 {array command, size option} {
+test set-old-8.40 {array command, size option} {
catch {unset a}
array size a
} {0}
-test set-old-8.33 {array command, size option} {
+test set-old-8.41 {array command, size option} {
catch {unset a}
set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx
list [catch {array size a} msg] $msg
} {0 3}
-test set-old-8.34 {array command, size option} {
+test set-old-8.42 {array command, size option} {
catch {unset a}
set a(22) 3; set a(xx) 44; set a(y) xxx
unset a(22) a(y) a(xx)
list [catch {array size a} msg] $msg
} {0 0}
-test set-old-8.35 {array command, size option} {
+test set-old-8.43 {array command, size option} {
catch {unset a}
set a(22) 3;
trace var a(33) rwu ignore
list [catch {array size a} msg] $msg
} {0 1}
-test set-old-8.36 {array command, startsearch option} {
+test set-old-8.44 {array command, size option, array doesn't exist yet but has compiler-allocated procedure slot} {
+ proc foo {x} {
+ if {$x==1} {
+ return [array size a]
+ }
+ set a(x) 123
+ }
+ list [catch {foo 1} msg] $msg
+} {0 0}
+test set-old-8.45 {array command, startsearch option} {
list [catch {array startsearch a b} msg] $msg
} {1 {wrong # args: should be "array startsearch arrayName"}}
-test set-old-8.37 {array command, startsearch option} {
+test set-old-8.46 {array command, startsearch option} {
catch {unset a}
list [catch {array startsearch a} msg] $msg
} {1 {"a" isn't an array}}
+test set-old-8.47 {array command, startsearch option, array doesn't exist yet but has compiler-allocated procedure slot} {
+ catch {rename p ""}
+ proc p {x} {
+ if {$x==1} {
+ return [array startsearch a]
+ }
+ set a(x) 123
+ }
+ list [catch {p 1} msg] $msg
+} {1 {"a" isn't an array}}
test set-old-9.1 {ids for array enumeration} {
catch {unset a}
@@ -676,4 +767,5 @@ test set-old-12.2 {cleanup on procedure return} {
catch {unset a}
catch {unset b}
catch {unset c}
+catch {unset aVaRnAmE}
return ""
diff --git a/contrib/tcl/tests/socket.test b/contrib/tcl/tests/socket.test
index 280db1ba5549..b2719de67b73 100644
--- a/contrib/tcl/tests/socket.test
+++ b/contrib/tcl/tests/socket.test
@@ -59,7 +59,7 @@
# 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.82 97/08/05 13:30:55
+# SCCS: @(#) socket.test 1.83 97/09/15 16:29:47
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -402,7 +402,7 @@ test socket-2.5 {tcp connection with redundant server port} {stdio} {
close $f
set x
} {ready hello}
-test socket-2.6 {tcp connection} {unixOrPc} {
+test socket-2.6 {tcp connection} {} {
set status ok
if {![catch {set sock [socket localhost 2828]}]} {
if {![catch {gets $sock}]} {
@@ -891,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} {tempNotMac} {
+test socket-9.2 {testing async write, fileevents, flush on close} {} {
set firstblock ""
for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
set secondblock ""
diff --git a/contrib/tcl/tests/source.test b/contrib/tcl/tests/source.test
index 1e0ff696c211..9a7e2305e9a1 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.25 97/07/02 16:41:34
+# SCCS: @(#) source.test 1.26 97/09/24 16:33:37
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -31,7 +31,7 @@ test source-1.2 {source command} {
source source.file
} result
-# The mac version of source returns a differnt result for
+# The mac version of source returns a different result for
# the next two tests.
if {$tcl_platform(platform) == "macintosh"} {
@@ -173,6 +173,13 @@ test source-5.6 {source resource files} {macOnly} {
list $msg2 $result $msg
} [list hello 1 bad]
+test source-6.1 {source is binary ok} {
+ set x {}
+ makeFile [list set x "a b\0c"] source.file
+ source source.file
+ string length $x
+} 5
+
catch {removeFile source.file}
# Generate null final value
diff --git a/contrib/tcl/tests/unixFCmd.test b/contrib/tcl/tests/unixFCmd.test
index 6b57e7565f87..037b5b472fe0 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.14 97/08/15 10:22:11
+# SCCS: @(#) unixFCmd.test 1.15 97/11/03 15:58:22
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -79,16 +79,17 @@ test unixFCmd-1.5 {TclpRenameFile: ENOENT} {
test unixFCmd-1.6 {TclpRenameFile: ENOTDIR} {
# can't make it happen
} {}
-test unixFCmd-1.7 {TclpRenameFile: EXDEV} {nonPortable} {
+test unixFCmd-1.7 {TclpRenameFile: EXDEV} {
cleanup
- file mkdir td1
- if [file exists /kernel] {
- set msg [list [catch {file rename /kernel td1} msg] $msg]
- set a1 {1 {can't unlink "/kernel": permission denied}}
- expr {$msg == $a1}
- } else {
- list 1
- }
+ file mkdir foo/bar
+ file attr foo -perm 040555
+ set msg [list [catch {file rename foo/bar /tmp} msg] $msg]
+ set a1 {1 {can't unlink "foo/bar": permission denied}}
+ set result [expr {$msg == $a1}]
+ catch {file delete /tmp/bar}
+ catch {file attr foo -perm 040777}
+ catch {file delete -force foo}
+ set result
} {1}
test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} {
@@ -232,7 +233,7 @@ 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"} {}}
-test unixFCmd-18.1 { nix pwd} {nonPortable} {
+test unixFCmd-18.1 {Unix pwd} {nonPortable} {
# This test is nonportable because SunOS generates a weird error
# message when the current directory isn't readable.
set cd [pwd]
diff --git a/contrib/tcl/tests/unixNotfy.test b/contrib/tcl/tests/unixNotfy.test
index ba99db103eaa..5ed5f12adede 100644
--- a/contrib/tcl/tests/unixNotfy.test
+++ b/contrib/tcl/tests/unixNotfy.test
@@ -9,13 +9,22 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) unixNotfy.test 1.2 97/06/16 17:26:28
+# SCCS: @(#) unixNotfy.test 1.3 97/09/15 15:39:53
if {[string compare test [info procs test]] == 1} then {source defs}
if {$tcl_platform(platform) != "unix"} {
return
}
+
+# The tests should not be run if you have a notifier which is unable to
+# detect infinite vwaits, as the tests below will hang. The presence of
+# the "testeventloop" command indicates that this is the case.
+
+if {"[info commands testeventloop]" == "testeventloop"} {
+ return
+}
+
test unixNotfy-1.1 {Tcl_DeleteFileHandler} {
catch {vwait x}
set f [open foo w]
diff --git a/contrib/tcl/tests/upvar.test b/contrib/tcl/tests/upvar.test
index 23419debd664..d9548b068bac 100644
--- a/contrib/tcl/tests/upvar.test
+++ b/contrib/tcl/tests/upvar.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: @(#) upvar.test 1.14 96/10/22 11:34:39
+# SCCS: @(#) upvar.test 1.15 97/10/29 18:25:56
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -315,6 +315,18 @@ test upvar-8.8 {create nested array with upvar} {
catch {unset x}
list [catch p1 msg] $msg
} {1 {can't set "b(2)": variable isn't array}}
+test upvar-8.9 {upvar won't create namespace variable that refers to procedure variable} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {rename MakeLink ""}
+ namespace eval ::test_ns_1 {}
+ proc MakeLink {a} {
+ namespace eval ::test_ns_1 {
+ upvar a a
+ }
+ unset ::test_ns_1::a
+ }
+ list [catch {MakeLink 1} msg] $msg
+} {1 {bad variable name "a": upvar won't create namespace variable that refers to procedure variable}}
if {[info commands testupvar] != {}} {
test upvar-9.1 {Tcl_UpVar2 procedure} {
diff --git a/contrib/tcl/tests/winFCmd.test b/contrib/tcl/tests/winFCmd.test
index bca8c4bbc736..a38d72f62e02 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.10 97/08/05 11:44:57
+# SCCS: @(#) winFCmd.test 1.11 97/10/10 11:50:05
#
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -853,32 +853,35 @@ test winFCmd-12.4 {ConvertFileNameFormat} {
close [open td1 w]
list [catch {string tolower [file attributes ./td1 -longname]} msg] $msg [cleanup]
} {0 ./td1 {}}
-test winFCmd-12.5 {ConvertFileNameFormat} {
+test winFCmd-12.5 {ConvertFileNameFormat: absolute path} {
+ list [file attributes / -longname] [file attributes \\ -longname]
+} {/ /}
+test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} {
catch {file delete -force -- c:/td1}
close [open c:/td1 w]
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} {
+test winFCmd-12.7 {ConvertFileNameFormat} {UNCPath} {
catch {file delete -force -- //bisque/icepick/test/td1}
close [open //bisque/icepick/test/td1 w]
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} {
+test winFCmd-12.8 {ConvertFileNameFormat} {longFileNames} {
cleanup
close [open td1 w]
list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
-test winFCmd-12.8 {ConvertFileNameFormat} {win32s} {
+test winFCmd-12.9 {ConvertFileNameFormat} {win32s} {
cleanup
close [open td1 w]
list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
-test winFCmd-12.9 {ConvertFileNameFormat} {longFileNames} {
+test winFCmd-12.10 {ConvertFileNameFormat} {longFileNames} {
cleanup
close [open td1td1td1 w]
list [catch {file attributes td1td1td1 -shortname}] [cleanup]
} {0 {}}
-test winFCmd-12.10 {ConvertFileNameFormat} {longFileNames} {
+test winFCmd-12.11 {ConvertFileNameFormat} {longFileNames} {
cleanup
close [open td1 w]
list [catch {string tolower [file attributes td1 -shortname]} msg] $msg [cleanup]
diff --git a/contrib/tcl/tests/winPipe.test b/contrib/tcl/tests/winPipe.test
index 483dfec9cc12..404251fd342a 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.9 97/08/05 11:44:28
+# SCCS: @(#) winPipe.test 1.11 97/10/09 17:06:16
if {$tcl_platform(platform) != "windows"} {
return
@@ -161,9 +161,6 @@ test winpipe-1.24 {32 bit comprehensive tests: read/write application} {
catch {close $f}
set r
} "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
-test winpipe-1.25 {32 bit comprehensive tests: to socket} {
- # doesn't work
-} {}
}
set stderr16 "stderr16"
@@ -280,10 +277,83 @@ test winpipe-2.24 {16 bit comprehensive tests: read/write application} {nt} {
catch {close $f}
set r
} "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
-test winpipe-2.25 {16 bit comprehensive tests: to socket} {
- # doesn't work
-} {}
}
-file delete big little
+test winpipe-3.1 {Tcl_WaitPid} {nt} {
+ proc readResults {f} {
+ global x result
+ if { [eof $f] } {
+ close $f
+ set x 1
+ } else {
+ set line [read $f ]
+ set result "$result$line"
+ }
+ }
+
+ set f [open "|$cat32 < big 2> stderr" r]
+ fconfigure $f -buffering none -blocking 0
+ fileevent $f readable "readResults $f"
+ set x 0
+ set result ""
+ vwait x
+ list $result $x [contents stderr]
+} "{$big} 1 stderr32"
+
+close [open nothing w]
+
+catch {set env_tmp $env(TMP)}
+catch {set env_temp $env(TEMP)}
+
+set env(TMP) c:/
+set env(TEMP) c:/
+
+test winpipe-3.1 {TclpCreateTempFile: cleanup temp files} {
+ set x {}
+ set existing [glob -nocomplain c:/tcl*.tmp]
+ exec $tcltest < nothing
+ foreach p [glob -nocomplain c:/tcl*.tmp] {
+ if {[lsearch $existing $p] != -1} {
+ lappend x $p
+ }
+ }
+ set x
+} {}
+test winpipe-3.2 {TclpCreateTempFile: TMP and TEMP not defined} {
+ set tmp $env(TMP)
+ set temp $env(TEMP)
+ unset env(TMP)
+ unset env(TEMP)
+ exec $tcltest < nothing
+ set env(TMP) $tmp
+ set env(TEMP) $temp
+ set x {}
+} {}
+test winpipe-3.3 {TclpCreateTempFile: TMP specifies non-existent directory} {
+ set tmp $env(TMP)
+ set env(TMP) snarky
+ exec $tcltest < nothing
+ set env(TMP) $tmp
+ set x {}
+} {}
+test winpipe-3.3 {TclpCreateTempFile: TEMP specifies non-existent directory} {
+ set tmp $env(TMP)
+ set temp $env(TEMP)
+ unset env(TMP)
+ set env(TEMP) snarky
+ exec $tcltest < nothing
+ set env(TMP) $tmp
+ set env(TEMP) $temp
+ set x {}
+} {}
+
+# restore old values fro env(TMP) and env(TEMP)
+
+if {[catch {set env(TMP) $env_tmp}]} {
+ unset $env(TMP)
+}
+if {[catch {set env(TEMP) $env_temp}]} {
+ unset $env(TEMP)
+}
+file delete big little stdout stderr nothing
diff --git a/contrib/tcl/unix/Makefile.in b/contrib/tcl/unix/Makefile.in
index 8d2d7c848109..6b15ff545ac2 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.187 97/08/15 10:23:55
+# SCCS: @(#) Makefile.in 1.190 97/11/05 10:57:38
# Current Tcl version; used in various names.
@@ -73,12 +73,7 @@ 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:
@@ -890,6 +885,11 @@ dist: $(UNIX_DIR)/configure
cp -p $(UNIX_DIR)/dltest/configure.in $(UNIX_DIR)/dltest/configure \
$(UNIX_DIR)/dltest/README $(DISTDIR)/unix/dltest
+#
+# The following target can only be used for non-patch releases. Use
+# the "allpatch" target below for patch releases.
+#
+
alldist: dist
rm -f /proj/tcl/dist/$(DISTNAME).tar.Z \
/proj/tcl/dist/$(DISTNAME).tar.gz \
@@ -899,6 +899,26 @@ alldist: dist
compress $(DISTNAME).tar; zip -r8 $(ZIPNAME) $(DISTNAME)
#
+# The target below is similar to "alldist" except it works for patch
+# releases. It is needed because patch releases are peculiar: the
+# patch designation appears in the name of the compressed file
+# (e.g. tcl8.0p1.tar.gz) but the extracted source directory doesn't
+# include the patch designation (e.g. tcl8.0).
+#
+
+allpatch: dist
+ rm -f /proj/tcl/dist/$(DISTNAME).tar.Z \
+ /proj/tcl/dist/$(DISTNAME).tar.gz \
+ /proj/tcl/dist/$(ZIPNAME)
+ mv /proj/tcl/dist/tcl${VERSION} /proj/tcl/dist/old
+ mv /proj/tcl/dist/$(DISTNAME) /proj/tcl/dist/tcl${VERSION}
+ cd /proj/tcl/dist; tar cf $(DISTNAME).tar tcl${VERSION}; \
+ gzip -9 -c $(DISTNAME).tar > $(DISTNAME).tar.gz; \
+ compress $(DISTNAME).tar; zip -r8 $(ZIPNAME) tcl${VERSION}
+ mv /proj/tcl/dist/tcl${VERSION} /proj/tcl/dist/$(DISTNAME)
+ mv /proj/tcl/dist/old /proj/tcl/dist/tcl${VERSION}
+
+#
# Target to create a Macintosh version of the distribution. This will
# do a normal distribution and then massage the output to prepare it
# for moving to the Mac platform. This requires a few scripts and
diff --git a/contrib/tcl/unix/configure b/contrib/tcl/unix/configure
index 0609faf99472..35cee45363c1 100755
--- a/contrib/tcl/unix/configure
+++ b/contrib/tcl/unix/configure
@@ -404,12 +404,12 @@ else
fi
-# SCCS: @(#) configure.in 1.140 97/08/12 10:36:18
+# SCCS: @(#) configure.in 1.144 97/11/20 12:39:44
TCL_VERSION=8.0
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=0
-TCL_PATCH_LEVEL=""
+TCL_PATCH_LEVEL="p2"
VERSION=${TCL_VERSION}
if test "${prefix}" = "NONE"; then
@@ -621,7 +621,7 @@ EOF
fi
done
-# Nb: if getcwd uses popen and pwd(1) (like Solaris) we should really
+# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
# define USEGETWD even if the posix getcwd exists. Add a test ?
for ac_func in opendir strstr
@@ -2000,6 +2000,43 @@ EOF
fi
#--------------------------------------------------------------------
+# Some systems (e.g., IRIX 4.0.5) lack the st_blksize field
+# in struct stat.
+#--------------------------------------------------------------------
+echo $ac_n "checking for st_blksize in struct stat""... $ac_c" 1>&6
+if eval "test \"`echo '$''{'ac_cv_struct_st_blksize'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 2012 "configure"
+#include "confdefs.h"
+#include <sys/types.h>
+#include <sys/stat.h>
+int main() { return 0; }
+int t() {
+struct stat s; s.st_blksize;
+; return 0; }
+EOF
+if eval $ac_compile; then
+ rm -rf conftest*
+ ac_cv_struct_st_blksize=yes
+else
+ rm -rf conftest*
+ ac_cv_struct_st_blksize=no
+fi
+rm -f conftest*
+
+fi
+echo "$ac_t""$ac_cv_struct_st_blksize" 1>&6
+if test $ac_cv_struct_st_blksize = yes; then
+ cat >> confdefs.h <<\EOF
+#define HAVE_ST_BLKSIZE 1
+EOF
+
+fi
+
+
+#--------------------------------------------------------------------
# On some systems strstr is broken: it returns a pointer even
# even if the original string is empty.
#--------------------------------------------------------------------
@@ -2009,7 +2046,7 @@ if test "$cross_compiling" = yes; then
tcl_ok=no
else
cat > conftest.$ac_ext <<EOF
-#line 2013 "configure"
+#line 2050 "configure"
#include "confdefs.h"
extern int strstr();
@@ -2045,7 +2082,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 2049 "configure"
+#line 2086 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strtoul(); below. */
@@ -2089,7 +2126,7 @@ if test "$cross_compiling" = yes; then
tcl_ok=0
else
cat > conftest.$ac_ext <<EOF
-#line 2093 "configure"
+#line 2130 "configure"
#include "confdefs.h"
extern int strtoul();
@@ -2128,7 +2165,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 2132 "configure"
+#line 2169 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strtod(); below. */
@@ -2172,7 +2209,7 @@ if test "$cross_compiling" = yes; then
tcl_ok=0
else
cat > conftest.$ac_ext <<EOF
-#line 2176 "configure"
+#line 2213 "configure"
#include "confdefs.h"
extern double strtod();
@@ -2213,7 +2250,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 2217 "configure"
+#line 2254 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strtod(); below. */
@@ -2259,7 +2296,7 @@ if test "$tcl_strtod" = 1; then
tcl_ok=0
else
cat > conftest.$ac_ext <<EOF
-#line 2263 "configure"
+#line 2300 "configure"
#include "confdefs.h"
extern double strtod();
@@ -2304,7 +2341,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 2308 "configure"
+#line 2345 "configure"
#include "confdefs.h"
#include <stdlib.h>
#include <stdarg.h>
@@ -2326,7 +2363,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 2330 "configure"
+#line 2367 "configure"
#include "confdefs.h"
#include <string.h>
EOF
@@ -2344,7 +2381,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 2348 "configure"
+#line 2385 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
@@ -2365,7 +2402,7 @@ if test "$cross_compiling" = yes; then
ac_cv_header_stdc=no
else
cat > conftest.$ac_ext <<EOF
-#line 2369 "configure"
+#line 2406 "configure"
#include "confdefs.h"
#include <ctype.h>
#define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
@@ -2399,7 +2436,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 2403 "configure"
+#line 2440 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
@@ -2430,7 +2467,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 2434 "configure"
+#line 2471 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
@@ -2461,7 +2498,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 2465 "configure"
+#line 2502 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
@@ -2492,7 +2529,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 2496 "configure"
+#line 2533 "configure"
#include "confdefs.h"
#include <sys/types.h>
EOF
@@ -2532,7 +2569,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 2536 "configure"
+#line 2573 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char opendir(); below. */
@@ -2586,7 +2623,7 @@ fi
echo $ac_n "checking union wait""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 2590 "configure"
+#line 2627 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/wait.h>
@@ -2623,7 +2660,7 @@ fi
echo $ac_n "checking matherr support""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 2627 "configure"
+#line 2664 "configure"
#include "confdefs.h"
#include <math.h>
int main() { return 0; }
@@ -2665,7 +2702,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 2669 "configure"
+#line 2706 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char vfork(); below. */
@@ -2711,7 +2748,7 @@ if test "$tcl_ok" = 1; then
tcl_ok=0
else
cat > conftest.$ac_ext <<EOF
-#line 2715 "configure"
+#line 2752 "configure"
#include "confdefs.h"
#include <stdio.h>
@@ -2772,7 +2809,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 2776 "configure"
+#line 2813 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strncasecmp(); below. */
@@ -2820,7 +2857,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-lsocket $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 2824 "configure"
+#line 2861 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -2856,7 +2893,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-linet $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 2860 "configure"
+#line 2897 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -2904,7 +2941,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 2908 "configure"
+#line 2945 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char BSDgettimeofday(); below. */
@@ -2949,7 +2986,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 2953 "configure"
+#line 2990 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char gettimeofday(); below. */
@@ -2996,7 +3033,7 @@ fi
echo $ac_n "checking for gettimeofday declaration""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 3000 "configure"
+#line 3037 "configure"
#include "confdefs.h"
#include <sys/time.h>
EOF
@@ -3029,7 +3066,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-linet $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 3033 "configure"
+#line 3070 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -3061,7 +3098,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 3065 "configure"
+#line 3102 "configure"
#include "confdefs.h"
#include <net/errno.h>
EOF
@@ -3101,7 +3138,7 @@ else
if test "$GCC" = yes; then
# GCC predefines this symbol on systems where it applies.
cat > conftest.$ac_ext <<EOF
-#line 3105 "configure"
+#line 3142 "configure"
#include "confdefs.h"
#ifdef __CHAR_UNSIGNED__
yes
@@ -3123,7 +3160,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 3127 "configure"
+#line 3164 "configure"
#include "confdefs.h"
/* volatile prevents gcc2 from optimizing the test away on sparcs. */
#if !defined(__STDC__) || __STDC__ != 1
@@ -3153,7 +3190,7 @@ fi
echo $ac_n "checking signed char declarations""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 3157 "configure"
+#line 3194 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -3205,7 +3242,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 3209 "configure"
+#line 3246 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char connect(); below. */
@@ -3253,7 +3290,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-lsocket $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 3257 "configure"
+#line 3294 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -3289,7 +3326,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 3293 "configure"
+#line 3330 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char accept(); below. */
@@ -3335,7 +3372,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 3339 "configure"
+#line 3376 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char gethostbyname(); below. */
@@ -3379,7 +3416,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-lnsl $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 3383 "configure"
+#line 3420 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -3495,7 +3532,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-ldl $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 3499 "configure"
+#line 3536 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -3581,7 +3618,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-ldld $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 3585 "configure"
+#line 3622 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -3667,7 +3704,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 3671 "configure"
+#line 3708 "configure"
#include "confdefs.h"
#include <dld.h>
EOF
@@ -3725,7 +3762,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 3729 "configure"
+#line 3766 "configure"
#include "confdefs.h"
#include <dlfcn.h>
EOF
@@ -3908,7 +3945,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 3912 "configure"
+#line 3949 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -3958,7 +3995,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 3962 "configure"
+#line 3999 "configure"
#include "confdefs.h"
#include <sys/exec.h>
int main() { return 0; }
@@ -3995,7 +4032,7 @@ EOF
else
echo $ac_n "checking a.out.h""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 3999 "configure"
+#line 4036 "configure"
#include "confdefs.h"
#include <a.out.h>
int main() { return 0; }
@@ -4032,7 +4069,7 @@ EOF
else
echo $ac_n "checking sys/exec_aout.h""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 4036 "configure"
+#line 4073 "configure"
#include "confdefs.h"
#include <sys/exec_aout.h>
int main() { return 0; }
@@ -4143,7 +4180,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 4147 "configure"
+#line 4184 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
@@ -4179,7 +4216,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 4183 "configure"
+#line 4220 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
diff --git a/contrib/tcl/unix/configure.in b/contrib/tcl/unix/configure.in
index 27fa8b1bd31b..ee36dc4f7906 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.140 97/08/12 10:36:18
+# SCCS: @(#) configure.in 1.144 97/11/20 12:39:44
TCL_VERSION=8.0
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=0
-TCL_PATCH_LEVEL=""
+TCL_PATCH_LEVEL="p2"
VERSION=${TCL_VERSION}
if test "${prefix}" = "NONE"; then
@@ -36,7 +36,7 @@ AC_C_CROSS
# 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
+# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
# define USEGETWD even if the posix getcwd exists. Add a test ?
AC_REPLACE_FUNCS(opendir strstr)
@@ -269,6 +269,12 @@ if test $libbsd = yes; then
fi
#--------------------------------------------------------------------
+# Some systems (e.g., IRIX 4.0.5) lack the st_blksize field
+# in struct stat.
+#--------------------------------------------------------------------
+AC_STRUCT_ST_BLKSIZE
+
+#--------------------------------------------------------------------
# On some systems strstr is broken: it returns a pointer even
# even if the original string is empty.
#--------------------------------------------------------------------
diff --git a/contrib/tcl/unix/porting.notes b/contrib/tcl/unix/porting.notes
index 39b35cbbd583..2d0a40390051 100644
--- a/contrib/tcl/unix/porting.notes
+++ b/contrib/tcl/unix/porting.notes
@@ -11,7 +11,7 @@ cases the person's name and e-mail address are listed. I'm
interested in getting new porting information to add to the file;
please mail updates to "john.ousterhout@eng.sun.com".
-This file reflects information provided for Tcl 7.4 and later releases.
+This file reflects information provided for Tcl 7.4 and later releases (8.x).
If there is no information for your configuration in this file, check
the file "porting.old" too; it contains information that was
submitted for Tcl 7.3 and earlier releases, and some of that information
@@ -19,14 +19,14 @@ may still be valid.
A new porting database has recently become available on the Web at
the following URL:
- http://www.sunlabs.com/cgi-bin/tcl/info.4.0
-This page provides information about the platforms on which Tcl 7.4
-and Tk 4.0 have been compiled and what changes were needed to get Tcl
+ http://www.sunlabs.com/cgi-bin/tcl/info.8.0
+This page provides information about the platforms on which Tcl and
+and Tk 8.0 have been compiled and what changes were needed to get Tcl
and Tk to compile. You can also add new entries to that database
when you install Tcl and Tk on a new platform. The Web database is
likely to be more up-to-date than this file.
-sccsid = SCCS: @(#) porting.notes 1.18 96/12/31 14:50:27
+sccsid = SCCS: @(#) porting.notes 1.20 97/11/03 09:43:40
--------------------------------------------
Solaris, various versions
@@ -51,6 +51,26 @@ run and add "-DNO_DIRENT_H=1" to the definitions of DEFS. Do this
before compiling.
--------------------------------------------
+SunOS 4 and potentially other OSes
+--------------------------------------------
+
+On systems where both getcwd(3) and getwd(3) exist, check the man
+page and if getcwd, like on SunOS 4, uses popen to pwd(1)
+add -DUSEGETWD to the flags CFLAGS so getwd will be used instead.
+
+That is, change the CFLAGS = -O line so it reads
+CFLAGS = -O -DUSEGETWD
+
+--------------------------------------------
+Linux, ELF, various versions/distributions
+--------------------------------------------
+
+If ./configure --enable-shared complains it can not do a shared
+library you might have to make the following symbolic link:
+ln -s /lib/libdl.so.1 /lib/libdl.so
+then remove config.cache and re run configure.
+
+--------------------------------------------
Pyramid DC/OSx SVr4, DC/OSx version 94c079
--------------------------------------------
diff --git a/contrib/tcl/unix/tclUnixChan.c b/contrib/tcl/unix/tclUnixChan.c
index 2e53440bb1d4..2c0e9961f834 100644
--- a/contrib/tcl/unix/tclUnixChan.c
+++ b/contrib/tcl/unix/tclUnixChan.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: @(#) tclUnixChan.c 1.203 97/06/20 13:03:18
+ * SCCS: @(#) tclUnixChan.c 1.207 97/11/04 14:45:29
*/
#include "tclInt.h" /* Internal definitions for Tcl. */
@@ -1713,7 +1713,7 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
}
Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr));
hostEntPtr = gethostbyaddr((char *) &(sockname.sin_addr),
- sizeof(peername.sin_addr), AF_INET);
+ sizeof(sockname.sin_addr), AF_INET);
if (hostEntPtr != (struct hostent *) NULL) {
Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name);
} else {
@@ -2360,6 +2360,7 @@ Tcl_GetOpenFile(interp, string, forWriting, checkUsage, filePtr)
Tcl_Channel chan;
int chanMode;
Tcl_ChannelType *chanTypePtr;
+ ClientData data;
int fd;
FILE *f;
@@ -2387,8 +2388,9 @@ Tcl_GetOpenFile(interp, string, forWriting, checkUsage, filePtr)
if ((chanTypePtr == &fileChannelType) || (chanTypePtr == &tcpChannelType)
|| (strcmp(chanTypePtr->typeName, "pipe") == 0)) {
if (Tcl_GetChannelHandle(chan,
- (forWriting ? TCL_WRITABLE : TCL_READABLE), (ClientData*) &fd)
- == TCL_OK) {
+ (forWriting ? TCL_WRITABLE : TCL_READABLE),
+ (ClientData*) &data) == TCL_OK) {
+ fd = (int) data;
/*
* The call to fdopen below is probably dangerous, since it will
diff --git a/contrib/tcl/unix/tclUnixFCmd.c b/contrib/tcl/unix/tclUnixFCmd.c
index 51224e68f886..3ec1a69d9f46 100644
--- a/contrib/tcl/unix/tclUnixFCmd.c
+++ b/contrib/tcl/unix/tclUnixFCmd.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: @(#) tclUnixFCmd.c 1.29 97/06/16 16:28:25
+ * SCCS: @(#) tclUnixFCmd.c 1.31 97/10/13 16:51:14
*
* Portions of this code were derived from NetBSD source code which has
* the following copyright notice:
@@ -363,7 +363,12 @@ CopyFile(src, dst, srcStatBufPtr)
return TCL_ERROR;
}
+#if HAVE_ST_BLKSIZE
blockSize = srcStatBufPtr->st_blksize;
+#else
+ blockSize = 4096;
+#endif
+
buffer = ckalloc(blockSize);
while (1) {
nread = read(srcFd, buffer, blockSize);
@@ -937,16 +942,11 @@ GetGroupAttribute(interp, objIndex, fileName, attributePtrPtr)
groupPtr = getgrgid(statBuf.st_gid);
if (groupPtr == NULL) {
- endgrent();
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "could not get group for file \"", fileName, "\": ",
- Tcl_PosixError(interp), (char *) NULL);
- return TCL_ERROR;
+ *attributePtrPtr = Tcl_NewIntObj(statBuf.st_gid);
+ } else {
+ *attributePtrPtr = Tcl_NewStringObj(groupPtr->gr_name, -1);
}
-
- *attributePtrPtr = Tcl_NewStringObj(groupPtr->gr_name, -1);
endgrent();
-
return TCL_OK;
}
@@ -986,16 +986,11 @@ GetOwnerAttribute(interp, objIndex, fileName, attributePtrPtr)
pwPtr = getpwuid(statBuf.st_uid);
if (pwPtr == NULL) {
- endpwent();
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "could not get owner for file \"", fileName, "\": ",
- Tcl_PosixError(interp), (char *) NULL);
- return TCL_ERROR;
+ *attributePtrPtr = Tcl_NewIntObj(statBuf.st_uid);
+ } else {
+ *attributePtrPtr = Tcl_NewStringObj(pwPtr->pw_name, -1);
}
-
- *attributePtrPtr = Tcl_NewStringObj(pwPtr->pw_name, -1);
endpwent();
-
return TCL_OK;
}
diff --git a/contrib/tcl/unix/tclUnixNotfy.c b/contrib/tcl/unix/tclUnixNotfy.c
index 857454c65da2..1a866804a352 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.42 97/07/02 20:55:44
+ * SCCS: @(#) tclUnixNotfy.c 1.44 97/11/05 13:02:20
*/
#include "tclInt.h"
@@ -266,7 +266,8 @@ Tcl_DeleteFileHandler(fd)
int fd; /* Stream id for which to remove callback procedure. */
{
FileHandler *filePtr, *prevPtr;
- int index, bit, mask, i;
+ int index, bit, i;
+ unsigned long flags;
if (!initialized) {
InitNotifier();
@@ -310,12 +311,12 @@ Tcl_DeleteFileHandler(fd)
if (fd+1 == notifier.numFdBits) {
for (notifier.numFdBits = 0; index >= 0; index--) {
- mask = notifier.checkMasks[index]
+ flags = notifier.checkMasks[index]
| (notifier.checkMasks+MASK_SIZE)[index]
| (notifier.checkMasks+2*(MASK_SIZE))[index];
- if (mask) {
+ if (flags) {
for (i = (NBBY*sizeof(fd_mask)); i > 0; i--) {
- if (mask & (1 << (i-1))) {
+ if (flags & (((unsigned long)1) << (i-1))) {
break;
}
}
diff --git a/contrib/tcl/unix/tclUnixPipe.c b/contrib/tcl/unix/tclUnixPipe.c
index f6d90d702cb2..83aa4e888e51 100644
--- a/contrib/tcl/unix/tclUnixPipe.c
+++ b/contrib/tcl/unix/tclUnixPipe.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: @(#) tclUnixPipe.c 1.36 97/05/14 13:24:24
+ * SCCS: @(#) tclUnixPipe.c 1.37 97/10/31 17:23:37
*/
#include "tclInt.h"
@@ -22,7 +22,7 @@
* the same as NULL.
*/
-#define MakeFile(fd) ((TclFile)((fd)+1))
+#define MakeFile(fd) ((TclFile)(((int)fd)+1))
#define GetFd(file) (((int)file)-1)
/*
@@ -100,11 +100,11 @@ TclpMakeFile(channel, direction)
Tcl_Channel channel; /* Channel to get file from. */
int direction; /* Either TCL_READABLE or TCL_WRITABLE. */
{
- int fd;
+ ClientData data;
- if (Tcl_GetChannelHandle(channel, direction, (ClientData *) &fd)
+ if (Tcl_GetChannelHandle(channel, direction, (ClientData *) &data)
== TCL_OK) {
- return MakeFile(fd);
+ return MakeFile((int)data);
} else {
return (TclFile) NULL;
}
diff --git a/contrib/tcl/unix/tclUnixSock.c b/contrib/tcl/unix/tclUnixSock.c
index b917832ca8d5..c532993c19be 100644
--- a/contrib/tcl/unix/tclUnixSock.c
+++ b/contrib/tcl/unix/tclUnixSock.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: @(#) tclUnixSock.c 1.7 97/07/24 17:54:02
+ * SCCS: @(#) tclUnixSock.c 1.9 97/10/09 18:24:49
*/
#include "tcl.h"
@@ -47,11 +47,12 @@ static int hostnameInited = 0;
*
* Tcl_GetHostName --
*
- * Get the network name for this machine, in a system dependent way.
+ * Returns the name of the local host.
*
* Results:
* A string containing the network name for this machine, or
- * an empty string if we can't figure out the name.
+ * an empty string if we can't figure out the name. The caller
+ * must not modify or free this string.
*
* Side effects:
* None.
@@ -72,6 +73,7 @@ Tcl_GetHostName()
}
#ifndef NO_UNAME
+ (VOID *) memset((VOID *) &u, (int) 0, sizeof(struct utsname));
if (uname(&u) > -1) {
hp = gethostbyname(u.nodename);
if (hp != NULL) {
diff --git a/contrib/tcl/unix/tclUnixTest.c b/contrib/tcl/unix/tclUnixTest.c
index 67717d02b771..b1d16768dec9 100644
--- a/contrib/tcl/unix/tclUnixTest.c
+++ b/contrib/tcl/unix/tclUnixTest.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: @(#) tclUnixTest.c 1.4 97/05/14 13:24:29
+ * SCCS: @(#) tclUnixTest.c 1.5 97/10/31 17:23:42
*/
#include "tclInt.h"
@@ -343,6 +343,7 @@ TestfilewaitCmd(clientData, interp, argc, argv)
int mask, result, timeout;
Tcl_Channel channel;
int fd;
+ ClientData data;
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
@@ -366,10 +367,11 @@ TestfilewaitCmd(clientData, interp, argc, argv)
}
if (Tcl_GetChannelHandle(channel,
(mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE,
- (ClientData*) &fd) != TCL_OK) {
+ (ClientData*) &data) != TCL_OK) {
Tcl_SetResult(interp, "couldn't get channel file", TCL_STATIC);
return TCL_ERROR;
}
+ fd = (int) data;
if (Tcl_GetInt(interp, argv[3], &timeout) != TCL_OK) {
return TCL_ERROR;
}
diff --git a/contrib/tcl/unix/tclUnixTime.c b/contrib/tcl/unix/tclUnixTime.c
index 0c6a5d032608..ba8d984f3119 100644
--- a/contrib/tcl/unix/tclUnixTime.c
+++ b/contrib/tcl/unix/tclUnixTime.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: @(#) tclUnixTime.c 1.12 97/01/08 17:38:15
+ * SCCS: @(#) tclUnixTime.c 1.13 97/10/31 15:04:58
*/
#include "tclInt.h"
@@ -127,7 +127,7 @@ TclpGetTimeZone (currentTime)
#if defined(HAVE_TM_GMTOFF) && !defined (TCL_GOT_TIMEZONE)
# define TCL_GOT_TIMEZONE
time_t curTime = (time_t) currentTime;
- struct tm *timeDataPtr = localtime(&currentTime);
+ struct tm *timeDataPtr = localtime(&curTime);
int timeZone;
timeZone = -(timeDataPtr->tm_gmtoff / 60);
diff --git a/contrib/tcl/unix/tclXtTest.c b/contrib/tcl/unix/tclXtTest.c
index bb232569cdcd..1479412dd5eb 100644
--- a/contrib/tcl/unix/tclXtTest.c
+++ b/contrib/tcl/unix/tclXtTest.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: @(#) tclXtTest.c 1.1 97/03/24 14:30:42
+ * SCCS: @(#) tclXtTest.c 1.2 97/09/15 15:26:52
*/
#include <X11/Intrinsic.h>
@@ -100,7 +100,7 @@ TesteventloopCmd(clientData, interp, argc, argv)
done = 0;
while (!done) {
- XtProcessEvent(XtIMAll);
+ XtAppProcessEvent(TclSetAppContext(NULL), XtIMAll);
}
(void) Tcl_SetServiceMode(oldMode);
framePtr = oldFramePtr;