Compare commits
28
Commits
tip-616
...
core-8-2-2
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
afc90f1942 | ||
|
|
72aebeb0e0 | ||
|
|
3043b7b021 | ||
|
|
3f916836f0 | ||
|
|
d5aa5663f3 | ||
|
|
7fbc352012 | ||
|
|
9e26d55149 | ||
|
|
b6a5656b86 | ||
|
|
a749ffc6bb | ||
|
|
fd533c1ea0 | ||
|
|
997d8bc95b | ||
|
|
9a22a7fb98 | ||
|
|
e50a4ccd52 | ||
|
|
026affa06c | ||
|
|
cee92d2123 | ||
|
|
ab02c72438 | ||
|
|
33ecba92bf | ||
|
|
cc6438765e | ||
|
|
5266850d3a | ||
|
|
de292a9d9f | ||
|
|
36336894ed | ||
|
|
6051e0b7f6 | ||
|
|
90cbff24c4 | ||
|
|
200423b2be | ||
|
|
382dc12d62 | ||
|
|
9454094a1f | ||
|
|
7552a963ef | ||
|
|
de797a1c88 |
@@ -1,7 +1,236 @@
|
||||
1999-11-02 Jeff Hobbs <hobbs@scriptics.com>
|
||||
|
||||
* tagged 8.2.2 final
|
||||
* changes: updated based on ChangeLog
|
||||
* library/dde1.1/pkgIndex.tcl:
|
||||
* library/reg1.0/pkgIndex.tcl: fixed packaging to use the debug
|
||||
versions of the libraries when compiled with symbols [Bug: 3254]
|
||||
|
||||
1999-10-30 Jeff Hobbs <hobbs@scriptics.com>
|
||||
|
||||
* unix/configure.in:
|
||||
* win/configure.in:
|
||||
* README:
|
||||
* mac/README:
|
||||
* win/README.binary:
|
||||
* tools/tcl.wse.in: made demos\twind.tcl install in correct place
|
||||
* generic/tcl.h: updated to patchlevel 2
|
||||
|
||||
All of the following are backported from 8.3 alpha
|
||||
|
||||
* generic/regc_color.c:
|
||||
* generic/regc_cvec.c:
|
||||
* generic/regc_lex.c:
|
||||
* generic/regc_locale.c:
|
||||
* generic/regcomp.c:
|
||||
* generic/regcustom.h:
|
||||
* generic/regerrs.h:
|
||||
* generic/regex.h:
|
||||
* generic/regexec.c:
|
||||
* generic/regguts.h:
|
||||
* generic/tclRegexp.c:
|
||||
* generic/tclTest.c:
|
||||
* tests/reg.test: updated to Henry Spencer's new regexp engine
|
||||
(mid-Sept 99). Should greatly reduce stack space reqs.
|
||||
|
||||
* library/init.tcl: removed [info nameof]/../bin from auto_path
|
||||
|
||||
* library/http2.1/http.tcl: protected gets with catch [Bug: 2665]
|
||||
Fixed a bug in the handling of
|
||||
the state(status) variable when the -timeout flag is specified.
|
||||
Previously it was possible to leave the status undefined
|
||||
instead of empty, which caused errors in http::status
|
||||
|
||||
* mac/tclMacLoad.c: Stupid bug - we converted the filename to
|
||||
external, but used the unconverted version.
|
||||
* mac/tclMacFCmd.c: Fix a merge error in the bug fix for [Bug: 2869]
|
||||
|
||||
* tests/string.test:
|
||||
* generic/tclCmdMZ.c: fixed [string index] to return ByteArrayObj
|
||||
when indexing into one (test case string-5.16) [Bug: 2871]
|
||||
|
||||
* tests/incr.test:
|
||||
* tests/set.test:
|
||||
* generic/tclCompCmds.c: fixed improper bytecode handling of
|
||||
'eval {set array($unknownvar) 5}' (also for incr)
|
||||
|
||||
* unix/tclUnixNotfy.c: fixed event/io threading problems by
|
||||
making triggerPipe non-blocking
|
||||
|
||||
* library/tcltest1.0/tcltest.tcl:
|
||||
* generic/tclThreadTest.c: fixed mem leaks in threads
|
||||
|
||||
* generic/tclStringObj.c: fixed Tcl_AppendStringsToObjVA and
|
||||
* generic/tclResult.c: fixed Tcl_AppendResultVA to only
|
||||
iterates once over the va_list (avoiding a memcpy of it,
|
||||
which is not portable).
|
||||
|
||||
* generic/tclCompile.c: removed savedChar trick that appeared to
|
||||
be causing a segv when the literal table was released
|
||||
[Bug: 2459, 2515]
|
||||
|
||||
* generic/tclEnv.c: fixed mem leak with putenv and DStrings
|
||||
and fixed possible ABR error in environ array
|
||||
* tests/encoding.test: fixed test case that change system
|
||||
encoding to a double-byte one (this causes a bogus mem read
|
||||
error for purify)
|
||||
* unix/Makefile.in: purify has to use -best-effort to instrument
|
||||
* unix/tclUnixPipe.c: fixed mem leak in TclpCreateProcess when
|
||||
doing alloc between vfork and execvp.
|
||||
* unix/tclUnixTest.c: fixed mem leak in findexecutable test command
|
||||
|
||||
1999-10-19 Jennifer Hom <jenn@scriptics.com>
|
||||
|
||||
* library/tcltest1.0/pkgIndex.tcl: Removed nonexistent
|
||||
procs from pkgIndex.tcl.
|
||||
|
||||
* library/tcltest1.0/tcltest.tcl: Fixed the way that the
|
||||
interactive constraint is set so that it checks the content
|
||||
of the tcl_interactive flag as well as its existence, and removed
|
||||
the extra return at the end of tcltest.tcl.
|
||||
|
||||
1999-10-01 Jeff Hobbs <hobbs@scriptics.com>
|
||||
|
||||
* All frozen for 10/4/99 8.2.1 release
|
||||
* changes: updated from ChangeLog
|
||||
* unix/Makefile.in: added ChangeLog to source dist
|
||||
|
||||
1999-09-30 Jeff Hobbs <hobbs@scriptics.com>
|
||||
|
||||
* unix/configure.in:
|
||||
* win/configure.in: updated patchlevel to 1
|
||||
|
||||
1999-09-24 Jennifer Hom <jenn@scriptics.com>
|
||||
|
||||
* library/tcltest1.0/tcltest.tcl: Changed checks for value of
|
||||
tcl_interactive to checks for existence of tcl_interactive.
|
||||
|
||||
1999-09-24 Jeff Hobbs <hobbs@scriptics.com>
|
||||
|
||||
* mac/tclMacFCmd.c: fixed filename stuff to support UTF-8 [Bug: 2869]
|
||||
|
||||
* win/tclWinSerial.c: changed SerialSetOptionProc to return
|
||||
TCL_OK by default. (patch from Rolf Schroedter)
|
||||
|
||||
1999-09-23 Jeff Hobbs <hobbs@scriptics.com>
|
||||
|
||||
* README:
|
||||
* generic/tcl.h:
|
||||
* tools/tcl.wse.in: updated text to reflect 8.2.1 where necessary
|
||||
|
||||
1999-09-22 Jennifer Hom <jenn@scriptics.com>
|
||||
|
||||
* tests/tcltest.test: Added 'exit' calls to the scripts that the
|
||||
test creates and added tests for -tmpdir and -args.
|
||||
|
||||
* tests/env.test:
|
||||
* tests/exec.test: Added 'exit' calls to scripts that the tests
|
||||
themselves write.
|
||||
|
||||
* tests/README: Cleaned up documentation in README so that it
|
||||
refers to variables and documentation that actually exist. Also
|
||||
added missing documentation for flag usage.
|
||||
|
||||
* library/tcltest1.0/tcltest.tcl: Added a -args flag that sets a
|
||||
variable named ::tcltest::parameters based on whatever's being
|
||||
sent in as the argument to the -args flag. Modified tcltest so
|
||||
that tcltest namespace variables are only initialized to their
|
||||
default values if they did not previously exist. Modified the
|
||||
::tcltest::testConstraints variable so that it isn't unset every
|
||||
time ::tcltest::initConstraints is called. Modified command line
|
||||
processing so that they are only processed if ::tcltest doesn't
|
||||
have a child namespace (if there is a child namespace, then the
|
||||
command line arguments *must* be processed in that namespace).
|
||||
|
||||
1999-09-21 Jeff Hobbs <hobbs@scriptics.com>
|
||||
|
||||
* tests/env.test:
|
||||
* unix/Makefile.in: added support for AIX LIBPATH env var [Bug: 2793]
|
||||
removed second definition of INCLUDE_INSTALL_DIR (the one that
|
||||
referenced @includedir@) [Bug: 2805]
|
||||
* unix/dltest/Makefile.in: added -lc to LIBS [Bug: 2794]
|
||||
|
||||
* tests/timer.test: changed after delay in timer test 6.29 from
|
||||
1 to 10. [Bug: 2796]
|
||||
|
||||
* tests/pkg.test:
|
||||
* generic/tclPkg.c: fixed package version check to disallow 1.2..3
|
||||
[Bug: 2539]
|
||||
|
||||
* unix/Makefile.in: fixed gendate target - this never worked
|
||||
since RCS was intro'd.
|
||||
* generic/tclGetDate.y: updated to reflect previous changes
|
||||
to tclDate.c (leap year calc) and added CEST and UCT time zone
|
||||
recognition. Fixed 4 missing UCHAR() casts. [Bug: 2717, 954,
|
||||
1245, 1249]
|
||||
|
||||
* generic/tclCkalloc.c: changed Tcl_DumpActiveMemory to really
|
||||
dump to stderr and close it [Bug: 725] and changed Tcl_Ckrealloc
|
||||
and Tcl_Ckfree to not bomb when NULL was passed in [Bug: 1719]
|
||||
and changed Tcl_Alloc, et al to not panic when a alloc request
|
||||
for zero came through and NULL was returned (valid on AIX, Tru64)
|
||||
[Bug: 2795, etc]
|
||||
|
||||
* generic/tclIOCmd.c: fixed potential core dump in conjunction
|
||||
with stacked channels with result obj manipulation in
|
||||
Tcl_ReadChars [Bug: 2623]
|
||||
|
||||
* tests/format.test:
|
||||
* generic/tclCmdAH.c: fixed translation of %0#s in format [Bug: 2605]
|
||||
|
||||
* tests/set-old.test:
|
||||
* generic/tclVar.c: Added fix in TclArraySet
|
||||
to check when trying to set in a non-existent namespace. [Bug: 2613]
|
||||
|
||||
* tests/linsert.test:
|
||||
* generic/tclCmdIL.c: fixed end-int interpretation of linsert
|
||||
to correctly calculate value for end, added test and docs [Bug: 2693]
|
||||
|
||||
* doc/switch.n: added proper use of comments to example.
|
||||
* generic/tclCmdMZ.c: changed switch to complain when an error
|
||||
occurs that seems to be due to a misplaced comment.
|
||||
|
||||
* generic/tclCmdMZ.c: fixed illegal ref for \[0-9] substitutions
|
||||
in regsub [Bug: 2723]
|
||||
|
||||
* generic/tclCmdMZ.c: changed [string equal] to return an Int
|
||||
type object (was a Boolean)
|
||||
|
||||
* generic/tclParseExpr.c: changed '"' to '\"' to make FreeBSD
|
||||
happy [Bug: 2625]
|
||||
|
||||
* generic/tclProc.c: moved static buf to better location and
|
||||
changed static msg that would overflow in ProcessProcResultCode
|
||||
[Bug: 2483] and added Tcl_DStringFree to Tcl_ProcObjCmd.
|
||||
Also reworked size of static buffers.
|
||||
|
||||
* tests/stringObj.test: added test 9.11
|
||||
* generic/tclStringObj.c: changed Tcl_AppendObjToObj to
|
||||
properly handle the 1-byte dest and mixed src case where
|
||||
both had had Unicode string len checks made on them. [Bug: 2678]
|
||||
|
||||
* unix/aclocal.m4:
|
||||
* unix/tcl.m4: added -bnoentry to the AIX-* case [Bug: 1909]
|
||||
added fix for FreeBSD-[1-2] recognition
|
||||
[Bug: 2070] and fix for IRIX SHLIB_LB_LIBS. [Bug: 2610]
|
||||
|
||||
* generic/tclPosixStr.c: fixed typo [Bug: 2592]
|
||||
|
||||
* win/README.binary: fixed version info and some typos [Bug: 2561]
|
||||
|
||||
* generic/tclIO.c: changed Tcl_GetChannelNames* to use style guide
|
||||
headers (pleases HP cc)
|
||||
|
||||
* tests/expr.test:
|
||||
* generic/tclCompile.c: add TCL_TOKEN_VARIABLE to the part types
|
||||
that cause differed compilation for exprs, to correct the expr
|
||||
double-evaluation problem for vars. Added test cases.
|
||||
Related to [Bug: 732]
|
||||
|
||||
1999-08-05 Jim Ingham <jingham@cygnus.com>
|
||||
|
||||
* mac/tclMacProjects.sea.hqx: Rearrange the projects so that the build
|
||||
directory is separate from the sources. Much more convenient!
|
||||
* mac/tclMacProjects.sea.hqx: Rearrange the projects so that the build
|
||||
directory is separate from the sources. Much more convenient!
|
||||
|
||||
1999-08-12 Scott Stanton <stanton@scriptics.com>
|
||||
|
||||
@@ -115,6 +344,13 @@
|
||||
instead to send a message to the socket event window to tell it to
|
||||
terminate its thread.
|
||||
|
||||
1999-07-30 Jennifer Hom <jenn@scriptics.com>
|
||||
|
||||
* tests/tcltest.test:
|
||||
* library/tcltest1.0/tcltest.tcl: Exit with non-zero status if
|
||||
there were problems with the way the test suite was started
|
||||
(e.g. wrong # arguments).
|
||||
|
||||
1999-07-30 Jeff Hobbs <hobbs@scriptics.com>
|
||||
|
||||
* generic/tclInt.decls: added declaractions necessary for the
|
||||
|
||||
@@ -1,9 +1,9 @@
|
||||
README: Tcl
|
||||
This is the Tcl 8.2.0 source distribution.
|
||||
This is the Tcl 8.2.1 source distribution.
|
||||
You can get this release from:
|
||||
http://www.scriptics.com/registration/8.2.0.tml
|
||||
http://www.scriptics.com/registration/8.2.1.tml
|
||||
|
||||
RCS: @(#) $Id: README,v 1.23 1999/08/10 23:16:25 redman Exp $
|
||||
RCS: @(#) $Id: README,v 1.23.2.1 1999/09/24 02:01:41 hobbs Exp $
|
||||
|
||||
Contents
|
||||
--------
|
||||
@@ -50,7 +50,7 @@ Information about new features in 8.2 can be found at
|
||||
http://www.scriptics.com/software/whatsnew82.html
|
||||
|
||||
Detailed release notes can be found at
|
||||
http://www.scriptics.com/software/relnotes/tcl8.2.0
|
||||
http://www.scriptics.com/software/relnotes/tcl8.2.1
|
||||
|
||||
Information about Tcl itself can be found at
|
||||
http://www.scriptics.com/scripting/
|
||||
|
||||
@@ -1,6 +1,6 @@
|
||||
Recent user-visible changes to Tcl:
|
||||
|
||||
RCS: @(#) $Id: changes,v 1.50 1999/08/13 18:30:24 redman Exp $
|
||||
RCS: @(#) $Id: changes,v 1.50.2.2 1999/11/03 00:42:07 hobbs Exp $
|
||||
|
||||
1. No more [command1] [command2] construct for grouping multiple
|
||||
commands on a single command line.
|
||||
@@ -4640,3 +4640,46 @@ error code. [Bug: 2535] (stanton)
|
||||
|
||||
--------------- Released 8.2.0, August 17, 1999 ----------------------
|
||||
|
||||
9/21/99 (config fixes) fixed several AIX configuration issues. gcc and
|
||||
threading may still cause problems on AIX. (hobbs)
|
||||
|
||||
9/21/99 (bug fix) fixed expr double-eval problem. [Bug: 732] (hobbs)
|
||||
|
||||
9/21/99 (bug fix) fixed static buffer overflow problem. [Bug: 2483] (hobbs)
|
||||
|
||||
9/21/99 (bug fix) fixed end-int linsert interpretation. [Bug: 2693] (hobbs)
|
||||
|
||||
9/21/99 (bug fix) fixed bug when setting array in non-existent
|
||||
namespace. [Bug: 2613] (hobbs)
|
||||
|
||||
--- Released 8.2.1, October 04, 1999 --- See ChangeLog for details ---
|
||||
|
||||
10/30/99 (feature enhancement) new regexp engine from Henry Spencer
|
||||
was patched in - should greatly reduce stack space usage. (spencer)
|
||||
|
||||
10/30/99 (bug fix) fixed Purify reported memory leaks in findexecutable
|
||||
test command, TclpCreateProcess on Unix, in handling of C environ array,
|
||||
and in testthread code. No more known (reported) mem leaks for Tcl
|
||||
built using gcc on Solaris 2.5.1. Also none reported for Tcl on NT
|
||||
(using Purify 6.0). (hobbs)
|
||||
|
||||
10/30/99 (bug fix) fixed improper bytecode handling of
|
||||
'eval {set array($unknownvar) 5}' (also for incr) (hobbs)
|
||||
|
||||
10/30/99 (bug fix) fixed event/io threading problems by making
|
||||
triggerPipe non-blocking (nick kisserbeth)
|
||||
|
||||
10/30/99 (bug fix) fixed Tcl_AppendStringsToObjVA and Tcl_AppendResultVA
|
||||
to only iterates once over the va_list (avoiding non-portable memcpy).
|
||||
(joe english, hobbs)
|
||||
|
||||
10/30/99 (bug fix) removed savedChar trick in tclCompile.c that appeared
|
||||
to be causing a segv when the literal table was released.
|
||||
[Bug: 2459, 2515] (David Whitehouse)
|
||||
|
||||
10/30/99 (bug fix) fixed [string index] to return ByteArrayObj
|
||||
when indexing into one (test case string-5.16) [Bug: 2871] (hobbs)
|
||||
|
||||
10/30/99 (bug fix) fixes for mac UTF filename handling (ingham)
|
||||
|
||||
--- Released 8.2.2, November 04, 1999 --- See ChangeLog for details ---
|
||||
|
||||
+5
-2
@@ -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.
|
||||
'\"
|
||||
'\" RCS: @(#) $Id: switch.n,v 1.3 1999/06/24 21:15:14 jpeek Exp $
|
||||
'\" RCS: @(#) $Id: switch.n,v 1.3.4.1 1999/09/22 04:12:42 hobbs Exp $
|
||||
'\"
|
||||
.so man.macros
|
||||
.TH switch n 7.0 Tcl "Tcl Built-In Commands"
|
||||
@@ -94,7 +94,10 @@ will return \fB1\fR, and
|
||||
a
|
||||
\-
|
||||
b
|
||||
{format 1}
|
||||
{
|
||||
# Correct Comment Placement (in switch body)
|
||||
format 1
|
||||
}
|
||||
a*
|
||||
{format 2}
|
||||
default
|
||||
|
||||
@@ -97,7 +97,7 @@ struct colormap *cm;
|
||||
cm->magic = 0;
|
||||
if (NBYTS > 1)
|
||||
cmtreefree(cm, cm->tree, 0);
|
||||
for (i = 1; i < cm->max; i++) /* skip WHITE */
|
||||
for (i = 1; i <= cm->max; i++) /* skip WHITE */
|
||||
if (!UNUSEDCOLOR(&cm->cd[i])) {
|
||||
cb = cm->cd[i].block;
|
||||
if (cb != NULL)
|
||||
@@ -456,7 +456,7 @@ struct state *rp;
|
||||
color co;
|
||||
color sco;
|
||||
|
||||
assert((uc & BYTMASK) == 0);
|
||||
assert((uc % BYTTAB) == 0);
|
||||
|
||||
/* find its color block, making new pointer blocks as needed */
|
||||
t = cm->tree;
|
||||
@@ -614,8 +614,6 @@ struct arc *a;
|
||||
a->colorchain = NULL; /* paranoia */
|
||||
}
|
||||
|
||||
#ifdef NOTDEF /* This isn't used currently. */
|
||||
|
||||
/*
|
||||
- singleton - is this character in its own color?
|
||||
^ static int singleton(struct colormap *, pchr c);
|
||||
@@ -633,8 +631,6 @@ pchr c;
|
||||
return 0;
|
||||
}
|
||||
|
||||
#endif /* NOTDEF */
|
||||
|
||||
/*
|
||||
- rainbow - add arcs of all full colors (but one) between specified states
|
||||
^ static VOID rainbow(struct nfa *, struct colormap *, int, pcolor,
|
||||
|
||||
+9
-10
@@ -110,8 +110,6 @@ pchr to;
|
||||
cv->nranges++;
|
||||
}
|
||||
|
||||
#ifdef NOTDEF /* This isn't used currently. */
|
||||
|
||||
/*
|
||||
- addmcce - add an MCCE to a cvec
|
||||
^ static VOID addmcce(struct cvec *, chr *, chr *);
|
||||
@@ -122,25 +120,26 @@ struct cvec *cv;
|
||||
chr *startp; /* beginning of text */
|
||||
chr *endp; /* just past end of text */
|
||||
{
|
||||
int n = endp - startp;
|
||||
int len;
|
||||
int i;
|
||||
chr *s;
|
||||
chr *d;
|
||||
|
||||
assert(n > 0);
|
||||
assert(cv->nchrs + n < cv->chrspace - cv->nmccechrs);
|
||||
if (startp == NULL && endp == NULL)
|
||||
return;
|
||||
len = endp - startp;
|
||||
assert(len > 0);
|
||||
assert(cv->nchrs + len < cv->chrspace - cv->nmccechrs);
|
||||
assert(cv->nmcces < cv->mccespace);
|
||||
d = &cv->chrs[cv->chrspace - cv->nmccechrs - n - 1];
|
||||
d = &cv->chrs[cv->chrspace - cv->nmccechrs - len - 1];
|
||||
cv->mcces[cv->nmcces++] = d;
|
||||
for (s = startp, i = n; i > 0; s++, i--)
|
||||
for (s = startp, i = len; i > 0; s++, i--)
|
||||
*d++ = *s;
|
||||
*d++ = 0; /* endmarker */
|
||||
assert(d == &cv->chrs[cv->chrspace - cv->nmccechrs]);
|
||||
cv->nmccechrs += n + 1;
|
||||
cv->nmccechrs += len + 1;
|
||||
}
|
||||
|
||||
#endif /* NOTDEF */
|
||||
|
||||
/*
|
||||
- haschr - does a cvec contain this chr?
|
||||
^ static int haschr(struct cvec *, pchr);
|
||||
|
||||
+3
-2
@@ -1010,8 +1010,9 @@ newline()
|
||||
}
|
||||
|
||||
/*
|
||||
- ch - return the chr sequence for locale.c's fake collating element ch
|
||||
* This helps confine use of CHR to this source file.
|
||||
- ch - return the chr sequence for regc_locale.c's fake collating element ch
|
||||
* This helps confine use of CHR to this source file. Beware that the caller
|
||||
* knows how long the sequence is.
|
||||
^ #ifdef REG_DEBUG
|
||||
^ static chr *ch(NOPARMS);
|
||||
^ #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.
|
||||
*
|
||||
* RCS: @(#) $Id: regc_locale.c,v 1.4 1999/06/24 03:27:56 stanton Exp $
|
||||
* RCS: @(#) $Id: regc_locale.c,v 1.4.4.1 1999/11/02 02:09:48 hobbs Exp $
|
||||
*/
|
||||
|
||||
/* ASCII character-name table */
|
||||
@@ -634,7 +634,7 @@ int cases; /* all cases? */
|
||||
struct cvec *cv;
|
||||
|
||||
/* crude fake equivalence class for testing */
|
||||
if ((v->cflags®_FAKEEC) && c == 'x') {
|
||||
if ((v->cflags®_FAKE) && c == 'x') {
|
||||
cv = getcvec(v, 4, 0, 0);
|
||||
addchr(cv, (chr)'x');
|
||||
addchr(cv, (chr)'y');
|
||||
|
||||
+14
-18
@@ -105,9 +105,7 @@ static VOID subblock _ANSI_ARGS_((struct vars *, pchr, struct state *, struct st
|
||||
static VOID okcolors _ANSI_ARGS_((struct nfa *, struct colormap *));
|
||||
static VOID colorchain _ANSI_ARGS_((struct colormap *, struct arc *));
|
||||
static VOID uncolorchain _ANSI_ARGS_((struct colormap *, struct arc *));
|
||||
#ifdef NOTDEF /* Avoid compiler warnings. */
|
||||
static int singleton _ANSI_ARGS_((struct colormap *, pchr c));
|
||||
#endif
|
||||
static VOID rainbow _ANSI_ARGS_((struct nfa *, struct colormap *, int, pcolor, struct state *, struct state *));
|
||||
static VOID colorcomplement _ANSI_ARGS_((struct nfa *, struct colormap *, int, struct state *, struct state *, struct state *));
|
||||
#ifdef REG_DEBUG
|
||||
@@ -173,9 +171,7 @@ static struct cvec *newcvec _ANSI_ARGS_((int, int, int));
|
||||
static struct cvec *clearcvec _ANSI_ARGS_((struct cvec *));
|
||||
static VOID addchr _ANSI_ARGS_((struct cvec *, pchr));
|
||||
static VOID addrange _ANSI_ARGS_((struct cvec *, pchr, pchr));
|
||||
#ifdef NOTDEF /* Avoid compiler warnings. */
|
||||
static VOID addmcce _ANSI_ARGS_((struct cvec *, chr *, chr *));
|
||||
#endif
|
||||
static int haschr _ANSI_ARGS_((struct cvec *, pchr));
|
||||
static struct cvec *getcvec _ANSI_ARGS_((struct vars *, int, int, int));
|
||||
static VOID freecvec _ANSI_ARGS_((struct cvec *));
|
||||
@@ -229,7 +225,6 @@ struct vars {
|
||||
struct state *mccepend; /* in nfa, end of MCCE prototypes */
|
||||
struct subre *lacons; /* lookahead-constraint vector */
|
||||
int nlacons; /* size of lacons */
|
||||
int usedshorter; /* used short-preferring quantifiers */
|
||||
};
|
||||
|
||||
/* parsing macros; most know that `v' is the struct vars pointer */
|
||||
@@ -362,6 +357,7 @@ int flags;
|
||||
CNOERR();
|
||||
v->mcces = allmcces(v, v->mcces);
|
||||
leaders(v, v->mcces);
|
||||
addmcce(v->mcces, (chr *)NULL, (chr *)NULL); /* dummy */
|
||||
}
|
||||
CNOERR();
|
||||
|
||||
@@ -386,18 +382,16 @@ int flags;
|
||||
dumpnfa(v->nfa, debug);
|
||||
dumpst(v->tree, debug, 1);
|
||||
}
|
||||
v->usedshorter = 0;
|
||||
optst(v, v->tree);
|
||||
v->ntree = numst(v->tree, 1);
|
||||
markst(v->tree);
|
||||
cleanst(v);
|
||||
if (debug != NULL) {
|
||||
fprintf(debug, "\n\n\n========= TREE FIXED ==========\n");
|
||||
fprintf(debug, "-->\n");
|
||||
dumpst(v->tree, debug, 1);
|
||||
}
|
||||
|
||||
/* build compacted NFAs for tree, lacons, fast search */
|
||||
/* build compacted NFAs for tree and lacons */
|
||||
re->re_info |= nfatree(v, v->tree, debug);
|
||||
CNOERR();
|
||||
assert(v->nlacons == 0 || v->lacons != NULL);
|
||||
@@ -407,6 +401,10 @@ int flags;
|
||||
nfanode(v, &v->lacons[i], debug);
|
||||
}
|
||||
CNOERR();
|
||||
if (v->tree->flags&SHORTER)
|
||||
NOTE(REG_USHORTEST);
|
||||
|
||||
/* build compacted NFAs for tree, lacons, fast search */
|
||||
if (debug != NULL)
|
||||
fprintf(debug, "\n\n\n========= SEARCH ==========\n");
|
||||
/* can sacrifice main NFA now, so use it as work area */
|
||||
@@ -431,7 +429,6 @@ int flags;
|
||||
g->lacons = v->lacons;
|
||||
v->lacons = NULL;
|
||||
g->nlacons = v->nlacons;
|
||||
g->usedshorter = v->usedshorter;
|
||||
|
||||
if (flags®_DUMP)
|
||||
dump(re, stdout);
|
||||
@@ -507,7 +504,7 @@ int err;
|
||||
}
|
||||
|
||||
/*
|
||||
- makesearch - turn an NFA into a fast-scan NFA (implicit prepend of .*?)
|
||||
- makesearch - turn an NFA into a search NFA (implicit prepend of .*?)
|
||||
* NFA must have been optimize()d already.
|
||||
^ static VOID makesearch(struct vars *, struct nfa *);
|
||||
*/
|
||||
@@ -1653,6 +1650,10 @@ struct state *rp;
|
||||
for (i = 0; i < cv->nmcces; i++) {
|
||||
p = cv->mcces[i];
|
||||
assert(singleton(v->cm, *p));
|
||||
if (!singleton(v->cm, *p)) {
|
||||
ERR(REG_ASSERT);
|
||||
return;
|
||||
}
|
||||
ch = *p++;
|
||||
co = GETCOLOR(v->cm, ch);
|
||||
a = findarc(lp, PLAIN, co);
|
||||
@@ -1835,10 +1836,6 @@ struct subre *t;
|
||||
if (t == NULL)
|
||||
return;
|
||||
|
||||
/* preference cleanup and analysis */
|
||||
if (t->flags&SHORTER)
|
||||
v->usedshorter = 1;
|
||||
|
||||
/* recurse through children */
|
||||
if (t->left != NULL)
|
||||
optst(v, t->left);
|
||||
@@ -1937,7 +1934,7 @@ FILE *f; /* for debug output */
|
||||
{
|
||||
struct nfa *nfa;
|
||||
long ret = 0;
|
||||
char idbuf[50];
|
||||
char idbuf[50];
|
||||
|
||||
assert(t->begin != NULL);
|
||||
|
||||
@@ -2066,9 +2063,8 @@ FILE *f;
|
||||
GUTSMAGIC);
|
||||
|
||||
fprintf(f, "\n\n\n========= DUMP ==========\n");
|
||||
fprintf(f, "nsub %d, info 0%lo, csize %d, ntree %d, usedshort %d\n",
|
||||
re->re_nsub, re->re_info, re->re_csize, g->ntree,
|
||||
g->usedshorter);
|
||||
fprintf(f, "nsub %d, info 0%lo, csize %d, ntree %d\n",
|
||||
re->re_nsub, re->re_info, re->re_csize, g->ntree);
|
||||
|
||||
dumpcolors(&g->cmap, f);
|
||||
if (!NULLCNFA(g->search)) {
|
||||
|
||||
+9
-8
@@ -26,11 +26,10 @@
|
||||
* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
*/
|
||||
|
||||
/* headers (which also pick up the standard ones, or equivalents) */
|
||||
/* headers if any */
|
||||
#include "tclInt.h"
|
||||
|
||||
/* overrides for regguts.h definitions */
|
||||
/* function-pointer declarations */
|
||||
/* overrides for regguts.h definitions, if any */
|
||||
#define FUNCPTR(name, args) (*name) _ANSI_ARGS_(args)
|
||||
#define MALLOC(n) ckalloc(n)
|
||||
#define FREE(p) ckfree(VS(p))
|
||||
@@ -62,6 +61,12 @@
|
||||
#ifdef __REG_CONST
|
||||
#undef __REG_CONST
|
||||
#endif
|
||||
#ifdef __REG_NOFRONT
|
||||
#undef __REG_NOFRONT
|
||||
#endif
|
||||
#ifdef __REG_NOCHAR
|
||||
#undef __REG_NOCHAR
|
||||
#endif
|
||||
/* interface types */
|
||||
#define __REG_WIDE_T Tcl_UniChar
|
||||
#define __REG_REGOFF_T long /* not really right, but good enough... */
|
||||
@@ -70,12 +75,8 @@
|
||||
/* names and declarations */
|
||||
#define __REG_WIDE_COMPILE TclReComp
|
||||
#define __REG_WIDE_EXEC TclReExec
|
||||
#ifndef __REG_NOFRONT
|
||||
#define __REG_NOFRONT /* don't want regcomp() and regexec() */
|
||||
#endif
|
||||
#ifndef __REG_NOCHAR
|
||||
#define __REG_NOCHAR /* or the char versions */
|
||||
#endif
|
||||
#define regfree TclReFree
|
||||
#define regerror TclReError
|
||||
/* --- end --- */
|
||||
@@ -105,7 +106,7 @@ typedef int celt; /* type to hold chr, MCCE number, or NOCELT */
|
||||
#define exec TclReExec
|
||||
|
||||
/* enable/disable debugging code (by whether REG_DEBUG is defined or not) */
|
||||
#ifdef notdef
|
||||
#if 0 /* no debug unless requested by makefile */
|
||||
#define REG_DEBUG /* */
|
||||
#endif
|
||||
|
||||
|
||||
+1
-1
@@ -1,6 +1,6 @@
|
||||
{ REG_OKAY, "REG_OKAY", "no errors detected" },
|
||||
{ REG_NOMATCH, "REG_NOMATCH", "failed to match" },
|
||||
{ REG_BADPAT, "REG_BADPAT", "invalid regexp (reg version 0.4)" },
|
||||
{ REG_BADPAT, "REG_BADPAT", "invalid regexp (reg version 0.8)" },
|
||||
{ REG_ECOLLATE, "REG_ECOLLATE", "invalid collating element" },
|
||||
{ REG_ECTYPE, "REG_ECTYPE", "invalid character class" },
|
||||
{ REG_EESCAPE, "REG_EESCAPE", "invalid escape \\ sequence" },
|
||||
|
||||
+9
-6
@@ -101,6 +101,12 @@ extern "C" {
|
||||
#ifdef __REG_CONST
|
||||
#undef __REG_CONST
|
||||
#endif
|
||||
#ifdef __REG_NOFRONT
|
||||
#undef __REG_NOFRONT
|
||||
#endif
|
||||
#ifdef __REG_NOCHAR
|
||||
#undef __REG_NOCHAR
|
||||
#endif
|
||||
/* interface types */
|
||||
#define __REG_WIDE_T Tcl_UniChar
|
||||
#define __REG_REGOFF_T long /* not really right, but good enough... */
|
||||
@@ -109,12 +115,8 @@ extern "C" {
|
||||
/* names and declarations */
|
||||
#define __REG_WIDE_COMPILE TclReComp
|
||||
#define __REG_WIDE_EXEC TclReExec
|
||||
#ifndef __REG_NOFRONT
|
||||
#define __REG_NOFRONT /* don't want regcomp() and regexec() */
|
||||
#endif
|
||||
#ifndef __REG_NOCHAR
|
||||
#define __REG_NOCHAR /* or the char versions */
|
||||
#endif
|
||||
#define regfree TclReFree
|
||||
#define regerror TclReError
|
||||
/* --- end --- */
|
||||
@@ -163,7 +165,7 @@ typedef void re_void;
|
||||
typedef struct {
|
||||
int re_magic; /* magic number */
|
||||
size_t re_nsub; /* number of subexpressions */
|
||||
int re_info; /* information about RE */
|
||||
long re_info; /* information about RE */
|
||||
# define REG_UBACKREF 000001
|
||||
# define REG_ULOOKAHEAD 000002
|
||||
# define REG_UBOUNDS 000004
|
||||
@@ -177,6 +179,7 @@ typedef struct {
|
||||
# define REG_ULOCALE 002000
|
||||
# define REG_UEMPTYMATCH 004000
|
||||
# define REG_UIMPOSSIBLE 010000
|
||||
# define REG_USHORTEST 020000
|
||||
int re_csize; /* sizeof(character) */
|
||||
char *re_endp; /* backward compatibility kludge */
|
||||
/* the rest is opaque pointers to hidden innards */
|
||||
@@ -225,7 +228,7 @@ typedef struct {
|
||||
#define REG_EXPECT 001000 /* report details on partial/limited matches */
|
||||
#define REG_BOSONLY 002000 /* temporary kludge for BOS-only matches */
|
||||
#define REG_DUMP 004000 /* none of your business :-) */
|
||||
#define REG_FAKEEC 010000 /* none of your business :-) */
|
||||
#define REG_FAKE 010000 /* none of your business :-) */
|
||||
#define REG_PROGRESS 020000 /* none of your business :-) */
|
||||
|
||||
|
||||
|
||||
+66
-82
@@ -33,29 +33,6 @@
|
||||
|
||||
|
||||
|
||||
/* internal variables, bundled for easy passing around */
|
||||
struct vars {
|
||||
regex_t *re;
|
||||
struct guts *g;
|
||||
int eflags; /* copies of arguments */
|
||||
size_t nmatch;
|
||||
regmatch_t *pmatch;
|
||||
rm_detail_t *details;
|
||||
chr *start; /* start of string */
|
||||
chr *stop; /* just past end of string */
|
||||
int err; /* error code if any (0 none) */
|
||||
regoff_t *mem; /* memory vector for backtracking */
|
||||
};
|
||||
#define VISERR(vv) ((vv)->err != 0) /* have we seen an error yet? */
|
||||
#define ISERR() VISERR(v)
|
||||
#define VERR(vv,e) (((vv)->err) ? (vv)->err : ((vv)->err = (e)))
|
||||
#define ERR(e) VERR(v, e) /* record an error */
|
||||
#define NOERR() {if (ISERR()) return;} /* if error seen, return */
|
||||
#define OFF(p) ((p) - v->start)
|
||||
#define LOFF(p) ((long)OFF(p))
|
||||
|
||||
|
||||
|
||||
/* lazy-DFA representation */
|
||||
struct arcp { /* "pointer" to an outarc */
|
||||
struct sset *ss;
|
||||
@@ -111,9 +88,34 @@ struct smalldfa {
|
||||
struct sset *outsarea[FEWSTATES*2 * FEWCOLORS];
|
||||
struct arcp incarea[FEWSTATES*2 * FEWCOLORS];
|
||||
};
|
||||
#define DOMALLOC ((struct smalldfa *)NULL) /* force malloc */
|
||||
|
||||
|
||||
|
||||
/* internal variables, bundled for easy passing around */
|
||||
struct vars {
|
||||
regex_t *re;
|
||||
struct guts *g;
|
||||
int eflags; /* copies of arguments */
|
||||
size_t nmatch;
|
||||
regmatch_t *pmatch;
|
||||
rm_detail_t *details;
|
||||
chr *start; /* start of string */
|
||||
chr *stop; /* just past end of string */
|
||||
int err; /* error code if any (0 none) */
|
||||
regoff_t *mem; /* memory vector for backtracking */
|
||||
struct smalldfa dfa1;
|
||||
struct smalldfa dfa2;
|
||||
};
|
||||
#define VISERR(vv) ((vv)->err != 0) /* have we seen an error yet? */
|
||||
#define ISERR() VISERR(v)
|
||||
#define VERR(vv,e) (((vv)->err) ? (vv)->err : ((vv)->err = (e)))
|
||||
#define ERR(e) VERR(v, e) /* record an error */
|
||||
#define NOERR() {if (ISERR()) return v->err;} /* if error seen, return it */
|
||||
#define OFF(p) ((p) - v->start)
|
||||
#define LOFF(p) ((long)OFF(p))
|
||||
|
||||
|
||||
|
||||
/*
|
||||
* forward declarations
|
||||
@@ -196,8 +198,8 @@ int flags;
|
||||
if (v->g->cflags®_NOSUB)
|
||||
nmatch = 0; /* override client */
|
||||
v->nmatch = nmatch;
|
||||
if (backref && v->nmatch < v->g->nsub + 1) {
|
||||
/* need work area bigger than what user gave us */
|
||||
if (backref) {
|
||||
/* need work area */
|
||||
if (v->g->nsub + 1 <= LOCALMAT)
|
||||
v->pmatch = mat;
|
||||
else
|
||||
@@ -260,10 +262,8 @@ struct vars *v;
|
||||
struct cnfa *cnfa;
|
||||
struct colormap *cm;
|
||||
{
|
||||
struct smalldfa da;
|
||||
struct dfa *d = newdfa(v, cnfa, cm, &da);
|
||||
struct smalldfa sa;
|
||||
struct dfa *s = newdfa(v, &v->g->search, cm, &sa);
|
||||
struct dfa *s;
|
||||
struct dfa *d;
|
||||
chr *begin;
|
||||
chr *end;
|
||||
chr *cold;
|
||||
@@ -272,19 +272,15 @@ struct colormap *cm;
|
||||
int hitend;
|
||||
int shorter = (v->g->tree->flags&SHORTER) ? 1 : 0;
|
||||
|
||||
if (ISERR()) { /* should be newdfa() failure */
|
||||
if (d != NULL)
|
||||
freedfa(d);
|
||||
if (s != NULL)
|
||||
freedfa(s);
|
||||
return v->err;
|
||||
}
|
||||
|
||||
/* first, a shot with the search RE */
|
||||
s = newdfa(v, &v->g->search, cm, &v->dfa1);
|
||||
assert(!(ISERR() && s != NULL));
|
||||
NOERR();
|
||||
MDEBUG(("\nsearch at %ld\n", LOFF(v->start)));
|
||||
cold = NULL;
|
||||
close = shortest(v, s, v->start, v->start, v->stop, &cold, (int *)NULL);
|
||||
freedfa(s);
|
||||
NOERR();
|
||||
if (v->g->cflags®_EXPECT) {
|
||||
assert(v->details != NULL);
|
||||
if (cold != NULL)
|
||||
@@ -293,22 +289,19 @@ struct colormap *cm;
|
||||
v->details->rm_extend.rm_so = OFF(v->stop);
|
||||
v->details->rm_extend.rm_eo = OFF(v->stop); /* unknown */
|
||||
}
|
||||
if (close == NULL) { /* not found */
|
||||
freedfa(d);
|
||||
if (ISERR())
|
||||
return v->err;
|
||||
if (close == NULL) /* not found */
|
||||
return REG_NOMATCH;
|
||||
}
|
||||
if (v->nmatch == 0) { /* found, don't need exact location */
|
||||
freedfa(d);
|
||||
if (v->nmatch == 0) /* found, don't need exact location */
|
||||
return REG_OKAY;
|
||||
}
|
||||
|
||||
/* find starting point */
|
||||
/* find starting point and match */
|
||||
assert(cold != NULL);
|
||||
open = cold;
|
||||
cold = NULL;
|
||||
MDEBUG(("between %ld and %ld\n", LOFF(open), LOFF(close)));
|
||||
d = newdfa(v, cnfa, cm, &v->dfa1);
|
||||
assert(!(ISERR() && d != NULL));
|
||||
NOERR();
|
||||
for (begin = open; begin <= close; begin++) {
|
||||
MDEBUG(("\nfind trying at %ld\n", LOFF(begin)));
|
||||
if (shorter)
|
||||
@@ -316,6 +309,7 @@ struct colormap *cm;
|
||||
(chr **)NULL, &hitend);
|
||||
else
|
||||
end = longest(v, d, begin, v->stop, &hitend);
|
||||
NOERR();
|
||||
if (hitend && cold == NULL)
|
||||
cold = begin;
|
||||
if (end != NULL)
|
||||
@@ -335,13 +329,12 @@ struct colormap *cm;
|
||||
v->details->rm_extend.rm_so = OFF(v->stop);
|
||||
v->details->rm_extend.rm_eo = OFF(v->stop); /* unknown */
|
||||
}
|
||||
if (v->nmatch > 1) {
|
||||
zapsubs(v->pmatch, v->nmatch);
|
||||
return dissect(v, v->g->tree, begin, end);
|
||||
}
|
||||
if (ISERR())
|
||||
return v->err;
|
||||
return REG_OKAY;
|
||||
if (v->nmatch == 1) /* no need for submatches */
|
||||
return REG_OKAY;
|
||||
|
||||
/* submatches */
|
||||
zapsubs(v->pmatch, v->nmatch);
|
||||
return dissect(v, v->g->tree, begin, end);
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -354,17 +347,17 @@ struct vars *v;
|
||||
struct cnfa *cnfa;
|
||||
struct colormap *cm;
|
||||
{
|
||||
struct smalldfa da;
|
||||
struct dfa *d = newdfa(v, cnfa, cm, &da);
|
||||
struct smalldfa sa;
|
||||
struct dfa *s = newdfa(v, &v->g->search, cm, &sa);
|
||||
struct dfa *s;
|
||||
struct dfa *d;
|
||||
chr *cold;
|
||||
int ret;
|
||||
|
||||
if (d == NULL)
|
||||
return v->err;
|
||||
if (s == NULL) {
|
||||
freedfa(d);
|
||||
s = newdfa(v, &v->g->search, cm, &v->dfa1);
|
||||
NOERR();
|
||||
d = newdfa(v, cnfa, cm, &v->dfa2);
|
||||
if (ISERR()) {
|
||||
assert(d == NULL);
|
||||
freedfa(s);
|
||||
return v->err;
|
||||
}
|
||||
|
||||
@@ -372,8 +365,7 @@ struct colormap *cm;
|
||||
|
||||
freedfa(d);
|
||||
freedfa(s);
|
||||
if (ISERR())
|
||||
return v->err;
|
||||
NOERR();
|
||||
if (v->g->cflags®_EXPECT) {
|
||||
assert(v->details != NULL);
|
||||
if (cold != NULL)
|
||||
@@ -589,9 +581,7 @@ struct subre *t;
|
||||
chr *begin; /* beginning of relevant substring */
|
||||
chr *end; /* end of same */
|
||||
{
|
||||
struct smalldfa da;
|
||||
struct dfa *d;
|
||||
struct smalldfa d2a;
|
||||
struct dfa *d2;
|
||||
chr *mid;
|
||||
int i;
|
||||
@@ -602,11 +592,11 @@ chr *end; /* end of same */
|
||||
assert(t->left != NULL && t->left->cnfa.nstates > 0);
|
||||
assert(t->right != NULL && t->right->cnfa.nstates > 0);
|
||||
|
||||
d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da);
|
||||
if (ISERR())
|
||||
return v->err;
|
||||
d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, &d2a);
|
||||
d = newdfa(v, &t->left->cnfa, &v->g->cmap, &v->dfa1);
|
||||
NOERR();
|
||||
d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, &v->dfa2);
|
||||
if (ISERR()) {
|
||||
assert(d2 == NULL);
|
||||
freedfa(d);
|
||||
return v->err;
|
||||
}
|
||||
@@ -670,7 +660,6 @@ struct subre *t;
|
||||
chr *begin; /* beginning of relevant substring */
|
||||
chr *end; /* end of same */
|
||||
{
|
||||
struct smalldfa da;
|
||||
struct dfa *d;
|
||||
int i;
|
||||
|
||||
@@ -680,7 +669,7 @@ chr *end; /* end of same */
|
||||
for (i = 0; t != NULL; t = t->right, i++) {
|
||||
MDEBUG(("trying %dth\n", i));
|
||||
assert(t->left != NULL && t->left->cnfa.nstates > 0);
|
||||
d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da);
|
||||
d = newdfa(v, &t->left->cnfa, &v->g->cmap, &v->dfa1);
|
||||
if (ISERR())
|
||||
return v->err;
|
||||
if (longest(v, d, begin, end, (int *)NULL) == end) {
|
||||
@@ -755,9 +744,7 @@ struct subre *t;
|
||||
chr *begin; /* beginning of relevant substring */
|
||||
chr *end; /* end of same */
|
||||
{
|
||||
struct smalldfa da;
|
||||
struct dfa *d;
|
||||
struct smalldfa d2a;
|
||||
struct dfa *d2;
|
||||
chr *mid;
|
||||
int er;
|
||||
@@ -769,10 +756,10 @@ chr *end; /* end of same */
|
||||
if (t->left->flags&SHORTER) /* reverse scan */
|
||||
return crevdissect(v, t, begin, end);
|
||||
|
||||
d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da);
|
||||
d = newdfa(v, &t->left->cnfa, &v->g->cmap, DOMALLOC);
|
||||
if (ISERR())
|
||||
return v->err;
|
||||
d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, &d2a);
|
||||
d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, DOMALLOC);
|
||||
if (ISERR()) {
|
||||
freedfa(d);
|
||||
return v->err;
|
||||
@@ -839,7 +826,7 @@ chr *end; /* end of same */
|
||||
}
|
||||
|
||||
/*
|
||||
- crevdissect - determine shortest-first subexpression matches
|
||||
- crevdissect - determine backref shortest-first subexpression matches
|
||||
* The retry memory stores the offset of the trial midpoint from begin,
|
||||
* plus 1 so that 0 uniquely means "clean slate".
|
||||
^ static int crevdissect(struct vars *, struct subre *, chr *, chr *);
|
||||
@@ -851,9 +838,7 @@ struct subre *t;
|
||||
chr *begin; /* beginning of relevant substring */
|
||||
chr *end; /* end of same */
|
||||
{
|
||||
struct smalldfa da;
|
||||
struct dfa *d;
|
||||
struct smalldfa d2a;
|
||||
struct dfa *d2;
|
||||
chr *mid;
|
||||
int er;
|
||||
@@ -864,10 +849,10 @@ chr *end; /* end of same */
|
||||
assert(t->left->flags&SHORTER);
|
||||
|
||||
/* concatenation -- need to split the substring between parts */
|
||||
d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da);
|
||||
d = newdfa(v, &t->left->cnfa, &v->g->cmap, DOMALLOC);
|
||||
if (ISERR())
|
||||
return v->err;
|
||||
d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, &d2a);
|
||||
d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, DOMALLOC);
|
||||
if (ISERR()) {
|
||||
freedfa(d);
|
||||
return v->err;
|
||||
@@ -1011,7 +996,6 @@ struct subre *t;
|
||||
chr *begin; /* beginning of relevant substring */
|
||||
chr *end; /* end of same */
|
||||
{
|
||||
struct smalldfa da;
|
||||
struct dfa *d;
|
||||
int er;
|
||||
# define UNTRIED 0 /* not yet tried at all */
|
||||
@@ -1028,7 +1012,7 @@ chr *end; /* end of same */
|
||||
assert(t->left != NULL);
|
||||
|
||||
if (v->mem[t->retry] == UNTRIED) {
|
||||
d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da);
|
||||
d = newdfa(v, &t->left->cnfa, &v->g->cmap, DOMALLOC);
|
||||
if (ISERR())
|
||||
return v->err;
|
||||
if (longest(v, d, begin, end, (int *)NULL) != end) {
|
||||
|
||||
+6
-2
@@ -1,5 +1,5 @@
|
||||
/*
|
||||
* Internal interface definitions, etc., for the regex package
|
||||
* Internal interface definitions, etc., for the reg package
|
||||
*
|
||||
* Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
|
||||
*
|
||||
@@ -77,6 +77,11 @@
|
||||
#define NOPARMS VOID /* for empty parm lists */
|
||||
#endif
|
||||
|
||||
/* const */
|
||||
#ifndef CONST
|
||||
#define CONST const /* for old compilers, might be empty */
|
||||
#endif
|
||||
|
||||
/* function-pointer declarator */
|
||||
#ifndef FUNCPTR
|
||||
#if __STDC__ >= 1
|
||||
@@ -410,5 +415,4 @@ struct guts {
|
||||
int FUNCPTR(compare, (CONST chr *, CONST chr *, size_t));
|
||||
struct subre *lacons; /* lookahead-constraint vector */
|
||||
int nlacons; /* size of lacons */
|
||||
int usedshorter; /* used non-greedy quantifiers? */
|
||||
};
|
||||
|
||||
+15
-15
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tcl.h,v 1.57 1999/08/10 23:16:25 redman Exp $
|
||||
* RCS: @(#) $Id: tcl.h,v 1.57.2.2 1999/10/30 11:05:57 hobbs Exp $
|
||||
*/
|
||||
|
||||
#ifndef _TCL
|
||||
@@ -38,28 +38,28 @@ extern "C" {
|
||||
* When version numbers change here, must also go into the following files
|
||||
* and update the version numbers:
|
||||
*
|
||||
* library/init.tcl (only if major.minor changes, not patchlevel)
|
||||
* unix/configure.in
|
||||
* win/configure.in (only if major.minor changes, not patchlevel)
|
||||
* win/makefile.bc (only if major.minor changes, not patchlevel)
|
||||
* win/makefile.vc (only if major.minor changes, not patchlevel)
|
||||
* win/pkgIndex.tcl (for tclregNN.dll, not patchlevel)
|
||||
* README
|
||||
* mac/README
|
||||
* win/README.binary
|
||||
* win/README (only if major.minor changes, not patchlevel)
|
||||
* unix/README (only if major.minor changes, not patchlevel)
|
||||
* tools/tcl.hpj.in (for windows installer)
|
||||
* library/init.tcl (only if Major.minor changes, not patchlevel) 1 LOC
|
||||
* unix/configure.in (2 LOC Major, 2 LOC minor, 1 LOC patch)
|
||||
* win/configure.in (as above)
|
||||
* win/makefile.vc (not patchlevel) 2 LOC
|
||||
* win/pkgIndex.tcl (not patchlevel, for tclregNN.dll)
|
||||
* README (sections 0 and 2)
|
||||
* mac/README (2 LOC)
|
||||
* win/README.binary (sections 0-4)
|
||||
* win/README (not patchlevel) (sections 0 and 2)
|
||||
* unix/README (not patchlevel) (part (h))
|
||||
* tests/basic.test (not patchlevel) (version checks)
|
||||
* tools/tcl.hpj.in (not patchlevel, for windows installer)
|
||||
* tools/tcl.wse.in (for windows installer)
|
||||
*/
|
||||
|
||||
#define TCL_MAJOR_VERSION 8
|
||||
#define TCL_MINOR_VERSION 2
|
||||
#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE
|
||||
#define TCL_RELEASE_SERIAL 0
|
||||
#define TCL_RELEASE_SERIAL 2
|
||||
|
||||
#define TCL_VERSION "8.2"
|
||||
#define TCL_PATCH_LEVEL "8.2.0"
|
||||
#define TCL_PATCH_LEVEL "8.2.2"
|
||||
|
||||
/*
|
||||
* The following definitions set up the proper options for Windows
|
||||
|
||||
+43
-23
@@ -13,7 +13,7 @@
|
||||
*
|
||||
* This code contributed by Karl Lehenbauer and Mark Diekhans
|
||||
*
|
||||
* RCS: @(#) $Id: tclCkalloc.c,v 1.5 1999/08/10 02:42:12 welch Exp $
|
||||
* RCS: @(#) $Id: tclCkalloc.c,v 1.5.4.1 1999/09/22 04:12:45 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -294,7 +294,7 @@ Tcl_DumpActiveMemory (fileName)
|
||||
char *address;
|
||||
|
||||
if (fileName == NULL) {
|
||||
fileP = stdout;
|
||||
fileP = stderr;
|
||||
} else {
|
||||
fileP = fopen(fileName, "w");
|
||||
if (fileP == NULL) {
|
||||
@@ -445,10 +445,16 @@ Tcl_DbCkalloc(size, file, line)
|
||||
|
||||
int
|
||||
Tcl_DbCkfree(ptr, file, line)
|
||||
char * ptr;
|
||||
char *file;
|
||||
int line;
|
||||
char *ptr;
|
||||
char *file;
|
||||
int line;
|
||||
{
|
||||
struct mem_header *memp;
|
||||
|
||||
if (ptr == NULL) {
|
||||
return;
|
||||
}
|
||||
|
||||
/*
|
||||
* The following cast is *very* tricky. Must convert the pointer
|
||||
* to an integer before doing arithmetic on it, because otherwise
|
||||
@@ -457,8 +463,7 @@ Tcl_DbCkfree(ptr, file, line)
|
||||
* even though BODY_OFFSET is in words on these machines).
|
||||
*/
|
||||
|
||||
struct mem_header *memp = (struct mem_header *)
|
||||
(((unsigned long) ptr) - BODY_OFFSET);
|
||||
memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);
|
||||
|
||||
if (alloc_tracing)
|
||||
fprintf(stderr, "ckfree %lx %ld %s %d\n",
|
||||
@@ -520,14 +525,18 @@ Tcl_DbCkrealloc(ptr, size, file, line)
|
||||
{
|
||||
char *new;
|
||||
unsigned int copySize;
|
||||
struct mem_header *memp;
|
||||
|
||||
if (ptr == NULL) {
|
||||
return Tcl_DbCkalloc(size, file, line);
|
||||
}
|
||||
|
||||
/*
|
||||
* See comment from Tcl_DbCkfree before you change the following
|
||||
* line.
|
||||
*/
|
||||
|
||||
struct mem_header *memp = (struct mem_header *)
|
||||
(((unsigned long) ptr) - BODY_OFFSET);
|
||||
memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);
|
||||
|
||||
copySize = size;
|
||||
if (copySize > (unsigned int) memp->length) {
|
||||
@@ -796,12 +805,22 @@ char *
|
||||
Tcl_Alloc (size)
|
||||
unsigned int size;
|
||||
{
|
||||
char *result;
|
||||
char *result;
|
||||
|
||||
result = TclpAlloc(size);
|
||||
if (result == NULL)
|
||||
panic("unable to alloc %d bytes", size);
|
||||
return result;
|
||||
result = TclpAlloc(size);
|
||||
/*
|
||||
* Most systems will not alloc(0), instead bumping it to one so
|
||||
* that NULL isn't returned. Some systems (AIX, Tru64) will alloc(0)
|
||||
* by returning NULL, so we have to check that the NULL we get is
|
||||
* not in response to alloc(0).
|
||||
*
|
||||
* The ANSI spec actually says that systems either return NULL *or*
|
||||
* a special pointer on failure, but we only check for NULL
|
||||
*/
|
||||
if ((result == NULL) && size) {
|
||||
panic("unable to alloc %d bytes", size);
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
char *
|
||||
@@ -814,7 +833,7 @@ Tcl_DbCkalloc(size, file, line)
|
||||
|
||||
result = (char *) TclpAlloc(size);
|
||||
|
||||
if (result == NULL) {
|
||||
if ((result == NULL) && size) {
|
||||
fflush(stdout);
|
||||
panic("unable to alloc %d bytes, %s line %d", size, file,
|
||||
line);
|
||||
@@ -841,8 +860,10 @@ Tcl_Realloc(ptr, size)
|
||||
char *result;
|
||||
|
||||
result = TclpRealloc(ptr, size);
|
||||
if (result == NULL)
|
||||
|
||||
if ((result == NULL) && size) {
|
||||
panic("unable to realloc %d bytes", size);
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
@@ -857,10 +878,9 @@ Tcl_DbCkrealloc(ptr, size, file, line)
|
||||
|
||||
result = (char *) TclpRealloc(ptr, size);
|
||||
|
||||
if (result == NULL) {
|
||||
if ((result == NULL) && size) {
|
||||
fflush(stdout);
|
||||
panic("unable to realloc %d bytes, %s line %d", size, file,
|
||||
line);
|
||||
panic("unable to realloc %d bytes, %s line %d", size, file, line);
|
||||
}
|
||||
return result;
|
||||
}
|
||||
@@ -880,14 +900,14 @@ void
|
||||
Tcl_Free (ptr)
|
||||
char *ptr;
|
||||
{
|
||||
TclpFree(ptr);
|
||||
TclpFree(ptr);
|
||||
}
|
||||
|
||||
int
|
||||
Tcl_DbCkfree(ptr, file, line)
|
||||
char * ptr;
|
||||
char *file;
|
||||
int line;
|
||||
char *ptr;
|
||||
char *file;
|
||||
int line;
|
||||
{
|
||||
TclpFree(ptr);
|
||||
return 0;
|
||||
|
||||
+17
-6
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclCmdAH.c,v 1.7 1999/07/01 23:21:06 redman Exp $
|
||||
* RCS: @(#) $Id: tclCmdAH.c,v 1.7.4.1 1999/09/22 04:12:45 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -1907,6 +1907,8 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
|
||||
* been seen in the current field. */
|
||||
int gotPrecision; /* Non-zero indicates that a precision has
|
||||
* been set for the current field. */
|
||||
int gotZero; /* Non-zero indicates that a zero flag has
|
||||
* been seen in the current field. */
|
||||
|
||||
/*
|
||||
* This procedure is a bit nasty. The goal is to use sprintf to
|
||||
@@ -1935,7 +1937,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
|
||||
register char *newPtr = newFormat;
|
||||
|
||||
width = precision = noPercent = useShort = 0;
|
||||
gotMinus = gotPrecision = 0;
|
||||
gotZero = gotMinus = gotPrecision = 0;
|
||||
whichValue = PTR_VALUE;
|
||||
|
||||
/*
|
||||
@@ -2004,6 +2006,13 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
|
||||
if (*format == '-') {
|
||||
gotMinus = 1;
|
||||
}
|
||||
if (*format == '0') {
|
||||
/*
|
||||
* This will be handled by sprintf for numbers, but we
|
||||
* need to do the char/string ones ourselves
|
||||
*/
|
||||
gotZero = 1;
|
||||
}
|
||||
*newPtr = *format;
|
||||
newPtr++;
|
||||
format++;
|
||||
@@ -2191,21 +2200,23 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
|
||||
}
|
||||
case CHAR_VALUE: {
|
||||
char *ptr;
|
||||
char padChar = (gotZero ? '0' : ' ');
|
||||
ptr = dst;
|
||||
if (!gotMinus) {
|
||||
for ( ; --width > 0; ptr++) {
|
||||
*ptr = ' ';
|
||||
*ptr = padChar;
|
||||
}
|
||||
}
|
||||
ptr += Tcl_UniCharToUtf(intValue, ptr);
|
||||
for ( ; --width > 0; ptr++) {
|
||||
*ptr = ' ';
|
||||
*ptr = padChar;
|
||||
}
|
||||
*ptr = '\0';
|
||||
break;
|
||||
}
|
||||
case STRING_VALUE: {
|
||||
char *ptr;
|
||||
char padChar = (gotZero ? '0' : ' ');
|
||||
int pad;
|
||||
|
||||
ptr = dst;
|
||||
@@ -2217,7 +2228,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
|
||||
|
||||
if (!gotMinus) {
|
||||
while (pad > 0) {
|
||||
*ptr++ = ' ';
|
||||
*ptr++ = padChar;
|
||||
pad--;
|
||||
}
|
||||
}
|
||||
@@ -2228,7 +2239,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
|
||||
ptr += size;
|
||||
}
|
||||
while (pad > 0) {
|
||||
*ptr++ = ' ';
|
||||
*ptr++ = padChar;
|
||||
pad--;
|
||||
}
|
||||
*ptr = '\0';
|
||||
|
||||
+7
-3
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclCmdIL.c,v 1.15 1999/08/10 17:35:18 redman Exp $
|
||||
* RCS: @(#) $Id: tclCmdIL.c,v 1.15.4.1 1999/09/22 04:12:46 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -1954,8 +1954,12 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv)
|
||||
* will invalidate the list's internal representation.
|
||||
*/
|
||||
|
||||
result = TclGetIntForIndex(interp, objv[2], /*endValue*/ INT_MAX,
|
||||
&index);
|
||||
result = Tcl_ListObjLength(interp, objv[1], &len);
|
||||
if (result != TCL_OK) {
|
||||
return result;
|
||||
}
|
||||
|
||||
result = TclGetIntForIndex(interp, objv[2], /*endValue*/ len, &index);
|
||||
if (result != TCL_OK) {
|
||||
return result;
|
||||
}
|
||||
|
||||
+37
-9
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclCmdMZ.c,v 1.19 1999/07/22 21:50:54 redman Exp $
|
||||
* RCS: @(#) $Id: tclCmdMZ.c,v 1.19.4.2 1999/10/30 11:05:58 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -485,11 +485,13 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv)
|
||||
if (firstChar != src) {
|
||||
Tcl_AppendToObj(resultPtr, firstChar, src - firstChar);
|
||||
}
|
||||
subStart = info.matches[index].start;
|
||||
subEnd = info.matches[index].end;
|
||||
if ((subStart >= 0) && (subEnd >= 0)) {
|
||||
Tcl_AppendUnicodeToObj(resultPtr, wstring + offset + subStart,
|
||||
subEnd - subStart);
|
||||
if (index <= info.nsubs) {
|
||||
subStart = info.matches[index].start;
|
||||
subEnd = info.matches[index].end;
|
||||
if ((subStart >= 0) && (subEnd >= 0)) {
|
||||
Tcl_AppendUnicodeToObj(resultPtr,
|
||||
wstring + offset + subStart, subEnd - subStart);
|
||||
}
|
||||
}
|
||||
if (*src == '\\') {
|
||||
src++;
|
||||
@@ -949,7 +951,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
|
||||
}
|
||||
|
||||
if ((enum options) index == STR_EQUAL) {
|
||||
Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1);
|
||||
Tcl_SetIntObj(resultPtr, (match) ? 0 : 1);
|
||||
} else {
|
||||
Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 :
|
||||
(match < 0) ? -1 : 0));
|
||||
@@ -1063,7 +1065,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
|
||||
&index) != TCL_OK) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
Tcl_SetStringObj(resultPtr, &string1[index], 1);
|
||||
Tcl_SetByteArrayObj(resultPtr,
|
||||
(unsigned char *)(&string1[index]), 1);
|
||||
} else {
|
||||
string1 = Tcl_GetStringFromObj(objv[2], &length1);
|
||||
|
||||
@@ -2136,7 +2139,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
|
||||
int objc; /* Number of arguments. */
|
||||
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
||||
{
|
||||
int i, j, index, mode, matched, result;
|
||||
int i, j, index, mode, matched, result, splitObjs, seenComment;
|
||||
char *string, *pattern;
|
||||
Tcl_Obj *stringObj;
|
||||
static char *options[] = {
|
||||
@@ -2179,6 +2182,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
|
||||
* argument, split them out again.
|
||||
*/
|
||||
|
||||
splitObjs = 0;
|
||||
if (objc == 1) {
|
||||
Tcl_Obj **listv;
|
||||
|
||||
@@ -2186,13 +2190,26 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
|
||||
return TCL_ERROR;
|
||||
}
|
||||
objv = listv;
|
||||
splitObjs = 1;
|
||||
}
|
||||
|
||||
seenComment = 0;
|
||||
for (i = 0; i < objc; i += 2) {
|
||||
if (i == objc - 1) {
|
||||
Tcl_ResetResult(interp);
|
||||
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
||||
"extra switch pattern with no body", -1);
|
||||
|
||||
/*
|
||||
* Check if this can be due to a badly placed comment
|
||||
* in the switch block
|
||||
*/
|
||||
|
||||
if (splitObjs && seenComment) {
|
||||
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
||||
", this may be due to a comment incorrectly placed outside of a switch body - see the \"switch\" documentation", -1);
|
||||
}
|
||||
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
@@ -2201,6 +2218,17 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
|
||||
*/
|
||||
|
||||
pattern = Tcl_GetString(objv[i]);
|
||||
|
||||
/*
|
||||
* The following is an heuristic to detect the infamous
|
||||
* "comment in switch" error: just check if a pattern
|
||||
* begins with '#'.
|
||||
*/
|
||||
|
||||
if (splitObjs && *pattern == '#') {
|
||||
seenComment = 1;
|
||||
}
|
||||
|
||||
matched = 0;
|
||||
if ((i == objc - 2)
|
||||
&& (*pattern == 'd')
|
||||
|
||||
+23
-4
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclCompCmds.c,v 1.2 1999/04/16 00:46:43 stanton Exp $
|
||||
* RCS: @(#) $Id: tclCompCmds.c,v 1.2.6.1 1999/10/30 11:05:58 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -1341,7 +1341,16 @@ TclCompileIncrCmd(interp, parsePtr, envPtr)
|
||||
|
||||
varTokenPtr = parsePtr->tokenPtr
|
||||
+ (parsePtr->tokenPtr->numComponents + 1);
|
||||
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
|
||||
/*
|
||||
* Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
|
||||
* curly braces surround the variable name.
|
||||
* This really matters for array elements to handle things like
|
||||
* set {x($foo)} 5
|
||||
* which raises an undefined var error if we are not careful here.
|
||||
* This goes with the hack in TclCompileSetCmd.
|
||||
*/
|
||||
if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
|
||||
(varTokenPtr->start[0] != '{')) {
|
||||
/*
|
||||
* A simple variable name. Divide it up into "name" and "elName"
|
||||
* strings. If it is not a local variable, look it up at runtime.
|
||||
@@ -1446,7 +1455,7 @@ TclCompileIncrCmd(interp, parsePtr, envPtr)
|
||||
|
||||
word[numBytes] = '\0';
|
||||
if (TclLooksLikeInt(word, numBytes)
|
||||
&& (TclGetLong((Tcl_Interp *) NULL, word, &n) == TCL_OK)) {
|
||||
&& (TclGetLong((Tcl_Interp *) NULL, word, &n) == TCL_OK)) {
|
||||
if ((-127 <= n) && (n <= 127)) {
|
||||
haveImmValue = 1;
|
||||
immValue = n;
|
||||
@@ -1600,8 +1609,18 @@ TclCompileSetCmd(interp, parsePtr, envPtr)
|
||||
|
||||
varTokenPtr = parsePtr->tokenPtr
|
||||
+ (parsePtr->tokenPtr->numComponents + 1);
|
||||
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
|
||||
/*
|
||||
* Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
|
||||
* curly braces surround the variable name.
|
||||
* This really matters for array elements to handle things like
|
||||
* set {x($foo)} 5
|
||||
* which raises an undefined var error if we are not careful here.
|
||||
* This goes with the hack in TclCompileIncrCmd.
|
||||
*/
|
||||
if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
|
||||
(varTokenPtr->start[0] != '{')) {
|
||||
simpleVarName = 1;
|
||||
|
||||
name = varTokenPtr[1].start;
|
||||
nameChars = varTokenPtr[1].size;
|
||||
/* last char is ')' => potential array reference */
|
||||
|
||||
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclCompile.c,v 1.15 1999/04/22 22:57:06 stanton Exp $
|
||||
* RCS: @(#) $Id: tclCompile.c,v 1.15.6.2 1999/10/30 11:05:59 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -1348,7 +1348,6 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr)
|
||||
JumpFixup jumpFixup;
|
||||
int maxDepth, doExprInline, range, numBytes, i, j, code;
|
||||
char *script;
|
||||
char saveChar;
|
||||
int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;
|
||||
int saveExprIsComparison = envPtr->exprIsComparison;
|
||||
|
||||
@@ -1370,10 +1369,7 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr)
|
||||
|
||||
script = tokenPtr[1].start;
|
||||
numBytes = tokenPtr[1].size;
|
||||
saveChar = script[numBytes];
|
||||
script[numBytes] = 0;
|
||||
code = TclCompileExpr(interp, script, numBytes, envPtr);
|
||||
script[numBytes] = saveChar;
|
||||
return code;
|
||||
}
|
||||
|
||||
@@ -1393,7 +1389,8 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr)
|
||||
for (j = 0, partPtr = wordPtr+1; j < wordPtr->numComponents;
|
||||
j++, partPtr++) {
|
||||
if ((partPtr->type == TCL_TOKEN_BS)
|
||||
|| (partPtr->type == TCL_TOKEN_COMMAND)) {
|
||||
|| (partPtr->type == TCL_TOKEN_COMMAND)
|
||||
|| (partPtr->type == TCL_TOKEN_VARIABLE)) {
|
||||
doExprInline = 0;
|
||||
break;
|
||||
}
|
||||
|
||||
+41
-37
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclDate.c,v 1.5 1999/05/14 18:29:50 stanton Exp $
|
||||
* RCS: @(#) $Id: tclDate.c,v 1.5.4.1 1999/09/22 04:12:47 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -135,22 +135,27 @@ typedef union
|
||||
|
||||
|
||||
|
||||
#ifdef __cplusplus
|
||||
|
||||
#if defined(__cplusplus) || defined(__STDC__)
|
||||
|
||||
#if defined(__cplusplus) && defined(__EXTERN_C__)
|
||||
extern "C" {
|
||||
#endif
|
||||
#ifndef TclDateerror
|
||||
#if defined(__cplusplus)
|
||||
void TclDateerror(const char *);
|
||||
#endif
|
||||
|
||||
#endif
|
||||
#ifndef TclDatelex
|
||||
#ifdef __EXTERN_C__
|
||||
extern "C" { int TclDatelex(void); }
|
||||
#else
|
||||
int TclDatelex(void);
|
||||
#endif
|
||||
#endif
|
||||
int TclDateparse(void);
|
||||
#if defined(__cplusplus) && defined(__EXTERN_C__)
|
||||
}
|
||||
#endif
|
||||
|
||||
#endif
|
||||
|
||||
#define TclDateclearin TclDatechar = -1
|
||||
#define TclDateerrok TclDateerrflag = 0
|
||||
extern int TclDatechar;
|
||||
@@ -258,7 +263,8 @@ static TABLE TimezoneTable[] = {
|
||||
{ "gmt", tZONE, HOUR( 0) }, /* Greenwich Mean */
|
||||
{ "ut", tZONE, HOUR( 0) }, /* Universal (Coordinated) */
|
||||
{ "utc", tZONE, HOUR( 0) },
|
||||
{ "wet", tZONE, HOUR( 0) } , /* Western European */
|
||||
{ "uct", tZONE, HOUR( 0) }, /* Universal Coordinated Time */
|
||||
{ "wet", tZONE, HOUR( 0) }, /* Western European */
|
||||
{ "bst", tDAYZONE, HOUR( 0) }, /* British Summer */
|
||||
{ "wat", tZONE, HOUR( 1) }, /* West Africa */
|
||||
{ "at", tZONE, HOUR( 2) }, /* Azores */
|
||||
@@ -290,6 +296,7 @@ static TABLE TimezoneTable[] = {
|
||||
{ "nt", tZONE, HOUR(11) }, /* Nome */
|
||||
{ "idlw", tZONE, HOUR(12) }, /* International Date Line West */
|
||||
{ "cet", tZONE, -HOUR( 1) }, /* Central European */
|
||||
{ "cest", tDAYZONE, -HOUR( 1) }, /* Central European Summer */
|
||||
{ "met", tZONE, -HOUR( 1) }, /* Middle European */
|
||||
{ "mewt", tZONE, -HOUR( 1) }, /* Middle European Winter */
|
||||
{ "mest", tDAYZONE, -HOUR( 1) }, /* Middle European Summer */
|
||||
@@ -430,12 +437,10 @@ Convert(Month, Day, Year, Hours, Minutes, Seconds, Meridian, DSTmode, TimePtr)
|
||||
Julian += DaysInMonth[i];
|
||||
if (Year >= EPOCH) {
|
||||
for (i = EPOCH; i < Year; i++)
|
||||
Julian += 365 + (((i % 4) == 0) &&
|
||||
(((i % 100) != 0) || ((i % 400) == 0)));
|
||||
Julian += 365 + (i % 4 == 0);
|
||||
} else {
|
||||
for (i = Year; i < EPOCH; i++)
|
||||
Julian -= 365 + (((i % 4) == 0) &&
|
||||
(((i % 100) != 0) || ((i % 400) == 0)));
|
||||
Julian -= 365 + (i % 4 == 0);
|
||||
}
|
||||
Julian *= SECSPERDAY;
|
||||
Julian += TclDateTimezone * 60L;
|
||||
@@ -660,10 +665,10 @@ TclDatelex()
|
||||
TclDateInput++;
|
||||
}
|
||||
|
||||
if (isdigit(c = *TclDateInput) || c == '-' || c == '+') { /* INTL: digit */
|
||||
if (isdigit(UCHAR(c = *TclDateInput)) || c == '-' || c == '+') { /* INTL: digit */
|
||||
if (c == '-' || c == '+') {
|
||||
sign = c == '-' ? -1 : 1;
|
||||
if (!isdigit(*++TclDateInput)) { /* INTL: digit */
|
||||
if (!isdigit(UCHAR(*++TclDateInput))) { /* INTL: digit */
|
||||
/*
|
||||
* skip the '-' sign
|
||||
*/
|
||||
@@ -673,7 +678,7 @@ TclDatelex()
|
||||
sign = 0;
|
||||
}
|
||||
for (TclDatelval.Number = 0;
|
||||
isdigit(c = *TclDateInput++); ) { /* INTL: digit */
|
||||
isdigit(UCHAR(c = *TclDateInput++)); ) { /* INTL: digit */
|
||||
TclDatelval.Number = 10 * TclDatelval.Number + c - '0';
|
||||
}
|
||||
TclDateInput--;
|
||||
@@ -683,7 +688,7 @@ TclDatelex()
|
||||
return sign ? tSNUMBER : tUNUMBER;
|
||||
}
|
||||
if (!(c & 0x80) && isalpha(UCHAR(c))) { /* INTL: ISO only. */
|
||||
for (p = buff; isalpha(c = *TclDateInput++) /* INTL: ISO only. */
|
||||
for (p = buff; isalpha(UCHAR(c = *TclDateInput++)) /* INTL: ISO only. */
|
||||
|| c == '.'; ) {
|
||||
if (p < &buff[sizeof buff - 1]) {
|
||||
*p++ = c;
|
||||
@@ -803,14 +808,14 @@ TclGetDate(p, now, zone, timePtr)
|
||||
*timePtr = Start;
|
||||
return 0;
|
||||
}
|
||||
TclDatetabelem TclDateexca[] ={
|
||||
static const TclDatetabelem TclDateexca[] ={
|
||||
-1, 1,
|
||||
0, -1,
|
||||
-2, 0,
|
||||
};
|
||||
# define YYNPROD 41
|
||||
# define YYLAST 227
|
||||
TclDatetabelem TclDateact[]={
|
||||
static const TclDatetabelem TclDateact[]={
|
||||
|
||||
14, 11, 23, 28, 17, 12, 19, 18, 16, 9,
|
||||
10, 13, 42, 21, 46, 45, 44, 48, 41, 37,
|
||||
@@ -835,39 +840,39 @@ TclDatetabelem TclDateact[]={
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 22, 0, 0, 20, 25, 24, 27,
|
||||
26, 42, 0, 0, 0, 0, 40 };
|
||||
TclDatetabelem TclDatepact[]={
|
||||
static const TclDatetabelem TclDatepact[]={
|
||||
|
||||
-10000000, -258,-10000000,-10000000,-10000000,-10000000,-10000000,-10000000,-10000000, -45,
|
||||
-267,-10000000, -244,-10000000, -14, -231, -240,-10000000,-10000000,-10000000,
|
||||
-10000000, -246,-10000000, -247, -248,-10000000,-10000000,-10000000,-10000000, -15,
|
||||
-10000000,-10000000,-10000000,-10000000,-10000000, -40, -20,-10000000, -251,-10000000,
|
||||
-10000000, -252,-10000000, -253,-10000000, -249,-10000000,-10000000,-10000000 };
|
||||
TclDatetabelem TclDatepgo[]={
|
||||
static const TclDatetabelem TclDatepgo[]={
|
||||
|
||||
0, 28, 39, 38, 37, 36, 35, 34, 33, 32,
|
||||
31 };
|
||||
TclDatetabelem TclDater1[]={
|
||||
static const TclDatetabelem TclDater1[]={
|
||||
|
||||
0, 2, 2, 3, 3, 3, 3, 3, 3, 4,
|
||||
4, 4, 4, 4, 5, 5, 5, 7, 7, 7,
|
||||
6, 6, 6, 6, 6, 6, 6, 8, 8, 10,
|
||||
10, 10, 10, 10, 10, 10, 10, 10, 9, 1,
|
||||
1 };
|
||||
TclDatetabelem TclDater2[]={
|
||||
static const TclDatetabelem TclDater2[]={
|
||||
|
||||
0, 0, 4, 3, 3, 3, 3, 3, 2, 5,
|
||||
9, 9, 13, 13, 5, 3, 3, 3, 5, 5,
|
||||
7, 11, 5, 9, 5, 3, 7, 5, 2, 5,
|
||||
5, 3, 5, 5, 3, 5, 5, 3, 3, 1,
|
||||
3 };
|
||||
TclDatetabelem TclDatechk[]={
|
||||
static const TclDatetabelem TclDatechk[]={
|
||||
|
||||
-10000000, -2, -3, -4, -5, -6, -7, -8, -9, 267,
|
||||
268, 259, 263, 269, 258, -10, 266, 262, 265, 264,
|
||||
261, 58, 258, 47, 263, 262, 265, 264, 270, 267,
|
||||
44, 257, 262, 265, 264, 267, 267, 267, 44, -1,
|
||||
266, 58, 261, 47, 267, 267, 267, -1, 266 };
|
||||
TclDatetabelem TclDatedef[]={
|
||||
static const TclDatetabelem TclDatedef[]={
|
||||
|
||||
1, -2, 2, 3, 4, 5, 6, 7, 8, 38,
|
||||
15, 16, 0, 25, 17, 28, 0, 31, 34, 37,
|
||||
@@ -979,7 +984,7 @@ char * TclDatereds[] =
|
||||
#define YYRECOVERING() (!!TclDateerrflag)
|
||||
#define YYNEW(type) malloc(sizeof(type) * TclDatenewmax)
|
||||
#define YYCOPY(to, from, type) \
|
||||
(type *) memcpy(to, (char *) from, TclDatenewmax * sizeof(type))
|
||||
(type *) memcpy(to, (char *) from, TclDatemaxdepth * sizeof (type))
|
||||
#define YYENLARGE( from, type) \
|
||||
(type *) realloc((char *) from, TclDatenewmax * sizeof(type))
|
||||
#ifndef YYDEBUG
|
||||
@@ -1063,12 +1068,12 @@ int TclDateparse(void)
|
||||
int TclDateparse()
|
||||
#endif
|
||||
{
|
||||
register YYSTYPE *TclDatepvt; /* top of value stack for $vars */
|
||||
register YYSTYPE *TclDatepvt = 0; /* top of value stack for $vars */
|
||||
|
||||
#if defined(__cplusplus) || defined(lint)
|
||||
/*
|
||||
hacks to please C++ and lint - goto's inside switch should never be
|
||||
executed; TclDatepvt is set to 0 to avoid "used before set" warning.
|
||||
hacks to please C++ and lint - goto's inside
|
||||
switch should never be executed
|
||||
*/
|
||||
static int __yaccpar_lint_hack__ = 0;
|
||||
switch (__yaccpar_lint_hack__)
|
||||
@@ -1076,7 +1081,6 @@ int TclDateparse()
|
||||
case 1: goto TclDateerrlab;
|
||||
case 2: goto TclDatenewstate;
|
||||
}
|
||||
TclDatepvt = 0;
|
||||
#endif
|
||||
|
||||
/*
|
||||
@@ -1167,9 +1171,9 @@ int TclDateparse()
|
||||
** reallocate and recover. Note that pointers
|
||||
** have to be reset, or bad things will happen
|
||||
*/
|
||||
int TclDateps_index = (TclDate_ps - TclDates);
|
||||
int TclDatepv_index = (TclDate_pv - TclDatev);
|
||||
int TclDatepvt_index = (TclDatepvt - TclDatev);
|
||||
long TclDateps_index = (TclDate_ps - TclDates);
|
||||
long TclDatepv_index = (TclDate_pv - TclDatev);
|
||||
long TclDatepvt_index = (TclDatepvt - TclDatev);
|
||||
int TclDatenewmax;
|
||||
#ifdef YYEXPAND
|
||||
TclDatenewmax = YYEXPAND(TclDatemaxdepth);
|
||||
@@ -1295,7 +1299,7 @@ int TclDateparse()
|
||||
** look through exception table
|
||||
*/
|
||||
{
|
||||
register int *TclDatexi = TclDateexca;
|
||||
register const int *TclDatexi = TclDateexca;
|
||||
|
||||
while ( ( *TclDatexi != -1 ) ||
|
||||
( TclDatexi[1] != TclDate_state ) )
|
||||
@@ -1572,10 +1576,10 @@ case 24:{
|
||||
TclDateDay = TclDatepvt[-1].Number;
|
||||
} break;
|
||||
case 25:{
|
||||
TclDateMonth = 1;
|
||||
TclDateDay = 1;
|
||||
TclDateYear = EPOCH;
|
||||
} break;
|
||||
TclDateMonth = 1;
|
||||
TclDateDay = 1;
|
||||
TclDateYear = EPOCH;
|
||||
} break;
|
||||
case 26:{
|
||||
TclDateMonth = TclDatepvt[-1].Number;
|
||||
TclDateDay = TclDatepvt[-2].Number;
|
||||
|
||||
+15
-21
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclEnv.c,v 1.4 1999/04/16 00:46:46 stanton Exp $
|
||||
* RCS: @(#) $Id: tclEnv.c,v 1.4.6.1 1999/10/30 11:06:00 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -225,23 +225,23 @@ TclSetEnv(name, value)
|
||||
p[nameLength] = '=';
|
||||
strcpy(p+nameLength+1, value);
|
||||
p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString);
|
||||
ckfree(p);
|
||||
|
||||
/*
|
||||
* Copy the native string to heap memory.
|
||||
*/
|
||||
|
||||
p = (char *) ckrealloc(p, (unsigned) (strlen(p2) + 1));
|
||||
strcpy(p, p2);
|
||||
Tcl_DStringFree(&envString);
|
||||
|
||||
#ifdef USE_PUTENV
|
||||
/*
|
||||
* Update the system environment.
|
||||
*/
|
||||
|
||||
putenv(p2);
|
||||
putenv(p);
|
||||
index = TclpFindVariable(name, &length);
|
||||
#else
|
||||
/*
|
||||
* Copy the native string to heap memory.
|
||||
*/
|
||||
|
||||
p = (char *) ckalloc((unsigned) (strlen(p2) + 1));
|
||||
strcpy(p, p2);
|
||||
environ[index] = p;
|
||||
#endif
|
||||
|
||||
@@ -251,9 +251,7 @@ TclSetEnv(name, value)
|
||||
* update the string in the cache.
|
||||
*/
|
||||
|
||||
if (environ[index] != p) {
|
||||
Tcl_DStringFree(&envString);
|
||||
} else {
|
||||
if ((index != -1) && (environ[index] == p)) {
|
||||
ReplaceString(oldValue, p);
|
||||
}
|
||||
|
||||
@@ -381,8 +379,10 @@ TclUnsetEnv(name)
|
||||
string[length+1] = '\0';
|
||||
|
||||
Tcl_UtfToExternalDString(NULL, string, -1, &envString);
|
||||
ckfree(string);
|
||||
string = Tcl_DStringValue(&envString);
|
||||
string = ckrealloc(string, (unsigned) (Tcl_DStringLength(&envString)+1));
|
||||
strcpy(string, Tcl_DStringValue(&envString));
|
||||
Tcl_DStringFree(&envString);
|
||||
|
||||
putenv(string);
|
||||
|
||||
/*
|
||||
@@ -391,9 +391,7 @@ TclUnsetEnv(name)
|
||||
* update the string in the cache.
|
||||
*/
|
||||
|
||||
if (environ[index] != string) {
|
||||
Tcl_DStringFree(&envString);
|
||||
} else {
|
||||
if (environ[index] == string) {
|
||||
ReplaceString(oldValue, string);
|
||||
}
|
||||
#else
|
||||
@@ -663,7 +661,3 @@ TclFinalizeEnvironment()
|
||||
#endif
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
+13
-11
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclGetDate.y,v 1.4 1999/04/16 00:46:46 stanton Exp $
|
||||
* RCS: @(#) $Id: tclGetDate.y,v 1.4.6.1 1999/09/22 04:12:47 hobbs Exp $
|
||||
*/
|
||||
|
||||
%{
|
||||
@@ -250,11 +250,11 @@ date : tUNUMBER '/' tUNUMBER {
|
||||
yyMonth = $2;
|
||||
yyDay = $1;
|
||||
}
|
||||
| tEPOCH {
|
||||
yyMonth = 1;
|
||||
yyDay = 1;
|
||||
yyYear = EPOCH;
|
||||
}
|
||||
| tEPOCH {
|
||||
yyMonth = 1;
|
||||
yyDay = 1;
|
||||
yyYear = EPOCH;
|
||||
}
|
||||
| tUNUMBER tMONTH tUNUMBER {
|
||||
yyMonth = $2;
|
||||
yyDay = $1;
|
||||
@@ -413,7 +413,8 @@ static TABLE TimezoneTable[] = {
|
||||
{ "gmt", tZONE, HOUR( 0) }, /* Greenwich Mean */
|
||||
{ "ut", tZONE, HOUR( 0) }, /* Universal (Coordinated) */
|
||||
{ "utc", tZONE, HOUR( 0) },
|
||||
{ "wet", tZONE, HOUR( 0) } , /* Western European */
|
||||
{ "uct", tZONE, HOUR( 0) }, /* Universal Coordinated Time */
|
||||
{ "wet", tZONE, HOUR( 0) }, /* Western European */
|
||||
{ "bst", tDAYZONE, HOUR( 0) }, /* British Summer */
|
||||
{ "wat", tZONE, HOUR( 1) }, /* West Africa */
|
||||
{ "at", tZONE, HOUR( 2) }, /* Azores */
|
||||
@@ -445,6 +446,7 @@ static TABLE TimezoneTable[] = {
|
||||
{ "nt", tZONE, HOUR(11) }, /* Nome */
|
||||
{ "idlw", tZONE, HOUR(12) }, /* International Date Line West */
|
||||
{ "cet", tZONE, -HOUR( 1) }, /* Central European */
|
||||
{ "cest", tDAYZONE, -HOUR( 1) }, /* Central European Summer */
|
||||
{ "met", tZONE, -HOUR( 1) }, /* Middle European */
|
||||
{ "mewt", tZONE, -HOUR( 1) }, /* Middle European Winter */
|
||||
{ "mest", tDAYZONE, -HOUR( 1) }, /* Middle European Summer */
|
||||
@@ -813,10 +815,10 @@ yylex()
|
||||
yyInput++;
|
||||
}
|
||||
|
||||
if (isdigit(c = *yyInput) || c == '-' || c == '+') { /* INTL: digit */
|
||||
if (isdigit(UCHAR(c = *yyInput)) || c == '-' || c == '+') { /* INTL: digit */
|
||||
if (c == '-' || c == '+') {
|
||||
sign = c == '-' ? -1 : 1;
|
||||
if (!isdigit(*++yyInput)) { /* INTL: digit */
|
||||
if (!isdigit(UCHAR(*++yyInput))) { /* INTL: digit */
|
||||
/*
|
||||
* skip the '-' sign
|
||||
*/
|
||||
@@ -826,7 +828,7 @@ yylex()
|
||||
sign = 0;
|
||||
}
|
||||
for (yylval.Number = 0;
|
||||
isdigit(c = *yyInput++); ) { /* INTL: digit */
|
||||
isdigit(UCHAR(c = *yyInput++)); ) { /* INTL: digit */
|
||||
yylval.Number = 10 * yylval.Number + c - '0';
|
||||
}
|
||||
yyInput--;
|
||||
@@ -836,7 +838,7 @@ yylex()
|
||||
return sign ? tSNUMBER : tUNUMBER;
|
||||
}
|
||||
if (!(c & 0x80) && isalpha(UCHAR(c))) { /* INTL: ISO only. */
|
||||
for (p = buff; isalpha(c = *yyInput++) /* INTL: ISO only. */
|
||||
for (p = buff; isalpha(UCHAR(c = *yyInput++)) /* INTL: ISO only. */
|
||||
|| c == '.'; ) {
|
||||
if (p < &buff[sizeof buff - 1]) {
|
||||
*p++ = c;
|
||||
|
||||
+3
-3
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclIO.c,v 1.14 1999/08/10 17:35:18 redman Exp $
|
||||
* RCS: @(#) $Id: tclIO.c,v 1.14.4.1 1999/09/22 04:12:48 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -8157,7 +8157,6 @@ SetBlockMode(interp, chanPtr, mode)
|
||||
}
|
||||
return TCL_OK;
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
@@ -8176,7 +8175,8 @@ SetBlockMode(interp, chanPtr, mode)
|
||||
*/
|
||||
|
||||
int
|
||||
Tcl_GetChannelNames(Tcl_Interp *interp)
|
||||
Tcl_GetChannelNames(interp)
|
||||
Tcl_Interp *interp; /* Interp for error reporting. */
|
||||
{
|
||||
Channel *chanPtr;
|
||||
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
||||
|
||||
+6
-2
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclIOCmd.c,v 1.6 1999/05/05 01:19:43 stanton Exp $
|
||||
* RCS: @(#) $Id: tclIOCmd.c,v 1.6.6.1 1999/09/22 04:12:49 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -350,12 +350,14 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv)
|
||||
}
|
||||
}
|
||||
|
||||
resultPtr = Tcl_GetObjResult(interp);
|
||||
resultPtr = Tcl_NewObj();
|
||||
Tcl_IncrRefCount(resultPtr);
|
||||
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
|
||||
if (charactersRead < 0) {
|
||||
Tcl_ResetResult(interp);
|
||||
Tcl_AppendResult(interp, "error reading \"", name, "\": ",
|
||||
Tcl_PosixError(interp), (char *) NULL);
|
||||
Tcl_DecrRefCount(resultPtr);
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
@@ -372,6 +374,8 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv)
|
||||
Tcl_SetObjLength(resultPtr, length - 1);
|
||||
}
|
||||
}
|
||||
Tcl_SetObjResult(interp, resultPtr);
|
||||
Tcl_DecrRefCount(resultPtr);
|
||||
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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclParseExpr.c,v 1.4 1999/04/21 21:50:28 rjohnson Exp $
|
||||
* RCS: @(#) $Id: tclParseExpr.c,v 1.4.6.1 1999/09/22 04:12:49 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -1589,7 +1589,7 @@ GetLexeme(infoPtr)
|
||||
infoPtr->lexeme = DOLLAR;
|
||||
return TCL_OK;
|
||||
|
||||
case '"':
|
||||
case '\"':
|
||||
infoPtr->lexeme = QUOTE;
|
||||
return TCL_OK;
|
||||
|
||||
|
||||
+7
-4
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclPkg.c,v 1.4 1999/04/16 00:46:51 stanton Exp $
|
||||
* RCS: @(#) $Id: tclPkg.c,v 1.4.6.1 1999/09/22 04:12:49 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -871,16 +871,19 @@ CheckVersion(interp, string)
|
||||
* by dots. */
|
||||
{
|
||||
char *p = string;
|
||||
char prevChar;
|
||||
|
||||
if (!isdigit(UCHAR(*p))) { /* INTL: digit */
|
||||
goto error;
|
||||
}
|
||||
for (p++; *p != 0; p++) {
|
||||
if (!isdigit(UCHAR(*p)) && (*p != '.')) { /* INTL: digit */
|
||||
for (prevChar = *p, p++; *p != 0; p++) {
|
||||
if (!isdigit(UCHAR(*p)) &&
|
||||
((*p != '.') || (prevChar == '.'))) { /* INTL: digit */
|
||||
goto error;
|
||||
}
|
||||
prevChar = *p;
|
||||
}
|
||||
if (p[-1] != '.') {
|
||||
if (prevChar != '.') {
|
||||
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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclPosixStr.c,v 1.4 1999/04/16 00:46:52 stanton Exp $
|
||||
* RCS: @(#) $Id: tclPosixStr.c,v 1.4.6.1 1999/09/22 04:12:49 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -736,7 +736,7 @@ Tcl_ErrnoMsg(err)
|
||||
case ENOPKG: return "package not installed";
|
||||
#endif
|
||||
#ifdef ENOPROTOOPT
|
||||
case ENOPROTOOPT: return "bad proocol option";
|
||||
case ENOPROTOOPT: return "bad protocol option";
|
||||
#endif
|
||||
#ifdef ENOSPC
|
||||
case ENOSPC: return "no space left on device";
|
||||
|
||||
+18
-9
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclProc.c,v 1.19 1999/04/16 00:46:52 stanton Exp $
|
||||
* RCS: @(#) $Id: tclProc.c,v 1.19.6.1 1999/09/22 04:12:50 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -135,6 +135,7 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
|
||||
cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
|
||||
TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc);
|
||||
|
||||
Tcl_DStringFree(&ds);
|
||||
/*
|
||||
* Now initialize the new procedure's cmdPtr field. This will be used
|
||||
* later when the procedure is called to determine what namespace the
|
||||
@@ -265,7 +266,7 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
|
||||
|
||||
if (precompiled) {
|
||||
if (numArgs > procPtr->numArgs) {
|
||||
char buf[128];
|
||||
char buf[64 + TCL_INTEGER_SPACE + TCL_INTEGER_SPACE];
|
||||
sprintf(buf, "\": arg list contains %d entries, precompiled header expects %d",
|
||||
numArgs, procPtr->numArgs);
|
||||
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
||||
@@ -351,7 +352,7 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
|
||||
&& (fieldCount == 2))
|
||||
|| ((localPtr->defValuePtr != NULL)
|
||||
&& (fieldCount != 2))) {
|
||||
char buf[128];
|
||||
char buf[80 + TCL_INTEGER_SPACE];
|
||||
sprintf(buf, "\": formal parameter %d is inconsistent with precompiled body",
|
||||
i);
|
||||
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
||||
@@ -1087,7 +1088,6 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
|
||||
}
|
||||
}
|
||||
if (bodyPtr->typePtr != &tclByteCodeType) {
|
||||
char buf[100];
|
||||
int numChars;
|
||||
char *ellipsis;
|
||||
|
||||
@@ -1133,7 +1133,9 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
|
||||
|
||||
if (result != TCL_OK) {
|
||||
if (result == TCL_ERROR) {
|
||||
numChars = strlen(procName);
|
||||
char buf[100 + TCL_INTEGER_SPACE];
|
||||
|
||||
numChars = strlen(procName);
|
||||
ellipsis = "";
|
||||
if (numChars > 50) {
|
||||
numChars = 50;
|
||||
@@ -1201,13 +1203,20 @@ ProcessProcResultCode(interp, procName, nameLen, returnCode)
|
||||
int returnCode; /* The unexpected result code. */
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
char msg[100 + TCL_INTEGER_SPACE];
|
||||
|
||||
|
||||
if (returnCode == TCL_RETURN) {
|
||||
returnCode = TclUpdateReturnInfo(iPtr);
|
||||
} else if (returnCode == TCL_ERROR) {
|
||||
sprintf(msg, "\n (procedure \"%.*s\" line %d)",
|
||||
nameLen, procName, iPtr->errorLine);
|
||||
char msg[100 + TCL_INTEGER_SPACE];
|
||||
char *ellipsis = "";
|
||||
int numChars = nameLen;
|
||||
|
||||
if (numChars > 60) {
|
||||
numChars = 60;
|
||||
ellipsis = "...";
|
||||
}
|
||||
sprintf(msg, "\n (procedure \"%.*s%s\" line %d)",
|
||||
numChars, procName, ellipsis, iPtr->errorLine);
|
||||
Tcl_AddObjErrorInfo(interp, msg, -1);
|
||||
} else if (returnCode == TCL_BREAK) {
|
||||
Tcl_ResetResult(interp);
|
||||
|
||||
+3
-2
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclRegexp.c,v 1.9 1999/06/17 19:32:15 stanton Exp $
|
||||
* RCS: @(#) $Id: tclRegexp.c,v 1.9.4.1 1999/11/02 02:09:49 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -642,7 +642,8 @@ TclRegAbout(interp, re)
|
||||
{REG_ULOCALE, "REG_ULOCALE"},
|
||||
{REG_UEMPTYMATCH, "REG_UEMPTYMATCH"},
|
||||
{REG_UIMPOSSIBLE, "REG_UIMPOSSIBLE"},
|
||||
{0, ""}
|
||||
{REG_USHORTEST, "REG_USHORTEST"},
|
||||
{0, ""}
|
||||
};
|
||||
struct infoname *inf;
|
||||
int n;
|
||||
|
||||
+42
-15
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclResult.c,v 1.3 1999/05/07 20:07:35 stanton Exp $
|
||||
* RCS: @(#) $Id: tclResult.c,v 1.3.6.1 1999/10/30 11:06:00 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -455,10 +455,12 @@ Tcl_AppendResultVA (interp, argList)
|
||||
* return value. */
|
||||
va_list argList; /* Variable argument list. */
|
||||
{
|
||||
#define STATIC_LIST_SIZE 16
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
va_list tmpArgList;
|
||||
char *string;
|
||||
int newSpace;
|
||||
char *string, *static_list[STATIC_LIST_SIZE];
|
||||
char **args = static_list;
|
||||
int nargs_space = STATIC_LIST_SIZE;
|
||||
int nargs, newSpace, i;
|
||||
|
||||
/*
|
||||
* If the string result is empty, move the object result to the
|
||||
@@ -472,17 +474,35 @@ Tcl_AppendResultVA (interp, argList)
|
||||
}
|
||||
|
||||
/*
|
||||
* Scan through all the arguments to see how much space is needed.
|
||||
* Scan through all the arguments to see how much space is needed
|
||||
* and save pointers to the arguments in the args array,
|
||||
* reallocating as necessary.
|
||||
*/
|
||||
|
||||
memcpy ((VOID *) &tmpArgList, (VOID *) &argList, sizeof (tmpArgList));
|
||||
nargs = 0;
|
||||
newSpace = 0;
|
||||
while (1) {
|
||||
string = va_arg(tmpArgList, char *);
|
||||
string = va_arg(argList, char *);
|
||||
if (string == NULL) {
|
||||
break;
|
||||
}
|
||||
newSpace += strlen(string);
|
||||
if (nargs >= nargs_space) {
|
||||
/*
|
||||
* Expand the args buffer
|
||||
*/
|
||||
nargs_space += STATIC_LIST_SIZE;
|
||||
if (args == static_list) {
|
||||
args = (void *)ckalloc(nargs_space * sizeof(char *));
|
||||
for (i = 0; i < nargs; ++i) {
|
||||
args[i] = static_list[i];
|
||||
}
|
||||
} else {
|
||||
args = (void *)ckrealloc((void *)args,
|
||||
nargs_space * sizeof(char *));
|
||||
}
|
||||
}
|
||||
newSpace += strlen(string);
|
||||
args[nargs++] = string;
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -501,14 +521,21 @@ Tcl_AppendResultVA (interp, argList)
|
||||
* buffer.
|
||||
*/
|
||||
|
||||
while (1) {
|
||||
string = va_arg(argList, char *);
|
||||
if (string == NULL) {
|
||||
break;
|
||||
}
|
||||
strcpy(iPtr->appendResult + iPtr->appendUsed, string);
|
||||
iPtr->appendUsed += strlen(string);
|
||||
for (i = 0; i < nargs; ++i) {
|
||||
string = args[i];
|
||||
strcpy(iPtr->appendResult + iPtr->appendUsed, string);
|
||||
iPtr->appendUsed += strlen(string);
|
||||
}
|
||||
|
||||
/*
|
||||
* If we had to allocate a buffer from the heap,
|
||||
* free it now.
|
||||
*/
|
||||
|
||||
if (args != static_list) {
|
||||
ckfree((void *)args);
|
||||
}
|
||||
#undef STATIC_LIST_SIZE
|
||||
}
|
||||
|
||||
/*
|
||||
|
||||
+43
-11
@@ -33,7 +33,7 @@
|
||||
* See the file "license.terms" for information on usage and redistribution
|
||||
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
*
|
||||
* RCS: @(#) $Id: tclStringObj.c,v 1.12 1999/06/16 00:47:56 hershey Exp $ */
|
||||
* RCS: @(#) $Id: tclStringObj.c,v 1.12.4.2 1999/10/30 11:06:01 hobbs Exp $ */
|
||||
|
||||
#include "tclInt.h"
|
||||
|
||||
@@ -334,7 +334,7 @@ Tcl_GetCharLength(objPtr)
|
||||
if (stringPtr->numChars == objPtr->length) {
|
||||
|
||||
/*
|
||||
* Since we've just calucalated the number of chars, and all
|
||||
* Since we've just calculated the number of chars, and all
|
||||
* UTF chars are 1-byte long, we don't need to store the
|
||||
* unicode string.
|
||||
*/
|
||||
@@ -916,17 +916,18 @@ Tcl_AppendObjToObj(objPtr, appendObjPtr)
|
||||
* number of characters in the final (appended-to) object.
|
||||
*/
|
||||
|
||||
bytes = Tcl_GetStringFromObj(appendObjPtr, &length);
|
||||
|
||||
allOneByteChars = 0;
|
||||
numChars = stringPtr->numChars;
|
||||
if ((numChars >= 0) && (appendObjPtr->typePtr == &tclStringType)) {
|
||||
stringPtr = GET_STRING(appendObjPtr);
|
||||
if (stringPtr->numChars >= 0) {
|
||||
if ((stringPtr->numChars >= 0) && (stringPtr->numChars == length)) {
|
||||
numChars += stringPtr->numChars;
|
||||
allOneByteChars = 1;
|
||||
}
|
||||
}
|
||||
|
||||
bytes = Tcl_GetStringFromObj(appendObjPtr, &length);
|
||||
|
||||
AppendUtfToUtfRep(objPtr, bytes, length);
|
||||
|
||||
if (allOneByteChars) {
|
||||
@@ -1169,10 +1170,14 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
|
||||
Tcl_Obj *objPtr; /* Points to the object to append to. */
|
||||
va_list argList; /* Variable argument list. */
|
||||
{
|
||||
#define STATIC_LIST_SIZE 16
|
||||
String *stringPtr;
|
||||
va_list tmpArgList;
|
||||
int newLength, oldLength;
|
||||
register char *string, *dst;
|
||||
char *static_list[STATIC_LIST_SIZE];
|
||||
char **args = static_list;
|
||||
int nargs_space = STATIC_LIST_SIZE;
|
||||
int nargs, i;
|
||||
|
||||
if (Tcl_IsShared(objPtr)) {
|
||||
panic("Tcl_AppendStringsToObj called with shared object");
|
||||
@@ -1187,17 +1192,33 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
|
||||
* (notably OS/390) the argList is an array so we need to use memcpy.
|
||||
*/
|
||||
|
||||
memcpy ((VOID *) &tmpArgList, (VOID *) &argList, sizeof (tmpArgList));
|
||||
nargs = 0;
|
||||
newLength = oldLength = objPtr->length;
|
||||
while (1) {
|
||||
string = va_arg(tmpArgList, char *);
|
||||
string = va_arg(argList, char *);
|
||||
if (string == NULL) {
|
||||
break;
|
||||
}
|
||||
if (nargs >= nargs_space) {
|
||||
/*
|
||||
* Expand the args buffer
|
||||
*/
|
||||
nargs_space += STATIC_LIST_SIZE;
|
||||
if (args == static_list) {
|
||||
args = (void *)ckalloc(nargs_space * sizeof(char *));
|
||||
for (i = 0; i < nargs; ++i) {
|
||||
args[i] = static_list[i];
|
||||
}
|
||||
} else {
|
||||
args = (void *)ckrealloc((void *)args,
|
||||
nargs_space * sizeof(char *));
|
||||
}
|
||||
}
|
||||
newLength += strlen(string);
|
||||
args[nargs++] = string;
|
||||
}
|
||||
if (newLength == oldLength) {
|
||||
return;
|
||||
goto done;
|
||||
}
|
||||
|
||||
stringPtr = GET_STRING(objPtr);
|
||||
@@ -1221,8 +1242,8 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
|
||||
*/
|
||||
|
||||
dst = objPtr->bytes + oldLength;
|
||||
while (1) {
|
||||
string = va_arg(argList, char *);
|
||||
for (i = 0; i < nargs; ++i) {
|
||||
string = args[i];
|
||||
if (string == NULL) {
|
||||
break;
|
||||
}
|
||||
@@ -1244,6 +1265,17 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
|
||||
*dst = 0;
|
||||
}
|
||||
objPtr->length = newLength;
|
||||
|
||||
done:
|
||||
/*
|
||||
* If we had to allocate a buffer from the heap,
|
||||
* free it now.
|
||||
*/
|
||||
|
||||
if (args != static_list) {
|
||||
ckfree((void *)args);
|
||||
}
|
||||
#undef STATIC_LIST_SIZE
|
||||
}
|
||||
|
||||
/*
|
||||
|
||||
+3
-3
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclTest.c,v 1.16 1999/08/13 17:53:19 redman Exp $
|
||||
* RCS: @(#) $Id: tclTest.c,v 1.16.2.1 1999/11/02 02:09:50 hobbs Exp $
|
||||
*/
|
||||
|
||||
#define TCL_TEST
|
||||
@@ -2788,7 +2788,7 @@ TestregexpXflags(string, length, cflagsPtr, eflagsPtr)
|
||||
break;
|
||||
}
|
||||
case '+': {
|
||||
cflags |= REG_FAKEEC;
|
||||
cflags |= REG_FAKE;
|
||||
break;
|
||||
}
|
||||
case ',': {
|
||||
@@ -2815,7 +2815,7 @@ TestregexpXflags(string, length, cflagsPtr, eflagsPtr)
|
||||
eflags |= REG_NOTEOL;
|
||||
break;
|
||||
}
|
||||
case '?': {
|
||||
case 't': {
|
||||
cflags |= REG_EXPECT;
|
||||
break;
|
||||
}
|
||||
|
||||
+89
-12
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclThreadTest.c,v 1.3 1999/05/26 20:24:43 redman Exp $
|
||||
* RCS: @(#) $Id: tclThreadTest.c,v 1.3.4.1 1999/10/30 11:06:01 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -135,6 +135,9 @@ static void ListRemove _ANSI_ARGS_((ThreadSpecificData *tsdPtr));
|
||||
static void ListUpdateInner _ANSI_ARGS_((ThreadSpecificData *tsdPtr));
|
||||
static int ThreadEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int mask));
|
||||
static void ThreadErrorProc _ANSI_ARGS_((Tcl_Interp *interp));
|
||||
static void ThreadFreeProc _ANSI_ARGS_((ClientData clientData));
|
||||
static int ThreadDeleteEvent _ANSI_ARGS_((Tcl_Event *eventPtr,
|
||||
ClientData clientData));
|
||||
static void ThreadExitProc _ANSI_ARGS_((ClientData clientData));
|
||||
|
||||
|
||||
@@ -351,8 +354,7 @@ TclCreateThread(interp, script)
|
||||
ThreadCtrl ctrl;
|
||||
Tcl_ThreadId id;
|
||||
|
||||
ctrl.script = (char*)ckalloc( strlen(script) + 1 );
|
||||
strcpy(ctrl.script, script);
|
||||
ctrl.script = (char *) script;
|
||||
ctrl.condWait = NULL;
|
||||
ctrl.flags = 0;
|
||||
|
||||
@@ -413,10 +415,8 @@ NewThread(clientData)
|
||||
{
|
||||
ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData;
|
||||
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
||||
ThreadCtrl ctrl;
|
||||
int result;
|
||||
|
||||
ctrl = *ctrlPtr;
|
||||
char *threadEvalScript;
|
||||
|
||||
/*
|
||||
* Initialize the interpreter. This should be more general.
|
||||
@@ -432,7 +432,14 @@ NewThread(clientData)
|
||||
|
||||
Tcl_MutexLock(&threadMutex);
|
||||
ListUpdateInner(tsdPtr);
|
||||
Tcl_CreateThreadExitHandler(ThreadExitProc, NULL);
|
||||
/*
|
||||
* We need to keep a pointer to the alloc'ed mem of the script
|
||||
* we are eval'ing, for the case that we exit during evaluation
|
||||
*/
|
||||
threadEvalScript = (char *) ckalloc(strlen(ctrlPtr->script)+1);
|
||||
strcpy(threadEvalScript, ctrlPtr->script);
|
||||
|
||||
Tcl_CreateThreadExitHandler(ThreadExitProc, (ClientData) threadEvalScript);
|
||||
|
||||
/*
|
||||
* Notify the parent we are alive.
|
||||
@@ -446,7 +453,7 @@ NewThread(clientData)
|
||||
*/
|
||||
|
||||
Tcl_Preserve((ClientData) tsdPtr->interp);
|
||||
result = Tcl_Eval(tsdPtr->interp, ctrl.script);
|
||||
result = Tcl_Eval(tsdPtr->interp, threadEvalScript);
|
||||
if (result != TCL_OK) {
|
||||
ThreadErrorProc(tsdPtr->interp);
|
||||
}
|
||||
@@ -456,7 +463,6 @@ NewThread(clientData)
|
||||
*/
|
||||
|
||||
ListRemove(tsdPtr);
|
||||
ckfree((char*)ctrl.script);
|
||||
Tcl_Release((ClientData) tsdPtr->interp);
|
||||
Tcl_DeleteInterp(tsdPtr->interp);
|
||||
Tcl_ExitThread(result);
|
||||
@@ -676,7 +682,7 @@ TclThreadSend(interp, id, script, wait)
|
||||
threadEventPtr->script = ckalloc(strlen(script) + 1);
|
||||
strcpy(threadEventPtr->script, script);
|
||||
if (!wait) {
|
||||
threadEventPtr->resultPtr = NULL;
|
||||
resultPtr = threadEventPtr->resultPtr = NULL;
|
||||
} else {
|
||||
resultPtr = (ThreadEventResult *) ckalloc(sizeof(ThreadEventResult));
|
||||
threadEventPtr->resultPtr = resultPtr;
|
||||
@@ -802,7 +808,11 @@ ThreadEventProc(evPtr, mask)
|
||||
} else {
|
||||
Tcl_Preserve((ClientData) interp);
|
||||
Tcl_ResetResult(interp);
|
||||
Tcl_CreateThreadExitHandler(ThreadFreeProc,
|
||||
(ClientData) threadEventPtr->script);
|
||||
code = Tcl_GlobalEval(interp, threadEventPtr->script);
|
||||
Tcl_DeleteThreadExitHandler(ThreadFreeProc,
|
||||
(ClientData) threadEventPtr->script);
|
||||
result = Tcl_GetStringResult(interp);
|
||||
if (code != TCL_OK) {
|
||||
errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
|
||||
@@ -834,6 +844,65 @@ ThreadEventProc(evPtr, mask)
|
||||
return 1;
|
||||
}
|
||||
|
||||
/*
|
||||
*------------------------------------------------------------------------
|
||||
*
|
||||
* ThreadFreeProc --
|
||||
*
|
||||
* This is called from when we are exiting and memory needs
|
||||
* to be freed.
|
||||
*
|
||||
* Results:
|
||||
* None.
|
||||
*
|
||||
* Side effects:
|
||||
* Clears up mem specified in ClientData
|
||||
*
|
||||
*------------------------------------------------------------------------
|
||||
*/
|
||||
/* ARGSUSED */
|
||||
void
|
||||
ThreadFreeProc(clientData)
|
||||
ClientData clientData;
|
||||
{
|
||||
if (clientData) {
|
||||
ckfree((char *) clientData);
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
*------------------------------------------------------------------------
|
||||
*
|
||||
* ThreadDeleteEvent --
|
||||
*
|
||||
* This is called from the ThreadExitProc to delete memory related
|
||||
* to events that we put on the queue.
|
||||
*
|
||||
* Results:
|
||||
* 1 it was our event and we want it removed, 0 otherwise.
|
||||
*
|
||||
* Side effects:
|
||||
* It cleans up our events in the event queue for this thread.
|
||||
*
|
||||
*------------------------------------------------------------------------
|
||||
*/
|
||||
/* ARGSUSED */
|
||||
int
|
||||
ThreadDeleteEvent(eventPtr, clientData)
|
||||
Tcl_Event *eventPtr; /* Really ThreadEvent */
|
||||
ClientData clientData; /* dummy */
|
||||
{
|
||||
if (eventPtr->proc == ThreadEventProc) {
|
||||
ckfree((char *) ((ThreadEvent *) eventPtr)->script);
|
||||
return 1;
|
||||
}
|
||||
/*
|
||||
* If it was NULL, we were in the middle of servicing the event
|
||||
* and it should be removed
|
||||
*/
|
||||
return (eventPtr->proc == NULL);
|
||||
}
|
||||
|
||||
/*
|
||||
*------------------------------------------------------------------------
|
||||
*
|
||||
@@ -852,13 +921,21 @@ ThreadEventProc(evPtr, mask)
|
||||
*/
|
||||
/* ARGSUSED */
|
||||
void
|
||||
ThreadExitProc(dummy)
|
||||
ClientData dummy;
|
||||
ThreadExitProc(clientData)
|
||||
ClientData clientData;
|
||||
{
|
||||
char *threadEvalScript = (char *) clientData;
|
||||
ThreadEventResult *resultPtr, *nextPtr;
|
||||
Tcl_ThreadId self = Tcl_GetCurrentThread();
|
||||
|
||||
Tcl_MutexLock(&threadMutex);
|
||||
|
||||
if (threadEvalScript) {
|
||||
ckfree((char *) threadEvalScript);
|
||||
threadEvalScript = NULL;
|
||||
}
|
||||
Tcl_DeleteEvents((Tcl_EventDeleteProc *)ThreadDeleteEvent, NULL);
|
||||
|
||||
for (resultPtr = resultList ; resultPtr ; resultPtr = nextPtr) {
|
||||
nextPtr = resultPtr->nextPtr;
|
||||
if (resultPtr->srcThreadId == self) {
|
||||
|
||||
+11
-4
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclVar.c,v 1.12 1999/08/10 02:42:14 welch Exp $
|
||||
* RCS: @(#) $Id: tclVar.c,v 1.12.4.1 1999/09/22 04:12:50 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -3255,8 +3255,7 @@ TclArraySet(interp, arrayNameObj, arrayElemObj)
|
||||
|
||||
return TCL_OK;
|
||||
}
|
||||
if (TclIsVarArrayElement(varPtr) ||
|
||||
!TclIsVarUndefined(varPtr)) {
|
||||
if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
|
||||
/*
|
||||
* Either an array element, or a scalar: lose!
|
||||
*/
|
||||
@@ -3269,9 +3268,17 @@ TclArraySet(interp, arrayNameObj, arrayElemObj)
|
||||
* Create variable for new array.
|
||||
*/
|
||||
|
||||
varPtr = TclLookupVar(interp, varName, (char *) NULL, 0, 0,
|
||||
varPtr = TclLookupVar(interp, varName, (char *) NULL,
|
||||
TCL_LEAVE_ERR_MSG, "set",
|
||||
/*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
|
||||
|
||||
/*
|
||||
* Still couldn't do it - this can occur if a non-existent
|
||||
* namespace was specified
|
||||
*/
|
||||
if (varPtr == NULL) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
}
|
||||
TclSetVarArray(varPtr);
|
||||
TclClearVarUndefined(varPtr);
|
||||
|
||||
@@ -1 +1,5 @@
|
||||
package ifneeded dde 1.1 "load [list [file join $dir tcldde82.dll]] dde"
|
||||
if {[info exists tcl_platform(debug)]} {
|
||||
package ifneeded dde 1.1 [list load [file join $dir tcldde82d.dll] dde]
|
||||
} else {
|
||||
package ifneeded dde 1.1 [list load [file join $dir tcldde82.dll] dde]
|
||||
}
|
||||
|
||||
@@ -1 +1,5 @@
|
||||
package ifneeded dde 1.1 "load [list [file join $dir tcldde82.dll]] dde"
|
||||
if {[info exists tcl_platform(debug)]} {
|
||||
package ifneeded dde 1.1 [list load [file join $dir tcldde82d.dll] dde]
|
||||
} else {
|
||||
package ifneeded dde 1.1 [list load [file join $dir tcldde82.dll] dde]
|
||||
}
|
||||
|
||||
+16
-20
@@ -9,13 +9,12 @@
|
||||
# See the file "license.terms" for information on usage and
|
||||
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
# RCS: @(#) $Id: http.tcl,v 1.9 1999/08/05 16:57:48 hobbs Exp $
|
||||
# RCS: @(#) $Id: http.tcl,v 1.9.4.2 1999/10/30 11:06:30 hobbs Exp $
|
||||
|
||||
package provide http 2.1 ;# This uses Tcl namespaces
|
||||
|
||||
namespace eval http {
|
||||
variable http
|
||||
|
||||
array set http {
|
||||
-accept */*
|
||||
-proxyhost {}
|
||||
@@ -25,8 +24,8 @@ namespace eval http {
|
||||
}
|
||||
|
||||
variable formMap
|
||||
set alphanumeric a-zA-Z0-9
|
||||
|
||||
variable alphanumeric a-zA-Z0-9
|
||||
variable c
|
||||
variable i 0
|
||||
for {} {$i <= 256} {incr i} {
|
||||
set c [format %c $i]
|
||||
@@ -179,12 +178,10 @@ proc http::geturl { url args } {
|
||||
set pat ^-([join $options |])$
|
||||
foreach {flag value} $args {
|
||||
if {[regexp $pat $flag]} {
|
||||
|
||||
# Validate numbers
|
||||
|
||||
if {[info exists state($flag)] && \
|
||||
[regexp {^[0-9]+$} $state($flag)] && \
|
||||
![regexp {^[0-9]+$} $value]} {
|
||||
[string is integer -strict $state($flag)] && \
|
||||
![string is integer -strict $value]} {
|
||||
return -code error "Bad value for $flag ($value), must be integer"
|
||||
}
|
||||
set state($flag) $value
|
||||
@@ -192,7 +189,7 @@ proc http::geturl { url args } {
|
||||
return -code error "Unknown option $flag, can be: $usage"
|
||||
}
|
||||
}
|
||||
if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
|
||||
if {![regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
|
||||
x proto host y port srvurl]} {
|
||||
error "Unsupported URL: $url"
|
||||
}
|
||||
@@ -236,14 +233,13 @@ proc http::geturl { url args } {
|
||||
# Wait for the connection to complete
|
||||
|
||||
if {$state(-timeout) > 0} {
|
||||
#fileevent $s writable [list set $token\(status) connect]
|
||||
fileevent $s writable [list http::Connect $token]
|
||||
http::wait $token
|
||||
if {[string compare $state(status) "timeout"] == 0} {
|
||||
if {[string equal $state(status) "timeout"]} {
|
||||
return
|
||||
}
|
||||
fileevent $s writable {}
|
||||
unset state(status)
|
||||
set state(status) ""
|
||||
}
|
||||
|
||||
# Send data in cr-lf format, but accept any line terminators
|
||||
@@ -351,8 +347,10 @@ proc http::cleanup {token} {
|
||||
Eof $token
|
||||
return
|
||||
}
|
||||
if {$state(state) == "header"} {
|
||||
set n [gets $s line]
|
||||
if {[string equal $state(state) "header"]} {
|
||||
if {[catch {gets $s line} n]} {
|
||||
Finish $token $err
|
||||
}
|
||||
if {$n == 0} {
|
||||
set state(state) body
|
||||
if {![regexp -nocase ^text $state(type)]} {
|
||||
@@ -423,7 +421,7 @@ proc http::cleanup {token} {
|
||||
eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
|
||||
}
|
||||
# At this point the token may have been reset
|
||||
if {([string length $error] != 0)} {
|
||||
if {[string length $error]} {
|
||||
Finish $token $error
|
||||
} elseif {[catch {::eof $s} iseof] || $iseof} {
|
||||
Eof $token
|
||||
@@ -434,7 +432,7 @@ proc http::cleanup {token} {
|
||||
proc http::Eof {token} {
|
||||
variable $token
|
||||
upvar 0 $token state
|
||||
if {$state(state) == "header"} {
|
||||
if {[string equal $state(state) "header"]} {
|
||||
# Premature eof
|
||||
set state(status) eof
|
||||
} else {
|
||||
@@ -458,9 +456,7 @@ proc http::wait {token} {
|
||||
upvar 0 $token state
|
||||
|
||||
if {![info exists state(status)] || [string length $state(status)] == 0} {
|
||||
|
||||
# We must wait on the original variable name, not the upvar alias
|
||||
|
||||
vwait $token\(status)
|
||||
}
|
||||
if {[info exists state(error)]} {
|
||||
@@ -487,8 +483,8 @@ proc http::formatQuery {args} {
|
||||
set result ""
|
||||
set sep ""
|
||||
foreach i $args {
|
||||
append result $sep [mapReply $i]
|
||||
if {$sep != "="} {
|
||||
append result $sep [mapReply $i]
|
||||
if {[string compare $sep "="]} {
|
||||
set sep =
|
||||
} else {
|
||||
set sep &
|
||||
|
||||
+16
-20
@@ -9,13 +9,12 @@
|
||||
# See the file "license.terms" for information on usage and
|
||||
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
# RCS: @(#) $Id: http.tcl,v 1.9 1999/08/05 16:57:48 hobbs Exp $
|
||||
# RCS: @(#) $Id: http.tcl,v 1.9.4.2 1999/10/30 11:06:30 hobbs Exp $
|
||||
|
||||
package provide http 2.1 ;# This uses Tcl namespaces
|
||||
|
||||
namespace eval http {
|
||||
variable http
|
||||
|
||||
array set http {
|
||||
-accept */*
|
||||
-proxyhost {}
|
||||
@@ -25,8 +24,8 @@ namespace eval http {
|
||||
}
|
||||
|
||||
variable formMap
|
||||
set alphanumeric a-zA-Z0-9
|
||||
|
||||
variable alphanumeric a-zA-Z0-9
|
||||
variable c
|
||||
variable i 0
|
||||
for {} {$i <= 256} {incr i} {
|
||||
set c [format %c $i]
|
||||
@@ -179,12 +178,10 @@ proc http::geturl { url args } {
|
||||
set pat ^-([join $options |])$
|
||||
foreach {flag value} $args {
|
||||
if {[regexp $pat $flag]} {
|
||||
|
||||
# Validate numbers
|
||||
|
||||
if {[info exists state($flag)] && \
|
||||
[regexp {^[0-9]+$} $state($flag)] && \
|
||||
![regexp {^[0-9]+$} $value]} {
|
||||
[string is integer -strict $state($flag)] && \
|
||||
![string is integer -strict $value]} {
|
||||
return -code error "Bad value for $flag ($value), must be integer"
|
||||
}
|
||||
set state($flag) $value
|
||||
@@ -192,7 +189,7 @@ proc http::geturl { url args } {
|
||||
return -code error "Unknown option $flag, can be: $usage"
|
||||
}
|
||||
}
|
||||
if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
|
||||
if {![regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
|
||||
x proto host y port srvurl]} {
|
||||
error "Unsupported URL: $url"
|
||||
}
|
||||
@@ -236,14 +233,13 @@ proc http::geturl { url args } {
|
||||
# Wait for the connection to complete
|
||||
|
||||
if {$state(-timeout) > 0} {
|
||||
#fileevent $s writable [list set $token\(status) connect]
|
||||
fileevent $s writable [list http::Connect $token]
|
||||
http::wait $token
|
||||
if {[string compare $state(status) "timeout"] == 0} {
|
||||
if {[string equal $state(status) "timeout"]} {
|
||||
return
|
||||
}
|
||||
fileevent $s writable {}
|
||||
unset state(status)
|
||||
set state(status) ""
|
||||
}
|
||||
|
||||
# Send data in cr-lf format, but accept any line terminators
|
||||
@@ -351,8 +347,10 @@ proc http::cleanup {token} {
|
||||
Eof $token
|
||||
return
|
||||
}
|
||||
if {$state(state) == "header"} {
|
||||
set n [gets $s line]
|
||||
if {[string equal $state(state) "header"]} {
|
||||
if {[catch {gets $s line} n]} {
|
||||
Finish $token $err
|
||||
}
|
||||
if {$n == 0} {
|
||||
set state(state) body
|
||||
if {![regexp -nocase ^text $state(type)]} {
|
||||
@@ -423,7 +421,7 @@ proc http::cleanup {token} {
|
||||
eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
|
||||
}
|
||||
# At this point the token may have been reset
|
||||
if {([string length $error] != 0)} {
|
||||
if {[string length $error]} {
|
||||
Finish $token $error
|
||||
} elseif {[catch {::eof $s} iseof] || $iseof} {
|
||||
Eof $token
|
||||
@@ -434,7 +432,7 @@ proc http::cleanup {token} {
|
||||
proc http::Eof {token} {
|
||||
variable $token
|
||||
upvar 0 $token state
|
||||
if {$state(state) == "header"} {
|
||||
if {[string equal $state(state) "header"]} {
|
||||
# Premature eof
|
||||
set state(status) eof
|
||||
} else {
|
||||
@@ -458,9 +456,7 @@ proc http::wait {token} {
|
||||
upvar 0 $token state
|
||||
|
||||
if {![info exists state(status)] || [string length $state(status)] == 0} {
|
||||
|
||||
# We must wait on the original variable name, not the upvar alias
|
||||
|
||||
vwait $token\(status)
|
||||
}
|
||||
if {[info exists state(error)]} {
|
||||
@@ -487,8 +483,8 @@ proc http::formatQuery {args} {
|
||||
set result ""
|
||||
set sep ""
|
||||
foreach i $args {
|
||||
append result $sep [mapReply $i]
|
||||
if {$sep != "="} {
|
||||
append result $sep [mapReply $i]
|
||||
if {[string compare $sep "="]} {
|
||||
set sep =
|
||||
} else {
|
||||
set sep &
|
||||
|
||||
+16
-20
@@ -9,13 +9,12 @@
|
||||
# See the file "license.terms" for information on usage and
|
||||
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
# RCS: @(#) $Id: http.tcl,v 1.9 1999/08/05 16:57:48 hobbs Exp $
|
||||
# RCS: @(#) $Id: http.tcl,v 1.9.4.2 1999/10/30 11:06:30 hobbs Exp $
|
||||
|
||||
package provide http 2.1 ;# This uses Tcl namespaces
|
||||
|
||||
namespace eval http {
|
||||
variable http
|
||||
|
||||
array set http {
|
||||
-accept */*
|
||||
-proxyhost {}
|
||||
@@ -25,8 +24,8 @@ namespace eval http {
|
||||
}
|
||||
|
||||
variable formMap
|
||||
set alphanumeric a-zA-Z0-9
|
||||
|
||||
variable alphanumeric a-zA-Z0-9
|
||||
variable c
|
||||
variable i 0
|
||||
for {} {$i <= 256} {incr i} {
|
||||
set c [format %c $i]
|
||||
@@ -179,12 +178,10 @@ proc http::geturl { url args } {
|
||||
set pat ^-([join $options |])$
|
||||
foreach {flag value} $args {
|
||||
if {[regexp $pat $flag]} {
|
||||
|
||||
# Validate numbers
|
||||
|
||||
if {[info exists state($flag)] && \
|
||||
[regexp {^[0-9]+$} $state($flag)] && \
|
||||
![regexp {^[0-9]+$} $value]} {
|
||||
[string is integer -strict $state($flag)] && \
|
||||
![string is integer -strict $value]} {
|
||||
return -code error "Bad value for $flag ($value), must be integer"
|
||||
}
|
||||
set state($flag) $value
|
||||
@@ -192,7 +189,7 @@ proc http::geturl { url args } {
|
||||
return -code error "Unknown option $flag, can be: $usage"
|
||||
}
|
||||
}
|
||||
if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
|
||||
if {![regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
|
||||
x proto host y port srvurl]} {
|
||||
error "Unsupported URL: $url"
|
||||
}
|
||||
@@ -236,14 +233,13 @@ proc http::geturl { url args } {
|
||||
# Wait for the connection to complete
|
||||
|
||||
if {$state(-timeout) > 0} {
|
||||
#fileevent $s writable [list set $token\(status) connect]
|
||||
fileevent $s writable [list http::Connect $token]
|
||||
http::wait $token
|
||||
if {[string compare $state(status) "timeout"] == 0} {
|
||||
if {[string equal $state(status) "timeout"]} {
|
||||
return
|
||||
}
|
||||
fileevent $s writable {}
|
||||
unset state(status)
|
||||
set state(status) ""
|
||||
}
|
||||
|
||||
# Send data in cr-lf format, but accept any line terminators
|
||||
@@ -351,8 +347,10 @@ proc http::cleanup {token} {
|
||||
Eof $token
|
||||
return
|
||||
}
|
||||
if {$state(state) == "header"} {
|
||||
set n [gets $s line]
|
||||
if {[string equal $state(state) "header"]} {
|
||||
if {[catch {gets $s line} n]} {
|
||||
Finish $token $err
|
||||
}
|
||||
if {$n == 0} {
|
||||
set state(state) body
|
||||
if {![regexp -nocase ^text $state(type)]} {
|
||||
@@ -423,7 +421,7 @@ proc http::cleanup {token} {
|
||||
eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
|
||||
}
|
||||
# At this point the token may have been reset
|
||||
if {([string length $error] != 0)} {
|
||||
if {[string length $error]} {
|
||||
Finish $token $error
|
||||
} elseif {[catch {::eof $s} iseof] || $iseof} {
|
||||
Eof $token
|
||||
@@ -434,7 +432,7 @@ proc http::cleanup {token} {
|
||||
proc http::Eof {token} {
|
||||
variable $token
|
||||
upvar 0 $token state
|
||||
if {$state(state) == "header"} {
|
||||
if {[string equal $state(state) "header"]} {
|
||||
# Premature eof
|
||||
set state(status) eof
|
||||
} else {
|
||||
@@ -458,9 +456,7 @@ proc http::wait {token} {
|
||||
upvar 0 $token state
|
||||
|
||||
if {![info exists state(status)] || [string length $state(status)] == 0} {
|
||||
|
||||
# We must wait on the original variable name, not the upvar alias
|
||||
|
||||
vwait $token\(status)
|
||||
}
|
||||
if {[info exists state(error)]} {
|
||||
@@ -487,8 +483,8 @@ proc http::formatQuery {args} {
|
||||
set result ""
|
||||
set sep ""
|
||||
foreach i $args {
|
||||
append result $sep [mapReply $i]
|
||||
if {$sep != "="} {
|
||||
append result $sep [mapReply $i]
|
||||
if {[string compare $sep "="]} {
|
||||
set sep =
|
||||
} else {
|
||||
set sep &
|
||||
|
||||
+5
-7
@@ -3,7 +3,7 @@
|
||||
# Default system startup file for Tcl-based applications. Defines
|
||||
# "unknown" procedure and auto-load facilities.
|
||||
#
|
||||
# RCS: @(#) $Id: init.tcl,v 1.32 1999/08/09 16:30:50 hobbs Exp $
|
||||
# RCS: @(#) $Id: init.tcl,v 1.32.4.1 1999/10/30 11:06:17 hobbs Exp $
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
@@ -52,12 +52,10 @@ if {[string compare [info library] {}]} {
|
||||
}
|
||||
}
|
||||
}
|
||||
foreach __dir [list [file dirname [info nameofexecutable]] \
|
||||
[file join [file dirname [file dirname \
|
||||
[info nameofexecutable]]] lib]] {
|
||||
if {[lsearch -exact $auto_path $__dir] < 0} {
|
||||
lappend auto_path $__dir
|
||||
}
|
||||
set __dir [file join [file dirname \
|
||||
[file dirname [info nameofexecutable]]] lib]
|
||||
if {[lsearch -exact $auto_path $__dir] < 0} {
|
||||
lappend auto_path $__dir
|
||||
}
|
||||
if {[info exist tcl_pkgPath]} {
|
||||
foreach __dir $tcl_pkgPath {
|
||||
|
||||
@@ -1 +1,7 @@
|
||||
package ifneeded registry 1.0 "load [list [file join $dir tclreg82.dll]] registry"
|
||||
if {[info exists tcl_platform(debug)]} {
|
||||
package ifneeded registry 1.0 \
|
||||
[list load [file join $dir tclreg82d.dll] registry]
|
||||
} else {
|
||||
package ifneeded registry 1.0 \
|
||||
[list load [file join $dir tclreg82.dll] registry]
|
||||
}
|
||||
|
||||
@@ -1 +1,7 @@
|
||||
package ifneeded registry 1.0 "load [list [file join $dir tclreg82.dll]] registry"
|
||||
if {[info exists tcl_platform(debug)]} {
|
||||
package ifneeded registry 1.0 \
|
||||
[list load [file join $dir tclreg82d.dll] registry]
|
||||
} else {
|
||||
package ifneeded registry 1.0 \
|
||||
[list load [file join $dir tclreg82.dll] registry]
|
||||
}
|
||||
|
||||
@@ -10,9 +10,9 @@
|
||||
|
||||
package ifneeded tcltest 1.0 [list tclPkgSetup $dir tcltest 1.0 \
|
||||
{{tcltest.tcl source {::tcltest::bytestring ::tcltest::cleanupTests \
|
||||
::tcltest::dotests ::tcltest::makeDirectory ::tcltest::makeFile \
|
||||
::tcltest::normalizeMsg ::tcltest::removeDirectory \
|
||||
::tcltest::removeFile ::tcltest::restoreState ::tcltest::saveState \
|
||||
::tcltest::test ::tcltest::threadReap ::tcltest::viewFile memory \
|
||||
::tcltest:grep ::tcltest::getMatchingTestFiles }}}]
|
||||
::tcltest::makeDirectory ::tcltest::makeFile ::tcltest::normalizeMsg \
|
||||
::tcltest::removeDirectory ::tcltest::removeFile \
|
||||
::tcltest::restoreState ::tcltest::saveState ::tcltest::test \
|
||||
::tcltest::threadReap ::tcltest::viewFile \
|
||||
::tcltest::grep ::tcltest::getMatchingFiles }}}]
|
||||
|
||||
|
||||
+163
-80
@@ -12,7 +12,7 @@
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
# All rights reserved.
|
||||
#
|
||||
# RCS: @(#) $Id: tcltest.tcl,v 1.9 1999/07/30 01:35:27 jenn Exp $
|
||||
# RCS: @(#) $Id: tcltest.tcl,v 1.9.4.4 1999/10/30 11:07:05 hobbs Exp $
|
||||
|
||||
package provide tcltest 1.0
|
||||
|
||||
@@ -26,43 +26,62 @@ namespace eval tcltest {
|
||||
# Export the public tcltest procs
|
||||
set procList [list test cleanupTests saveState restoreState \
|
||||
normalizeMsg makeFile removeFile makeDirectory removeDirectory \
|
||||
viewFile bytestring safeFetch threadReap getMatchingTestFiles]
|
||||
viewFile bytestring safeFetch threadReap getMatchingFiles]
|
||||
foreach proc $procList {
|
||||
namespace export $proc
|
||||
}
|
||||
|
||||
# ::tcltest::verbose defaults to "b"
|
||||
|
||||
variable verbose "b"
|
||||
if {![info exists verbose]} {
|
||||
variable verbose "b"
|
||||
}
|
||||
|
||||
# Match and skip patterns default to the empty list, except for
|
||||
# matchFiles, which defaults to all .test files in the testsDirectory
|
||||
|
||||
variable match {}
|
||||
variable skip {}
|
||||
|
||||
variable matchFiles {*.test}
|
||||
variable skipFiles {}
|
||||
if {![info exists match]} {
|
||||
variable match {}
|
||||
}
|
||||
if {![info exists skip]} {
|
||||
variable skip {}
|
||||
}
|
||||
if {![info exists matchFiles]} {
|
||||
variable matchFiles {*.test}
|
||||
}
|
||||
if {![info exists skipFiles]} {
|
||||
variable skipFiles {}
|
||||
}
|
||||
|
||||
# By default, don't save core files
|
||||
variable preserveCore 0
|
||||
if {![info exists preserveCore]} {
|
||||
variable preserveCore 0
|
||||
}
|
||||
|
||||
# output goes to stdout by default
|
||||
|
||||
variable outputChannel stdout
|
||||
if {![info exists outputChannel]} {
|
||||
variable outputChannel stdout
|
||||
}
|
||||
|
||||
# errors go to stderr by default
|
||||
|
||||
variable errorChannel stderr
|
||||
if {![info exists errorChannel]} {
|
||||
variable errorChannel stderr
|
||||
}
|
||||
|
||||
# debug output doesn't get printed by default; debug level 1 spits
|
||||
# up only the tets that were skipped because they didn't match or were
|
||||
# up only the tests that were skipped because they didn't match or were
|
||||
# specifically skipped. A debug level of 2 would spit up the tcltest
|
||||
# variables and flags provided; a debug level of 3 causes some additional
|
||||
# output regarding operations of the test harness. The tcltest package
|
||||
# currently implements only up to debug level 3.
|
||||
if {![info exists debug]} {
|
||||
variable debug 0
|
||||
}
|
||||
|
||||
variable debug 0
|
||||
# Save any arguments that we might want to pass through to other programs.
|
||||
# This is used by the -args flag.
|
||||
if {![info exists parameters]} {
|
||||
variable parameters {}
|
||||
}
|
||||
|
||||
# Count the number of files tested (0 if all.tcl wasn't called).
|
||||
# The all.tcl file will set testSingleFile to false, so stats will
|
||||
@@ -71,10 +90,18 @@ namespace eval tcltest {
|
||||
# current test file has had any failures. The failFiles list
|
||||
# stores the names of test files that had failures.
|
||||
|
||||
variable numTestFiles 0
|
||||
variable testSingleFile true
|
||||
variable currentFailure false
|
||||
variable failFiles {}
|
||||
if {![info exists numTestFiles]} {
|
||||
variable numTestFiles 0
|
||||
}
|
||||
if {![info exists testSingleFile]} {
|
||||
variable testSingleFile true
|
||||
}
|
||||
if {![info exists currentFailure]} {
|
||||
variable currentFailure false
|
||||
}
|
||||
if {![info exists failFiles]} {
|
||||
variable failFiles {}
|
||||
}
|
||||
|
||||
# Tests should remove all files they create. The test suite will
|
||||
# check the current working dir for files created by the tests.
|
||||
@@ -82,18 +109,29 @@ namespace eval tcltest {
|
||||
# ::tcltest::makeFile and ::tcltest::makeDirectory procedures.
|
||||
# ::tcltest::filesExisted stores the names of pre-existing files.
|
||||
|
||||
variable filesMade {}
|
||||
variable filesExisted {}
|
||||
if {![info exists filesMade]} {
|
||||
variable filesMade {}
|
||||
}
|
||||
if {![info exists filesExisted]} {
|
||||
variable filesExisted {}
|
||||
}
|
||||
|
||||
# ::tcltest::numTests will store test files as indices and the list
|
||||
# of files (that should not have been) left behind by the test files.
|
||||
|
||||
array set ::tcltest::createdNewFiles {}
|
||||
if {![info exists createdNewFiles]} {
|
||||
variable createdNewFiles
|
||||
array set ::tcltest::createdNewFiles {}
|
||||
}
|
||||
|
||||
# initialize ::tcltest::numTests array to keep track fo the number of
|
||||
# tests that pass, fial, and are skipped.
|
||||
# tests that pass, fail, and are skipped.
|
||||
|
||||
array set ::tcltest::numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
|
||||
if {![info exists numTests]} {
|
||||
variable numTests
|
||||
array set ::tcltest::numTests \
|
||||
[list Total 0 Passed 0 Skipped 0 Failed 0]
|
||||
}
|
||||
|
||||
# initialize ::tcltest::skippedBecause array to keep track of
|
||||
# constraints that kept tests from running; a constraint name of
|
||||
@@ -103,49 +141,70 @@ namespace eval tcltest {
|
||||
# both of these constraints are counted only if ::tcltest::debug is set to
|
||||
# true.
|
||||
|
||||
array set ::tcltest::skippedBecause {}
|
||||
if {![info exists skippedBecause]} {
|
||||
variable skippedBecause
|
||||
array set ::tcltest::skippedBecause {}
|
||||
}
|
||||
|
||||
# initialize the ::tcltest::testConstraints array to keep track of valid
|
||||
# predefined constraints (see the explanation for the
|
||||
# ::tcltest::initConstraints proc for more details).
|
||||
|
||||
array set ::tcltest::testConstraints {}
|
||||
if {![info exists testConstraints]} {
|
||||
variable testConstraints
|
||||
array set ::tcltest::testConstraints {}
|
||||
}
|
||||
|
||||
# Don't run only the constrained tests by default
|
||||
variable limitConstraints false
|
||||
if {![info exists limitConstraints]} {
|
||||
variable limitConstraints false
|
||||
}
|
||||
|
||||
# tests that use thread need to know which is the main thread
|
||||
# tests that use threads need to know which is the main thread
|
||||
|
||||
variable mainThread 1
|
||||
if {[info commands testthread] != {}} {
|
||||
set mainThread [testthread names]
|
||||
if {![info exists mainThread]} {
|
||||
variable mainThread 1
|
||||
if {[info commands testthread] != {}} {
|
||||
set mainThread [testthread names]
|
||||
}
|
||||
}
|
||||
|
||||
# save the original environment so that it can be restored later
|
||||
|
||||
array set ::tcltest::originalEnv [array get ::env]
|
||||
if {![info exists originalEnv]} {
|
||||
variable originalEnv
|
||||
array set ::tcltest::originalEnv [array get ::env]
|
||||
}
|
||||
|
||||
# Set ::tcltest::workingDirectory to [pwd]. The default output directory
|
||||
# for Tcl tests is the working directory.
|
||||
|
||||
variable workingDirectory [pwd]
|
||||
variable temporaryDirectory $workingDirectory
|
||||
if {![info exists workingDirectory]} {
|
||||
variable workingDirectory [pwd]
|
||||
}
|
||||
if {![info exists temporaryDirectory]} {
|
||||
variable temporaryDirectory $workingDirectory
|
||||
}
|
||||
|
||||
# Tests should not rely on the current working directory.
|
||||
# Files that are part of the test suite should be accessed relative to
|
||||
# ::tcltest::testsDirectory.
|
||||
|
||||
set oDir [pwd]
|
||||
catch {cd [file join [file dirname [info script]] .. .. tests]}
|
||||
variable testsDirectory [pwd]
|
||||
cd $oDir
|
||||
if {![info exists testsDirectory]} {
|
||||
set oDir [pwd]
|
||||
catch {cd [file join [file dirname [info script]] .. .. tests]}
|
||||
variable testsDirectory [pwd]
|
||||
cd $oDir
|
||||
}
|
||||
|
||||
# the variables and procs that existed when ::tcltest::saveState was
|
||||
# called are stored in a variable of the same name
|
||||
variable saveState {}
|
||||
if {![info exists saveState]} {
|
||||
variable saveState {}
|
||||
}
|
||||
|
||||
# Internationalization support
|
||||
if {![info exists ::tcltest::isoLocale]} {
|
||||
if {![info exists isoLocale]} {
|
||||
variable isoLocale fr
|
||||
switch $tcl_platform(platform) {
|
||||
"unix" {
|
||||
@@ -180,18 +239,22 @@ namespace eval tcltest {
|
||||
}
|
||||
|
||||
# Set the location of the execuatble
|
||||
variable tcltest [info nameofexecutable]
|
||||
|
||||
# save the platform information so it can be restored later
|
||||
variable originalTclPlatform [array get tcl_platform]
|
||||
|
||||
|
||||
# If a core file exists, save its modification time.
|
||||
if {[file exists [file join $::tcltest::workingDirectory core]]} {
|
||||
variable coreModificationTime [file mtime [file join \
|
||||
$::tcltest::workingDirectory core]]
|
||||
if {![info exists tcltest]} {
|
||||
variable tcltest [info nameofexecutable]
|
||||
}
|
||||
|
||||
# save the platform information so it can be restored later
|
||||
if {![info exists originalTclPlatform]} {
|
||||
variable originalTclPlatform [array get tcl_platform]
|
||||
}
|
||||
|
||||
# If a core file exists, save its modification time.
|
||||
if {![info exists coreModificationTime]} {
|
||||
if {[file exists [file join $::tcltest::workingDirectory core]]} {
|
||||
variable coreModificationTime [file mtime [file join \
|
||||
$::tcltest::workingDirectory core]]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tcltest::AddToSkippedBecause --
|
||||
@@ -207,7 +270,7 @@ namespace eval tcltest {
|
||||
# previously exist - otherwise, it just increments it.
|
||||
|
||||
proc ::tcltest::AddToSkippedBecause { constraint } {
|
||||
# add the constraint to the list of constraints the kept tests
|
||||
# add the constraint to the list of constraints that kept tests
|
||||
# from running
|
||||
|
||||
if {[info exists ::tcltest::skippedBecause($constraint)]} {
|
||||
@@ -270,7 +333,9 @@ proc ::tcltest::PrintError {errorMsg} {
|
||||
return
|
||||
}
|
||||
|
||||
proc ::tcltest::initConstraintsHook {} {}
|
||||
if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} {
|
||||
proc ::tcltest::initConstraintsHook {} {}
|
||||
}
|
||||
|
||||
# ::tcltest::initConstraints --
|
||||
#
|
||||
@@ -291,8 +356,6 @@ proc ::tcltest::initConstraintsHook {} {}
|
||||
proc ::tcltest::initConstraints {} {
|
||||
global tcl_platform tcl_interactive tk_version
|
||||
|
||||
catch {unset ::tcltest::testConstraints}
|
||||
|
||||
# The following trace procedure makes it so that we can safely refer to
|
||||
# non-existent members of the ::tcltest::testConstraints array without
|
||||
# causing an error. Instead, reading a non-existent member will return 0.
|
||||
@@ -339,9 +402,10 @@ proc ::tcltest::initConstraints {} {
|
||||
set ::tcltest::testConstraints(win32s) [string equal $tcl_platform(os) \
|
||||
"Win32s"]
|
||||
|
||||
# The following Constraints switches are used to mark tests that should work,
|
||||
# but have been temporarily disabled on certain platforms because they don't
|
||||
# and we haven't gotten around to fixing the underlying problem.
|
||||
# The following Constraints switches are used to mark tests that should
|
||||
# work, but have been temporarily disabled on certain platforms because
|
||||
# they don't and we haven't gotten around to fixing the underlying
|
||||
# problem.
|
||||
|
||||
set ::tcltest::testConstraints(tempNotPc) \
|
||||
[expr {!$::tcltest::testConstraints(pc)}]
|
||||
@@ -381,7 +445,11 @@ proc ::tcltest::initConstraints {} {
|
||||
|
||||
# Some tests must be skipped if the interpreter is not in interactive mode
|
||||
|
||||
set ::tcltest::testConstraints(interactive) $tcl_interactive
|
||||
if {[info exists tcl_interactive]} {
|
||||
set ::tcltest::testConstraints(interactive) $::tcl_interactive
|
||||
} else {
|
||||
set ::tcltest::testConstraints(interactive) 0
|
||||
}
|
||||
|
||||
# Some tests can only be run if the installation came from a CD image
|
||||
# instead of a web image
|
||||
@@ -437,7 +505,7 @@ proc ::tcltest::initConstraints {} {
|
||||
# to the "e" format of floating-point numbers.
|
||||
|
||||
set ::tcltest::testConstraints(eformat) 1
|
||||
if {[string compare "[format %g 5e-5]" "5e-05"] != 0} {
|
||||
if {![string equal "[format %g 5e-5]" "5e-05"]} {
|
||||
set ::tcltest::testConstraints(eformat) 0
|
||||
}
|
||||
|
||||
@@ -550,7 +618,9 @@ proc ::tcltest::initConstraints {} {
|
||||
# Hook used for customization of display of usage information.
|
||||
#
|
||||
|
||||
proc ::tcltest::PrintUsageInfoHook {} {}
|
||||
if {[namespace inscope ::tcltest info procs PrintUsageInfoHook] == {}} {
|
||||
proc ::tcltest::PrintUsageInfoHook {} {}
|
||||
}
|
||||
|
||||
# ::tcltest::PrintUsageInfo
|
||||
#
|
||||
@@ -612,7 +682,9 @@ proc ::tcltest::PrintUsageInfo {} {
|
||||
# processed by ::tcltest::processCmdLineArgs.
|
||||
#
|
||||
|
||||
proc ::tcltest::processCmdLineArgsAddFlagsHook {} {}
|
||||
if {[namespace inscope ::tcltest info procs processCmdLineArgsAddFlagsHook] == {}} {
|
||||
proc ::tcltest::processCmdLineArgsAddFlagsHook {} {}
|
||||
}
|
||||
|
||||
# ::tcltest::processCmdLineArgsHook --
|
||||
#
|
||||
@@ -623,7 +695,9 @@ proc ::tcltest::processCmdLineArgsAddFlagsHook {} {}
|
||||
# flags The flags that have been pulled out of argv
|
||||
#
|
||||
|
||||
proc ::tcltest::processCmdLineArgsHook {flag} {}
|
||||
if {[namespace inscope ::tcltest info procs processCmdLineArgsHook] == {}} {
|
||||
proc ::tcltest::processCmdLineArgsHook {flag} {}
|
||||
}
|
||||
|
||||
# ::tcltest::processCmdLineArgs --
|
||||
#
|
||||
@@ -672,7 +746,7 @@ proc ::tcltest::processCmdLineArgs {} {
|
||||
# -help is not listed since it has already been processed
|
||||
lappend defaultFlags -verbose -match -skip -constraints \
|
||||
-outfile -errfile -debug -tmpdir -file -notfile \
|
||||
-preservecore -limitconstraints
|
||||
-preservecore -limitconstraints -args
|
||||
set defaultFlags [concat $defaultFlags \
|
||||
[ ::tcltest::processCmdLineArgsAddFlagsHook ]]
|
||||
|
||||
@@ -685,6 +759,11 @@ proc ::tcltest::processCmdLineArgs {} {
|
||||
}
|
||||
}
|
||||
|
||||
# Set ::tcltest::parameters to the arg of the -args flag, if given
|
||||
if {[info exists flag(-args)]} {
|
||||
set ::tcltest::parameters $flag(-args)
|
||||
}
|
||||
|
||||
# Set ::tcltest::verbose to the arg of the -verbose flag, if given
|
||||
|
||||
if {[info exists flag(-verbose)]} {
|
||||
@@ -751,9 +830,9 @@ proc ::tcltest::processCmdLineArgs {} {
|
||||
if {[info exists flag(-tmpdir)]} {
|
||||
set ::tcltest::temporaryDirectory $flag(-tmpdir)
|
||||
|
||||
if {[string compare \
|
||||
if {![string equal \
|
||||
[file pathtype $::tcltest::temporaryDirectory] \
|
||||
"absolute"] != 0} {
|
||||
"absolute"]} {
|
||||
set ::tcltest::temporaryDirectory [file join [pwd] \
|
||||
$::tcltest::temporaryDirectory]
|
||||
}
|
||||
@@ -793,7 +872,7 @@ proc ::tcltest::processCmdLineArgs {} {
|
||||
|
||||
if {[info exists flag(-outfile)]} {
|
||||
set tmp $flag(-outfile)
|
||||
if {[string compare [file pathtype $tmp] "absolute"] != 0} {
|
||||
if {![string equal [file pathtype $tmp] "absolute"]} {
|
||||
set tmp [file join $::tcltest::temporaryDirectory $tmp]
|
||||
}
|
||||
set ::tcltest::outputChannel [open $tmp w]
|
||||
@@ -801,7 +880,7 @@ proc ::tcltest::processCmdLineArgs {} {
|
||||
|
||||
if {[info exists flag(-errfile)]} {
|
||||
set tmp $flag(-errfile)
|
||||
if {[string compare [file pathtype $tmp] "absolute"] != 0} {
|
||||
if {![string equal [file pathtype $tmp] "absolute"]} {
|
||||
set tmp [file join $::tcltest::temporaryDirectory $tmp]
|
||||
}
|
||||
set ::tcltest::errorChannel [open $tmp w]
|
||||
@@ -947,7 +1026,7 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
|
||||
# exit only if running Tk in non-interactive mode
|
||||
|
||||
global tk_version tcl_interactive
|
||||
if {[info exists tk_version] && !$tcl_interactive} {
|
||||
if {[info exists tk_version] && ![info exists tcl_interactive]} {
|
||||
exit
|
||||
}
|
||||
} else {
|
||||
@@ -1050,7 +1129,9 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
|
||||
# additional things that should be done at cleanup.
|
||||
#
|
||||
|
||||
proc ::tcltest::cleanupTestsHook {} {}
|
||||
if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} {
|
||||
proc ::tcltest::cleanupTestsHook {} {}
|
||||
}
|
||||
|
||||
# test --
|
||||
#
|
||||
@@ -1135,16 +1216,14 @@ proc ::tcltest::test {name description script expectedAnswer args} {
|
||||
if {[string match {*[$\[]*} $constraints] != 0} {
|
||||
# full expression, e.g. {$foo > [info tclversion]}
|
||||
catch {set doTest [uplevel #0 expr $constraints]}
|
||||
|
||||
} elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
|
||||
# something like {a || b} should be turned into
|
||||
# $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b).
|
||||
regsub -all {[.a-zA-Z0-9]+} $constraints \
|
||||
regsub -all {[.\w]+} $constraints \
|
||||
{$::tcltest::testConstraints(&)} c
|
||||
catch {set doTest [eval expr $c]}
|
||||
} else {
|
||||
# just simple constraints such as {unixOnly fonts}.
|
||||
|
||||
set doTest 1
|
||||
foreach constraint $constraints {
|
||||
if {(![info exists ::tcltest::testConstraints($constraint)]) \
|
||||
@@ -1191,7 +1270,7 @@ proc ::tcltest::test {name description script expectedAnswer args} {
|
||||
}
|
||||
|
||||
set code [catch {uplevel $script} actualAnswer]
|
||||
if {([string compare $actualAnswer $expectedAnswer] == 0) && ($code == 0)} {
|
||||
if {([string equal $actualAnswer $expectedAnswer]) && ($code == 0)} {
|
||||
incr ::tcltest::numTests(Passed)
|
||||
if {[string first p $::tcltest::verbose] != -1} {
|
||||
puts $::tcltest::outputChannel "++++ $name PASSED"
|
||||
@@ -1261,7 +1340,7 @@ proc ::tcltest::test {name description script expectedAnswer args} {
|
||||
}
|
||||
}
|
||||
|
||||
# ::tcltest::getMatchingTestFiles
|
||||
# ::tcltest::getMatchingFiles
|
||||
#
|
||||
# Looks at the patterns given to match and skip files
|
||||
# and uses them to put together a list of the tests that will be run.
|
||||
@@ -1379,7 +1458,7 @@ proc ::tcltest::restoreState {} {
|
||||
if {$::tcltest::debug > 2} {
|
||||
puts "::tcltest::restoreState: Removing variable $p"
|
||||
}
|
||||
uplevel #0 "unset $p"
|
||||
uplevel #0 "catch {unset $p}"
|
||||
}
|
||||
}
|
||||
}
|
||||
@@ -1508,7 +1587,7 @@ proc ::tcltest::viewFile {name} {
|
||||
# Example:
|
||||
# grep {regexp a} $someList
|
||||
#
|
||||
proc ::tcltest:grep { expression searchList } {
|
||||
proc ::tcltest::grep { expression searchList } {
|
||||
foreach element $searchList {
|
||||
if {[regsub -all CURRENT_ELEMENT $expression $element \
|
||||
newExpression] == 0} {
|
||||
@@ -1577,9 +1656,12 @@ proc ::tcltest::threadReap {} {
|
||||
foreach tid [testthread names] {
|
||||
if {$tid != $::tcltest::mainThread} {
|
||||
catch {testthread send -async $tid {testthread exit}}
|
||||
update
|
||||
}
|
||||
}
|
||||
## Enter a bit a sleep to give the threads enough breathing
|
||||
## room to kill themselves off, otherwise the end up with a
|
||||
## massive queue of repeated events
|
||||
after 1
|
||||
}
|
||||
testthread errorproc ThreadError
|
||||
return [llength [testthread names]]
|
||||
@@ -1591,7 +1673,8 @@ proc ::tcltest::threadReap {} {
|
||||
# Initialize the constraints and set up command line arguments
|
||||
namespace eval tcltest {
|
||||
::tcltest::initConstraints
|
||||
::tcltest::processCmdLineArgs
|
||||
if {[namespace children ::tcltest] == {}} {
|
||||
::tcltest::processCmdLineArgs
|
||||
}
|
||||
}
|
||||
|
||||
return
|
||||
|
||||
@@ -10,9 +10,9 @@
|
||||
|
||||
package ifneeded tcltest 1.0 [list tclPkgSetup $dir tcltest 1.0 \
|
||||
{{tcltest.tcl source {::tcltest::bytestring ::tcltest::cleanupTests \
|
||||
::tcltest::dotests ::tcltest::makeDirectory ::tcltest::makeFile \
|
||||
::tcltest::normalizeMsg ::tcltest::removeDirectory \
|
||||
::tcltest::removeFile ::tcltest::restoreState ::tcltest::saveState \
|
||||
::tcltest::test ::tcltest::threadReap ::tcltest::viewFile memory \
|
||||
::tcltest:grep ::tcltest::getMatchingTestFiles }}}]
|
||||
::tcltest::makeDirectory ::tcltest::makeFile ::tcltest::normalizeMsg \
|
||||
::tcltest::removeDirectory ::tcltest::removeFile \
|
||||
::tcltest::restoreState ::tcltest::saveState ::tcltest::test \
|
||||
::tcltest::threadReap ::tcltest::viewFile \
|
||||
::tcltest::grep ::tcltest::getMatchingFiles }}}]
|
||||
|
||||
|
||||
+163
-80
@@ -12,7 +12,7 @@
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
# All rights reserved.
|
||||
#
|
||||
# RCS: @(#) $Id: tcltest.tcl,v 1.9 1999/07/30 01:35:27 jenn Exp $
|
||||
# RCS: @(#) $Id: tcltest.tcl,v 1.9.4.4 1999/10/30 11:07:05 hobbs Exp $
|
||||
|
||||
package provide tcltest 1.0
|
||||
|
||||
@@ -26,43 +26,62 @@ namespace eval tcltest {
|
||||
# Export the public tcltest procs
|
||||
set procList [list test cleanupTests saveState restoreState \
|
||||
normalizeMsg makeFile removeFile makeDirectory removeDirectory \
|
||||
viewFile bytestring safeFetch threadReap getMatchingTestFiles]
|
||||
viewFile bytestring safeFetch threadReap getMatchingFiles]
|
||||
foreach proc $procList {
|
||||
namespace export $proc
|
||||
}
|
||||
|
||||
# ::tcltest::verbose defaults to "b"
|
||||
|
||||
variable verbose "b"
|
||||
if {![info exists verbose]} {
|
||||
variable verbose "b"
|
||||
}
|
||||
|
||||
# Match and skip patterns default to the empty list, except for
|
||||
# matchFiles, which defaults to all .test files in the testsDirectory
|
||||
|
||||
variable match {}
|
||||
variable skip {}
|
||||
|
||||
variable matchFiles {*.test}
|
||||
variable skipFiles {}
|
||||
if {![info exists match]} {
|
||||
variable match {}
|
||||
}
|
||||
if {![info exists skip]} {
|
||||
variable skip {}
|
||||
}
|
||||
if {![info exists matchFiles]} {
|
||||
variable matchFiles {*.test}
|
||||
}
|
||||
if {![info exists skipFiles]} {
|
||||
variable skipFiles {}
|
||||
}
|
||||
|
||||
# By default, don't save core files
|
||||
variable preserveCore 0
|
||||
if {![info exists preserveCore]} {
|
||||
variable preserveCore 0
|
||||
}
|
||||
|
||||
# output goes to stdout by default
|
||||
|
||||
variable outputChannel stdout
|
||||
if {![info exists outputChannel]} {
|
||||
variable outputChannel stdout
|
||||
}
|
||||
|
||||
# errors go to stderr by default
|
||||
|
||||
variable errorChannel stderr
|
||||
if {![info exists errorChannel]} {
|
||||
variable errorChannel stderr
|
||||
}
|
||||
|
||||
# debug output doesn't get printed by default; debug level 1 spits
|
||||
# up only the tets that were skipped because they didn't match or were
|
||||
# up only the tests that were skipped because they didn't match or were
|
||||
# specifically skipped. A debug level of 2 would spit up the tcltest
|
||||
# variables and flags provided; a debug level of 3 causes some additional
|
||||
# output regarding operations of the test harness. The tcltest package
|
||||
# currently implements only up to debug level 3.
|
||||
if {![info exists debug]} {
|
||||
variable debug 0
|
||||
}
|
||||
|
||||
variable debug 0
|
||||
# Save any arguments that we might want to pass through to other programs.
|
||||
# This is used by the -args flag.
|
||||
if {![info exists parameters]} {
|
||||
variable parameters {}
|
||||
}
|
||||
|
||||
# Count the number of files tested (0 if all.tcl wasn't called).
|
||||
# The all.tcl file will set testSingleFile to false, so stats will
|
||||
@@ -71,10 +90,18 @@ namespace eval tcltest {
|
||||
# current test file has had any failures. The failFiles list
|
||||
# stores the names of test files that had failures.
|
||||
|
||||
variable numTestFiles 0
|
||||
variable testSingleFile true
|
||||
variable currentFailure false
|
||||
variable failFiles {}
|
||||
if {![info exists numTestFiles]} {
|
||||
variable numTestFiles 0
|
||||
}
|
||||
if {![info exists testSingleFile]} {
|
||||
variable testSingleFile true
|
||||
}
|
||||
if {![info exists currentFailure]} {
|
||||
variable currentFailure false
|
||||
}
|
||||
if {![info exists failFiles]} {
|
||||
variable failFiles {}
|
||||
}
|
||||
|
||||
# Tests should remove all files they create. The test suite will
|
||||
# check the current working dir for files created by the tests.
|
||||
@@ -82,18 +109,29 @@ namespace eval tcltest {
|
||||
# ::tcltest::makeFile and ::tcltest::makeDirectory procedures.
|
||||
# ::tcltest::filesExisted stores the names of pre-existing files.
|
||||
|
||||
variable filesMade {}
|
||||
variable filesExisted {}
|
||||
if {![info exists filesMade]} {
|
||||
variable filesMade {}
|
||||
}
|
||||
if {![info exists filesExisted]} {
|
||||
variable filesExisted {}
|
||||
}
|
||||
|
||||
# ::tcltest::numTests will store test files as indices and the list
|
||||
# of files (that should not have been) left behind by the test files.
|
||||
|
||||
array set ::tcltest::createdNewFiles {}
|
||||
if {![info exists createdNewFiles]} {
|
||||
variable createdNewFiles
|
||||
array set ::tcltest::createdNewFiles {}
|
||||
}
|
||||
|
||||
# initialize ::tcltest::numTests array to keep track fo the number of
|
||||
# tests that pass, fial, and are skipped.
|
||||
# tests that pass, fail, and are skipped.
|
||||
|
||||
array set ::tcltest::numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
|
||||
if {![info exists numTests]} {
|
||||
variable numTests
|
||||
array set ::tcltest::numTests \
|
||||
[list Total 0 Passed 0 Skipped 0 Failed 0]
|
||||
}
|
||||
|
||||
# initialize ::tcltest::skippedBecause array to keep track of
|
||||
# constraints that kept tests from running; a constraint name of
|
||||
@@ -103,49 +141,70 @@ namespace eval tcltest {
|
||||
# both of these constraints are counted only if ::tcltest::debug is set to
|
||||
# true.
|
||||
|
||||
array set ::tcltest::skippedBecause {}
|
||||
if {![info exists skippedBecause]} {
|
||||
variable skippedBecause
|
||||
array set ::tcltest::skippedBecause {}
|
||||
}
|
||||
|
||||
# initialize the ::tcltest::testConstraints array to keep track of valid
|
||||
# predefined constraints (see the explanation for the
|
||||
# ::tcltest::initConstraints proc for more details).
|
||||
|
||||
array set ::tcltest::testConstraints {}
|
||||
if {![info exists testConstraints]} {
|
||||
variable testConstraints
|
||||
array set ::tcltest::testConstraints {}
|
||||
}
|
||||
|
||||
# Don't run only the constrained tests by default
|
||||
variable limitConstraints false
|
||||
if {![info exists limitConstraints]} {
|
||||
variable limitConstraints false
|
||||
}
|
||||
|
||||
# tests that use thread need to know which is the main thread
|
||||
# tests that use threads need to know which is the main thread
|
||||
|
||||
variable mainThread 1
|
||||
if {[info commands testthread] != {}} {
|
||||
set mainThread [testthread names]
|
||||
if {![info exists mainThread]} {
|
||||
variable mainThread 1
|
||||
if {[info commands testthread] != {}} {
|
||||
set mainThread [testthread names]
|
||||
}
|
||||
}
|
||||
|
||||
# save the original environment so that it can be restored later
|
||||
|
||||
array set ::tcltest::originalEnv [array get ::env]
|
||||
if {![info exists originalEnv]} {
|
||||
variable originalEnv
|
||||
array set ::tcltest::originalEnv [array get ::env]
|
||||
}
|
||||
|
||||
# Set ::tcltest::workingDirectory to [pwd]. The default output directory
|
||||
# for Tcl tests is the working directory.
|
||||
|
||||
variable workingDirectory [pwd]
|
||||
variable temporaryDirectory $workingDirectory
|
||||
if {![info exists workingDirectory]} {
|
||||
variable workingDirectory [pwd]
|
||||
}
|
||||
if {![info exists temporaryDirectory]} {
|
||||
variable temporaryDirectory $workingDirectory
|
||||
}
|
||||
|
||||
# Tests should not rely on the current working directory.
|
||||
# Files that are part of the test suite should be accessed relative to
|
||||
# ::tcltest::testsDirectory.
|
||||
|
||||
set oDir [pwd]
|
||||
catch {cd [file join [file dirname [info script]] .. .. tests]}
|
||||
variable testsDirectory [pwd]
|
||||
cd $oDir
|
||||
if {![info exists testsDirectory]} {
|
||||
set oDir [pwd]
|
||||
catch {cd [file join [file dirname [info script]] .. .. tests]}
|
||||
variable testsDirectory [pwd]
|
||||
cd $oDir
|
||||
}
|
||||
|
||||
# the variables and procs that existed when ::tcltest::saveState was
|
||||
# called are stored in a variable of the same name
|
||||
variable saveState {}
|
||||
if {![info exists saveState]} {
|
||||
variable saveState {}
|
||||
}
|
||||
|
||||
# Internationalization support
|
||||
if {![info exists ::tcltest::isoLocale]} {
|
||||
if {![info exists isoLocale]} {
|
||||
variable isoLocale fr
|
||||
switch $tcl_platform(platform) {
|
||||
"unix" {
|
||||
@@ -180,18 +239,22 @@ namespace eval tcltest {
|
||||
}
|
||||
|
||||
# Set the location of the execuatble
|
||||
variable tcltest [info nameofexecutable]
|
||||
|
||||
# save the platform information so it can be restored later
|
||||
variable originalTclPlatform [array get tcl_platform]
|
||||
|
||||
|
||||
# If a core file exists, save its modification time.
|
||||
if {[file exists [file join $::tcltest::workingDirectory core]]} {
|
||||
variable coreModificationTime [file mtime [file join \
|
||||
$::tcltest::workingDirectory core]]
|
||||
if {![info exists tcltest]} {
|
||||
variable tcltest [info nameofexecutable]
|
||||
}
|
||||
|
||||
# save the platform information so it can be restored later
|
||||
if {![info exists originalTclPlatform]} {
|
||||
variable originalTclPlatform [array get tcl_platform]
|
||||
}
|
||||
|
||||
# If a core file exists, save its modification time.
|
||||
if {![info exists coreModificationTime]} {
|
||||
if {[file exists [file join $::tcltest::workingDirectory core]]} {
|
||||
variable coreModificationTime [file mtime [file join \
|
||||
$::tcltest::workingDirectory core]]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tcltest::AddToSkippedBecause --
|
||||
@@ -207,7 +270,7 @@ namespace eval tcltest {
|
||||
# previously exist - otherwise, it just increments it.
|
||||
|
||||
proc ::tcltest::AddToSkippedBecause { constraint } {
|
||||
# add the constraint to the list of constraints the kept tests
|
||||
# add the constraint to the list of constraints that kept tests
|
||||
# from running
|
||||
|
||||
if {[info exists ::tcltest::skippedBecause($constraint)]} {
|
||||
@@ -270,7 +333,9 @@ proc ::tcltest::PrintError {errorMsg} {
|
||||
return
|
||||
}
|
||||
|
||||
proc ::tcltest::initConstraintsHook {} {}
|
||||
if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} {
|
||||
proc ::tcltest::initConstraintsHook {} {}
|
||||
}
|
||||
|
||||
# ::tcltest::initConstraints --
|
||||
#
|
||||
@@ -291,8 +356,6 @@ proc ::tcltest::initConstraintsHook {} {}
|
||||
proc ::tcltest::initConstraints {} {
|
||||
global tcl_platform tcl_interactive tk_version
|
||||
|
||||
catch {unset ::tcltest::testConstraints}
|
||||
|
||||
# The following trace procedure makes it so that we can safely refer to
|
||||
# non-existent members of the ::tcltest::testConstraints array without
|
||||
# causing an error. Instead, reading a non-existent member will return 0.
|
||||
@@ -339,9 +402,10 @@ proc ::tcltest::initConstraints {} {
|
||||
set ::tcltest::testConstraints(win32s) [string equal $tcl_platform(os) \
|
||||
"Win32s"]
|
||||
|
||||
# The following Constraints switches are used to mark tests that should work,
|
||||
# but have been temporarily disabled on certain platforms because they don't
|
||||
# and we haven't gotten around to fixing the underlying problem.
|
||||
# The following Constraints switches are used to mark tests that should
|
||||
# work, but have been temporarily disabled on certain platforms because
|
||||
# they don't and we haven't gotten around to fixing the underlying
|
||||
# problem.
|
||||
|
||||
set ::tcltest::testConstraints(tempNotPc) \
|
||||
[expr {!$::tcltest::testConstraints(pc)}]
|
||||
@@ -381,7 +445,11 @@ proc ::tcltest::initConstraints {} {
|
||||
|
||||
# Some tests must be skipped if the interpreter is not in interactive mode
|
||||
|
||||
set ::tcltest::testConstraints(interactive) $tcl_interactive
|
||||
if {[info exists tcl_interactive]} {
|
||||
set ::tcltest::testConstraints(interactive) $::tcl_interactive
|
||||
} else {
|
||||
set ::tcltest::testConstraints(interactive) 0
|
||||
}
|
||||
|
||||
# Some tests can only be run if the installation came from a CD image
|
||||
# instead of a web image
|
||||
@@ -437,7 +505,7 @@ proc ::tcltest::initConstraints {} {
|
||||
# to the "e" format of floating-point numbers.
|
||||
|
||||
set ::tcltest::testConstraints(eformat) 1
|
||||
if {[string compare "[format %g 5e-5]" "5e-05"] != 0} {
|
||||
if {![string equal "[format %g 5e-5]" "5e-05"]} {
|
||||
set ::tcltest::testConstraints(eformat) 0
|
||||
}
|
||||
|
||||
@@ -550,7 +618,9 @@ proc ::tcltest::initConstraints {} {
|
||||
# Hook used for customization of display of usage information.
|
||||
#
|
||||
|
||||
proc ::tcltest::PrintUsageInfoHook {} {}
|
||||
if {[namespace inscope ::tcltest info procs PrintUsageInfoHook] == {}} {
|
||||
proc ::tcltest::PrintUsageInfoHook {} {}
|
||||
}
|
||||
|
||||
# ::tcltest::PrintUsageInfo
|
||||
#
|
||||
@@ -612,7 +682,9 @@ proc ::tcltest::PrintUsageInfo {} {
|
||||
# processed by ::tcltest::processCmdLineArgs.
|
||||
#
|
||||
|
||||
proc ::tcltest::processCmdLineArgsAddFlagsHook {} {}
|
||||
if {[namespace inscope ::tcltest info procs processCmdLineArgsAddFlagsHook] == {}} {
|
||||
proc ::tcltest::processCmdLineArgsAddFlagsHook {} {}
|
||||
}
|
||||
|
||||
# ::tcltest::processCmdLineArgsHook --
|
||||
#
|
||||
@@ -623,7 +695,9 @@ proc ::tcltest::processCmdLineArgsAddFlagsHook {} {}
|
||||
# flags The flags that have been pulled out of argv
|
||||
#
|
||||
|
||||
proc ::tcltest::processCmdLineArgsHook {flag} {}
|
||||
if {[namespace inscope ::tcltest info procs processCmdLineArgsHook] == {}} {
|
||||
proc ::tcltest::processCmdLineArgsHook {flag} {}
|
||||
}
|
||||
|
||||
# ::tcltest::processCmdLineArgs --
|
||||
#
|
||||
@@ -672,7 +746,7 @@ proc ::tcltest::processCmdLineArgs {} {
|
||||
# -help is not listed since it has already been processed
|
||||
lappend defaultFlags -verbose -match -skip -constraints \
|
||||
-outfile -errfile -debug -tmpdir -file -notfile \
|
||||
-preservecore -limitconstraints
|
||||
-preservecore -limitconstraints -args
|
||||
set defaultFlags [concat $defaultFlags \
|
||||
[ ::tcltest::processCmdLineArgsAddFlagsHook ]]
|
||||
|
||||
@@ -685,6 +759,11 @@ proc ::tcltest::processCmdLineArgs {} {
|
||||
}
|
||||
}
|
||||
|
||||
# Set ::tcltest::parameters to the arg of the -args flag, if given
|
||||
if {[info exists flag(-args)]} {
|
||||
set ::tcltest::parameters $flag(-args)
|
||||
}
|
||||
|
||||
# Set ::tcltest::verbose to the arg of the -verbose flag, if given
|
||||
|
||||
if {[info exists flag(-verbose)]} {
|
||||
@@ -751,9 +830,9 @@ proc ::tcltest::processCmdLineArgs {} {
|
||||
if {[info exists flag(-tmpdir)]} {
|
||||
set ::tcltest::temporaryDirectory $flag(-tmpdir)
|
||||
|
||||
if {[string compare \
|
||||
if {![string equal \
|
||||
[file pathtype $::tcltest::temporaryDirectory] \
|
||||
"absolute"] != 0} {
|
||||
"absolute"]} {
|
||||
set ::tcltest::temporaryDirectory [file join [pwd] \
|
||||
$::tcltest::temporaryDirectory]
|
||||
}
|
||||
@@ -793,7 +872,7 @@ proc ::tcltest::processCmdLineArgs {} {
|
||||
|
||||
if {[info exists flag(-outfile)]} {
|
||||
set tmp $flag(-outfile)
|
||||
if {[string compare [file pathtype $tmp] "absolute"] != 0} {
|
||||
if {![string equal [file pathtype $tmp] "absolute"]} {
|
||||
set tmp [file join $::tcltest::temporaryDirectory $tmp]
|
||||
}
|
||||
set ::tcltest::outputChannel [open $tmp w]
|
||||
@@ -801,7 +880,7 @@ proc ::tcltest::processCmdLineArgs {} {
|
||||
|
||||
if {[info exists flag(-errfile)]} {
|
||||
set tmp $flag(-errfile)
|
||||
if {[string compare [file pathtype $tmp] "absolute"] != 0} {
|
||||
if {![string equal [file pathtype $tmp] "absolute"]} {
|
||||
set tmp [file join $::tcltest::temporaryDirectory $tmp]
|
||||
}
|
||||
set ::tcltest::errorChannel [open $tmp w]
|
||||
@@ -947,7 +1026,7 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
|
||||
# exit only if running Tk in non-interactive mode
|
||||
|
||||
global tk_version tcl_interactive
|
||||
if {[info exists tk_version] && !$tcl_interactive} {
|
||||
if {[info exists tk_version] && ![info exists tcl_interactive]} {
|
||||
exit
|
||||
}
|
||||
} else {
|
||||
@@ -1050,7 +1129,9 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
|
||||
# additional things that should be done at cleanup.
|
||||
#
|
||||
|
||||
proc ::tcltest::cleanupTestsHook {} {}
|
||||
if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} {
|
||||
proc ::tcltest::cleanupTestsHook {} {}
|
||||
}
|
||||
|
||||
# test --
|
||||
#
|
||||
@@ -1135,16 +1216,14 @@ proc ::tcltest::test {name description script expectedAnswer args} {
|
||||
if {[string match {*[$\[]*} $constraints] != 0} {
|
||||
# full expression, e.g. {$foo > [info tclversion]}
|
||||
catch {set doTest [uplevel #0 expr $constraints]}
|
||||
|
||||
} elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
|
||||
# something like {a || b} should be turned into
|
||||
# $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b).
|
||||
regsub -all {[.a-zA-Z0-9]+} $constraints \
|
||||
regsub -all {[.\w]+} $constraints \
|
||||
{$::tcltest::testConstraints(&)} c
|
||||
catch {set doTest [eval expr $c]}
|
||||
} else {
|
||||
# just simple constraints such as {unixOnly fonts}.
|
||||
|
||||
set doTest 1
|
||||
foreach constraint $constraints {
|
||||
if {(![info exists ::tcltest::testConstraints($constraint)]) \
|
||||
@@ -1191,7 +1270,7 @@ proc ::tcltest::test {name description script expectedAnswer args} {
|
||||
}
|
||||
|
||||
set code [catch {uplevel $script} actualAnswer]
|
||||
if {([string compare $actualAnswer $expectedAnswer] == 0) && ($code == 0)} {
|
||||
if {([string equal $actualAnswer $expectedAnswer]) && ($code == 0)} {
|
||||
incr ::tcltest::numTests(Passed)
|
||||
if {[string first p $::tcltest::verbose] != -1} {
|
||||
puts $::tcltest::outputChannel "++++ $name PASSED"
|
||||
@@ -1261,7 +1340,7 @@ proc ::tcltest::test {name description script expectedAnswer args} {
|
||||
}
|
||||
}
|
||||
|
||||
# ::tcltest::getMatchingTestFiles
|
||||
# ::tcltest::getMatchingFiles
|
||||
#
|
||||
# Looks at the patterns given to match and skip files
|
||||
# and uses them to put together a list of the tests that will be run.
|
||||
@@ -1379,7 +1458,7 @@ proc ::tcltest::restoreState {} {
|
||||
if {$::tcltest::debug > 2} {
|
||||
puts "::tcltest::restoreState: Removing variable $p"
|
||||
}
|
||||
uplevel #0 "unset $p"
|
||||
uplevel #0 "catch {unset $p}"
|
||||
}
|
||||
}
|
||||
}
|
||||
@@ -1508,7 +1587,7 @@ proc ::tcltest::viewFile {name} {
|
||||
# Example:
|
||||
# grep {regexp a} $someList
|
||||
#
|
||||
proc ::tcltest:grep { expression searchList } {
|
||||
proc ::tcltest::grep { expression searchList } {
|
||||
foreach element $searchList {
|
||||
if {[regsub -all CURRENT_ELEMENT $expression $element \
|
||||
newExpression] == 0} {
|
||||
@@ -1577,9 +1656,12 @@ proc ::tcltest::threadReap {} {
|
||||
foreach tid [testthread names] {
|
||||
if {$tid != $::tcltest::mainThread} {
|
||||
catch {testthread send -async $tid {testthread exit}}
|
||||
update
|
||||
}
|
||||
}
|
||||
## Enter a bit a sleep to give the threads enough breathing
|
||||
## room to kill themselves off, otherwise the end up with a
|
||||
## massive queue of repeated events
|
||||
after 1
|
||||
}
|
||||
testthread errorproc ThreadError
|
||||
return [llength [testthread names]]
|
||||
@@ -1591,7 +1673,8 @@ proc ::tcltest::threadReap {} {
|
||||
# Initialize the constraints and set up command line arguments
|
||||
namespace eval tcltest {
|
||||
::tcltest::initConstraints
|
||||
::tcltest::processCmdLineArgs
|
||||
if {[namespace children ::tcltest] == {}} {
|
||||
::tcltest::processCmdLineArgs
|
||||
}
|
||||
}
|
||||
|
||||
return
|
||||
|
||||
+2
-2
@@ -8,7 +8,7 @@ Jim Ingham
|
||||
Cygnus Solutions
|
||||
jingham@cygnus.com
|
||||
|
||||
RCS: @(#) $Id: README,v 1.8 1999/06/25 23:29:53 welch Exp $
|
||||
RCS: @(#) $Id: README,v 1.8.4.1 1999/10/30 11:07:32 hobbs Exp $
|
||||
|
||||
1. Introduction
|
||||
---------------
|
||||
@@ -64,7 +64,7 @@ In order to compile Macintosh Tcl you must have the
|
||||
following items:
|
||||
|
||||
CodeWarrior Pro 2 or 3
|
||||
Mac Tcl 8.1 (source)
|
||||
Mac Tcl (source)
|
||||
More Files 1.4.3
|
||||
|
||||
The included project files should work fine. However, for
|
||||
|
||||
+30
-14
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclMacFCmd.c,v 1.5 1999/05/11 07:12:00 jingham Exp $
|
||||
* RCS: @(#) $Id: tclMacFCmd.c,v 1.5.6.2 1999/10/30 11:07:33 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -1194,15 +1194,19 @@ static int
|
||||
GetFileFinderAttributes(
|
||||
Tcl_Interp *interp, /* The interp to report errors with. */
|
||||
int objIndex, /* The index of the attribute option. */
|
||||
CONST char *fileName, /* The name of the file. */
|
||||
CONST char *fileName, /* The name of the file (UTF-8). */
|
||||
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
|
||||
{
|
||||
OSErr err;
|
||||
FSSpec fileSpec;
|
||||
FInfo finfo;
|
||||
|
||||
err = FSpLocationFromPath(strlen(fileName), fileName, &fileSpec);
|
||||
|
||||
Tcl_DString pathString;
|
||||
|
||||
Tcl_UtfToExternalDString(NULL, fileName, -1, &pathString);
|
||||
err = FSpLocationFromPath(Tcl_DStringLength(&pathString),
|
||||
Tcl_DStringValue(&pathString), &fileSpec);
|
||||
Tcl_DStringFree(&pathString);
|
||||
|
||||
if (err == noErr) {
|
||||
err = FSpGetFInfo(&fileSpec, &finfo);
|
||||
}
|
||||
@@ -1269,14 +1273,18 @@ static int
|
||||
GetFileReadOnly(
|
||||
Tcl_Interp *interp, /* The interp to report errors with. */
|
||||
int objIndex, /* The index of the attribute. */
|
||||
CONST char *fileName, /* The name of the file. */
|
||||
CONST char *fileName, /* The name of the file (UTF-8). */
|
||||
Tcl_Obj **readOnlyPtrPtr) /* A pointer to return the object with. */
|
||||
{
|
||||
OSErr err;
|
||||
FSSpec fileSpec;
|
||||
CInfoPBRec paramBlock;
|
||||
|
||||
err = FSpLocationFromPath(strlen(fileName), fileName, &fileSpec);
|
||||
Tcl_DString pathString;
|
||||
|
||||
Tcl_UtfToExternalDString(NULL, fileName, -1, &pathString);
|
||||
err = FSpLocationFromPath(Tcl_DStringLength(&pathString),
|
||||
Tcl_DStringValue(&pathString), &fileSpec);
|
||||
Tcl_DStringFree(&pathString);
|
||||
|
||||
if (err == noErr) {
|
||||
if (err == noErr) {
|
||||
@@ -1330,14 +1338,18 @@ static int
|
||||
SetFileFinderAttributes(
|
||||
Tcl_Interp *interp, /* The interp to report errors with. */
|
||||
int objIndex, /* The index of the attribute. */
|
||||
CONST char *fileName, /* The name of the file. */
|
||||
CONST char *fileName, /* The name of the file (UTF-8). */
|
||||
Tcl_Obj *attributePtr) /* The command line object. */
|
||||
{
|
||||
OSErr err;
|
||||
FSSpec fileSpec;
|
||||
FInfo finfo;
|
||||
|
||||
err = FSpLocationFromPath(strlen(fileName), fileName, &fileSpec);
|
||||
Tcl_DString pathString;
|
||||
|
||||
Tcl_UtfToExternalDString(NULL, fileName, -1, &pathString);
|
||||
err = FSpLocationFromPath(Tcl_DStringLength(&pathString),
|
||||
Tcl_DStringValue(&pathString), &fileSpec);
|
||||
Tcl_DStringFree(&pathString);
|
||||
|
||||
if (err == noErr) {
|
||||
err = FSpGetFInfo(&fileSpec, &finfo);
|
||||
@@ -1418,15 +1430,19 @@ static int
|
||||
SetFileReadOnly(
|
||||
Tcl_Interp *interp, /* The interp to report errors with. */
|
||||
int objIndex, /* The index of the attribute. */
|
||||
CONST char *fileName, /* The name of the file. */
|
||||
CONST char *fileName, /* The name of the file (UTF-8). */
|
||||
Tcl_Obj *readOnlyPtr) /* The command line object. */
|
||||
{
|
||||
OSErr err;
|
||||
FSSpec fileSpec;
|
||||
HParamBlockRec paramBlock;
|
||||
int hidden;
|
||||
|
||||
err = FSpLocationFromPath(strlen(fileName), fileName, &fileSpec);
|
||||
Tcl_DString pathString;
|
||||
|
||||
Tcl_UtfToExternalDString(NULL, fileName, -1, &pathString);
|
||||
err = FSpLocationFromPath(Tcl_DStringLength(&pathString),
|
||||
Tcl_DStringValue(&pathString), &fileSpec);
|
||||
Tcl_DStringFree(&pathString);
|
||||
|
||||
if (err == noErr) {
|
||||
if (Tcl_GetBooleanFromObj(interp, readOnlyPtr, &hidden) != TCL_OK) {
|
||||
|
||||
+2
-2
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclMacLoad.c,v 1.3 1999/04/16 00:47:20 stanton Exp $
|
||||
* RCS: @(#) $Id: tclMacLoad.c,v 1.3.6.1 1999/10/30 11:07:33 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include <CodeFragments.h>
|
||||
@@ -135,7 +135,7 @@ TclpLoadFile(
|
||||
*(Tcl_UtfAtIndex(packageName, Tcl_NumUtfChars(packageName, -1) - 5)) = 0;
|
||||
|
||||
native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
|
||||
err = FSpLocationFromPath(strlen(fileName), fileName, &fileSpec);
|
||||
err = FSpLocationFromPath(strlen(native), native, &fileSpec);
|
||||
Tcl_DStringFree(&ds);
|
||||
|
||||
if (err != noErr) {
|
||||
|
||||
+52
-21
@@ -1,6 +1,6 @@
|
||||
README -- Tcl test suite design document.
|
||||
|
||||
RCS: @(#) $Id: README,v 1.6 1999/06/26 03:54:09 jenn Exp $
|
||||
RCS: @(#) $Id: README,v 1.6.4.1 1999/09/22 21:06:14 jenn Exp $
|
||||
|
||||
Contents:
|
||||
---------
|
||||
@@ -25,9 +25,12 @@ You can run the tests in three ways:
|
||||
(b) type "tcltest <testFile> ?<option> <value>?
|
||||
Command line options include:
|
||||
|
||||
-help display usage information
|
||||
|
||||
-verbose <level> set the level of verbosity to a substring
|
||||
of "bps". See the "Test output" section
|
||||
for an explanation of this option.
|
||||
of the tcltest man page for an
|
||||
explanation of this option.
|
||||
|
||||
-match <matchList> only run tests that match one or more of
|
||||
the glob patterns in <matchList>
|
||||
@@ -35,27 +38,60 @@ You can run the tests in three ways:
|
||||
-skip <skipList> do not run tests that match one or more
|
||||
of the glob patterns in <skipList>
|
||||
|
||||
-file <globPattern> only source test files that match
|
||||
<globPattern> (relative to the "tests"
|
||||
directory). This option only applies
|
||||
when you run the test suite with the
|
||||
"all.tcl" file.
|
||||
-file <globPatternList>
|
||||
only source test files that match one or
|
||||
more of the glob patterns in
|
||||
<globPatternList> (relative to the
|
||||
"tests" directory). This option only
|
||||
applies when you run the test suite with
|
||||
the "all.tcl" file.
|
||||
|
||||
-notfile <globPatternList>
|
||||
do not source test files that match one
|
||||
or more of the patterns in
|
||||
<globPatternList> (relative to the
|
||||
"tests" directory). This option only
|
||||
applies when you run the test suite with
|
||||
the "all.tcl" file.
|
||||
|
||||
-constraints <list> tests with any constraints in <list> will
|
||||
not be skipped. Not that elements of
|
||||
<list> must exactly match the existing
|
||||
constraints.
|
||||
|
||||
-limitconstraints <bool>
|
||||
If 1, limit test runs to those tests that
|
||||
match the constraints listed using the
|
||||
-constraints flag. Use of this flag
|
||||
requires use of the -constraints flag.
|
||||
The default value is 0.
|
||||
|
||||
-tmpdir <dirname> put temporary files created by
|
||||
::tcltest::makeFile and
|
||||
::tcltest::makeDirectory in the named
|
||||
directory. The default location is
|
||||
::tcltest::workingDirectory.
|
||||
|
||||
-preservecore <level>
|
||||
check for core files. If level is 0,
|
||||
check for core files only when
|
||||
cleanupTests is called from an all.tcl
|
||||
file. If 1, also check at the end of
|
||||
every test command. If 2, also save core
|
||||
files in ::tcltest::temporaryDirectory.
|
||||
The default level is 0.
|
||||
|
||||
(c) start up tcltest in this directory, then "source" the test
|
||||
file (for example, type "source parse.test"). To run all
|
||||
of the tests, type "source all.tcl". To use the options in
|
||||
interactive mode, you can set their corresponding tcltest
|
||||
namespace variables after sourcing the defs.tcl file.
|
||||
namespace variables after loading the tcltest package.
|
||||
For example, some of the tcltest variables are:
|
||||
::tcltest::match
|
||||
::tcltest::skip
|
||||
::tcltest::testConfig(nonPortable)
|
||||
::tcltest::testConfig(knownBug)
|
||||
::tcltest::testConfig(userInteractive)
|
||||
::tcltest::testConstraints(nonPortable)
|
||||
::tcltest::testConstraints(knownBug)
|
||||
::tcltest::testConstraints(userInteractive)
|
||||
|
||||
Please see the tcltest man page for more information regarding how to
|
||||
write and run tests.
|
||||
@@ -88,14 +124,9 @@ the constraints mechanism to skip those tests.
|
||||
-------- --------
|
||||
VERBOSE ::tcltest::verbose
|
||||
TESTS ::tcltest::match
|
||||
testConfig ::tcltest::testConfig
|
||||
testConfig ::tcltest::testConstraints
|
||||
|
||||
The introduction of the "tcltest" namespace is a precursor to using
|
||||
a "tcltest" package. This next step will be part of a future Tcl
|
||||
version.
|
||||
|
||||
2) VERBOSE values are no longer numeric. Please see the section above
|
||||
on "Test output" for the new usage of the ::tcltest::verbose variable.
|
||||
2) VERBOSE values are no longer numeric.
|
||||
|
||||
3) When you run "make test", the working dir for the test suite is now
|
||||
the one from which you called "make test", rather than the "tests"
|
||||
@@ -104,7 +135,7 @@ the constraints mechanism to skip those tests.
|
||||
other or with existing files. All tests must now run independently
|
||||
of their working directory.
|
||||
|
||||
4) The "all" and "visual" files are now called "all.tcl" ane
|
||||
4) The "all" and "visual" files are now called "all.tcl" and
|
||||
"visual_bb.test".
|
||||
|
||||
5) The "defs" file no longer exists.
|
||||
@@ -112,5 +143,5 @@ the constraints mechanism to skip those tests.
|
||||
6) Instead of creating a doAllTests file in the tests directory, to
|
||||
run all nonPortable tests, just use the "-constraints nonPortable"
|
||||
command line flag. If you are running interactively, you can set
|
||||
the ::tcltest::testConfig(nonPortable) variable to 1 (after
|
||||
sourcing the defs.tcl file).
|
||||
the ::tcltest::testConstraints(nonPortable) variable to 1 (after
|
||||
loading the tcltest package).
|
||||
|
||||
+9
-9
@@ -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.
|
||||
#
|
||||
# RCS: @(#) $Id: encoding.test,v 1.5 1999/07/02 06:41:29 welch Exp $
|
||||
# RCS: @(#) $Id: encoding.test,v 1.5.4.1 1999/10/30 11:07:53 hobbs Exp $
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
@@ -61,24 +61,24 @@ test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} {
|
||||
test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} {testencoding} {
|
||||
set system [encoding system]
|
||||
set path [testencoding path]
|
||||
encoding system jis0208 ;# incr ref count
|
||||
testencoding path .
|
||||
set x [encoding convertto jis0208 \u4e4e] ;# old one found
|
||||
encoding system shiftjis ;# incr ref count
|
||||
testencoding path [list [pwd]]
|
||||
set x [encoding convertto shiftjis \u4e4e] ;# old one found
|
||||
encoding system identity
|
||||
lappend x [catch {encoding convertto jis0208 \u4e4e} msg] $msg
|
||||
lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg
|
||||
encoding system identity
|
||||
testencoding path $path
|
||||
encoding system $system
|
||||
set x
|
||||
} {8C 1 {unknown encoding "jis0208"}}
|
||||
} "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}"
|
||||
|
||||
test encoding-3.1 {Tcl_GetEncodingName, NULL} {
|
||||
set old [encoding system]
|
||||
encoding system jis0208
|
||||
encoding system shiftjis
|
||||
set x [encoding system]
|
||||
encoding system $old
|
||||
set x
|
||||
} {jis0208}
|
||||
} {shiftjis}
|
||||
test encoding-3.2 {Tcl_GetEncodingName, non-null} {
|
||||
set old [fconfigure stdout -encoding]
|
||||
fconfigure stdout -encoding jis0208
|
||||
@@ -99,7 +99,7 @@ test encoding-4.1 {Tcl_GetEncodingNames} {testencoding} {
|
||||
foreach encoding [encoding names] {
|
||||
set encodings($encoding) 1
|
||||
}
|
||||
testencoding path .
|
||||
testencoding path [list [pwd]]
|
||||
foreach encoding [encoding names] {
|
||||
if {![info exists encodings($encoding)]} {
|
||||
lappend x $encoding
|
||||
|
||||
+4
-3
@@ -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.
|
||||
#
|
||||
# RCS: @(#) $Id: env.test,v 1.9 1999/07/08 19:44:43 rjohnson Exp $
|
||||
# RCS: @(#) $Id: env.test,v 1.9.4.2 1999/09/22 21:06:15 jenn Exp $
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
@@ -78,12 +78,13 @@ puts $f {
|
||||
lrem names ComSpec
|
||||
lrem names ""
|
||||
}
|
||||
foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH PURE_PROG_NAME DISPLAY SHLIB_PATH } {
|
||||
foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY SHLIB_PATH } {
|
||||
lrem names $name
|
||||
}
|
||||
foreach p $names {
|
||||
puts "$p=$env($p)"
|
||||
}
|
||||
exit
|
||||
}
|
||||
close $f
|
||||
|
||||
@@ -106,7 +107,7 @@ foreach name [array names env] {
|
||||
# Added the following lines so that child tcltest can actually find its
|
||||
# library if the initial tcltest is run from a non-standard place.
|
||||
# ('saved' env vars)
|
||||
foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH DISPLAY SHLIB_PATH} {
|
||||
foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH} {
|
||||
if {[info exists env2($name)]} {
|
||||
set env($name) $env2($name);
|
||||
}
|
||||
|
||||
+3
-3
@@ -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.
|
||||
#
|
||||
# RCS: @(#) $Id: event.test,v 1.8 1999/07/01 17:36:17 jenn Exp $
|
||||
# RCS: @(#) $Id: event.test,v 1.8.4.1 1999/09/22 04:12:56 hobbs Exp $
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
@@ -394,9 +394,9 @@ test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {soc
|
||||
puts $s foobar
|
||||
close $s
|
||||
}
|
||||
set s1 [socket -server accept 5001]
|
||||
catch {set s1 [socket -server accept 5001]}
|
||||
after 1000
|
||||
set s2 [socket 127.0.0.1 5001]
|
||||
catch {set s2 [socket 127.0.0.1 5001]}
|
||||
close $s1
|
||||
set x 0
|
||||
set y 0
|
||||
|
||||
+6
-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.
|
||||
#
|
||||
# RCS: @(#) $Id: exec.test,v 1.5 1999/07/01 17:36:17 jenn Exp $
|
||||
# RCS: @(#) $Id: exec.test,v 1.5.4.1 1999/09/22 21:06:15 jenn Exp $
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
@@ -29,6 +29,7 @@ puts $f {
|
||||
puts -nonewline " $str"
|
||||
}
|
||||
puts {}
|
||||
exit
|
||||
}
|
||||
close $f
|
||||
|
||||
@@ -51,6 +52,7 @@ puts $f {
|
||||
close $f
|
||||
}
|
||||
}
|
||||
exit
|
||||
}
|
||||
close $f
|
||||
|
||||
@@ -61,6 +63,7 @@ puts $f {
|
||||
set words [regsub -all "\[^ \t\n]+" $data {} dummy]
|
||||
set chars [string length $data]
|
||||
puts [format "%8.d%8.d%8.d" $lines $words $chars]
|
||||
exit
|
||||
}
|
||||
close $f
|
||||
|
||||
@@ -85,12 +88,14 @@ puts $f {
|
||||
}
|
||||
lappend newcmd $arg
|
||||
}
|
||||
exit
|
||||
}
|
||||
close $f
|
||||
|
||||
set f [open sleep w]
|
||||
puts $f {
|
||||
after [expr $argv*1000]
|
||||
exit
|
||||
}
|
||||
close $f
|
||||
|
||||
|
||||
+9
-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.
|
||||
#
|
||||
# RCS: @(#) $Id: expr.test,v 1.5 1999/06/30 00:17:06 jenn Exp $
|
||||
# RCS: @(#) $Id: expr.test,v 1.5.4.1 1999/09/22 04:12:57 hobbs Exp $
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
@@ -703,6 +703,14 @@ test expr-20.3 {broken substitution of integer digits} {
|
||||
# fails with 8.0.x, but not 8.1b2
|
||||
list [set a 000; expr 0x1$a] [set a 1; expr ${a}000]
|
||||
} {4096 1000}
|
||||
test expr-20.4 {proper double evaluation compilation, error case} {
|
||||
catch {unset a}; # make sure $a doesn't exist
|
||||
list [catch {expr 1?{$a}:0} msg] $msg
|
||||
} {1 {can't read "a": no such variable}}
|
||||
test expr-20.5 {proper double evaluation compilation, working case} {
|
||||
set a yellow
|
||||
expr 1?{$a}:0
|
||||
} yellow
|
||||
|
||||
# cleanup
|
||||
if {[info exists a]} {
|
||||
|
||||
+14
-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.
|
||||
#
|
||||
# RCS: @(#) $Id: format.test,v 1.5 1999/06/26 03:54:14 jenn Exp $
|
||||
# RCS: @(#) $Id: format.test,v 1.5.4.1 1999/09/22 04:12:57 hobbs Exp $
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
@@ -467,6 +467,19 @@ test format-14.2 {testing MAX_FLOAT_SIZE for 0 and 1} {
|
||||
format {%s} "a"
|
||||
} {a}
|
||||
|
||||
test format-15.1 {testing %0..s 0 padding for chars/strings} {
|
||||
format %05s a
|
||||
} {0000a}
|
||||
test format-15.2 {testing %0..s 0 padding for chars/strings} {
|
||||
format "% 5s" a
|
||||
} { a}
|
||||
test format-15.3 {testing %0..s 0 padding for chars/strings} {
|
||||
format %5s a
|
||||
} { a}
|
||||
test format-15.4 {testing %0..s 0 padding for chars/strings} {
|
||||
format %05c 61
|
||||
} {0000=}
|
||||
|
||||
set a "0123456789"
|
||||
set b ""
|
||||
for {set i 0} {$i < 290} {incr i} {
|
||||
|
||||
+7
-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.
|
||||
#
|
||||
# RCS: @(#) $Id: incr.test,v 1.4 1999/06/26 03:54:14 jenn Exp $
|
||||
# RCS: @(#) $Id: incr.test,v 1.4.4.1 1999/10/30 11:07:53 hobbs Exp $
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
@@ -239,6 +239,12 @@ test incr-1.29 {TclCompileIncrCmd: runtime error, bad variable value} {
|
||||
set x " - "
|
||||
list [catch {incr x 1} msg] $msg
|
||||
} {1 {expected integer but got " - "}}
|
||||
|
||||
test incr-1.30 {TclCompileIncrCmd: array var, braced (no subs)} {
|
||||
catch {unset array}
|
||||
set array(\$foo) 4
|
||||
incr {array($foo)}
|
||||
} 5
|
||||
|
||||
# Check "incr" and computed command names.
|
||||
|
||||
|
||||
+4
-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.
|
||||
#
|
||||
# RCS: @(#) $Id: linsert.test,v 1.6 1999/06/26 03:54:16 jenn Exp $
|
||||
# RCS: @(#) $Id: linsert.test,v 1.6.4.1 1999/09/22 04:12:57 hobbs Exp $
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
@@ -78,6 +78,9 @@ test linsert-1.18 {linsert command} {
|
||||
test linsert-1.19 {linsert command} {
|
||||
linsert {} end q r
|
||||
} {q r}
|
||||
test linsert-1.20 {linsert command, use of end-int index} {
|
||||
linsert {a b c d} end-2 e f
|
||||
} {a b e f c d}
|
||||
|
||||
test linsert-2.1 {linsert errors} {
|
||||
list [catch linsert msg] $msg
|
||||
|
||||
+4
-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.
|
||||
#
|
||||
# RCS: @(#) $Id: pkg.test,v 1.6 1999/06/26 20:55:09 rjohnson Exp $
|
||||
# RCS: @(#) $Id: pkg.test,v 1.6.4.1 1999/09/22 04:12:57 hobbs Exp $
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
@@ -529,6 +529,9 @@ test pkg-5.3 {CheckVersion procedure} {
|
||||
test pkg-5.4 {CheckVersion procedure} {
|
||||
list [catch {package vcompare 1.2.3. 2.1} msg] $msg
|
||||
} {1 {expected version number but got "1.2.3."}}
|
||||
test pkg-5.5 {CheckVersion procedure} {
|
||||
list [catch {package vcompare 1.2..3 2.1} msg] $msg
|
||||
} {1 {expected version number but got "1.2..3"}}
|
||||
|
||||
test pkg-6.1 {ComparePkgVersions procedure} {
|
||||
package vcompare 1.23 1.22
|
||||
|
||||
+125
-95
@@ -3,10 +3,13 @@
|
||||
# This file contains a collection of tests for one or more of the Tcl
|
||||
# built-in commands. Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
# (Don't panic if you are seeing this as part of the reg distribution
|
||||
# and aren't using Tcl -- reg's own regression tester also knows how
|
||||
# to read this file, ignoring the Tcl-isms.)
|
||||
#
|
||||
# Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
|
||||
#
|
||||
# RCS: @(#) $Id: reg.test,v 1.10 1999/08/05 01:21:09 stanton Exp $
|
||||
# RCS: @(#) $Id: reg.test,v 1.10.4.1 1999/11/02 02:10:05 hobbs Exp $
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
@@ -21,13 +24,18 @@ set ::tcltest::testConstraints(testregexp) \
|
||||
|
||||
# This file uses some custom procedures, defined below, for regexp regression
|
||||
# testing. The name of the procedure indicates the general nature of the
|
||||
# test: e for compile error expected, f for match failure expected, m
|
||||
# for a successful match, and i for a successful match with -indices (used
|
||||
# in checking things like nonparticipating subexpressions). There is also
|
||||
# a "doing" procedure which sets up title and major test number for each
|
||||
# block of tests, and an "xx" procedure which ignores its arguments and
|
||||
# arranges for the next invocation of "doing" to announce that some tests
|
||||
# were bypassed (which is better than just commenting them out).
|
||||
# test:
|
||||
# e compile error expected
|
||||
# f match failure expected
|
||||
# m successful match
|
||||
# i successful match with -indices (used in checking things like
|
||||
# nonparticipating subexpressions)
|
||||
# p unsuccessful match with -indices (!!) (used in checking
|
||||
# partial-match reporting)
|
||||
# There is also "doing" which sets up title and major test number for each
|
||||
# block of tests, and "xx" which ignores its arguments and arranges for the
|
||||
# next "doing" to announce that some tests were bypassed (which is better
|
||||
# than just commenting them out).
|
||||
|
||||
# The first 3 arguments are constant: a minor number (which often gets
|
||||
# a letter or two suffixed to it internally), some flags, and the RE itself.
|
||||
@@ -36,10 +44,10 @@ set ::tcltest::testConstraints(testregexp) \
|
||||
# to try the match against. Remaining arguments are the substring expected
|
||||
# to be matched, and any substrings expected to be matched by subexpressions.
|
||||
# (For f, these arguments are optional, and if present are ignored except
|
||||
# that they indicate how many subexpressions should be presents in the RE.)
|
||||
# that they indicate how many subexpressions should be present in the RE.)
|
||||
# It is an error for the number of subexpression arguments to be wrong.
|
||||
# Cases involving nonparticipating subexpressions, checking where empty
|
||||
# substrings are located, etc. should be done using i.
|
||||
# substrings are located, etc. should be done using i and p.
|
||||
|
||||
# The flag characters are complex and a bit eclectic. Generally speaking,
|
||||
# lowercase letters are compile options, uppercase are expected re_info
|
||||
@@ -51,11 +59,11 @@ set ::tcltest::testConstraints(testregexp) \
|
||||
# useful in this file.
|
||||
#
|
||||
# - no-op (placeholder)
|
||||
# + provide fake xy equivalence class
|
||||
# + provide fake xy equivalence class and ch collating element
|
||||
# % force small state-set cache in matcher (to test cache replace)
|
||||
# ^ beginning of string is not beginning of line
|
||||
# $ end of string is not end of line
|
||||
# ? report information on partial and limited matches
|
||||
# * test is Unicode-specific, needs big character set
|
||||
#
|
||||
# & test as both ARE and BRE
|
||||
# b BRE
|
||||
@@ -69,6 +77,7 @@ set ::tcltest::testConstraints(testregexp) \
|
||||
# w newlines are half-magic, significant to ^ and $ only
|
||||
# n newlines are fully magic, both effects
|
||||
# x expanded RE syntax
|
||||
# t incomplete-match reporting
|
||||
#
|
||||
# A backslash-_a_lphanumeric seen
|
||||
# B ERE/ARE literal-_b_race heuristic used
|
||||
@@ -82,6 +91,7 @@ set ::tcltest::testConstraints(testregexp) \
|
||||
# Q {} _q_uantifier seen
|
||||
# R back _r_eference seen
|
||||
# S POSIX-un_s_pecified syntax seen
|
||||
# T prefers shortest (_t_iny)
|
||||
# U saw original-POSIX botch: unmatched right paren in ERE (_u_gh)
|
||||
|
||||
# The one area we can't easily test is memory-allocation failures (which
|
||||
@@ -109,8 +119,9 @@ set infonames(P) "REG_UNONPOSIX"
|
||||
set infonames(Q) "REG_UBOUNDS"
|
||||
set infonames(R) "REG_UBACKREF"
|
||||
set infonames(S) "REG_UUNSPEC"
|
||||
set infonames(T) "REG_USHORTEST"
|
||||
set infonames(U) "REG_UPBOTCH"
|
||||
set infonameorder "RHQBAUEPSMLNI" ;# must match bit order, lsb first
|
||||
set infonameorder "RHQBAUEPSMLNIT" ;# must match bit order, lsb first
|
||||
|
||||
# set major test number and description
|
||||
proc doing {major desc} {
|
||||
@@ -182,6 +193,12 @@ proc infoflags {fl} {
|
||||
proc e {testid flags re err} {
|
||||
global prefix ask errorCode
|
||||
|
||||
# Tcl locale stuff doesn't do the ch/xy test fakery yet
|
||||
if {[string first "+" $flags] >= 0} {
|
||||
xx
|
||||
return
|
||||
}
|
||||
|
||||
# if &, test as both ARE and BRE
|
||||
set amp [string first "&" $flags]
|
||||
if {$amp >= 0} {
|
||||
@@ -201,6 +218,12 @@ proc e {testid flags re err} {
|
||||
proc f {testid flags re target args} {
|
||||
global prefix description ask
|
||||
|
||||
# Tcl locale stuff doesn't do the ch/xy test fakery yet
|
||||
if {[string first "+" $flags] >= 0} {
|
||||
xx
|
||||
return
|
||||
}
|
||||
|
||||
# if &, test as both ARE and BRE
|
||||
set amp [string first "&" $flags]
|
||||
if {$amp >= 0} {
|
||||
@@ -240,6 +263,12 @@ proc f {testid flags re target args} {
|
||||
proc matchexpected {opts testid flags re target args} {
|
||||
global prefix description ask
|
||||
|
||||
# Tcl locale stuff doesn't do the ch/xy test fakery yet
|
||||
if {[string first "+" $flags] >= 0} {
|
||||
xx
|
||||
return
|
||||
}
|
||||
|
||||
# if &, test as both BRE and ARE
|
||||
set amp [string first "&" $flags]
|
||||
if {$amp >= 0} {
|
||||
@@ -270,10 +299,10 @@ proc matchexpected {opts testid flags re target args} {
|
||||
append refs " \$$name"
|
||||
set $name ""
|
||||
}
|
||||
if {[string first "o" $flags] >= 0} { ;# REG_NOSUB
|
||||
if {[string first "o" $flags] >= 0} { ;# REG_NOSUB kludge
|
||||
set nsub 0 ;# unsigned value cannot be -1
|
||||
}
|
||||
if {[string first "?" $flags] >= 0} { ;# REG_EXPECT
|
||||
if {[string first "t" $flags] >= 0} { ;# REG_EXPECT
|
||||
incr nsub -1 ;# the extra does not count
|
||||
}
|
||||
set ecmd [concat $ecmd $names]
|
||||
@@ -431,11 +460,11 @@ m 7 bN ** *** ***
|
||||
e 8 & a** BADRPT
|
||||
e 9 & a**b BADRPT
|
||||
e 10 & *** BADRPT
|
||||
e 11 * a++ BADRPT
|
||||
e 12 * a?+ BADRPT
|
||||
e 13 * a?* BADRPT
|
||||
e 14 * a+* BADRPT
|
||||
e 15 * a*+ BADRPT
|
||||
e 11 - a++ BADRPT
|
||||
e 12 - a?+ BADRPT
|
||||
e 13 - a?* BADRPT
|
||||
e 14 - a+* BADRPT
|
||||
e 15 - a*+ BADRPT
|
||||
|
||||
|
||||
|
||||
@@ -514,7 +543,7 @@ m 40 eE {a[\\]b} "a\\b" "a\\b"
|
||||
m 41 bE {a[\\]b} "a\\b" "a\\b"
|
||||
e 42 - {a[\Z]b} EESCAPE
|
||||
m 43 & {a[[b]c} "a\[c" "a\[c"
|
||||
m 44 EMP {a[\u00fe-\u0507][\u00ff-\u0300]b} \
|
||||
m 44 EMP* {a[\u00fe-\u0507][\u00ff-\u0300]b} \
|
||||
"a\u0102\u02ffb" "a\u0102\u02ffb"
|
||||
|
||||
|
||||
@@ -645,26 +674,26 @@ m 26 MP "a\\010b" "a\bb" "a\bb"
|
||||
|
||||
doing 14 "back references"
|
||||
# ugh
|
||||
m 1 {R[1P} {a(b*)c\1} abbcbb abbcbb bb
|
||||
m 2 {R[1P} {a(b*)c\1} ac ac ""
|
||||
f 3 {R[1P} {a(b*)c\1} abbcb
|
||||
m 4 {R[1P} {a(b*)\1} abbcbb abb b
|
||||
m 5 {R[1P} {a(b|bb)\1} abbcbb abb b
|
||||
m 6 {R[1P} {a([bc])\1} abb abb b
|
||||
f 7 {R[1P} {a([bc])\1} abc
|
||||
m 8 {R[1P} {a([bc])\1} abcabb abb b
|
||||
f 9 {R[1P} {a([bc])*\1} abc
|
||||
f 10 {R[1P} {a([bc])\1} abB
|
||||
m 11 {iR[1P} {a([bc])\1} abB abB b
|
||||
m 12 {R[1P} {a([bc])\1+} abbb abbb b
|
||||
m 13 {QR[1P} "a(\[bc])\\1{3,4}" abbbb abbbb b
|
||||
f 14 {QR[1P} "a(\[bc])\\1{3,4}" abbb
|
||||
m 15 {R[1P} {a([bc])\1*} abbb abbb b
|
||||
m 16 {R[1P} {a([bc])\1*} ab ab b
|
||||
m 17 {R[2P} {a([bc])(\1*)} ab ab b ""
|
||||
m 1 RP {a(b*)c\1} abbcbb abbcbb bb
|
||||
m 2 RP {a(b*)c\1} ac ac ""
|
||||
f 3 RP {a(b*)c\1} abbcb
|
||||
m 4 RP {a(b*)\1} abbcbb abb b
|
||||
m 5 RP {a(b|bb)\1} abbcbb abb b
|
||||
m 6 RP {a([bc])\1} abb abb b
|
||||
f 7 RP {a([bc])\1} abc
|
||||
m 8 RP {a([bc])\1} abcabb abb b
|
||||
f 9 RP {a([bc])*\1} abc
|
||||
f 10 RP {a([bc])\1} abB
|
||||
m 11 iRP {a([bc])\1} abB abB b
|
||||
m 12 RP {a([bc])\1+} abbb abbb b
|
||||
m 13 QRP "a(\[bc])\\1{3,4}" abbbb abbbb b
|
||||
f 14 QRP "a(\[bc])\\1{3,4}" abbb
|
||||
m 15 RP {a([bc])\1*} abbb abbb b
|
||||
m 16 RP {a([bc])\1*} ab ab b
|
||||
m 17 RP {a([bc])(\1*)} ab ab b ""
|
||||
e 18 - {a((b)\1)} ESUBREG
|
||||
e 19 - {a(b)c\2} ESUBREG
|
||||
m 20 {bR[1} {a\(b*\)c\1} abbcbb abbcbb bb
|
||||
m 20 bR {a\(b*\)c\1} abbcbb abbcbb bb
|
||||
|
||||
|
||||
|
||||
@@ -804,29 +833,28 @@ m 34 N (a*)* bc "" ""
|
||||
|
||||
doing 22 "multicharacter collating elements"
|
||||
# again ugh
|
||||
# currently disabled because the fake MCCE we use for testing is unavailable
|
||||
xx m 1 &+L {a[c]e} ace ace
|
||||
xx f 2 &+I {a[c]h} ach
|
||||
xx m 3 &+L {a[[.ch.]]} ach ach
|
||||
xx f 4 &+L {a[[.ch.]]} ace
|
||||
xx m 5 &+L {a[c[.ch.]]} ac ac
|
||||
xx m 6 &+L {a[c[.ch.]]} ace ac
|
||||
xx m 7 &+L {a[c[.ch.]]} ache ach
|
||||
xx f 8 &+L {a[^c]e} ace
|
||||
xx m 9 &+L {a[^c]e} abe abe
|
||||
xx m 10 &+L {a[^c]e} ache ache
|
||||
xx f 11 &+L {a[^[.ch.]]} ach
|
||||
xx m 12 &+L {a[^[.ch.]]} ace ac
|
||||
xx m 13 &+L {a[^[.ch.]]} ac ac
|
||||
xx m 14 &+L {a[^[.ch.]]} abe ab
|
||||
xx f 15 &+L {a[^c[.ch.]]} ach
|
||||
xx f 16 &+L {a[^c[.ch.]]} ace
|
||||
xx f 17 &+L {a[^c[.ch.]]} ac
|
||||
xx m 18 &+L {a[^c[.ch.]]} abe ab
|
||||
xx m 19 &+L {a[^b]} ac ac
|
||||
xx m 20 &+L {a[^b]} ace ac
|
||||
xx m 21 &+L {a[^b]} ach ach
|
||||
xx f 22 &+L {a[^b]} abe
|
||||
m 1 &+L {a[c]e} ace ace
|
||||
f 2 &+IL {a[c]h} ach
|
||||
m 3 &+L {a[[.ch.]]} ach ach
|
||||
f 4 &+L {a[[.ch.]]} ace
|
||||
m 5 &+L {a[c[.ch.]]} ac ac
|
||||
m 6 &+L {a[c[.ch.]]} ace ac
|
||||
m 7 &+L {a[c[.ch.]]} ache ach
|
||||
f 8 &+L {a[^c]e} ace
|
||||
m 9 &+L {a[^c]e} abe abe
|
||||
m 10 &+L {a[^c]e} ache ache
|
||||
f 11 &+L {a[^[.ch.]]} ach
|
||||
m 12 &+L {a[^[.ch.]]} ace ac
|
||||
m 13 &+L {a[^[.ch.]]} ac ac
|
||||
m 14 &+L {a[^[.ch.]]} abe ab
|
||||
f 15 &+L {a[^c[.ch.]]} ach
|
||||
f 16 &+L {a[^c[.ch.]]} ace
|
||||
f 17 &+L {a[^c[.ch.]]} ac
|
||||
m 18 &+L {a[^c[.ch.]]} abe ab
|
||||
m 19 &+L {a[^b]} ac ac
|
||||
m 20 &+L {a[^b]} ace ac
|
||||
m 21 &+L {a[^b]} ach ach
|
||||
f 22 &+L {a[^b]} abe
|
||||
|
||||
|
||||
|
||||
@@ -843,27 +871,27 @@ f 8 HP (?=b)b a
|
||||
|
||||
|
||||
doing 24 "non-greedy quantifiers"
|
||||
m 1 P ab+? abb ab
|
||||
m 2 P ab+?c abbc abbc
|
||||
m 3 P ab*? abb a
|
||||
m 4 P ab*?c abbc abbc
|
||||
m 5 P ab?? ab a
|
||||
m 6 P ab??c abc abc
|
||||
m 7 PQ "ab{2,4}?" abbbb abb
|
||||
m 8 PQ "ab{2,4}?c" abbbbc abbbbc
|
||||
m 1 PT ab+? abb ab
|
||||
m 2 PT ab+?c abbc abbc
|
||||
m 3 PT ab*? abb a
|
||||
m 4 PT ab*?c abbc abbc
|
||||
m 5 PT ab?? ab a
|
||||
m 6 PT ab??c abc abc
|
||||
m 7 PQT "ab{2,4}?" abbbb abb
|
||||
m 8 PQT "ab{2,4}?c" abbbbc abbbbc
|
||||
m 9 - 3z* 123zzzz456 3zzzz
|
||||
m 10 P 3z*? 123zzzz456 3
|
||||
m 10 PT 3z*? 123zzzz456 3
|
||||
m 11 - z*4 123zzzz456 zzzz4
|
||||
m 12 P z*?4 123zzzz456 zzzz4
|
||||
m 12 PT z*?4 123zzzz456 zzzz4
|
||||
|
||||
|
||||
|
||||
doing 25 "mixed quantifiers"
|
||||
# this is very incomplete as yet
|
||||
# should include |
|
||||
m 1 PN {^(.*?)(a*)$} xyza xyza xyz a
|
||||
m 2 PN {^(.*?)(a*)$} xyzaa xyzaa xyz aa
|
||||
m 3 PN {^(.*?)(a*)$} xyz xyz xyz ""
|
||||
xx lots more to be done
|
||||
m 1 PNT {^(.*?)(a*)$} xyza xyza xyz a
|
||||
m 2 PNT {^(.*?)(a*)$} xyzaa xyzaa xyz aa
|
||||
m 3 PNT {^(.*?)(a*)$} xyz xyz xyz ""
|
||||
|
||||
|
||||
|
||||
@@ -913,22 +941,24 @@ i 12 %LP {\w+(abcdefghijklmnopqrst)?} xyzabcdefghijklmnopqrs \
|
||||
|
||||
|
||||
doing 29 "incomplete matches"
|
||||
p 1 ? def abc {3 2} ""
|
||||
p 2 ? bcd abc {1 2} ""
|
||||
p 3 ? abc abab {0 3} ""
|
||||
p 4 ? abc abdab {3 4} ""
|
||||
i 5 ? abc abc {0 2} {0 2}
|
||||
i 6 ? abc xyabc {2 4} {2 4}
|
||||
p 7 ? abc+ xyab {2 3} ""
|
||||
i 8 ? abc+ xyabc {2 4} {2 4}
|
||||
p 9 ?P abc+? xyab {2 3} ""
|
||||
p 1 t def abc {3 2} ""
|
||||
p 2 t bcd abc {1 2} ""
|
||||
p 3 t abc abab {0 3} ""
|
||||
p 4 t abc abdab {3 4} ""
|
||||
i 5 t abc abc {0 2} {0 2}
|
||||
i 6 t abc xyabc {2 4} {2 4}
|
||||
p 7 t abc+ xyab {2 3} ""
|
||||
i 8 t abc+ xyabc {2 4} {2 4}
|
||||
xx i 9 t abc+ xyabcd {2 4} {6 5}
|
||||
i 10 t abc+ xyabcdd {2 4} {7 6}
|
||||
p 11 tPT abc+? xyab {2 3} ""
|
||||
# the retain numbers in these two may look wrong, but they aren't
|
||||
i 10 ?P abc+? xyabc {2 4} {5 4}
|
||||
i 11 ?P abc+? xyabcc {2 4} {6 5}
|
||||
i 12 ?P abc+? xyabcd {2 4} {6 5}
|
||||
i 13 ? abcd|bc xyabc {3 4} {2 4}
|
||||
i 14 ? abc+ xyabcdd {2 4} {7 6}
|
||||
|
||||
i 12 tPT abc+? xyabc {2 4} {5 4}
|
||||
i 13 tPT abc+? xyabcc {2 4} {6 5}
|
||||
i 14 tPT abc+? xyabcd {2 4} {6 5}
|
||||
i 15 tPT abc+? xyabcdd {2 4} {7 6}
|
||||
i 16 t abcd|bc xyabc {3 4} {2 4}
|
||||
p 17 tn .*k "xx\nyyy" {3 5} ""
|
||||
|
||||
|
||||
doing 30 "misc. oddities and old bugs"
|
||||
@@ -936,8 +966,8 @@ e 1 & *** BADRPT
|
||||
m 2 N a?b* abb abb
|
||||
m 3 N a?b* bb bb
|
||||
m 4 & a*b aab aab
|
||||
m 5 & ^a*b aaaab aaaab
|
||||
m 6 &M {[0-6][1-2][0-3][0-6][1-6][0-6]} 010010 010010
|
||||
m 5 & ^a*b aaaab aaaab
|
||||
m 6 &M {[0-6][1-2][0-3][0-6][1-6][0-6]} 010010 010010
|
||||
# temporary REG_BOSONLY kludge
|
||||
m 7 s abc abcd abc
|
||||
f 8 s abc xabcd
|
||||
@@ -945,8 +975,8 @@ f 8 s abc xabcd
|
||||
m 9 HLP {(?n)^(?![t#])\S+} "tk\n\n#\n#\nit0" it0
|
||||
|
||||
|
||||
|
||||
doing 0 "flush" ;# to flush any leftover complaints
|
||||
# flush any leftover complaints
|
||||
doing 0 "flush"
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
|
||||
+10
-1
@@ -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.
|
||||
#
|
||||
# RCS: @(#) $Id: set-old.test,v 1.6 1999/06/26 20:55:12 rjohnson Exp $
|
||||
# RCS: @(#) $Id: set-old.test,v 1.6.4.1 1999/09/22 04:12:57 hobbs Exp $
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
@@ -501,6 +501,15 @@ test set-old-8.37.4 {array command, empty set with populated array} {
|
||||
array set aVaRnAmE [list e3 v3]
|
||||
list [lsort [array names aVaRnAmE]] [catch {set aVaRnAmE(e2)} msg] $msg
|
||||
} {{e1 e2 e3} 0 v2}
|
||||
test set-old-8.37.5 {array command, set with non-existent namespace} {
|
||||
list [catch {array set bogusnamespace::var {}} msg] $msg
|
||||
} {1 {can't set "bogusnamespace::var": parent namespace doesn't exist}}
|
||||
test set-old-8.37.6 {array command, set with non-existent namespace} {
|
||||
list [catch {array set bogusnamespace::var {a b}} msg] $msg
|
||||
} {1 {can't set "bogusnamespace::var(a)": parent namespace doesn't exist}}
|
||||
test set-old-8.37.7 {array command, set with non-existent namespace} {
|
||||
list [catch {array set bogusnamespace::var(0) {a b}} msg] $msg
|
||||
} {1 {can't set "bogusnamespace::var(0)": variable isn't array}}
|
||||
test set-old-8.38 {array command, size option} {
|
||||
catch {unset a}
|
||||
array size a
|
||||
|
||||
+7
-13
@@ -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.
|
||||
#
|
||||
# RCS: @(#) $Id: set.test,v 1.5 1999/06/26 20:55:12 rjohnson Exp $
|
||||
# RCS: @(#) $Id: set.test,v 1.5.4.1 1999/10/30 11:07:54 hobbs Exp $
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
@@ -200,6 +200,12 @@ test set-1.24 {TclCompileSetCmd: too many arguments} {
|
||||
set msg
|
||||
} {wrong # args: should be "set varName ?newValue?"}
|
||||
|
||||
test set-1.25 {TclCompileSetCmd: var is array, braced (no subs)} {
|
||||
# This was a known error in 8.1a* - 8.2.1
|
||||
catch {unset array}
|
||||
set {array($foo)} 5
|
||||
} 5
|
||||
|
||||
test set-2.1 {set command: runtime error, bad variable name} {
|
||||
list [catch {set {"foo}} msg] $msg $errorInfo
|
||||
} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable
|
||||
@@ -486,15 +492,3 @@ catch {unset x}
|
||||
catch {unset z}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
+6
-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.
|
||||
#
|
||||
# RCS: @(#) $Id: string.test,v 1.20 1999/08/10 05:09:20 hobbs Exp $
|
||||
# RCS: @(#) $Id: string.test,v 1.20.4.1 1999/10/30 11:07:54 hobbs Exp $
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
@@ -244,6 +244,11 @@ test string-5.15 {string index, bytearray object} {
|
||||
set i2 [string index $b 1]
|
||||
string compare $i1 $i2
|
||||
} 0
|
||||
test string-5.16 {string index, bytearray object with string obj shimmering} {
|
||||
set str "0123456789\x00 abcdedfghi"
|
||||
binary scan $str H* dump
|
||||
string compare [string index $str 10] \x00
|
||||
} 0
|
||||
|
||||
proc largest_int {} {
|
||||
# This will give us what the largest valid int on this machine is,
|
||||
|
||||
+18
-1
@@ -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.
|
||||
#
|
||||
# RCS: @(#) $Id: stringObj.test,v 1.8 1999/06/26 20:55:14 rjohnson Exp $
|
||||
# RCS: @(#) $Id: stringObj.test,v 1.8.4.1 1999/09/22 04:12:58 hobbs Exp $
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
@@ -299,6 +299,23 @@ test stringObj-9.10 {TclAppendObjToObj, integer src & mixed dest} {
|
||||
list [testobj objtype $x] [testobj objtype $y] [append x $y] \
|
||||
[set y] [testobj objtype $x] [testobj objtype $y]
|
||||
} {string int abc○ghi9 9 string int}
|
||||
test stringObj-9.11 {TclAppendObjToObj, mixed src & 1-byte dest index check} {
|
||||
# bug 2678, in <=8.2.0, the second obj (the one to append) in
|
||||
# Tcl_AppendObjToObj was not correctly checked to see if it was
|
||||
# all one byte chars, so a unicode string would be added as one
|
||||
# byte chars.
|
||||
set x abcdef
|
||||
set len [string length $x]
|
||||
set y aübåcï
|
||||
set len [string length $y]
|
||||
append x $y
|
||||
string length $x
|
||||
set q {}
|
||||
for {set i 0} {$i < 12} {incr i} {
|
||||
lappend q [string index $x $i]
|
||||
}
|
||||
set q
|
||||
} {a b c d e f a ü b å c ï}
|
||||
|
||||
test stringObj-10.1 {Tcl_GetRange with all byte-size chars} {
|
||||
set x "abcdef"
|
||||
|
||||
+72
-9
@@ -1,7 +1,7 @@
|
||||
# Command line options covered:
|
||||
# -help, -verbose, -match, -skip, -file, -notfile, -relateddir, -asidefromdir
|
||||
# -constraints, -limitconstraints, -preservecore, -tmpdir, -debug, -outfile,
|
||||
# -errfile
|
||||
# -help, -verbose, -match, -skip, -file, -notfile, -constraints,
|
||||
# -limitconstraints, -preservecore, -tmpdir, -debug, -outfile,
|
||||
# -errfile, -args
|
||||
#
|
||||
# This file contains a collection of tests for one or more of the Tcl
|
||||
# built-in commands. Sourcing this file into Tcl runs the tests and
|
||||
@@ -10,7 +10,7 @@
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
# All rights reserved.
|
||||
#
|
||||
# RCS: @(#) $Id: tcltest.test,v 1.5 1999/08/10 05:09:20 hobbs Exp $
|
||||
# RCS: @(#) $Id: tcltest.test,v 1.5.4.1 1999/09/22 21:06:16 jenn Exp $
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
@@ -29,12 +29,13 @@ makeFile {
|
||||
test c-1.0 {test c} {knownBug} {
|
||||
} {}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
exit
|
||||
} test.tcl
|
||||
|
||||
# test -help
|
||||
test tcltest-1.1 {tcltest -help} {
|
||||
set result [catch {exec $::tcltest::tcltest test.tcl -help} msg]
|
||||
set result [catch {runCmd $cmd}]
|
||||
list $result [regexp Usage $msg]
|
||||
} {1 1}
|
||||
test tcltest-1.2 {tcltest -help -something} {
|
||||
@@ -157,6 +158,7 @@ makeFile {
|
||||
::tcltest::PrintError "a really really long string containing a \
|
||||
\"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\""
|
||||
::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\""
|
||||
exit
|
||||
} printerror.tcl
|
||||
|
||||
# -outfile, -errfile
|
||||
@@ -216,7 +218,7 @@ makeFile {
|
||||
package require tcltest
|
||||
namespace import ::tcltest::*
|
||||
makeFile {} a.tmp
|
||||
return
|
||||
exit
|
||||
} a.tcl
|
||||
|
||||
makeFile {} thisdirectoryisafile
|
||||
@@ -234,8 +236,46 @@ test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
|
||||
list [regexp "not a directory" [join $msg]]
|
||||
} {1}
|
||||
|
||||
# Platform-specific attribute testing still needs to be set up
|
||||
# (non-writeable directories, non-readable directories) as tmpdir -- jlh
|
||||
# Test non-writeable directories, non-readable directories with tmpdir
|
||||
set notReadableDir [file join $::tcltest::temporaryDirectory notreadable]
|
||||
set notWriteableDir [file join $::tcltest::temporaryDirectory notwriteable]
|
||||
|
||||
::tcltest::makeDirectory notreadable
|
||||
::tcltest::makeDirectory notwriteable
|
||||
|
||||
switch $tcl_platform(platform) {
|
||||
"unix" {
|
||||
file attributes $notReadableDir -permissions 00333
|
||||
file attributes $notWriteableDir -permissions 00555
|
||||
}
|
||||
default {
|
||||
file attributes $notWriteableDir -readonly 1
|
||||
}
|
||||
}
|
||||
|
||||
test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {unixOnly} {
|
||||
catch {exec $::tcltest::tcltest a.tcl -tmpdir $notReadableDir} msg
|
||||
# The join is necessary because the message can be split on multiple lines
|
||||
list [regexp {not readable} [join $msg]]
|
||||
} {1}
|
||||
|
||||
test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {
|
||||
catch {exec $::tcltest::tcltest a.tcl -tmpdir $notWriteableDir} msg
|
||||
# The join is necessary because the message can be split on multiple lines
|
||||
list [regexp {not writeable} [join $msg]]
|
||||
} {1}
|
||||
|
||||
switch $tcl_platform(platform) {
|
||||
"unix" {
|
||||
file attributes $notReadableDir -permissions 777
|
||||
file attributes $notWriteableDir -permissions 777
|
||||
}
|
||||
default {
|
||||
file attributes $notWriteableDir -readonly 0
|
||||
}
|
||||
}
|
||||
|
||||
file delete -force $notReadableDir $notWriteableDir
|
||||
|
||||
# -file -notfile
|
||||
test tcltest-9.1 {-file a*.tcl} {
|
||||
@@ -284,10 +324,33 @@ test tcltest-10.4 {-preservecore 3} {
|
||||
[regexp "core-" $msg] [file delete core-makecore]
|
||||
} {1 1 1 {}}
|
||||
|
||||
makeFile {
|
||||
package require tcltest
|
||||
namespace import ::tcltest::*
|
||||
puts "=$::tcltest::parameters="
|
||||
exit
|
||||
} args.tcl
|
||||
|
||||
# -args
|
||||
test tcltest-11.1 {-args foo} {
|
||||
catch {exec $::tcltest::tcltest args.tcl -args foo} msg
|
||||
list $msg
|
||||
} {=foo=}
|
||||
|
||||
test tcltest-11.2 {-args {}} {
|
||||
catch {exec $::tcltest::tcltest args.tcl -args {}} msg
|
||||
list $msg
|
||||
} {==}
|
||||
|
||||
test tcltest-11.3 {-args {-foo bar -baz}} {
|
||||
catch {exec $::tcltest::tcltest args.tcl -args {-foo bar -baz}} msg
|
||||
list $msg
|
||||
} {{=-foo bar -baz=}}
|
||||
|
||||
# Begin testing of tcltest procs ...
|
||||
|
||||
# PrintError
|
||||
test tcltest-11.1 {PrintError} {
|
||||
test tcltest-20.1 {PrintError} {
|
||||
set result [catch {exec $::tcltest::tcltest printerror.tcl} msg]
|
||||
list $result [regexp "Error: a really short string" $msg] \
|
||||
[regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \
|
||||
|
||||
+2
-2
@@ -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.
|
||||
#
|
||||
# RCS: @(#) $Id: timer.test,v 1.5 1999/06/26 20:55:15 rjohnson Exp $
|
||||
# RCS: @(#) $Id: timer.test,v 1.5.4.1 1999/09/22 04:12:58 hobbs Exp $
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
@@ -412,7 +412,7 @@ test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NULL} {
|
||||
}
|
||||
set x "hello world"
|
||||
set id junk
|
||||
set id [after 1 set x ab\0cd]
|
||||
set id [after 10 set x ab\0cd]
|
||||
update
|
||||
set y [string length [lindex [lindex [after info $id] 0] 2]]
|
||||
foreach i [after info] {
|
||||
|
||||
+2
-2
@@ -12,7 +12,7 @@ item: Global
|
||||
Log Pathname=%MAINDIR%\INSTALL.LOG
|
||||
Message Font=MS Sans Serif
|
||||
Font Size=8
|
||||
Disk Label=tcl8.2.0
|
||||
Disk Label=tcl8.2.2
|
||||
Disk Filename=setup
|
||||
Patch Flags=0000000000000001
|
||||
Patch Threshold=85
|
||||
@@ -1715,7 +1715,7 @@ item: Install File
|
||||
end
|
||||
item: Install File
|
||||
Source=${__TKBASEDIR__}\library\demos\twind.tcl
|
||||
Destination=%MAINDIR%\lib\tk%VER%\demos\twin\released.tcl
|
||||
Destination=%MAINDIR%\lib\tk%VER%\demos\twind.tcl
|
||||
Flags=0000000000000010
|
||||
end
|
||||
item: Install File
|
||||
|
||||
+12
-12
@@ -5,7 +5,7 @@
|
||||
# "autoconf" program (constructs like "@foo@" will get replaced in the
|
||||
# actual Makefile.
|
||||
#
|
||||
# RCS: @(#) $Id: Makefile.in,v 1.44 1999/08/11 20:51:54 redman Exp $
|
||||
# RCS: @(#) $Id: Makefile.in,v 1.44.2.3 1999/10/30 11:09:43 hobbs Exp $
|
||||
|
||||
VERSION = @TCL_VERSION@
|
||||
|
||||
@@ -64,9 +64,6 @@ MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3
|
||||
# Tcl commands:
|
||||
MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann
|
||||
|
||||
# Directory in which to install the include file tcl.h:
|
||||
INCLUDE_INSTALL_DIR = @includedir@
|
||||
|
||||
# Package search path.
|
||||
TCL_PACKAGE_PATH = @TCL_PACKAGE_PATH@
|
||||
|
||||
@@ -216,7 +213,7 @@ DLTEST_DIR = @TCL_SRC_DIR@/unix/dltest
|
||||
# Must be absolute to so the corresponding tcltest's tcl_library is absolute.
|
||||
TCL_BUILDTIME_LIBRARY= @TCL_SRC_DIR@/library
|
||||
|
||||
#CC = purify @CC@
|
||||
#CC = purify -best-effort @CC@
|
||||
CC = @CC@
|
||||
|
||||
#----------------------------------------------------------------
|
||||
@@ -431,6 +428,7 @@ tcltest: ${TCLTEST_OBJS} ${TCL_LIB_FILE} ${BUILD_DLTEST}
|
||||
|
||||
test: tcltest
|
||||
LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \
|
||||
LIBPATH=`pwd`:${LIBPATH}; export LIBPATH; \
|
||||
SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \
|
||||
TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
|
||||
./tcltest $(TOP_DIR)/tests/all.tcl
|
||||
@@ -438,6 +436,7 @@ test: tcltest
|
||||
# Useful target to launch a built tcltest with the proper path,...
|
||||
runtest: tcltest
|
||||
LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \
|
||||
LIBPATH=`pwd`:${LIBPATH}; export LIBPATH; \
|
||||
SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \
|
||||
TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
|
||||
./tcltest
|
||||
@@ -461,9 +460,10 @@ topDirName:
|
||||
gendate:
|
||||
yacc -l $(GENERIC_DIR)/tclGetDate.y
|
||||
sed -e 's/yy/TclDate/g' -e '/^#include <values.h>/d' \
|
||||
-e "s/SCCSID/RCS: @(#) \$Id\$"
|
||||
-e 's?SCCSID?RCS: @(#) $$Id: Makefile.in,v 1.44.2.3 1999/10/30 11:09:43 hobbs Exp $$?' \
|
||||
-e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \
|
||||
-e '/TclDatenewstate:/d' -e '/#pragma/d' \
|
||||
-e '/#include <inttypes.h>/d' \
|
||||
<y.tab.c >$(GENERIC_DIR)/tclDate.c
|
||||
rm y.tab.c
|
||||
|
||||
@@ -485,13 +485,13 @@ dltest/Makefile: $(DLTEST_DIR)/configure $(DLTEST_DIR)/Makefile.in tclConfig.sh
|
||||
cd dltest; if test -f configure; then ./configure; else \
|
||||
$(DLTEST_DIR)/configure; fi
|
||||
|
||||
install: all install-binaries install-libraries install-doc
|
||||
install: install-binaries install-libraries install-doc
|
||||
|
||||
# Note: before running ranlib below, must cd to target directory because
|
||||
# some ranlibs write to current directory, and this might not always be
|
||||
# possible (e.g. if installing as root).
|
||||
|
||||
install-binaries:
|
||||
install-binaries: binaries
|
||||
@for i in $(LIB_INSTALL_DIR) $(BIN_INSTALL_DIR) ; \
|
||||
do \
|
||||
if [ ! -d $$i ] ; then \
|
||||
@@ -521,7 +521,7 @@ install-binaries:
|
||||
$(LIB_INSTALL_DIR)/$(TCL_STUB_LIB_FILE); \
|
||||
fi
|
||||
|
||||
install-libraries:
|
||||
install-libraries: libraries
|
||||
@for i in $(INSTALL_ROOT)$(prefix)/lib $(INCLUDE_INSTALL_DIR) \
|
||||
$(SCRIPT_INSTALL_DIR); \
|
||||
do \
|
||||
@@ -565,7 +565,7 @@ install-libraries:
|
||||
$(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR)/encoding; \
|
||||
done;
|
||||
|
||||
install-doc:
|
||||
install-doc: doc
|
||||
@chmod +x $(UNIX_DIR)/mkLinks
|
||||
@for i in $(MAN_INSTALL_DIR) $(MAN1_INSTALL_DIR) $(MAN3_INSTALL_DIR) $(MANN_INSTALL_DIR) ; \
|
||||
do \
|
||||
@@ -1064,8 +1064,8 @@ dist: $(UNIX_DIR)/configure
|
||||
cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic
|
||||
cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic
|
||||
cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic
|
||||
cp -p $(TOP_DIR)/changes $(TOP_DIR)/README* $(TOP_DIR)/license.terms \
|
||||
$(DISTDIR)
|
||||
cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README* \
|
||||
$(TOP_DIR)/license.terms $(DISTDIR)
|
||||
mkdir $(DISTDIR)/library
|
||||
cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \
|
||||
$(TOP_DIR)/library/tclIndex $(DISTDIR)/library
|
||||
|
||||
Vendored
+3
-3
@@ -578,7 +578,7 @@ AC_DEFUN(SC_CONFIG_CFLAGS, [
|
||||
;;
|
||||
AIX-*)
|
||||
SHLIB_CFLAGS=""
|
||||
SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512"
|
||||
SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
|
||||
SHLIB_LD_LIBS='${LIBS}'
|
||||
SHLIB_SUFFIX=".so"
|
||||
DL_OBJS="tclLoadDl.o"
|
||||
@@ -646,7 +646,7 @@ AC_DEFUN(SC_CONFIG_CFLAGS, [
|
||||
IRIX-5.*|IRIX-6.*|IRIX64-6.5*)
|
||||
SHLIB_CFLAGS=""
|
||||
SHLIB_LD="ld -n32 -shared -rdata_shared"
|
||||
SHLIB_LD_LIBS=""
|
||||
SHLIB_LD_LIBS='${LIBS}'
|
||||
SHLIB_SUFFIX=".so"
|
||||
DL_OBJS="tclLoadDl.o"
|
||||
DL_LIBS=""
|
||||
@@ -726,7 +726,7 @@ AC_DEFUN(SC_CONFIG_CFLAGS, [
|
||||
LDFLAGS="-Wl,-Bexport"
|
||||
LD_SEARCH_FLAGS=""
|
||||
;;
|
||||
NetBSD-*|FreeBSD-[[12]].*|OpenBSD-*)
|
||||
NetBSD-*|FreeBSD-[[1-2]].*|OpenBSD-*)
|
||||
# Not available on all versions: check for include file.
|
||||
AC_CHECK_HEADER(dlfcn.h, [
|
||||
SHLIB_CFLAGS="-fpic"
|
||||
|
||||
+2
-2
@@ -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)
|
||||
# RCS: @(#) $Id: configure.in,v 1.48 1999/08/11 22:48:09 wart Exp $
|
||||
# RCS: @(#) $Id: configure.in,v 1.48.2.2 1999/10/30 11:09:44 hobbs Exp $
|
||||
|
||||
TCL_VERSION=8.2
|
||||
TCL_MAJOR_VERSION=8
|
||||
TCL_MINOR_VERSION=2
|
||||
TCL_PATCH_LEVEL=".0"
|
||||
TCL_PATCH_LEVEL=".2"
|
||||
VERSION=${TCL_VERSION}
|
||||
|
||||
#------------------------------------------------------------------------
|
||||
|
||||
@@ -1,11 +1,11 @@
|
||||
# This Makefile is used to create several test cases for Tcl's load
|
||||
# command. It also illustrates how to take advantage of configuration
|
||||
# exported by Tcl to set up Makefiles for shared libraries.
|
||||
# RCS: @(#) $Id: Makefile.in,v 1.5 1999/04/16 00:48:06 stanton Exp $
|
||||
# RCS: @(#) $Id: Makefile.in,v 1.5.6.1 1999/09/22 04:13:07 hobbs Exp $
|
||||
|
||||
TCL_DBGX = @TCL_DBGX@
|
||||
CC = @CC@
|
||||
LIBS = @TCL_BUILD_STUB_LIB_SPEC@ @TCL_LIBS@
|
||||
LIBS = @TCL_BUILD_STUB_LIB_SPEC@ @TCL_LIBS@ -lc
|
||||
AC_FLAGS = @EXTRA_CFLAGS@
|
||||
SHLIB_CFLAGS = @SHLIB_CFLAGS@
|
||||
SHLIB_LD = @SHLIB_LD@
|
||||
|
||||
+3
-3
@@ -578,7 +578,7 @@ AC_DEFUN(SC_CONFIG_CFLAGS, [
|
||||
;;
|
||||
AIX-*)
|
||||
SHLIB_CFLAGS=""
|
||||
SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512"
|
||||
SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
|
||||
SHLIB_LD_LIBS='${LIBS}'
|
||||
SHLIB_SUFFIX=".so"
|
||||
DL_OBJS="tclLoadDl.o"
|
||||
@@ -646,7 +646,7 @@ AC_DEFUN(SC_CONFIG_CFLAGS, [
|
||||
IRIX-5.*|IRIX-6.*|IRIX64-6.5*)
|
||||
SHLIB_CFLAGS=""
|
||||
SHLIB_LD="ld -n32 -shared -rdata_shared"
|
||||
SHLIB_LD_LIBS=""
|
||||
SHLIB_LD_LIBS='${LIBS}'
|
||||
SHLIB_SUFFIX=".so"
|
||||
DL_OBJS="tclLoadDl.o"
|
||||
DL_LIBS=""
|
||||
@@ -726,7 +726,7 @@ AC_DEFUN(SC_CONFIG_CFLAGS, [
|
||||
LDFLAGS="-Wl,-Bexport"
|
||||
LD_SEARCH_FLAGS=""
|
||||
;;
|
||||
NetBSD-*|FreeBSD-[[12]].*|OpenBSD-*)
|
||||
NetBSD-*|FreeBSD-[[1-2]].*|OpenBSD-*)
|
||||
# Not available on all versions: check for include file.
|
||||
AC_CHECK_HEADER(dlfcn.h, [
|
||||
SHLIB_CFLAGS="-fpic"
|
||||
|
||||
+9
-7
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclUnixNotfy.c,v 1.5 1999/07/02 06:05:34 welch Exp $
|
||||
* RCS: @(#) $Id: tclUnixNotfy.c,v 1.5.4.1 1999/10/30 11:09:45 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -719,15 +719,12 @@ Tcl_WaitForEvent(timePtr)
|
||||
waitingListPtr = tsdPtr;
|
||||
tsdPtr->onList = 1;
|
||||
|
||||
Tcl_MutexUnlock(¬ifierMutex);
|
||||
write(triggerPipe, "", 1);
|
||||
Tcl_MutexLock(¬ifierMutex);
|
||||
}
|
||||
|
||||
memset((VOID *) tsdPtr->readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask));
|
||||
|
||||
if (!tsdPtr->eventReady) {
|
||||
|
||||
Tcl_ConditionWait(&tsdPtr->waitCV, ¬ifierMutex, timePtr);
|
||||
}
|
||||
tsdPtr->eventReady = 0;
|
||||
@@ -750,10 +747,7 @@ Tcl_WaitForEvent(timePtr)
|
||||
}
|
||||
tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
|
||||
tsdPtr->onList = 0;
|
||||
Tcl_MutexUnlock(¬ifierMutex);
|
||||
write(triggerPipe, "", 1);
|
||||
Tcl_MutexLock(¬ifierMutex);
|
||||
|
||||
}
|
||||
|
||||
|
||||
@@ -870,10 +864,18 @@ NotifierThreadProc(clientData)
|
||||
if (fcntl(receivePipe, F_SETFL, status) < 0) {
|
||||
panic("NotifierThreadProc: could not make receive pipe non blocking.");
|
||||
}
|
||||
status = fcntl(fds[1], F_GETFL);
|
||||
status |= O_NONBLOCK;
|
||||
if (fcntl(fds[1], F_SETFL, status) < 0) {
|
||||
panic("NotifierThreadProc: could not make trigger pipe non blocking.");
|
||||
}
|
||||
#else
|
||||
if (ioctl(receivePipe, (int) FIONBIO, &status) < 0) {
|
||||
panic("NotifierThreadProc: could not make receive pipe non blocking.");
|
||||
}
|
||||
if (ioctl(fds[1], (int) FIONBIO, &status) < 0) {
|
||||
panic("NotifierThreadProc: could not make trigger pipe non blocking.");
|
||||
}
|
||||
#endif
|
||||
|
||||
/*
|
||||
|
||||
+28
-21
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclUnixPipe.c,v 1.3 1999/04/16 00:48:05 stanton Exp $
|
||||
* RCS: @(#) $Id: tclUnixPipe.c,v 1.3.6.1 1999/10/30 11:09:45 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -333,7 +333,9 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
|
||||
TclFile errPipeIn, errPipeOut;
|
||||
int joinThisError, count, status, fd;
|
||||
char errSpace[200 + TCL_INTEGER_SPACE];
|
||||
int pid;
|
||||
Tcl_DString *dsArray;
|
||||
char **newArgv;
|
||||
int pid, i;
|
||||
|
||||
errPipeIn = NULL;
|
||||
errPipeOut = NULL;
|
||||
@@ -350,13 +352,20 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
|
||||
goto error;
|
||||
}
|
||||
|
||||
/*
|
||||
* We need to allocate and convert this before the (v)fork
|
||||
* so it is properly deallocated later
|
||||
*/
|
||||
dsArray = (Tcl_DString *) ckalloc(argc * sizeof(Tcl_DString));
|
||||
newArgv = (char **) ckalloc((argc+1) * sizeof(char *));
|
||||
newArgv[argc] = NULL;
|
||||
for (i = 0; i < argc; i++) {
|
||||
newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]);
|
||||
}
|
||||
|
||||
joinThisError = (errorFile == outputFile);
|
||||
pid = vfork();
|
||||
if (pid == 0) {
|
||||
Tcl_DString *dsArray;
|
||||
char *oldArgv0;
|
||||
int i;
|
||||
|
||||
fd = GetFd(errPipeOut);
|
||||
|
||||
/*
|
||||
@@ -370,8 +379,7 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
|
||||
((dup2(1,2) == -1) ||
|
||||
(fcntl(2, F_SETFD, 0) != 0)))) {
|
||||
sprintf(errSpace,
|
||||
"%dforked process couldn't set up input/output: ",
|
||||
errno);
|
||||
"%dforked process couldn't set up input/output: ", errno);
|
||||
write(fd, errSpace, (size_t) strlen(errSpace));
|
||||
_exit(1);
|
||||
}
|
||||
@@ -381,22 +389,21 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
|
||||
*/
|
||||
|
||||
RestoreSignals();
|
||||
for (i = 0; argv[i] != NULL; i++) {
|
||||
/*
|
||||
* How many arguments?
|
||||
*/
|
||||
}
|
||||
oldArgv0 = argv[0];
|
||||
dsArray = (Tcl_DString *) ckalloc(i * sizeof(Tcl_DString));
|
||||
for (i = 0; argv[i] != NULL; i++) {
|
||||
argv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]);
|
||||
}
|
||||
execvp(argv[0], argv); /* INTL: Native. */
|
||||
sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno,
|
||||
oldArgv0);
|
||||
execvp(newArgv[0], newArgv); /* INTL: Native. */
|
||||
sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, argv[0]);
|
||||
write(fd, errSpace, (size_t) strlen(errSpace));
|
||||
_exit(1);
|
||||
}
|
||||
|
||||
/*
|
||||
* Free the mem we used for the fork
|
||||
*/
|
||||
for (i = 0; i < argc; i++) {
|
||||
Tcl_DStringFree(&dsArray[i]);
|
||||
}
|
||||
ckfree((char *) dsArray);
|
||||
ckfree((char *) newArgv);
|
||||
|
||||
if (pid == -1) {
|
||||
Tcl_AppendResult(interp, "couldn't fork child process: ",
|
||||
Tcl_PosixError(interp), (char *) NULL);
|
||||
|
||||
+4
-1
@@ -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.
|
||||
*
|
||||
* RCS: @(#) $Id: tclUnixTest.c,v 1.10 1999/04/16 00:48:05 stanton Exp $
|
||||
* RCS: @(#) $Id: tclUnixTest.c,v 1.10.6.1 1999/10/30 11:09:45 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
@@ -465,6 +465,9 @@ TestfindexecutableCmd(clientData, interp, argc, argv)
|
||||
Tcl_SetResult(interp, tclExecutableName, TCL_VOLATILE);
|
||||
ckfree(tclExecutableName);
|
||||
}
|
||||
if (tclNativeExecutableName != NULL) {
|
||||
ckfree(tclNativeExecutableName);
|
||||
}
|
||||
|
||||
tclExecutableName = oldName;
|
||||
tclNativeExecutableName = oldNativeName;
|
||||
|
||||
+4
-4
@@ -1,11 +1,11 @@
|
||||
Tcl/Tk 8.2b2 for Windows, Binary Distribution
|
||||
Tcl/Tk 8.2 for Windows, Binary Distribution
|
||||
|
||||
RCS: @(#) $Id: README.binary,v 1.10 1999/08/10 23:16:27 redman Exp $
|
||||
RCS: @(#) $Id: README.binary,v 1.10.2.2 1999/10/30 11:09:57 hobbs Exp $
|
||||
|
||||
1. Introduction
|
||||
---------------
|
||||
|
||||
This directory contains the binary distribution of Tcl/Tk 8.2.0 for
|
||||
This directory contains the binary distribution of Tcl/Tk 8.2.2 for
|
||||
Windows. It was compiled with Microsoft Visual C++ 5.0 using Win32
|
||||
API, so that it will run under Windows NT, Windows 95, and Windows 98.
|
||||
|
||||
@@ -32,7 +32,7 @@ Information about new features in Tcl/Tk 8.2 can be found at
|
||||
http://www.scriptics.com/software/whatsnew82.html
|
||||
|
||||
Detailed release notes can be found at
|
||||
http://www.scriptics.com/software/relnotes/tcl8.2.0
|
||||
http://www.scriptics.com/software/relnotes/tcl8.2.2
|
||||
|
||||
Information about Tcl itself can be found at
|
||||
http://www.scriptics.com/scripting/
|
||||
|
||||
+2
-2
@@ -2,14 +2,14 @@
|
||||
# generate the file "configure", which is run during Tcl installation
|
||||
# to configure the system for the local environment.
|
||||
#
|
||||
# RCS: @(#) $Id: configure.in,v 1.13 1999/08/10 23:16:27 redman Exp $
|
||||
# RCS: @(#) $Id: configure.in,v 1.13.2.2 1999/10/30 11:09:58 hobbs Exp $
|
||||
|
||||
AC_INIT(../generic/tcl.h)
|
||||
|
||||
TCL_VERSION=8.2
|
||||
TCL_MAJOR_VERSION=8
|
||||
TCL_MINOR_VERSION=2
|
||||
TCL_PATCH_LEVEL=".0"
|
||||
TCL_PATCH_LEVEL=".2"
|
||||
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
|
||||
|
||||
#--------------------------------------------------------------------
|
||||
|
||||
+4
-4
@@ -10,7 +10,7 @@
|
||||
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
* Changes by Rolf.Schroedter@dlr.de June 25-27, 1999
|
||||
*
|
||||
* RCS: @(#) $Id: tclWinSerial.c,v 1.7 1999/08/12 17:38:49 redman Exp $
|
||||
* RCS: @(#) $Id: tclWinSerial.c,v 1.7.2.1 1999/09/24 22:49:14 hobbs Exp $
|
||||
*/
|
||||
|
||||
#include "tclWinInt.h"
|
||||
@@ -130,10 +130,10 @@ static int SerialOutputProc(ClientData instanceData, char *buf,
|
||||
static void SerialSetupProc(ClientData clientData, int flags);
|
||||
static void SerialWatchProc(ClientData instanceData, int mask);
|
||||
static void ProcExitHandler(ClientData clientData);
|
||||
static int SerialGetOptionProc _ANSI_ARGS_((ClientData instanceData,
|
||||
static int SerialGetOptionProc _ANSI_ARGS_((ClientData instanceData,
|
||||
Tcl_Interp *interp, char *optionName,
|
||||
Tcl_DString *dsPtr));
|
||||
static int SerialSetOptionProc _ANSI_ARGS_((ClientData instanceData,
|
||||
static int SerialSetOptionProc _ANSI_ARGS_((ClientData instanceData,
|
||||
Tcl_Interp *interp, char *optionName,
|
||||
char *value));
|
||||
|
||||
@@ -1008,7 +1008,7 @@ SerialSetOptionProc(instanceData, interp, optionName, value)
|
||||
return Tcl_BadChannelOption(interp, optionName,
|
||||
"mode pollinterval");
|
||||
}
|
||||
return TCL_ERROR;
|
||||
return TCL_OK;
|
||||
}
|
||||
|
||||
/*
|
||||
|
||||
Reference in New Issue
Block a user