Import TCL v8.0 PL2.
This commit is contained in:
parent
539e1e66ff
commit
f25b19db8d
|
@ -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.
|
||||
|
|
|
@ -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 -----------------------
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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,
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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,9 +132,11 @@ 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
|
||||
|
@ -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
|
||||
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.
|
||||
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
|
||||
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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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);
|
||||
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++;
|
||||
}
|
||||
|
|
|
@ -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,31 +1153,31 @@ 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;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
Tcl_SetIntObj(resultPtr, match);
|
||||
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;
|
||||
|
@ -1564,8 +1594,11 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
|
|||
switchObjv = objv+1;
|
||||
mode = EXACT;
|
||||
|
||||
while (switchObjc > 0) {
|
||||
string = Tcl_GetStringFromObj(switchObjv[0], &length);
|
||||
while ((switchObjc > 0) && (*string == '-')) {
|
||||
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:
|
||||
|
|
|
@ -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,10 +1995,10 @@ GetToken(interp, infoPtr, envPtr)
|
|||
(char *) NULL);
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
if (termPtr != src) {
|
||||
/*
|
||||
* Find/create an object in envPtr's object array that contains
|
||||
* the integer.
|
||||
* src was the start of a valid integer. Find/create an
|
||||
* object in envPtr's object array to contain the integer.
|
||||
*/
|
||||
|
||||
savedChar = *termPtr;
|
||||
|
@ -2016,6 +2016,7 @@ GetToken(interp, infoPtr, envPtr)
|
|||
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
|
||||
|
@ -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';
|
||||
|
|
|
@ -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"
|
||||
|
@ -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);
|
||||
|
|
|
@ -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"
|
||||
|
@ -243,15 +243,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
|
||||
}
|
||||
}
|
||||
|
|
|
@ -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;
|
||||
|
@ -885,11 +886,16 @@ TclExecuteByteCode(interp, codePtr)
|
|||
* Call any trace procedures.
|
||||
*/
|
||||
|
||||
if (iPtr->tracePtr != NULL) {
|
||||
Trace *tracePtr, *nextTracePtr;
|
||||
|
||||
for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
|
||||
tracePtr = tracePtr->nextPtr) {
|
||||
tracePtr = nextTracePtr) {
|
||||
nextTracePtr = tracePtr->nextPtr;
|
||||
if (iPtr->numLevels <= tracePtr->level) {
|
||||
int numChars;
|
||||
char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
|
||||
char *cmd = GetSrcInfoForPc(pc, codePtr,
|
||||
&numChars);
|
||||
if (cmd != NULL) {
|
||||
DECACHE_STACK_INFO();
|
||||
CallTraceProcedure(interp, tracePtr, cmdPtr,
|
||||
|
@ -898,6 +904,7 @@ TclExecuteByteCode(interp, codePtr)
|
|||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* Finally, invoke the command's Tcl_ObjCmdProc. First reset
|
||||
|
@ -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,44 +2922,7 @@ 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) {
|
||||
|
@ -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) ?
|
||||
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
|
||||
((opndPtr->typePtr == &tclDoubleType) ?
|
||||
"floating-point value" : "non-numeric string"),
|
||||
" as operand of \"", operatorStrings[opCode - INST_BITOR],
|
||||
" as operand of \"", operatorStrings[opCode - INST_LOR],
|
||||
"\"", (char *) NULL);
|
||||
}
|
||||
}
|
||||
|
@ -3251,6 +3221,76 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
|
|||
ckfree((char *) p);
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* 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;
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
|
@ -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);
|
||||
|
||||
/*
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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 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;
|
||||
}
|
||||
|
|
|
@ -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;
|
||||
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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
|
||||
|
@ -58,6 +58,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;
|
||||
}
|
||||
|
||||
if (strcmp(argv[1], "tracetest") == 0) {
|
||||
Tcl_DStringInit(&buffer);
|
||||
trace = Tcl_CreateTrace(interp, 50000,
|
||||
cmdTrace = Tcl_CreateTrace(interp, 50000,
|
||||
(Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
|
||||
|
||||
result = Tcl_Eval(interp, argv[1]);
|
||||
result = Tcl_Eval(interp, argv[2]);
|
||||
if (result == TCL_OK) {
|
||||
Tcl_ResetResult(interp);
|
||||
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
|
||||
}
|
||||
|
||||
Tcl_DeleteTrace(interp, trace);
|
||||
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;
|
||||
}
|
||||
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);
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
|
@ -1790,6 +1845,47 @@ TestsetplatformCmd(clientData, interp, argc, argv)
|
|||
}
|
||||
return TCL_OK;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* 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;
|
||||
}
|
||||
|
||||
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
|
@ -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;
|
||||
}
|
||||
|
||||
|
|
|
@ -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,9 +2666,29 @@ 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 */
|
||||
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)) {
|
||||
|
@ -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,17 +2824,15 @@ 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) {
|
||||
|
@ -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,13 +3056,39 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
|
|||
"list must have an even number of elements", -1);
|
||||
return TCL_ERROR;
|
||||
}
|
||||
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) {
|
||||
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;
|
||||
}
|
||||
case 7: { /*size*/
|
||||
|
@ -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();
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
}
|
||||
|
||||
# Setup the unknown package handler
|
||||
|
||||
package unknown tclPkgUnknown
|
||||
|
||||
# Conditionalize for presence of exec.
|
||||
|
||||
package unknown tclPkgUnknown
|
||||
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
|
||||
|
@ -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] != ""} {
|
||||
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
|
||||
|
@ -694,9 +782,4 @@ proc tclPkgUnknown {name version {exact {}}} {
|
|||
}
|
||||
}
|
||||
}
|
||||
if {[info exists save_dir]} {
|
||||
set dir $save_dir
|
||||
} else {
|
||||
unset dir
|
||||
}
|
||||
}
|
||||
|
|
|
@ -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,12 +200,19 @@ proc ::tcl::OptKeyRegister {desc {key ""}} {
|
|||
set flagsprg [list [list "P" 1] $res];
|
||||
} else {
|
||||
lappend program $res;
|
||||
set empty 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
if {$inflags} {
|
||||
if {$empty} {
|
||||
# We just have the subprogram, optimize and remove
|
||||
# unneeded level:
|
||||
set program $flagsprg;
|
||||
} else {
|
||||
lappend program $flagsprg;
|
||||
}
|
||||
}
|
||||
|
||||
set OptDesc($key) $program;
|
||||
|
||||
|
@ -629,13 +641,28 @@ 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]]} {
|
||||
# (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;
|
||||
}
|
||||
if {$hits} {
|
||||
|
@ -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
|
||||
|
|
|
@ -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]]
|
||||
|
|
|
@ -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,65 +36,243 @@ namespace eval ::safe {
|
|||
proc ::safe::interpCreate {} {}
|
||||
proc ::safe::interpInit {} {}
|
||||
proc ::safe::interpConfigure {} {}
|
||||
proc ::safe::interpDelete {} {}
|
||||
|
||||
|
||||
####
|
||||
#
|
||||
# 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"
|
||||
::tcl::OptProc interpCreate {
|
||||
{?slave? -name {} "name of the slave (optional)"}
|
||||
{-accessPath -list {} "access path for the slave"}
|
||||
{-noStatics "prevent loading of statically linked pkgs"}
|
||||
{-nestedLoadOk "allow nested loading"}
|
||||
{-deleteHook -script {} "delete hook"}
|
||||
} {
|
||||
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";
|
||||
}
|
||||
} else {
|
||||
# none was given, lets return current values instead
|
||||
# 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]]]
|
||||
if {![Set [StaticsOkName $slave]]} {
|
||||
lappend res "-noStatics"
|
||||
}
|
||||
if {[Set [NestedOkName $slave]]} {
|
||||
lappend res "-nestedLoadOk"
|
||||
}
|
||||
lappend res [list -statics [Set [StaticsOkName $slave]]]
|
||||
lappend res [list -nested [Set [NestedOkName $slave]]]
|
||||
lappend res [list -deleteHook [Set [DeleteHookName $slave]]]
|
||||
join $res
|
||||
}
|
||||
2 {
|
||||
# If we have exactly 2 arguments
|
||||
# the semantic is a "configure get"
|
||||
::tcl::Lassign $args slave arg;
|
||||
# get the flag sub program (we 'know' about Opt's internal
|
||||
# representation of data)
|
||||
set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]
|
||||
set hits [::tcl::OptHits desc $arg];
|
||||
if {$hits > 1} {
|
||||
return -code error [::tcl::OptAmbigous $desc $arg]
|
||||
} elseif {$hits == 0} {
|
||||
return -code error [::tcl::OptFlagUsage $desc $arg]
|
||||
}
|
||||
CheckInterp $slave;
|
||||
set item [::tcl::OptCurDesc $desc];
|
||||
set name [::tcl::OptName $item];
|
||||
switch -exact -- $name {
|
||||
-accessPath {
|
||||
return [list -accessPath [Set [PathListName $slave]]]
|
||||
}
|
||||
-statics {
|
||||
return [list -statics [Set [StaticsOkName $slave]]]
|
||||
}
|
||||
-nested {
|
||||
return [list -nested [Set [NestedOkName $slave]]]
|
||||
}
|
||||
-deleteHook {
|
||||
return [list -deleteHook [Set [DeleteHookName $slave]]]
|
||||
}
|
||||
-noStatics {
|
||||
# it is most probably a set in fact
|
||||
# but we would need then to jump to the set part
|
||||
# and it is not *sure* that it is a set action
|
||||
# that the user want, so force it to use the
|
||||
# unambigous -statics ?value? instead:
|
||||
return -code error\
|
||||
"ambigous query (get or set -noStatics ?)\
|
||||
use -statics instead";
|
||||
}
|
||||
-nestedLoadOk {
|
||||
return -code error\
|
||||
"ambigous query (get or set -nestedLoadOk ?)\
|
||||
use -nested instead";
|
||||
}
|
||||
default {
|
||||
return -code error "unknown flag $name (bug)";
|
||||
}
|
||||
}
|
||||
}
|
||||
default {
|
||||
# Otherwise we want to parse the arguments like init and create
|
||||
# did
|
||||
set Args [::tcl::OptKeyParse ::safe::interpIC $args];
|
||||
CheckInterp $slave;
|
||||
# Get the current (and not the default) values of
|
||||
# whatever has not been given:
|
||||
if {![::tcl::OptProcArgGiven -accessPath]} {
|
||||
set doreset 1
|
||||
set accessPath [Set [PathListName $slave]]
|
||||
} else {
|
||||
set doreset 0
|
||||
}
|
||||
if { (![::tcl::OptProcArgGiven -statics])
|
||||
&& (![::tcl::OptProcArgGiven -noStatics]) } {
|
||||
set statics [Set [StaticsOkName $slave]]
|
||||
} else {
|
||||
set statics [InterpStatics]
|
||||
}
|
||||
if { ([::tcl::OptProcArgGiven -nested])
|
||||
|| ([::tcl::OptProcArgGiven -nestedLoadOk]) } {
|
||||
set nested [InterpNested]
|
||||
} else {
|
||||
set nested [Set [NestedOkName $slave]]
|
||||
}
|
||||
if {![::tcl::OptProcArgGiven -deleteHook]} {
|
||||
set deleteHook [Set [DeleteHookName $slave]]
|
||||
}
|
||||
# we can now reconfigure :
|
||||
InterpSetConfig $slave $accessPath \
|
||||
$statics $nested $deleteHook;
|
||||
# auto_reset the slave (to completly synch the new access_path)
|
||||
if {$doreset} {
|
||||
if {[catch {::interp eval $slave {auto_reset}} msg]} {
|
||||
Log $slave "auto_reset failed: $msg";
|
||||
} else {
|
||||
Log $slave "successful auto_reset" NOTICE;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
####
|
||||
#
|
||||
# Functions that actually implements the exported APIs
|
||||
#
|
||||
####
|
||||
|
||||
|
||||
#
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
|
|
@ -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]]
|
||||
|
|
|
@ -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 ""}
|
||||
|
|
|
@ -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}
|
||||
|
|
|
@ -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}
|
||||
|
|
|
@ -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}
|
||||
|
|
|
@ -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}
|
||||
|
|
|
@ -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}
|
||||
|
||||
|
|
|
@ -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}
|
||||
|
||||
# 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}
|
||||
|
|
|
@ -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
|
||||
|
||||
# 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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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}
|
||||
|
|
|
@ -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,8 +39,26 @@ 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
|
||||
|
||||
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
|
||||
|
@ -57,6 +75,7 @@ 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
|
||||
|
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
@ -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 ""}
|
||||
|
|
|
@ -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}
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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:}}
|
||||
|
||||
|
|
|
@ -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,11 +141,23 @@ 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"}
|
||||
|
@ -136,30 +166,172 @@ test resource-6.3 {resource write tests} {
|
|||
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.}}
|
||||
|
|
|
@ -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 \
|
||||
|
|
|
@ -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} {
|
||||
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.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.33 {array command, size option} {
|
||||
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.40 {array command, size option} {
|
||||
catch {unset a}
|
||||
array size a
|
||||
} {0}
|
||||
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 ""
|
||||
|
|
|
@ -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 ""
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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} {
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 \
|
||||
|
@ -898,6 +898,26 @@ alldist: dist
|
|||
gzip -9 -c $(DISTNAME).tar > $(DISTNAME).tar.gz; \
|
||||
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
|
||||
|
|
|
@ -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
|
||||
|
@ -1999,6 +1999,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
|
||||
|
|
|
@ -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)
|
||||
|
@ -268,6 +268,12 @@ if test $libbsd = yes; then
|
|||
AC_DEFINE(USE_DELTA_FOR_TZ)
|
||||
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.
|
||||
|
|
|
@ -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
|
||||
|
@ -50,6 +50,26 @@ if you run into problems, edit the Makefile after "configure" is
|
|||
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
|
||||
--------------------------------------------
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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);
|
||||
}
|
||||
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);
|
||||
}
|
||||
endpwent();
|
||||
|
||||
return TCL_OK;
|
||||
}
|
||||
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
}
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
|
|
@ -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) {
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
|
|
@ -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(¤tTime);
|
||||
struct tm *timeDataPtr = localtime(&curTime);
|
||||
int timeZone;
|
||||
|
||||
timeZone = -(timeDataPtr->tm_gmtoff / 60);
|
||||
|
|
|
@ -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;
|
||||
|
|
Loading…
Reference in New Issue