summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2018-12-08 17:16:36 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2018-12-08 17:16:36 (GMT)
commit795fcf4f08882df1123a1ab6228a6cdf31fbb3eb (patch)
treece1eec15448d13d9dff53c233970313d8f68876e
parentb5fe898956f0d887cbda3595f970480144e89073 (diff)
parenta7858d818d69719efc88a5de7dfcf85032e7540b (diff)
downloadtcl-795fcf4f08882df1123a1ab6228a6cdf31fbb3eb.zip
tcl-795fcf4f08882df1123a1ab6228a6cdf31fbb3eb.tar.gz
tcl-795fcf4f08882df1123a1ab6228a6cdf31fbb3eb.tar.bz2
Merge 8.7
Bring back Tcl_InitSubsystems to what Tcl_InitSubsystems was: without additional parameters or additional functionality
-rw-r--r--.travis.yml139
-rw-r--r--ChangeLog2
-rw-r--r--README22
-rw-r--r--changes68
-rw-r--r--compat/fixstrtod.c36
-rw-r--r--compat/stdlib.h1
-rw-r--r--compat/strtod.c252
-rw-r--r--compat/zlib/contrib/minizip/crypt.h6
-rw-r--r--compat/zlib/contrib/minizip/miniunz.c2
-rw-r--r--compat/zlib/contrib/minizip/minizip.c2
-rw-r--r--doc/Exit.33
-rw-r--r--doc/FindExec.34
-rw-r--r--doc/InitSubSyst.331
-rw-r--r--doc/Panic.38
-rw-r--r--doc/StaticPkg.33
-rw-r--r--doc/Tcl_Main.32
-rw-r--r--doc/cookiejar.n217
-rw-r--r--doc/define.n264
-rw-r--r--doc/http.n111
-rw-r--r--doc/idna.n88
-rw-r--r--doc/info.n18
-rw-r--r--doc/lpop.n96
-rw-r--r--doc/string.n14
-rw-r--r--doc/tcltest.n14
-rw-r--r--doc/zipfs.32
-rw-r--r--generic/tcl.decls55
-rw-r--r--generic/tcl.h78
-rw-r--r--generic/tclAssembly.c20
-rw-r--r--generic/tclBasic.c96
-rw-r--r--generic/tclBinary.c222
-rw-r--r--generic/tclCkalloc.c2
-rw-r--r--generic/tclClock.c2
-rw-r--r--generic/tclCmdAH.c2
-rw-r--r--generic/tclCmdIL.c108
-rw-r--r--generic/tclCmdMZ.c88
-rw-r--r--generic/tclCompCmdsSZ.c18
-rw-r--r--generic/tclCompExpr.c8
-rw-r--r--generic/tclCompile.c32
-rw-r--r--generic/tclCompile.h19
-rw-r--r--generic/tclDate.c2
-rw-r--r--generic/tclDecls.h61
-rw-r--r--generic/tclDictObj.c222
-rw-r--r--generic/tclDisassemble.c88
-rw-r--r--generic/tclEncoding.c70
-rw-r--r--generic/tclEnsemble.c77
-rw-r--r--generic/tclEvent.c6
-rw-r--r--generic/tclExecute.c63
-rw-r--r--generic/tclFCmd.c2
-rw-r--r--generic/tclFileName.c8
-rw-r--r--generic/tclGetDate.y2
-rw-r--r--generic/tclIO.c43
-rw-r--r--generic/tclIO.h2
-rw-r--r--generic/tclIndexObj.c74
-rw-r--r--generic/tclInt.decls4
-rw-r--r--generic/tclInt.h87
-rw-r--r--generic/tclIntDecls.h10
-rw-r--r--generic/tclInterp.c2
-rw-r--r--generic/tclLink.c5
-rw-r--r--generic/tclListObj.c274
-rw-r--r--generic/tclNamesp.c65
-rw-r--r--generic/tclOO.c47
-rw-r--r--generic/tclOOCall.c292
-rw-r--r--generic/tclOODefineCmds.c205
-rw-r--r--generic/tclOOInfo.c66
-rw-r--r--generic/tclOOInt.h27
-rw-r--r--generic/tclOOMethod.c69
-rw-r--r--generic/tclOOScript.h4
-rw-r--r--generic/tclOOScript.tcl6
-rw-r--r--generic/tclObj.c335
-rw-r--r--generic/tclPanic.c5
-rw-r--r--generic/tclParse.c6
-rw-r--r--generic/tclPathObj.c329
-rw-r--r--generic/tclProc.c179
-rw-r--r--generic/tclRegexp.c60
-rw-r--r--generic/tclScan.c8
-rw-r--r--generic/tclStringObj.c15
-rw-r--r--generic/tclStubInit.c107
-rw-r--r--generic/tclTest.c463
-rw-r--r--generic/tclThreadAlloc.c2
-rw-r--r--generic/tclThreadTest.c2
-rw-r--r--generic/tclTimer.c11
-rw-r--r--generic/tclTrace.c16
-rw-r--r--generic/tclUtil.c247
-rw-r--r--generic/tclVar.c164
-rw-r--r--generic/tclZipfs.c69
-rw-r--r--generic/tclZlib.c38
-rw-r--r--library/dde/pkgIndex.tcl4
-rw-r--r--library/http/cookiejar.tcl745
-rw-r--r--library/http/effective_tld_names.txt.gzbin0 -> 39188 bytes
-rw-r--r--library/http/http.tcl121
-rw-r--r--library/http/idna.tcl292
-rw-r--r--library/http/pkgIndex.tcl2
-rw-r--r--library/init.tcl17
-rw-r--r--library/manifest.txt18
-rw-r--r--library/msgcat/msgcat.tcl18
-rw-r--r--library/package.tcl14
-rw-r--r--library/tcltest/pkgIndex.tcl2
-rw-r--r--library/tcltest/tcltest.tcl47
-rw-r--r--library/tzdata/Africa/Casablanca280
-rw-r--r--library/tzdata/Africa/El_Aaiun256
-rw-r--r--library/tzdata/Pacific/Honolulu5
-rw-r--r--macosx/GNUmakefile6
-rw-r--r--macosx/tclMacOSXFCmd.c36
-rw-r--r--tests/all.tcl4
-rw-r--r--tests/assemble.test13
-rw-r--r--tests/binary.test40
-rw-r--r--tests/clock.test42
-rw-r--r--tests/cmdAH.test7
-rw-r--r--tests/dict.test14
-rw-r--r--tests/event.test2
-rw-r--r--tests/http.test451
-rw-r--r--tests/httpcookie.test874
-rw-r--r--tests/ioCmd.test6
-rw-r--r--tests/list.test18
-rw-r--r--tests/lpop.test140
-rw-r--r--tests/msgcat.test8
-rw-r--r--tests/obj.test1
-rw-r--r--tests/oo.test335
-rw-r--r--tests/source.test11
-rw-r--r--tests/string.test79
-rw-r--r--tests/tcltest.test6
-rw-r--r--tests/timer.test4
-rw-r--r--tests/unixInit.test5
-rw-r--r--tests/util.test45
-rw-r--r--tests/winDde.test4
-rw-r--r--tests/winFile.test7
-rw-r--r--tests/winPipe.test8
-rw-r--r--tools/installVfs.tcl54
-rw-r--r--unix/Makefile.in28
-rwxr-xr-xunix/configure142
-rw-r--r--unix/configure.ac20
-rw-r--r--unix/tcl.m461
-rw-r--r--unix/tclConfig.h.in9
-rw-r--r--unix/tclUnixSock.c15
-rw-r--r--win/Makefile.in20
-rwxr-xr-xwin/configure4
-rw-r--r--win/makefile.vc2
-rw-r--r--win/tcl.m44
-rw-r--r--win/tclWin32Dll.c92
-rw-r--r--win/tclWinDde.c262
-rw-r--r--win/tclWinFile.c12
-rw-r--r--win/tclWinReg.c55
-rw-r--r--win/tclWinSerial.c4
-rw-r--r--win/tclWinTest.c10
144 files changed, 7915 insertions, 2960 deletions
diff --git a/.travis.yml b/.travis.yml
new file mode 100644
index 0000000..947e858
--- /dev/null
+++ b/.travis.yml
@@ -0,0 +1,139 @@
+sudo: false
+language: c
+
+matrix:
+ include:
+ - os: linux
+ dist: trusty
+ compiler: clang
+ env:
+ - BUILD_DIR=unix
+ - os: linux
+ dist: trusty
+ compiler: clang
+ env:
+ - CFGOPT=--disable-shared
+ - BUILD_DIR=unix
+ - os: linux
+ dist: trusty
+ compiler: gcc
+ env:
+ - BUILD_DIR=unix
+ - os: linux
+ dist: trusty
+ compiler: gcc
+ env:
+ - CFGOPT=--disable-shared
+ - BUILD_DIR=unix
+ - os: linux
+ dist: trusty
+ compiler: gcc-4.9
+ addons:
+ apt:
+ sources:
+ - ubuntu-toolchain-r-test
+ packages:
+ - g++-4.9
+ env:
+ - BUILD_DIR=unix
+ - os: linux
+ dist: trusty
+ compiler: gcc-5
+ addons:
+ apt:
+ sources:
+ - ubuntu-toolchain-r-test
+ packages:
+ - g++-5
+ env:
+ - BUILD_DIR=unix
+ - os: linux
+ dist: trusty
+ compiler: gcc-6
+ addons:
+ apt:
+ sources:
+ - ubuntu-toolchain-r-test
+ packages:
+ - g++-6
+ env:
+ - BUILD_DIR=unix
+ - os: linux
+ dist: trusty
+ compiler: gcc-7
+ addons:
+ apt:
+ sources:
+ - ubuntu-toolchain-r-test
+ packages:
+ - g++-7
+ env:
+ - BUILD_DIR=unix
+ - os: osx
+ osx_image: xcode8
+ env:
+ - BUILD_DIR=unix
+ - os: osx
+ osx_image: xcode8
+ env:
+ - BUILD_DIR=macosx
+ - NO_DIRECT_CONFIGURE=1
+ - os: osx
+ osx_image: xcode9
+ env:
+ - BUILD_DIR=macosx
+ - NO_DIRECT_CONFIGURE=1
+ - os: osx
+ osx_image: xcode10
+ env:
+ - BUILD_DIR=macosx
+ - NO_DIRECT_CONFIGURE=1
+### C builds not currently supported on Windows instances
+# - os: windows
+# env:
+# - BUILD_DIR=win
+### ... so proxy with a Mingw cross-compile
+# Test with mingw-w64 (32 bit)
+ - os: linux
+ dist: trusty
+ compiler: i686-w64-mingw32-gcc
+ addons:
+ apt:
+ packages:
+ - gcc-mingw-w64-base
+ - binutils-mingw-w64-i686
+ - gcc-mingw-w64-i686
+ - gcc-mingw-w64
+ - gcc-multilib
+ - wine
+ env:
+ - BUILD_DIR=win
+ - CFGOPT=--host=i686-w64-mingw32
+ - NO_DIRECT_TEST=1
+# Test with mingw-w64 (64 bit)
+ - os: linux
+ dist: trusty
+ compiler: x86_64-w64-mingw32-gcc
+ addons:
+ apt:
+ packages:
+ - gcc-mingw-w64-base
+ - binutils-mingw-w64-x86-64
+ - gcc-mingw-w64-x86-64
+ - gcc-mingw-w64
+ - wine
+ env:
+ - BUILD_DIR=win
+ - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit"
+ - NO_DIRECT_TEST=1
+
+before_install:
+ - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm get stable; fi
+ - export ERROR_ON_FAILURES=1
+ - cd ${BUILD_DIR}
+install:
+ - test -n "$NO_DIRECT_CONFIGURE" || ./configure ${CFGOPT}
+script:
+ - make
+ # The styles=develop avoids some weird problems on OSX
+ - test -n "$NO_DIRECT_TEST" || make test styles=develop
diff --git a/ChangeLog b/ChangeLog
index e2881a0..84281bc 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,6 +1,6 @@
A NOTE ON THE CHANGELOG:
Starting in early 2011, Tcl source code has been under the management of
-fossil, hosted at http://core.tcl.tk/tcl/ . Fossil presents a "Timeline"
+fossil, hosted at https://core.tcl-lang.org/tcl/ . Fossil presents a "Timeline"
view of changes made that is superior in every way to a hand edited log file.
Because of this, many Tcl developers are now out of the habit of maintaining
this log file. You may still find useful things in it, but the Timeline is
diff --git a/README b/README
index 322666a..30c6076 100644
--- a/README
+++ b/README
@@ -29,7 +29,7 @@ Tcl is maintained, enhanced, and distributed freely by the Tcl community.
Source code development and tracking of bug reports and feature requests
takes place at:
- http://core.tcl.tk/
+ http://core.tcl-lang.org/
Tcl/Tk release and mailing list services are hosted by SourceForge:
@@ -37,7 +37,7 @@ Tcl/Tk release and mailing list services are hosted by SourceForge:
with the Tcl Developer Xchange hosted at:
- http://www.tcl.tk/
+ http://www.tcl-lang.org/
Tcl is a freely available open source package. You can do virtually
anything you like with it, such as modifying it, redistributing it,
@@ -49,21 +49,21 @@ and selling it either in whole or in part. See the file
Extensive documentation is available at our website.
The home page for this release, including new features, is
- http://www.tcl.tk/software/tcltk/8.7.html
+ http://www.tcl-lang.org/software/tcltk/8.7.html
Detailed release notes can be found at the file distributions page
by clicking on the relevant version.
http://sourceforge.net/projects/tcl/files/Tcl/
Information about Tcl itself can be found at
- http://www.tcl.tk/about/
+ http://www.tcl-lang.org/about/
There have been many Tcl books on the market. Many are mentioned in the Wiki:
- http://wiki.tcl.tk/_/ref?N=25206
+ http://wiki.tcl-lang.org/_/ref?N=25206
To view the complete set of reference manual entries for Tcl 8.7 online,
visit the URL:
- http://www.tcl.tk/man/tcl8.7/
+ http://www.tcl-lang.org/man/tcl8.7/
2a. Unix Documentation
----------------------
@@ -101,7 +101,7 @@ There are brief notes in the unix/README, win/README, and macosx/README about
compiling on these different platforms. There is additional information
about building Tcl from sources at
- http://www.tcl.tk/doc/howto/compile.html
+ http://www.tcl-lang.org/doc/howto/compile.html
4. Development tools
---------------------------
@@ -127,7 +127,7 @@ see the "Support and bug fixes" section below.
A Wiki-based open community site covering all aspects of Tcl/Tk is at:
- http://wiki.tcl.tk/
+ http://wiki.tcl-lang.org/
It is dedicated to the Tcl programming language and its extensions. A
wealth of useful information can be found there. It contains code
@@ -153,7 +153,7 @@ We are very interested in receiving bug reports, patches, and suggestions
for improvements. We prefer that you send this information to us as
tickets entered into our tracker at:
- http://core.tcl.tk/tcl/reportlist
+ http://core.tcl-lang.org/tcl/reportlist
We will log and follow-up on each bug, although we cannot promise a
specific turn-around time. Enhancements may take longer and may not happen
@@ -169,13 +169,13 @@ questions for which no one else is likely to know the answer. In addition,
see the following Web site for links to other organizations that offer
Tcl/Tk training:
- http://wiki.tcl.tk/training
+ http://wiki.tcl-lang.org/training
9. Tracking Development
-----------------------
Tcl is developed in public. To keep an eye on how Tcl is changing, see
- http://core.tcl.tk/
+ http://core.tcl-lang.org/
10. Thank You
-------------
diff --git a/changes b/changes
index 01d4c7a..f8a8f96 100644
--- a/changes
+++ b/changes
@@ -8831,6 +8831,70 @@ improvements to regexp engine from Postgres (lane,porter,fellows,seltenreich)
--- Released 8.6.8, December 22, 2017 --- http://core.tcl.tk/tcl/ for details
+2018-02-11 (enhance) stop blocking conversion of object to/from class (coulter)
+
+2018-02-12 (enhance) NR-enable [package require] (coulter)
+
+2018-02-14 (bug)[9fd5c6] crash in object deletion, test oo-11.5 (coulter)
+
+2018-02-14 (bug)[3c32a3] crash deleting object with class mixed in (coulter)
+
+2018-02-15 (platform) stop using -lieee, removed from glibc-2.27 (porter)
+***POTENTIAL INCOMPATIBILITY for math programs that embed Tcl***
+
+2018-02-23 (bug)[8e6a9a] bad binary [string match], test string-11.55 (porter)
+
+2018-03-05 (bug)[1873ea] repair multi-thread std channel init (sebres)
+
+2018-03-09 (bug)[db36fa] broken bytecode for index values (porter)
+
+2018-03-13 (bug) broken compiled [string replace], test string-14.19 (porter)
+
+2018-03-14 (bug) [string trim*] engine crashed on invalid UTF (sebres)
+
+2018-04-17 (bug) missing trace in compiled [array set], test var-20.11 (porter)
+
+2018-04-22 (bug)[46a241] crash in unset array with search, var-13.[23] (goth)
+
+2018-04-30 (bug)[27b682] race made [file delete] raise "no such file" (sebres)
+
+2018-06-04 (bug)[925643] 32/64 cleanup of filesystem DIR operations (sebres)
+
+2018-06-18 (bug) leaks in TclSetEnv and env cache (coulter)
+
+2018-06-24 (bug)[3592747] [yieldto] dying namespace, tailcall-14.1 (coulter)
+
+2018-07-09 (bug)[270f78] race in [file mkdir] (sebres)
+
+2018-07-12 (bug)[3f7af0] [file delete] raised "permission denied" (sebres)
+
+2018-07-26 (bug)[d051b7] overflow crash in [format] (sebres)
+
+2018-08-29 revised quoting of [exec] args in generated command line (sebres)
+***POTENTIAL INCOMPATIBILITY***
+
+2018-09-20 HTTP Keep-Alive with pipelined requests (nash)
+=> http 2.9.0
+
+2018-09-27 (new)[TIP 505] [lreplace] accepts all out of range indices (porter)
+
+2018-10-04 (bug) Prevent crash from NULL keyName (nijtmans)
+=> registry 1.3.3
+
+2018-10-26 (enhance) advance dde version (nijtmans)
+=> dde 1.4.1
+
+2018-10-27 tzdata updated to Olson's tzdata2018g (jima)
+
+2018-10-29 Update tcltest package for Travis support (fellows)
+=> tcltest 2.5.0
+
+2018-11-09 (bug)[35a8f1] overlong string length of some lists (owens)
+
+2018-11-16 (bug)[00d04c] Repair [binary encode base64] (sebres)
+
+- Released 8.6.9, November 16, 2018 - details at http://core.tcl-lang.org/tcl/ -
+
Changes to 8.7a1 include all changes to the 8.6 line through 8.6.7,
plus the following, which focuses on the high-level feature changes
in this changeset (new minor version) rather than bug fixes:
@@ -8849,7 +8913,7 @@ in this changeset (new minor version) rather than bug fixes:
2016-10-04 Server socket on port 0 chooses port supporting IPv4 * IPv6 (max)
-2016-11-25 [array named -regexp] supports backrefs (goth)
+2016-11-25 [array names -regexp] supports backrefs (goth)
2017-01-04 (TIP 456) New routine Tcl_OpenTcpServerEx() (limeboy)
@@ -8884,3 +8948,5 @@ in this changeset (new minor version) rather than bug fixes:
2018-03-12 (TIP 499) custom locale preference list (oehlmann)
=> msgcat 1.7.0
+
+- Released 8.7a3, Nov 30, 2018 --- http://core.tcl-lang.org/tcl/ for details -
diff --git a/compat/fixstrtod.c b/compat/fixstrtod.c
deleted file mode 100644
index 63fb8ef..0000000
--- a/compat/fixstrtod.c
+++ /dev/null
@@ -1,36 +0,0 @@
-/*
- * fixstrtod.c --
- *
- * Source code for the "fixstrtod" procedure. This procedure is
- * used in place of strtod under Solaris 2.4, in order to fix
- * a bug where the "end" pointer gets set incorrectly.
- *
- * Copyright (c) 1995 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#include <stdio.h>
-
-#undef strtod
-
-/*
- * Declare strtod explicitly rather than including stdlib.h, since in
- * somes systems (e.g. SunOS 4.1.4) stdlib.h doesn't declare strtod.
- */
-
-extern double strtod(char *, char **);
-
-double
-fixstrtod(
- char *string,
- char **endPtr)
-{
- double d;
- d = strtod(string, endPtr);
- if ((endPtr != NULL) && (*endPtr != string) && ((*endPtr)[-1] == 0)) {
- *endPtr -= 1;
- }
- return d;
-}
diff --git a/compat/stdlib.h b/compat/stdlib.h
index 0ad4c1d..6900be3 100644
--- a/compat/stdlib.h
+++ b/compat/stdlib.h
@@ -29,7 +29,6 @@ extern char * malloc(unsigned int numBytes);
extern void qsort(void *base, int n, int size, int (*compar)(
const void *element1, const void *element2));
extern char * realloc(char *ptr, unsigned int numBytes);
-extern double strtod(const char *string, char **endPtr);
extern long strtol(const char *string, char **endPtr, int base);
extern unsigned long strtoul(const char *string, char **endPtr, int base);
diff --git a/compat/strtod.c b/compat/strtod.c
deleted file mode 100644
index 9643c09..0000000
--- a/compat/strtod.c
+++ /dev/null
@@ -1,252 +0,0 @@
-/*
- * strtod.c --
- *
- * Source code for the "strtod" library procedure.
- *
- * Copyright (c) 1988-1993 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#include "tclInt.h"
-
-#ifndef TRUE
-#define TRUE 1
-#define FALSE 0
-#endif
-#ifndef NULL
-#define NULL 0
-#endif
-
-static const int maxExponent = 511; /* Largest possible base 10 exponent. Any
- * exponent larger than this will already
- * produce underflow or overflow, so there's
- * no need to worry about additional digits.
- */
-static const double powersOf10[] = { /* Table giving binary powers of 10. Entry */
- 10., /* is 10^2^i. Used to convert decimal */
- 100., /* exponents into floating-point numbers. */
- 1.0e4,
- 1.0e8,
- 1.0e16,
- 1.0e32,
- 1.0e64,
- 1.0e128,
- 1.0e256
-};
-
-/*
- *----------------------------------------------------------------------
- *
- * strtod --
- *
- * This procedure converts a floating-point number from an ASCII
- * decimal representation to internal double-precision format.
- *
- * Results:
- * The return value is the double-precision floating-point
- * representation of the characters in string. If endPtr isn't
- * NULL, then *endPtr is filled in with the address of the
- * next character after the last one that was part of the
- * floating-point number.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-double
-strtod(
- const char *string, /* A decimal ASCII floating-point number,
- * optionally preceded by white space. Must
- * have form "-I.FE-X", where I is the integer
- * part of the mantissa, F is the fractional
- * part of the mantissa, and X is the
- * exponent. Either of the signs may be "+",
- * "-", or omitted. Either I or F may be
- * omitted, or both. The decimal point isn't
- * necessary unless F is present. The "E" may
- * actually be an "e". E and X may both be
- * omitted (but not just one). */
- char **endPtr) /* If non-NULL, store terminating character's
- * address here. */
-{
- int sign, expSign = FALSE;
- double fraction, dblExp;
- const double *d;
- register const char *p;
- register int c;
- int exp = 0; /* Exponent read from "EX" field. */
- int fracExp = 0; /* Exponent that derives from the fractional
- * part. Under normal circumstatnces, it is
- * the negative of the number of digits in F.
- * However, if I is very long, the last digits
- * of I get dropped (otherwise a long I with a
- * large negative exponent could cause an
- * unnecessary overflow on I alone). In this
- * case, fracExp is incremented one for each
- * dropped digit. */
- int mantSize; /* Number of digits in mantissa. */
- int decPt; /* Number of mantissa digits BEFORE decimal
- * point. */
- const char *pExp; /* Temporarily holds location of exponent in
- * string. */
-
- /*
- * Strip off leading blanks and check for a sign.
- */
-
- p = string;
- while (isspace(UCHAR(*p))) {
- p += 1;
- }
- if (*p == '-') {
- sign = TRUE;
- p += 1;
- } else {
- if (*p == '+') {
- p += 1;
- }
- sign = FALSE;
- }
-
- /*
- * Count the number of digits in the mantissa (including the decimal
- * point), and also locate the decimal point.
- */
-
- decPt = -1;
- for (mantSize = 0; ; mantSize += 1)
- {
- c = *p;
- if (!isdigit(c)) {
- if ((c != '.') || (decPt >= 0)) {
- break;
- }
- decPt = mantSize;
- }
- p += 1;
- }
-
- /*
- * Now suck up the digits in the mantissa. Use two integers to collect 9
- * digits each (this is faster than using floating-point). If the mantissa
- * has more than 18 digits, ignore the extras, since they can't affect the
- * value anyway.
- */
-
- pExp = p;
- p -= mantSize;
- if (decPt < 0) {
- decPt = mantSize;
- } else {
- mantSize -= 1; /* One of the digits was the point. */
- }
- if (mantSize > 18) {
- fracExp = decPt - 18;
- mantSize = 18;
- } else {
- fracExp = decPt - mantSize;
- }
- if (mantSize == 0) {
- fraction = 0.0;
- p = string;
- goto done;
- } else {
- int frac1, frac2;
-
- frac1 = 0;
- for ( ; mantSize > 9; mantSize -= 1) {
- c = *p;
- p += 1;
- if (c == '.') {
- c = *p;
- p += 1;
- }
- frac1 = 10*frac1 + (c - '0');
- }
- frac2 = 0;
- for (; mantSize > 0; mantSize -= 1) {
- c = *p;
- p += 1;
- if (c == '.') {
- c = *p;
- p += 1;
- }
- frac2 = 10*frac2 + (c - '0');
- }
- fraction = (1.0e9 * frac1) + frac2;
- }
-
- /*
- * Skim off the exponent.
- */
-
- p = pExp;
- if ((*p == 'E') || (*p == 'e')) {
- p += 1;
- if (*p == '-') {
- expSign = TRUE;
- p += 1;
- } else {
- if (*p == '+') {
- p += 1;
- }
- expSign = FALSE;
- }
- if (!isdigit(UCHAR(*p))) {
- p = pExp;
- goto done;
- }
- while (isdigit(UCHAR(*p))) {
- exp = exp * 10 + (*p - '0');
- p += 1;
- }
- }
- if (expSign) {
- exp = fracExp - exp;
- } else {
- exp = fracExp + exp;
- }
-
- /*
- * Generate a floating-point number that represents the exponent. Do this
- * by processing the exponent one bit at a time to combine many powers of
- * 2 of 10. Then combine the exponent with the fraction.
- */
-
- if (exp < 0) {
- expSign = TRUE;
- exp = -exp;
- } else {
- expSign = FALSE;
- }
- if (exp > maxExponent) {
- exp = maxExponent;
- errno = ERANGE;
- }
- dblExp = 1.0;
- for (d = powersOf10; exp != 0; exp >>= 1, ++d) {
- if (exp & 01) {
- dblExp *= *d;
- }
- }
- if (expSign) {
- fraction /= dblExp;
- } else {
- fraction *= dblExp;
- }
-
- done:
- if (endPtr != NULL) {
- *endPtr = (char *) p;
- }
-
- if (sign) {
- return -fraction;
- }
- return fraction;
-}
diff --git a/compat/zlib/contrib/minizip/crypt.h b/compat/zlib/contrib/minizip/crypt.h
index 1e9e820..c422c26 100644
--- a/compat/zlib/contrib/minizip/crypt.h
+++ b/compat/zlib/contrib/minizip/crypt.h
@@ -29,6 +29,12 @@
#define CRC32(c, b) ((*(pcrc_32_tab+(((int)(c) ^ (b)) & 0xff))) ^ ((c) >> 8))
+#ifdef Z_U4
+ typedef Z_U4 z_crc_t;
+#else
+ typedef unsigned long z_crc_t;
+#endif
+
/***********************************************************************
* Return the next byte in the pseudo-random sequence
*/
diff --git a/compat/zlib/contrib/minizip/miniunz.c b/compat/zlib/contrib/minizip/miniunz.c
index 3d65401..0518dd9 100644
--- a/compat/zlib/contrib/minizip/miniunz.c
+++ b/compat/zlib/contrib/minizip/miniunz.c
@@ -97,7 +97,7 @@ void change_file_date(filename,dosdate,tmu_date)
SetFileTime(hFile,&ftm,&ftLastAcc,&ftm);
CloseHandle(hFile);
#else
-#ifdef unix || __APPLE__
+#if defined(unix) || defined(__APPLE__)
struct utimbuf ut;
struct tm newdate;
newdate.tm_sec = tmu_date.tm_sec;
diff --git a/compat/zlib/contrib/minizip/minizip.c b/compat/zlib/contrib/minizip/minizip.c
index 17582d0..2dd9f10 100644
--- a/compat/zlib/contrib/minizip/minizip.c
+++ b/compat/zlib/contrib/minizip/minizip.c
@@ -92,7 +92,7 @@ uLong filetime(f, tmzip, dt)
return ret;
}
#else
-#ifdef unix || __APPLE__
+#if defined(unix) || defined(__APPLE__)
uLong filetime(f, tmzip, dt)
char *f; /* name of file to get info on */
tm_zip *tmzip; /* return value: access, modific. and creation times */
diff --git a/doc/Exit.3 b/doc/Exit.3
index 9a04db3..a52b2e1 100644
--- a/doc/Exit.3
+++ b/doc/Exit.3
@@ -134,6 +134,9 @@ finalization of Tcl's subsystems via \fBTcl_Finalize\fR at an
appropriate time. The argument passed to \fIproc\fR when it is
invoked will be the exit status code (as passed to \fBTcl_Exit\fR)
cast to a ClientData value.
+.PP
+\fBTcl_SetExitProc\fR can not be used in stub-enabled extensions. Its symbol
+entry in the stub table is deprecated and it will be removed in Tcl 9.0.
.SH "SEE ALSO"
exit(n)
.SH KEYWORDS
diff --git a/doc/FindExec.3 b/doc/FindExec.3
index 1fd57db..149ef8a 100644
--- a/doc/FindExec.3
+++ b/doc/FindExec.3
@@ -58,6 +58,8 @@ internal full path name of the executable file as computed by
equivalent to the \fBinfo nameofexecutable\fR command. NULL
is returned if the internal full path name has not been
computed or unknown.
-
+.PP
+\fBTcl_FindExecutable\fR can not be used in stub-enabled extensions. Its symbol
+entry in the stub table is deprecated and it will be removed in Tcl 9.0.
.SH KEYWORDS
binary, executable file
diff --git a/doc/InitSubSyst.3 b/doc/InitSubSyst.3
new file mode 100644
index 0000000..eef801f
--- /dev/null
+++ b/doc/InitSubSyst.3
@@ -0,0 +1,31 @@
+'\"
+'\" Copyright (c) 2018 Tcl Core Team
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.so man.macros
+.TH Tcl_InitSubsystems 3 8.7 Tcl "Tcl Library Procedures"
+.BS
+.SH NAME
+Tcl_InitSubsystems \- initialize the Tcl library.
+.SH SYNOPSIS
+.nf
+\fB#include <tcl.h>\fR
+.sp
+void
+\fBTcl_InitSubsystems\fR(\fIvoid\fR)
+.SH DESCRIPTION
+.PP
+The \fBTcl_InitSubsystems\fR procedure initializes the Tcl
+library. This procedure is typically invoked as the very
+first thing in the application's main program.
+.PP
+\fBTcl_InitSubsystems\fR is very similar in use to
+\fBTcl_FindExecutable\fR. It can be used when Tcl is
+used as utility library, no other encodings than utf8,
+iso8859-1 or unicode are used, and no interest exists in the
+value of \fBinfo nameofexecutable\fR. The system encoding will not
+be extracted from the environment, but falls back to iso8859-1.
+.SH KEYWORDS
+binary, executable file
diff --git a/doc/Panic.3 b/doc/Panic.3
index 573a239..ba39ddf 100644
--- a/doc/Panic.3
+++ b/doc/Panic.3
@@ -18,7 +18,7 @@ void
void
\fBTcl_PanicVA\fR(\fIformat\fR, \fIargList\fR)
.sp
-const char *
+void
\fBTcl_SetPanicProc\fR(\fIpanicProc\fR)
.sp
void
@@ -93,9 +93,11 @@ have a panic message displayed the same way that panic messages from Tcl
will be displayed.
.PP
\fBTcl_PanicVA\fR is the same as \fBTcl_Panic\fR except that instead of
-taking a variable number of arguments it takes an argument list.
+taking a variable number of arguments it takes an argument list. This
+function is deprecated and will be removed in Tcl 9.0.
.PP
-The return value is the Tcl version.
+This function can not be used in stub-enabled extensions. Its symbol
+entry in the stub table is deprecated and it will be removed in Tcl 9.0.
.SH "SEE ALSO"
abort(3), printf(3), exec(n), format(n)
.SH KEYWORDS
diff --git a/doc/StaticPkg.3 b/doc/StaticPkg.3
index 41e2d65..8d04cd1 100644
--- a/doc/StaticPkg.3
+++ b/doc/StaticPkg.3
@@ -64,6 +64,9 @@ the event of an error it should set the interpreter's result to point to an
error message. The result or error from the initialization procedure will
be returned as the result of the \fBload\fR command that caused the
initialization procedure to be invoked.
+.PP
+This function can not be used in stub-enabled extensions. Its symbol
+entry in the stub table is deprecated and it will be removed in Tcl 9.0.
.SH KEYWORDS
initialization procedure, package, static linking
.SH "SEE ALSO"
diff --git a/doc/Tcl_Main.3 b/doc/Tcl_Main.3
index 3ec33d1..816dfeb 100644
--- a/doc/Tcl_Main.3
+++ b/doc/Tcl_Main.3
@@ -189,6 +189,8 @@ procedure (if any) returns. In non-interactive mode, after
\fBTcl_Main\fR evaluates the startup script, and the main loop
procedure (if any) returns, \fBTcl_Main\fR will also evaluate
the \fBexit\fR command.
+.PP
+This function can not be used in stub-enabled extensions.
.SH "SEE ALSO"
tclsh(1), Tcl_GetStdChannel(3), Tcl_StandardChannels(3), Tcl_AppInit(3),
exit(n), encoding(n)
diff --git a/doc/cookiejar.n b/doc/cookiejar.n
new file mode 100644
index 0000000..ac71759
--- /dev/null
+++ b/doc/cookiejar.n
@@ -0,0 +1,217 @@
+'\"
+'\" Copyright (c) 2014-2018 Donal K. Fellows.
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH "cookiejar" n 0.1 http "Tcl Bundled Packages"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+cookiejar \- Implementation of the Tcl http package cookie jar protocol
+.SH SYNOPSIS
+.nf
+\fBpackage require\fR \fBcookiejar\fR ?\fB0.1\fR?
+
+\fB::http::cookiejar configure\fR ?\fIoptionName\fR? ?\fIoptionValue\fR?
+\fB::http::cookiejar create\fR \fIname\fR ?\fIfilename\fR?
+\fB::http::cookiejar new\fR ?\fIfilename\fR?
+
+\fIcookiejar\fR \fBdestroy\fR
+\fIcookiejar\fR \fBforceLoadDomainData\fR
+\fIcookiejar\fR \fBgetCookies\fR \fIprotocol host path\fR
+\fIcookiejar\fR \fBstoreCookie\fR \fIoptions\fR
+\fIcookiejar\fR \fBlookup\fR ?\fIhost\fR? ?\fIkey\fR?
+.fi
+.SH DESCRIPTION
+.PP
+The cookiejar package provides an implementation of the http package's cookie
+jar protocol using an SQLite database. It provides one main command,
+\fB::http::cookiejar\fR, which is a TclOO class that should be instantiated to
+create a cookie jar that manages a particular HTTP session.
+.PP
+The database management policy can be controlled at the package level by the
+\fBconfigure\fR method on the \fB::http::cookiejar\fR class object:
+.TP
+\fB::http::cookiejar configure\fR ?\fIoptionName\fR? ?\fIoptionValue\fR?
+.
+If neither \fIoptionName\fR nor \fIoptionValue\fR are supplied, this returns a
+copy of the configuration as a Tcl dictionary. If just \fIoptionName\fR is
+supplied, just the value of the named option is returned. If both
+\fIoptionName\fR and \fIoptionValue\fR are given, the named option is changed
+to be the given value.
+.RS
+.PP
+Supported options are:
+.TP
+\fB\-domainfile \fIfilename\fR
+.
+A file (defaulting to within the cookiejar package) with a description of the
+list of top-level domains (e.g., \fB.com\fR or \fB.co.jp\fR). Such domains
+\fImust not\fR accept cookies set upon them. Note that the list of such
+domains is both security-sensitive and \fInot\fR constant and should be
+periodically refetched. Cookie jars maintain their own cache of the domain
+list.
+.TP
+\fB\-domainlist \fIurl\fR
+.
+A URL to fetch the list of top-level domains (e.g., \fB.com\fR or
+\fB.co.jp\fR) from. Such domains \fImust not\fR accept cookies set upon
+them. Note that the list of such domains is both security-sensitive and
+\fInot\fR constant and should be periodically refetched. Cookie jars maintain
+their own cache of the domain list.
+.TP
+\fB\-domainrefresh \fIintervalMilliseconds\fR
+.
+The number of milliseconds between checks of the \fI\-domainlist\fR for new
+domains.
+.TP
+\fB\-loglevel \fIlevel\fR
+.
+The logging level of this package. The logging level must be (in order of
+decreasing verbosity) one of \fBdebug\fR, \fBinfo\fR, \fBwarn\fR, or
+\fBerror\fR.
+.TP
+\fB\-offline \fIflag\fR
+.
+Allows the cookie managment engine to be placed into offline mode. In offline
+mode, the list of domains is read immediately from the file configured in the
+\fB\-domainfile\fR option, and the \fB\-domainlist\fR option is not used; it
+also makes the \fB\-domainrefresh\fR option be effectively ignored.
+.TP
+\fB\-purgeold \fIintervalMilliseconds\fR
+.
+The number of milliseconds between checks of the database for expired
+cookies; expired cookies are deleted.
+.TP
+\fB\-retain \fIcookieCount\fR
+.
+The maximum number of cookies to retain in the database.
+.TP
+\fB\-vacuumtrigger \fIdeletionCount\fR
+.
+A count of the number of persistent cookie deletions to go between vacuuming
+the database.
+.RE
+.PP
+Cookie jar instances may be made with any of the standard TclOO instance
+creation methods (\fBcreate\fR or \fRnew\fR).
+.TP
+\fB::http::cookiejar new\fR ?\fIfilename\fR?
+.
+If a \fIfilename\fR argument is provided, it is the name of a file containing
+an SQLite database that will contain the persistent cookies maintained by the
+cookie jar; the database will be created if the file does not already
+exist. If \fIfilename\fR is not supplied, the database will be held entirely within
+memory, which effectively forces all cookies within it to be session cookies.
+.SS "INSTANCE METHODS"
+.PP
+The following methods are supported on the instances:
+.TP
+\fIcookiejar\fR \fBdestroy\fR
+.
+This is the standard TclOO destruction method. It does \fInot\fR delete the
+SQLite database if it is written to disk. Callers are responsible for ensuring
+that the cookie jar is not in use by the http package at the time of
+destruction.
+.TP
+\fIcookiejar\fR \fBforceLoadDomainData\fR
+.
+This method causes the cookie jar to immediately load (and cache) the domain
+list data. The domain list will be loaded from the \fB\-domainlist\fR
+configured a the package level if that is enabled, and otherwise will be
+obtained from the \fB\-domainfile\fR configured at the package level.
+.TP
+\fIcookiejar\fR \fBgetCookies\fR \fIprotocol host path\fR
+.
+This method obtains the cookies for a particular HTTP request. \fIThis
+implements the http cookie jar protocol.\fR
+.TP
+\fIcookiejar\fR \fBpolicyAllow\fR \fIoperation domain path\fR
+.
+This method is called by the \fBstoreCookie\fR method to get a decision on
+whether to allow \fIoperation\fR to be performed for the \fIdomain\fR and
+\fIpath\fR. This is checked immediately before the database is updated but
+after the built-in security checks are done, and should return a boolean
+value; if the value is false, the operation is rejected and the database is
+not modified. The supported \fIoperation\fRs are:
+.RS
+.TP
+\fBdelete\fR
+.
+The \fIdomain\fR is seeking to delete a cookie.
+.TP
+\fBsession\fR
+.
+The \fIdomain\fR is seeking to create or update a session cookie.
+.TP
+\fBset\fR
+.
+The \fIdomain\fR is seeking to create or update a persistent cookie (with a
+defined lifetime).
+.PP
+The default implementation of this method just returns true, but subclasses of
+this class may impose their own rules.
+.RE
+.TP
+\fIcookiejar\fR \fBstoreCookie\fR \fIoptions\fR
+.
+This method stores a single cookie from a particular HTTP response. Cookies
+that fail security checks are ignored. \fIThis implements the http cookie jar
+protocol.\fR
+.TP
+\fIcookiejar\fR \fBlookup\fR ?\fIhost\fR? ?\fIkey\fR?
+.
+This method looks a cookie by exact host (or domain) matching. If neither
+\fIhost\fR nor \fIkey\fR are supplied, the list of hosts for which a cookie is
+stored is returned. If just \fIhost\fR (which may be a hostname or a domain
+name) is supplied, the list of cookie keys stored for that host is returned.
+If both \fIhost\fR and \fIkey\fR are supplied, the value for that key is
+returned; it is an error if no such host or key match exactly.
+.SH "EXAMPLES"
+.PP
+The simplest way of using a cookie jar is to just permanently configure it at
+the start of the application.
+.PP
+.CS
+package require http
+\fBpackage require cookiejar\fR
+
+set cookiedb ~/.tclcookies.db
+http::configure -cookiejar [\fBhttp::cookiejar new\fR $cookiedb]
+
+# No further explicit steps are required to use cookies
+set tok [http::geturl http://core.tcl.tk/]
+.CE
+.PP
+To only allow a particular domain to use cookies, perhaps because you only
+want to enable a particular host to create and manipulate sessions, create a
+subclass that imposes that policy.
+.PP
+.CS
+package require http
+\fBpackage require cookiejar\fR
+
+oo::class create MyCookieJar {
+ superclass \fBhttp::cookiejar\fR
+
+ method \fBpolicyAllow\fR {operation domain path} {
+ return [expr {$domain eq "my.example.com"}]
+ }
+}
+
+set cookiedb ~/.tclcookies.db
+http::configure -cookiejar [MyCookieJar new $cookiedb]
+
+# No further explicit steps are required to use cookies
+set tok [http::geturl http://core.tcl.tk/]
+.CE
+.SH "SEE ALSO"
+http(n), oo::class(n), sqlite3(n)
+.SH KEYWORDS
+cookie, internet, security policy, www
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/define.n b/doc/define.n
index 883d5fa..a84028b 100644
--- a/doc/define.n
+++ b/doc/define.n
@@ -34,7 +34,11 @@ either the \fIdefScript\fR argument or by the \fIsubcommand\fR and following
\fIarg\fR arguments; when the second is present, it is exactly as if all the
arguments from \fIsubcommand\fR onwards are made into a list and that list is
used as the \fIdefScript\fR argument.
-.SS "CONFIGURING CLASSES"
+.PP
+Note that the constructor for \fBoo::class\fR will call \fBoo::define\fR on
+the script argument that it is provided. This is a convenient way to create
+and define a class in one step.
+.SH "CONFIGURING CLASSES"
.PP
The following commands are supported in the \fIdefScript\fR for
\fBoo::define\fR, each of which may also be used in the \fIsubcommand\fR form:
@@ -70,13 +74,11 @@ namespace of the constructor will be a namespace that is unique to the object
being constructed. Within the constructor, the \fBnext\fR command should be
used to call the superclasses' constructors. If \fIbodyScript\fR is the empty
string, the constructor will be deleted.
-.TP
-\fBdeletemethod\fI name\fR ?\fIname ...\fR?
-.
-This deletes each of the methods called \fIname\fR from a class. The methods
-must have previously existed in that class. Does not affect the superclasses
-of the class, nor does it affect the subclasses or instances of the class
-(except when they have a call chain through the class being modified).
+.RS
+.PP
+Classes do not need to have a constructor defined. If none is specified, the
+superclass's constructor will be used instead.
+.RE
.TP
\fBdestructor\fI bodyScript\fR
.
@@ -102,16 +104,6 @@ class being defined. Note that the methods themselves may be actually defined
by a superclass; subclass exports override superclass visibility, and may in
turn be overridden by instances.
.TP
-\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
-.
-This slot (see \fBSLOTTED DEFINITIONS\fR below)
-sets or updates the list of method names that are used to guard whether
-method call to instances of the class may be called and what the method's
-results are. Each \fImethodName\fR names a single filtering method (which may
-be exposed or not exposed); it is not an error for a non-existent method to be
-named since they may be defined by subclasses.
-By default, this slot works by appending.
-.TP
\fBforward\fI name cmdName \fR?\fIarg ...\fR?
.
This creates or updates a forwarded method called \fIname\fR. The method is
@@ -140,7 +132,7 @@ where the current namespace is the instance namespace of the class object
itself. This is useful for setting up, e.g., class-scoped variables.
.VE TIP478
.TP
-\fBmethod\fI name argList bodyScript\fR
+\fBmethod\fI name \fR?\fIoption\fR? \fIargList bodyScript\fR
.
This creates or updates a method that is implemented as a procedure-like
script. The name of the method is \fIname\fR, the formal arguments to the
@@ -150,23 +142,20 @@ the body of the method is evaluated, the current namespace of the method will
be a namespace that is unique to the current object. The method will be
exported if \fIname\fR starts with a lower-case letter, and non-exported
otherwise; this behavior can be overridden via \fBexport\fR and
-\fBunexport\fR.
+\fBunexport\fR
+.VS TIP519
+or by specifying \fB\-export\fR, \fB\-private\fR or \fB\-unexport\fR in the
+optional parameter \fIoption\fR.
+.VE TIP519
.RS
.PP
.VS TIP500
If in a private definition context (see the \fBprivate\fR definition command,
-below), this command creates private procedure-like methods.
+below) or if the \fB\-private\fR flag is given for \fIoption\fR, this command
+creates private procedure-like methods.
.VE TIP500
.RE
.TP
-\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
-.
-This slot (see \fBSLOTTED DEFINITIONS\fR below)
-sets or updates the list of additional classes that are to be mixed into
-all the instances of the class being defined. Each \fIclassName\fR argument
-names a single class that is to be mixed in.
-By default, this slot works by replacement.
-.TP
\fBprivate \fIcmd arg...\fR
.TP
\fBprivate \fIscript\fR
@@ -186,16 +175,6 @@ context.
.RE
.VE TIP500
.TP
-\fBrenamemethod\fI fromName toName\fR
-.
-This renames the method called \fIfromName\fR in a class to \fItoName\fR. The
-method must have previously existed in the class, and \fItoName\fR must not
-previously refer to a method in that class. Does not affect the superclasses
-of the class, nor does it affect the subclasses or instances of the class
-(except when they have a call chain through the class being modified). Does
-not change the export status of the method; if it was exported before, it will
-be afterwards.
-.TP
\fBself\fI subcommand arg ...\fR
.TP
\fBself\fI script\fR
@@ -269,23 +248,76 @@ namespace has a unique prefix that makes accidental use from other classes
extremely unlikely.
.VE TIP500
.RE
-.SS "CONFIGURING OBJECTS"
+.SS "ADVANCED CLASS CONFIGURATION OPTIONS"
.PP
-The following commands are supported in the \fIdefScript\fR for
-\fBoo::objdefine\fR, each of which may also be used in the \fIsubcommand\fR
-form:
+The following definitions are also supported, but are not required in simple
+programs:
+.TP
+\fBdefinitionnamespace\fR ?\fIkind\fR? \fInamespaceName\fR
+.VS TIP524
+This allows control over what namespace will be used by the \fBoo::define\fR
+and \fBoo::objdefine\fR commands to look up the definition commands they
+use. When any object has a definition operation applied to it, \fIthe class that
+it is an instance of\fR (and its superclasses and mixins) is consulted for
+what definition namespace to use. \fBoo::define\fR gets the class definition
+namespace, and \fB::oo::objdefine\fR gets the instance definition namespace,
+but both otherwise use the identical lookup operation.
+.RS
+.PP
+This sets the definition namespace of kind \fIkind\fR provided by the current
+class to \fInamespaceName\fR. The \fInamespaceName\fR must refer to a
+currently existing namespace, or must be the empty string (to stop the current
+class from having such a namespace connected). The \fIkind\fR, if supplied,
+must be either \fB\-class\fR (the default) or \fB\-instance\fR to specify the
+whether the namespace for use with \fBoo::define\fR or \fBoo::objdefine\fR
+respectively is being set.
+.PP
+The class \fBoo::object\fR has its instance namespace locked to
+\fB::oo::objdefine\fR, and the class \fBoo::class\fR has its class namespace
+locked to \fB::oo::define\fR. A consequence of this is that effective use of
+this feature for classes requires the definition of a metaclass.
+.RE
+.VE TIP524
.TP
-\fBclass\fI className\fR
+\fBdeletemethod\fI name\fR ?\fIname ...\fR?
.
-This allows the class of an object to be changed after creation. Note that the
-class's constructors are not called when this is done, and so the object may
-well be in an inconsistent state unless additional configuration work is done.
+This deletes each of the methods called \fIname\fR from a class. The methods
+must have previously existed in that class. Does not affect the superclasses
+of the class, nor does it affect the subclasses or instances of the class
+(except when they have a call chain through the class being modified).
.TP
-\fBdeletemethod\fI name\fR ?\fIname ...\fR
+\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
.
-This deletes each of the methods called \fIname\fR from an object. The methods
-must have previously existed in that object. Does not affect the classes that
-the object is an instance of.
+This slot (see \fBSLOTTED DEFINITIONS\fR below)
+sets or updates the list of method names that are used to guard whether
+method call to instances of the class may be called and what the method's
+results are. Each \fImethodName\fR names a single filtering method (which may
+be exposed or not exposed); it is not an error for a non-existent method to be
+named since they may be defined by subclasses.
+By default, this slot works by appending.
+.TP
+\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
+.
+This slot (see \fBSLOTTED DEFINITIONS\fR below)
+sets or updates the list of additional classes that are to be mixed into
+all the instances of the class being defined. Each \fIclassName\fR argument
+names a single class that is to be mixed in.
+By default, this slot works by replacement.
+.TP
+\fBrenamemethod\fI fromName toName\fR
+.
+This renames the method called \fIfromName\fR in a class to \fItoName\fR. The
+method must have previously existed in the class, and \fItoName\fR must not
+previously refer to a method in that class. Does not affect the superclasses
+of the class, nor does it affect the subclasses or instances of the class
+(except when they have a call chain through the class being modified). Does
+not change the export status of the method; if it was exported before, it will
+be afterwards.
+.SH "CONFIGURING OBJECTS"
+.PP
+The following commands are supported in the \fIdefScript\fR for
+\fBoo::objdefine\fR, each of which may also be used in the \fIsubcommand\fR
+form:
.TP
\fBexport\fI name \fR?\fIname ...\fR?
.
@@ -294,17 +326,6 @@ This arranges for each of the named methods, \fIname\fR, to be exported
being defined. Note that the methods themselves may be actually defined by a
class or superclass; object exports override class visibility.
.TP
-\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
-.
-This slot (see \fBSLOTTED DEFINITIONS\fR below)
-sets or updates the list of method names that are used to guard whether a
-method call to the object may be called and what the method's results are.
-Each \fImethodName\fR names a single filtering method (which may be exposed or
-not exposed); it is not an error for a non-existent method to be named. Note
-that the actual list of filters also depends on the filters set upon any
-classes that the object is an instance of.
-By default, this slot works by appending.
-.TP
\fBforward\fI name cmdName \fR?\fIarg ...\fR?
.
This creates or updates a forwarded object method called \fIname\fR. The
@@ -321,7 +342,7 @@ below), this command creates private forwarded methods.
.VE TIP500
.RE
.TP
-\fBmethod\fI name argList bodyScript\fR
+\fBmethod\fI name \fR?\fIoption\fR? \fIargList bodyScript\fR
.
This creates, updates or deletes an object method. The name of the method is
\fIname\fR, the formal arguments to the method (defined using the same format
@@ -329,12 +350,18 @@ as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the
method will be \fIbodyScript\fR. When the body of the method is evaluated, the
current namespace of the method will be a namespace that is unique to the
object. The method will be exported if \fIname\fR starts with a lower-case
-letter, and non-exported otherwise.
+letter, and non-exported otherwise;
+.VS TIP519
+this can be overridden by specifying \fB\-export\fR, \fB\-private\fR or
+\fB\-unexport\fR in the optional parameter \fIoption\fR, or via the
+\fBexport\fR and \fBunexport\fR definitions.
+.VE TIP519
.RS
.PP
.VS TIP500
If in a private definition context (see the \fBprivate\fR definition command,
-below), this command creates private procedure-like methods.
+below) or if the \fB\-private\fR flag is given for \fIoption\fR, this command
+creates private procedure-like methods.
.VE TIP500
.RE
.TP
@@ -363,19 +390,6 @@ difference in behavior when used in a private definition context.
.RE
.VE TIP500
.TP
-\fBrenamemethod\fI fromName toName\fR
-.
-This renames the method called \fIfromName\fR in an object to \fItoName\fR.
-The method must have previously existed in the object, and \fItoName\fR must
-not previously refer to a method in that object. Does not affect the classes
-that the object is an instance of. Does not change the export status of the
-method; if it was exported before, it will be afterwards.
-.TP
-\fBself \fR
-.VS TIP470
-This gives the name of the object currently being configured.
-.VE TIP470
-.TP
\fBunexport\fI name \fR?\fIname ...\fR?
.
This arranges for each of the named methods, \fIname\fR, to be not exported
@@ -408,6 +422,46 @@ instance namespace has a unique prefix that makes accidental use from
superclass methods extremely unlikely.
.VE TIP500
.RE
+.SS "ADVANCED OBJECT CONFIGURATION OPTIONS"
+.PP
+The following definitions are also supported, but are not required in simple
+programs:
+.TP
+\fBclass\fI className\fR
+.
+This allows the class of an object to be changed after creation. Note that the
+class's constructors are not called when this is done, and so the object may
+well be in an inconsistent state unless additional configuration work is done.
+.TP
+\fBdeletemethod\fI name\fR ?\fIname ...\fR
+.
+This deletes each of the methods called \fIname\fR from an object. The methods
+must have previously existed in that object. Does not affect the classes that
+the object is an instance of.
+.TP
+\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
+.
+This slot (see \fBSLOTTED DEFINITIONS\fR below)
+sets or updates the list of method names that are used to guard whether a
+method call to the object may be called and what the method's results are.
+Each \fImethodName\fR names a single filtering method (which may be exposed or
+not exposed); it is not an error for a non-existent method to be named. Note
+that the actual list of filters also depends on the filters set upon any
+classes that the object is an instance of.
+By default, this slot works by appending.
+.TP
+\fBrenamemethod\fI fromName toName\fR
+.
+This renames the method called \fIfromName\fR in an object to \fItoName\fR.
+The method must have previously existed in the object, and \fItoName\fR must
+not previously refer to a method in that object. Does not affect the classes
+that the object is an instance of. Does not change the export status of the
+method; if it was exported before, it will be afterwards.
+.TP
+\fBself \fR
+.VS TIP470
+This gives the name of the object currently being configured.
+.VE TIP470
.SH "PRIVATE METHODS"
.VS TIP500
When a class or instance has a private method, that private method can only be
@@ -659,6 +713,60 @@ $g update "emailaddress=admins"
\fI\(-> DB: update row ::oo::Obj125 with emailaddress=admins\fR
.CE
.VE TIP478
+.PP
+.VS TIP524
+This example shows how to make a custom definition for a class. Note that it
+explicitly includes delegation to the existing definition commands via
+\fBnamespace path\fR.
+.PP
+.CS
+namespace eval myDefinitions {
+ # Delegate to existing definitions where not overridden
+ namespace path \fB::oo::define\fR
+
+ # A custom type of method
+ proc exprmethod {name arguments body} {
+ tailcall \fBmethod\fR $name $arguments [list expr $body]
+ }
+
+ # A custom way of building a constructor
+ proc parameters args {
+ uplevel 1 [list \fBvariable\fR {*}$args]
+ set body [join [lmap a $args {
+ string map [list VAR $a] {
+ set [my varname VAR] [expr {double($VAR)}]
+ }
+ }] ";"]
+ tailcall \fBconstructor\fR $args $body
+ }
+}
+
+# Bind the namespace into a (very simple) metaclass for use
+oo::class create exprclass {
+ \fBsuperclass\fR oo::class
+ \fBdefinitionnamespace\fR myDefinitions
+}
+
+# Use the custom definitions
+exprclass create quadratic {
+ parameters a b c
+ exprmethod evaluate {x} {
+ ($a * $x**2) + ($b * $x) + $c
+ }
+}
+
+# Showing the resulting class and object in action
+quadratic create quad 1 2 3
+for {set x 0} {$x <= 4} {incr x} {
+ puts [format "quad(%d) = %.2f" $x [quad evaluate $x]]
+}
+ \fI\(-> quad(0) = 3.00\fR
+ \fI\(-> quad(1) = 6.00\fR
+ \fI\(-> quad(2) = 11.00\fR
+ \fI\(-> quad(3) = 18.00\fR
+ \fI\(-> quad(4) = 27.00\fR
+.CE
+.VE TIP524
.SH "SEE ALSO"
next(n), oo::class(n), oo::object(n)
.SH KEYWORDS
diff --git a/doc/http.n b/doc/http.n
index a986704..7845e60 100644
--- a/doc/http.n
+++ b/doc/http.n
@@ -99,6 +99,15 @@ comma-separated list of mime type patterns that you are
willing to receive. For example,
.QW "image/gif, image/jpeg, text/*" .
.TP
+\fB\-cookiejar\fR \fIcommand\fR
+.VS TIP406
+The cookie store for the package to use to manage HTTP cookies.
+\fIcommand\fR is a command prefix list; if the empty list (the
+default value) is used, no cookies will be sent by requests or stored
+from responses. The command indicated by \fIcommand\fR, if supplied,
+must obey the \fBCOOKIE JAR PROTOCOL\fR described below.
+.VE TIP406
+.TP
\fB\-pipeline\fR \fIboolean\fR
.
Specifies whether HTTP/1.1 transactions on a persistent socket will be
@@ -770,6 +779,108 @@ Subsequent GET and HEAD requests in a failed pipeline will also be retried.
that the retry is appropriate\fR - specifically, the application must know
that if the failed POST successfully modified the state of the server, a repeat POST
would have no adverse effect.
+.VS TIP406
+.SH "COOKIE JAR PROTOCOL"
+.PP
+Cookies are short key-value pairs used to implement sessions within the
+otherwise-stateless HTTP protocol. (See RFC 6265 for details; Tcl does not
+implement the Cookie2 protocol as that is rarely seen in the wild.)
+.PP
+Cookie storage managment commands \(em
+.QW "cookie jars"
+\(em must support these subcommands which form the HTTP cookie storage
+management protocol. Note that \fIcookieJar\fR below does not have to be a
+command name; it is properly a command prefix (a Tcl list of words that will
+be expanded in place) and admits many possible implementations.
+.PP
+Though not formally part of the protocol, it is expected that particular
+values of \fIcookieJar\fR will correspond to sessions; it is up to the caller
+of \fB::http::config\fR to decide what session applies and to manage the
+deletion of said sessions when they are no longer desired (which should be
+when they not configured as the current cookie jar).
+.TP
+\fIcookieJar \fBgetCookies \fIprotocol host requestPath\fR
+.
+This command asks the cookie jar what cookies should be supplied for a
+particular request. It should take the \fIprotocol\fR (typically \fBhttp\fR or
+\fBhttps\fR), \fIhost\fR name and \fIrequestPath\fR (parsed from the \fIurl\fR
+argument to \fB::http::geturl\fR) and return a list of cookie keys and values
+that describe the cookies to supply to the remote host. The list must have an
+even number of elements.
+.RS
+.PP
+There should only ever be at most one cookie with a particular key for any
+request (typically the one with the most specific \fIhost\fR/domain match and
+most specific \fIrequestPath\fR/path match), but there may be many cookies
+with different names in any request.
+.RE
+.TP
+\fIcookieJar \fBstoreCookie \fIcookieDictionary\fR
+.
+This command asks the cookie jar to store a particular cookie that was
+returned by a request; the result of this command is ignored. The cookie
+(which will have been parsed by the http package) is described by a
+dictionary, \fIcookieDictionary\fR, that may have the following keys:
+.RS
+.TP
+\fBdomain\fR
+.
+This is always present. Its value describes the domain hostname \fIor
+prefix\fR that the cookie should be returned for. The checking of the domain
+against the origin (below) should be careful since sites that issue cookies
+should only do so for domains related to themselves. Cookies that do not obey
+a relevant origin matching rule should be ignored.
+.TP
+\fBexpires\fR
+.
+This is optional. If present, the cookie is intended to be a persistent cookie
+and the value of the option is the Tcl timestamp (in seconds from the same
+base as \fBclock seconds\fR) of when the cookie expires (which may be in the
+past, which should result in the cookie being deleted immediately). If absent,
+the cookie is intended to be a session cookie that should be not persisted
+beyond the lifetime of the cookie jar.
+.TP
+\fBhostonly\fR
+.
+This is always present. Its value is a boolean that describes whether the
+cookie is a single host cookie (true) or a domain-level cookie (false).
+.TP
+\fBhttponly\fR
+.
+This is always present. Its value is a boolean that is true when the site
+wishes the cookie to only ever be used with HTTP (or HTTPS) traffic.
+.TP
+\fBkey\fR
+.
+This is always present. Its value is the \fIkey\fR of the cookie, which is
+part of the information that must be return when sending this cookie back in a
+future request.
+.TP
+\fBorigin\fR
+.
+This is always present. Its value describes where the http package believes it
+received the cookie from, which may be useful for checking whether the
+cookie's domain is valid.
+.TP
+\fBpath\fR
+.
+This is always present. Its value describes the path prefix of requests to the
+cookie domain where the cookie should be returned.
+.TP
+\fBsecure\fR
+.
+This is always present. Its value is a boolean that is true when the cookie
+should only used on requests sent over secure channels (typically HTTPS).
+.TP
+\fBvalue\fR
+.
+This is always present. Its value is the value of the cookie, which is part of
+the information that must be return when sending this cookie back in a future
+request.
+.PP
+Other keys may always be ignored; they have no meaning in this protocol.
+.RE
+.VE TIP406
.SH EXAMPLE
.PP
This example creates a procedure to copy a URL to a file while printing a
diff --git a/doc/idna.n b/doc/idna.n
new file mode 100644
index 0000000..744bf67
--- /dev/null
+++ b/doc/idna.n
@@ -0,0 +1,88 @@
+'\"
+'\" Copyright (c) 2014-2018 Donal K. Fellows.
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH "idna" n 0.1 http "Tcl Bundled Packages"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+tcl::idna \- Support for normalization of Internationalized Domain Names
+.SH SYNOPSIS
+.nf
+package require tcl::idna 1.0
+
+\fBtcl::idna decode\fR \fIhostname\fR
+\fBtcl::idna encode\fR \fIhostname\fR
+\fBtcl::idna puny decode\fR \fIstring\fR ?\fIcase\fR?
+\fBtcl::idna puny encode\fR \fIstring\fR ?\fIcase\fR?
+\fBtcl::idna version\fR
+.fi
+.SH DESCRIPTION
+This package provides an implementation of the punycode scheme used in
+Internationalised Domain Names, and some access commands. (See RFC 3492 for a
+description of punycode.)
+.TP
+\fBtcl::idna decode\fR \fIhostname\fR
+.
+This command takes the name of a host that potentially contains
+punycode-encoded character sequences, \fIhostname\fR, and returns the hostname
+as might be displayed to the user. Note that there are often UNICODE
+characters that have extremely similar glyphs, so care should be taken with
+displaying hostnames to users.
+.TP
+\fBtcl::idna encode\fR \fIhostname\fR
+.
+This command takes the name of a host as might be displayed to the user,
+\fIhostname\fR, and returns the version of the hostname with characters not
+permitted in basic hostnames encoded with punycode.
+.TP
+\fBtcl::idna puny\fR \fIsubcommand ...\fR
+.
+This command provides direct access to the basic punycode encoder and
+decoder. It supports two \fIsubcommand\fRs:
+.RS
+.TP
+\fBtcl::idna puny decode\fR \fIstring\fR ?\fIcase\fR?
+.
+This command decodes the punycode-encoded string, \fIstring\fR, and returns
+the result. If \fIcase\fR is provided, it is a boolean to make the case be
+folded to upper case (if \fIcase\fR is true) or lower case (if \fIcase\fR is
+false) during the decoding process; if omitted, no case transformation is
+applied.
+.TP
+\fBtcl::idna puny encode\fR \fIstring\fR ?\fIcase\fR?
+.
+This command encodes the string, \fIstring\fR, and returns the
+punycode-encoded version of the string. If \fIcase\fR is provided, it is a
+boolean to make the case be folded to upper case (if \fIcase\fR is true) or
+lower case (if \fIcase\fR is false) during the encoding process; if omitted,
+no case transformation is applied.
+.RE
+.TP
+\fBtcl::idna version\fR
+.
+This returns the version of the \fBtcl::idna\fR package.
+.SH "EXAMPLE"
+.PP
+This is an example of how punycoding of a string works:
+.PP
+.CS
+package require tcl::idna
+
+puts [\fBtcl::idna puny encode\fR "abc\(->def"]
+# prints: \fIabcdef-kn2c\fR
+puts [\fBtcl::idna puny decode\fR "abcdef-kn2c"]
+# prints: \fIabc\(->def\fR
+.CE
+'\" TODO: show how it handles a real domain name
+.SH "SEE ALSO"
+http(n), cookiejar(n)
+.SH KEYWORDS
+internet, www
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/info.n b/doc/info.n
index 5732a13..cf5a438 100644
--- a/doc/info.n
+++ b/doc/info.n
@@ -481,6 +481,24 @@ list; the first element is the list of arguments to the method in a form
suitable for passing to another call to \fBproc\fR or a method definition, and
the second element is the body of the method.
.TP
+\fBinfo class definitionnamespace\fI class\fR ?\fIkind\fR?
+.VS TIP524
+This subcommand returns the definition namespace for \fIkind\fR definitions of
+the class \fIclass\fR; the definition namespace only affects the instances of
+\fIclass\fR, not \fIclass\fR itself. The \fIkind\fR can be either
+\fB\-class\fR to return the definition namespace used for \fBoo::define\fR, or
+\fB\-instance\fR to return the definition namespace used for
+\fBoo::objdefine\fR; the \fB\-class\fR kind is default (though this is only
+actually useful on classes that are subclasses of \fBoo::class\fR).
+.RS
+.PP
+If \fIclass\fR does not provide a definition namespace of the specified kind,
+this command returns the empty string. In those circumstances, the
+\fBoo::define\fR and \fBoo::objdefine\fR commands look up which definition
+namespace to use using the class inheritance hierarchy.
+.RE
+.VE TIP524
+.TP
\fBinfo class destructor\fI class\fR
.
This subcommand returns the body of the destructor of class \fIclass\fR. If no
diff --git a/doc/lpop.n b/doc/lpop.n
new file mode 100644
index 0000000..0ce8ff8
--- /dev/null
+++ b/doc/lpop.n
@@ -0,0 +1,96 @@
+'\"
+'\" Copyright (c) 2018 by Peter Spjuth. All rights reserved.
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH lpop n 8.7 Tcl "Tcl Built-In Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+lpop \- Get and remove an element in a list
+.SH SYNOPSIS
+\fBlpop \fIvarName ?index ...?\fR
+.BE
+.SH DESCRIPTION
+.PP
+The \fBlpop\fR command accepts a parameter, \fIvarName\fR, which
+it interprets as the name of a variable containing a Tcl list.
+It also accepts one or more \fIindices\fR into
+the list. If no indices are presented, it defaults to "end".
+.PP
+When presented with a single index, the \fBlpop\fR command
+addresses the \fIindex\fR'th element in it, removes if from the list
+and returns the element.
+.PP
+If \fIindex\fR is negative or greater or equal than the number
+of elements in \fI$varName\fR, then an error occurs.
+.PP
+The interpretation of each simple \fIindex\fR value is the same as
+for the command \fBstring index\fR, supporting simple index
+arithmetic and indices relative to the end of the list.
+.PP
+If additional \fIindex\fR arguments are supplied, then each argument is
+used in turn to address an element within a sublist designated
+by the previous indexing operation,
+allowing the script to remove elements in sublists.
+The command,
+.PP
+.CS
+\fBlpop\fR a 1 2
+.CE
+.PP
+gets and removes element 2 of sublist 1.
+.PP
+.SH EXAMPLES
+.PP
+In each of these examples, the initial value of \fIx\fR is:
+.PP
+.CS
+set x [list [list a b c] [list d e f] [list g h i]]
+ \fI\(-> {a b c} {d e f} {g h i}\fR
+.CE
+.PP
+The indicated value becomes the new value of \fIx\fR
+(except in the last case, which is an error which leaves the value of
+\fIx\fR unchanged.)
+.PP
+.CS
+\fBlpop\fR x 0
+ \fI\(-> {d e f} {g h i}\fR
+\fBlpop\fR x 2
+ \fI\(-> {a b c} {d e f}\fR
+\fBlpop\fR x end
+ \fI\(-> {a b c} {d e f}\fR
+\fBlpop\fR x end-1
+ \fI\(-> {a b c} {g h i}\fR
+\fBlpop\fR x 2 1
+ \fI\(-> {a b c} {d e f} {g i}\fR
+\fBlpop\fR x 2 3 j
+ \fI\(-> list index out of range\fR
+.CE
+.PP
+In the following examples, the initial value of \fIx\fR is:
+.PP
+.CS
+set x [list [list [list a b] [list c d]] \e
+ [list [list e f] [list g h]]]
+ \fI\(-> {{a b} {c d}} {{e f} {g h}}\fR
+.CE
+.PP
+The indicated value becomes the new value of \fIx\fR.
+.PP
+.CS
+\fBlpop\fR x 1 1 0
+ \fI\(-> {{a b} {c d}} {{e f} h}\fR
+.CE
+.SH "SEE ALSO"
+list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
+lsort(n), lrange(n), lreplace(n), lset(n)
+string(n)
+.SH KEYWORDS
+element, index, list, remove, pop, stack, queue
+'\"Local Variables:
+'\"mode: nroff
+'\"End:
diff --git a/doc/string.n b/doc/string.n
index 439f3b7..cc3fc54 100644
--- a/doc/string.n
+++ b/doc/string.n
@@ -20,7 +20,7 @@ Performs one of several string operations, depending on \fIoption\fR.
The legal \fIoption\fRs (which may be abbreviated) are:
.TP
\fBstring cat\fR ?\fIstring1\fR? ?\fIstring2...\fR?
-.VS 8.6.2
+.
Concatenate the given \fIstring\fRs just like placing them directly
next to each other and return the resulting compound string. If no
\fIstring\fRs are present, the result is an empty string.
@@ -32,7 +32,6 @@ of a concatenation without resorting to \fBreturn\fR \fB\-level 0\fR,
and is more efficient than building a list of arguments and using
\fBjoin\fR with an empty join string.
.RE
-.VE
.TP
\fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR
.
@@ -111,17 +110,24 @@ Any character with a value less than \eu0080 (those that are in the
Any of the forms allowed to \fBTcl_GetBoolean\fR.
.IP \fBcontrol\fR 12
Any Unicode control character.
+.IP \fBdict\fR 12
+.VS TIP501
+Any proper dict structure, with optional surrounding whitespace. In
+case of improper dict structure, 0 is returned and the \fIvarname\fR
+will contain the index of the
+.QW element
+where the dict parsing fails, or \-1 if this cannot be determined.
+.VE TIP501
.IP \fBdigit\fR 12
Any Unicode digit character. Note that this includes characters
outside of the [0\-9] range.
.IP \fBdouble\fR 12
Any of the forms allowed to \fBTcl_GetDoubleFromObj\fR.
.IP \fBentier\fR 12
-.VS 8.6
+.
Any of the valid string formats for an integer value of arbitrary size
in Tcl, with optional surrounding whitespace. The formats accepted are
exactly those accepted by the C routine \fBTcl_GetBignumFromObj\fR.
-.VE
.IP \fBfalse\fR 12
Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is
false.
diff --git a/doc/tcltest.n b/doc/tcltest.n
index 05c1922..b161a2b 100644
--- a/doc/tcltest.n
+++ b/doc/tcltest.n
@@ -8,7 +8,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-.TH "tcltest" n 2.3 tcltest "Tcl Bundled Packages"
+.TH "tcltest" n 2.5 tcltest "Tcl Bundled Packages"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
@@ -16,7 +16,7 @@
tcltest \- Test harness support code and utilities
.SH SYNOPSIS
.nf
-\fBpackage require tcltest\fR ?\fB2.3\fR?
+\fBpackage require tcltest\fR ?\fB2.5\fR?
\fBtcltest::test \fIname description\fR ?\fI\-option value ...\fR?
\fBtcltest::test \fIname description\fR ?\fIconstraints\fR? \fIbody result\fR
@@ -454,6 +454,7 @@ The valid options for \fBtest\fR are summarized:
?\fB\-output \fIexpectedOutput\fR?
?\fB\-errorOutput \fIexpectedError\fR?
?\fB\-returnCodes \fIcodeList\fR?
+ ?\fB\-errorCode \fIexpectedErrorCode\fR?
?\fB\-match \fImode\fR?
.CE
.PP
@@ -577,6 +578,15 @@ return codes known to \fBreturn\fR, in both numeric and symbolic
form, including extended return codes, are acceptable elements in
the \fIexpectedCodeList\fR. Default value is
.QW "\fBok return\fR" .
+.TP
+\fB\-errorCode \fIexpectedErrorCode\fR
+.
+The optional \fB\-errorCode\fR attribute supplies \fIexpectedErrorCode\fR,
+a glob pattern that should match the error code reported from evaluation of the
+\fB\-body\fR script. If evaluation of the \fB\-body\fR script returns
+a code not matching \fIexpectedErrorCode\fR, the test fails. Default value is
+.QW "\fB*\fR" .
+If \fB\-returnCodes\fR does not include \fBerror\fR it is set to \fBerror\fR.
.PP
To pass, a test must successfully evaluate its \fB\-setup\fR, \fB\-body\fR,
and \fB\-cleanup\fR scripts. The return code of the \fB\-body\fR script and
diff --git a/doc/zipfs.3 b/doc/zipfs.3
index 8e2eacc..23b9a93 100644
--- a/doc/zipfs.3
+++ b/doc/zipfs.3
@@ -112,6 +112,8 @@ call is a standard Tcl result code.
unmounts the mounted ZIP file system that was mounted from \fIzipname\fR (at
\fImountpoint\fR). Errors are reported in the interpreter \fIinterp\fR. The
result of this call is a standard Tcl result code.
+.PP
+\fBTclZipfs_AppHook\fR can not be used in stub-enabled extensions.
.SH "SEE ALSO"
zipfs(n)
.SH KEYWORDS
diff --git a/generic/tcl.decls b/generic/tcl.decls
index bd11024..7703ceb 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -132,8 +132,9 @@ declare 28 {
declare 29 {
Tcl_Obj *Tcl_DuplicateObj(Tcl_Obj *objPtr)
}
+# Only available as stub-entry, for backwards-compatible stub-enabled extensions
declare 30 {
- void TclFreeObj(Tcl_Obj *objPtr)
+ void TclOldFreeObj(Tcl_Obj *objPtr)
}
declare 31 {
int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *boolPtr)
@@ -813,7 +814,7 @@ declare 229 {
void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr)
}
declare 230 {nostub {Don't use this function in a stub-enabled extension}} {
- const char *Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc)
+ void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc)
}
declare 231 {
int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth)
@@ -859,7 +860,7 @@ declare 242 {
declare 243 {
void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr)
}
-declare 244 {
+declare 244 {nostub {Don't use this function in a stub-enabled extension}} {
void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName,
Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
}
@@ -2346,6 +2347,38 @@ declare 635 {
unsigned char *data, size_t datalen, int copy)
}
+# TIP #445
+declare 636 {
+ void Tcl_FreeIntRep(Tcl_Obj *objPtr)
+}
+declare 637 {
+ char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes,
+ unsigned int numBytes)
+}
+declare 638 {
+ Tcl_ObjIntRep *Tcl_FetchIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr)
+}
+declare 639 {
+ void Tcl_StoreIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr,
+ const Tcl_ObjIntRep *irPtr)
+}
+declare 640 {
+ int Tcl_HasStringRep(Tcl_Obj *objPtr)
+}
+
+# TIP #506
+declare 641 {
+ void Tcl_IncrRefCount(Tcl_Obj *objPtr)
+}
+
+declare 642 {
+ void Tcl_DecrRefCount(Tcl_Obj *objPtr)
+}
+
+declare 643 {
+ int Tcl_IsShared(Tcl_Obj *objPtr)
+}
+
# ----- BASELINE -- FOR -- 8.7.0 ----- #
##############################################################################
@@ -2397,6 +2430,19 @@ export {
Tcl_Interp *interp)
}
export {
+ void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName,
+ Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
+}
+export {
+ void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc)
+}
+export {
+ Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc)
+}
+export {
+ void Tcl_FindExecutable(const char *argv0)
+}
+export {
const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version,
int exact)
}
@@ -2411,6 +2457,9 @@ export {
export {
void Tcl_GetMemoryInfo(Tcl_DString *dsPtr)
}
+export {
+ void Tcl_InitSubsystems(void)
+}
# Local Variables:
# mode: tcl
diff --git a/generic/tcl.h b/generic/tcl.h
index 31e3419..ba4f0df 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -42,10 +42,6 @@ extern "C" {
* win/configure.ac (as above)
* win/tcl.m4 (not patchlevel)
* README (sections 0 and 2, with and without separator)
- * macosx/Tcl.pbproj/project.pbxproj (not patchlevel) 1 LOC
- * macosx/Tcl.pbproj/default.pbxuser (not patchlevel) 1 LOC
- * macosx/Tcl.xcode/project.pbxproj (not patchlevel) 2 LOC
- * macosx/Tcl.xcode/default.pbxuser (not patchlevel) 1 LOC
* macosx/Tcl-Common.xcconfig (not patchlevel) 1 LOC
* win/README (not patchlevel) (sections 0 and 2)
* unix/tcl.spec (1 LOC patch)
@@ -751,6 +747,29 @@ typedef struct Tcl_ObjType {
} Tcl_ObjType;
/*
+ * The following structure stores an internal representation (intrep) for
+ * a Tcl value. An intrep is associated with an Tcl_ObjType when both
+ * are stored in the same Tcl_Obj. The routines of the Tcl_ObjType govern
+ * the handling of the intrep.
+ */
+
+typedef union Tcl_ObjIntRep { /* The internal representation: */
+ long longValue; /* - an long integer value. */
+ double doubleValue; /* - a double-precision floating value. */
+ void *otherValuePtr; /* - another, type-specific value, */
+ /* not used internally any more. */
+ Tcl_WideInt wideValue; /* - an integer value >= 64bits */
+ struct { /* - internal rep as two pointers. */
+ void *ptr1;
+ void *ptr2;
+ } twoPtrValue;
+ struct { /* - internal rep as a pointer and a long, */
+ void *ptr; /* not used internally any more. */
+ unsigned long value;
+ } ptrAndLongRep;
+} Tcl_ObjIntRep;
+
+/*
* One of the following structures exists for each object in the Tcl system.
* An object stores a value as either a string, some internal representation,
* or both.
@@ -775,40 +794,9 @@ typedef struct Tcl_Obj {
* corresponds to the type of the object's
* internal rep. NULL indicates the object has
* no internal rep (has no type). */
- union { /* The internal representation: */
- long longValue; /* - an long integer value. */
- double doubleValue; /* - a double-precision floating value. */
- void *otherValuePtr; /* - another, type-specific value, not used
- * internally any more. */
- Tcl_WideInt wideValue; /* - a long long value. */
- struct { /* - internal rep as two pointers.
- * Many uses in Tcl, including a bignum's
- * tightly packed fields, where the alloc,
- * used and signum flags are packed into
- * ptr2 with everything else hung off
- * ptr1. */
- void *ptr1;
- void *ptr2;
- } twoPtrValue;
- struct { /* - internal rep as a pointer and a long,
- * not used internally any more. */
- void *ptr;
- unsigned long value;
- } ptrAndLongRep;
- } internalRep;
+ Tcl_ObjIntRep internalRep; /* The internal representation: */
} Tcl_Obj;
-/*
- * Macros to increment and decrement a Tcl_Obj's reference count, and to test
- * whether an object is shared (i.e. has reference count > 1). Note: clients
- * should use Tcl_DecrRefCount() when they are finished using an object, and
- * should never call TclFreeObj() directly. TclFreeObj() is only defined and
- * made public in tcl.h to support Tcl_DecrRefCount's macro definition.
- */
-
-void Tcl_IncrRefCount(Tcl_Obj *objPtr);
-void Tcl_DecrRefCount(Tcl_Obj *objPtr);
-int Tcl_IsShared(Tcl_Obj *objPtr);
/*
*----------------------------------------------------------------------------
@@ -2408,6 +2396,7 @@ EXTERN void Tcl_MainEx(int argc, char **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp,
const char *version, int exact);
+EXTERN void Tcl_InitSubsystems(void);
EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
#ifndef _WIN32
EXTERN int TclZipfs_AppHook(int *argc, char ***argv);
@@ -2482,26 +2471,39 @@ EXTERN int TclZipfs_AppHook(int *argc, char ***argv);
#endif /* !TCL_MEM_DEBUG */
#ifdef TCL_MEM_DEBUG
+# undef Tcl_IncrRefCount
# define Tcl_IncrRefCount(objPtr) \
Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__)
+# undef Tcl_DecrRefCount
# define Tcl_DecrRefCount(objPtr) \
Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)
+# undef Tcl_IsShared
# define Tcl_IsShared(objPtr) \
Tcl_DbIsShared(objPtr, __FILE__, __LINE__)
-#else
+#elif (!defined(TCL_NO_DEPRECATED) && defined(USE_TCL_STUBS))
+/*
+ * When compiling stub-enabled extensions without -DTCL_NO_DEPRECATED,
+ * those extensions are expected to run fine with Tcl 8.6 as well.
+ * This means we must continue to use macro's for the above 3 functions,
+ * and the old stub entry for TclFreeObj. All other usage of TclFreeObj()
+ * is forbidden now, therefore it is changed to be MODULE_SCOPE internal.
+ */
+# undef Tcl_IncrRefCount
# define Tcl_IncrRefCount(objPtr) \
++(objPtr)->refCount
/*
* Use do/while0 idiom for optimum correctness without compiler warnings.
* http://c2.com/cgi/wiki?TrivialDoWhileLoop
*/
+# undef Tcl_DecrRefCount
# define Tcl_DecrRefCount(objPtr) \
do { \
Tcl_Obj *_objPtr = (objPtr); \
if ((_objPtr)->refCount-- <= 1) { \
- TclFreeObj(_objPtr); \
+ TclOldFreeObj(_objPtr); \
} \
} while(0)
+# undef Tcl_IsShared
# define Tcl_IsShared(objPtr) \
((objPtr)->refCount > 1)
#endif
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 6356a00..5ac9a55 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -32,6 +32,7 @@
#include "tclInt.h"
#include "tclCompile.h"
#include "tclOOInt.h"
+#include <assert.h>
/*
* Structure that represents a range of instructions in the bytecode.
@@ -271,15 +272,12 @@ static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*,
const TalInstDesc*);
static int DefineLabel(AssemblyEnv* envPtr, const char* label);
static void DeleteMirrorJumpTable(JumptableInfo* jtPtr);
-static void DupAssembleCodeInternalRep(Tcl_Obj* src,
- Tcl_Obj* dest);
static void FillInJumpOffsets(AssemblyEnv*);
static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr,
Tcl_Obj* jumpTable);
static int FindLocalVar(AssemblyEnv* envPtr,
Tcl_Token** tokenPtrPtr);
static int FinishAssembly(AssemblyEnv*);
-static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr);
static void FreeAssemblyEnv(AssemblyEnv*);
static int GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*);
static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*);
@@ -318,6 +316,9 @@ static void UnstackExpiredCatches(CompileEnv*, BasicBlock*, int,
* Tcl_ObjType that describes bytecode emitted by the assembler.
*/
+static Tcl_FreeInternalRepProc FreeAssembleCodeInternalRep;
+static Tcl_DupInternalRepProc DupAssembleCodeInternalRep;
+
static const Tcl_ObjType assembleCodeType = {
"assemblecode",
FreeAssembleCodeInternalRep, /* freeIntRepProc */
@@ -847,15 +848,15 @@ CompileAssembleObj(
const char* source; /* String representation of the source code */
int sourceLen; /* Length of the source code in bytes */
-
/*
* Get the expression ByteCode from the object. If it exists, make sure it
* is valid in the current context.
*/
- if (objPtr->typePtr == &assembleCodeType) {
+ ByteCodeGetIntRep(objPtr, &assembleCodeType, codePtr);
+
+ if (codePtr) {
namespacePtr = iPtr->varFramePtr->nsPtr;
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle == iPtr)
&& (codePtr->compileEpoch == iPtr->compileEpoch)
&& (codePtr->nsPtr == namespacePtr)
@@ -869,7 +870,7 @@ CompileAssembleObj(
* Not valid, so free it and regenerate.
*/
- TclFreeIntRep(objPtr);
+ Tcl_StoreIntRep(objPtr, &assembleCodeType, NULL);
}
/*
@@ -4332,7 +4333,10 @@ static void
FreeAssembleCodeInternalRep(
Tcl_Obj *objPtr)
{
- ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
+
+ ByteCodeGetIntRep(objPtr, &assembleCodeType, codePtr);
+ assert(codePtr != NULL);
TclReleaseByteCode(codePtr);
}
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 179306d..644b54b 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -260,6 +260,7 @@ static const CmdInfo builtInCmds[] = {
{"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED},
{"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE},
{"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE},
+ {"lpop", Tcl_LpopObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE},
{"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE},
@@ -572,7 +573,7 @@ Tcl_CreateInterp(void)
char mathFuncName[32];
CallFrame *framePtr;
- TclInitSubsystems();
+ Tcl_InitSubsystems();
/*
* Panic if someone updated the CallFrame structure without also updating
@@ -3867,9 +3868,14 @@ OldMathFuncProc(
valuePtr = objv[j];
result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d);
#ifdef ACCEPT_NAN
- if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) {
- d = valuePtr->internalRep.doubleValue;
- result = TCL_OK;
+ if (result != TCL_OK) {
+ const Tcl_ObjIntRep *irPtr
+ = Tcl_FetchIntRep(valuePtr, &tclDoubleType);
+
+ if (irPtr) {
+ d = irPtr->doubleValue;
+ result = TCL_OK;
+ }
}
#endif
if (result != TCL_OK) {
@@ -6151,7 +6157,7 @@ TclArgumentGet(
* up by the caller. It knows better than us.
*/
- if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) {
+ if (!TclHasStringRep(obj) || TclListObjIsCanonical(obj)) {
return;
}
@@ -7428,9 +7434,13 @@ ExprCeilFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- Tcl_SetObjResult(interp, objv[1]);
- return TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7464,9 +7474,13 @@ ExprFloorFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- Tcl_SetObjResult(interp, objv[1]);
- return TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7600,9 +7614,13 @@ ExprSqrtFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- Tcl_SetObjResult(interp, objv[1]);
- return TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7643,10 +7661,14 @@ ExprUnaryFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- d = objv[1]->internalRep.doubleValue;
- Tcl_ResetResult(interp);
- code = TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ d = irPtr->doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7703,10 +7725,14 @@ ExprBinaryFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d1);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- d1 = objv[1]->internalRep.doubleValue;
- Tcl_ResetResult(interp);
- code = TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ d1 = irPtr->doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7714,10 +7740,14 @@ ExprBinaryFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[2], &d2);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) {
- d2 = objv[2]->internalRep.doubleValue;
- Tcl_ResetResult(interp);
- code = TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ d2 = irPtr->doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7754,14 +7784,16 @@ ExprAbsFunc(
if (l > (Tcl_WideInt)0) {
goto unChanged;
} else if (l == (Tcl_WideInt)0) {
- const char *string = objv[1]->bytes;
- if (string) {
- while (*string != '0') {
- if (*string == '-') {
+ if (TclHasStringRep(objv[1])) {
+ int numBytes;
+ const char *bytes = TclGetStringFromObj(objv[1], &numBytes);
+
+ while (numBytes) {
+ if (*bytes == '-') {
Tcl_SetObjResult(interp, Tcl_NewLongObj(0));
return TCL_OK;
}
- string++;
+ bytes++; numBytes--;
}
}
goto unChanged;
@@ -7857,7 +7889,7 @@ ExprDoubleFunc(
}
if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) {
#ifdef ACCEPT_NAN
- if (objv[1]->typePtr == &tclDoubleType) {
+ if (Tcl_FetchIntRep(objv[1], &tclDoubleType)) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index fdc60e7..4e17979 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -15,6 +15,7 @@
#include "tommath.h"
#include <math.h>
+#include <assert.h>
/*
* The following constants are used by GetFormatSpec to indicate various
@@ -56,9 +57,12 @@
static void DupByteArrayInternalRep(Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr);
+static void DupProperByteArrayInternalRep(Tcl_Obj *srcPtr,
+ Tcl_Obj *copyPtr);
static int FormatNumber(Tcl_Interp *interp, int type,
Tcl_Obj *src, unsigned char **cursorPtr);
static void FreeByteArrayInternalRep(Tcl_Obj *objPtr);
+static void FreeProperByteArrayInternalRep(Tcl_Obj *objPtr);
static int GetFormatSpec(const char **formatPtr, char *cmdPtr,
int *countPtr, int *flagsPtr);
static Tcl_Obj * ScanNumber(unsigned char *buffer, int type,
@@ -246,8 +250,8 @@ static const EnsembleImplMap decodeMap[] = {
static const Tcl_ObjType properByteArrayType = {
"bytearray",
- FreeByteArrayInternalRep,
- DupByteArrayInternalRep,
+ FreeProperByteArrayInternalRep,
+ DupProperByteArrayInternalRep,
UpdateStringOfByteArray,
NULL
};
@@ -268,9 +272,9 @@ const Tcl_ObjType tclByteArrayType = {
*/
typedef struct ByteArray {
- int used; /* The number of bytes used in the byte
+ unsigned int used; /* The number of bytes used in the byte
* array. */
- int allocated; /* The amount of space actually allocated
+ unsigned int allocated; /* The amount of space actually allocated
* minus 1 byte. */
unsigned char bytes[1]; /* The array of bytes. The actual size of this
* field depends on the 'allocated' field
@@ -279,16 +283,15 @@ typedef struct ByteArray {
#define BYTEARRAY_SIZE(len) \
((unsigned) (TclOffset(ByteArray, bytes) + (len)))
-#define GET_BYTEARRAY(objPtr) \
- ((ByteArray *) (objPtr)->internalRep.twoPtrValue.ptr1)
-#define SET_BYTEARRAY(objPtr, baPtr) \
- (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (baPtr)
+#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1)
+#define SET_BYTEARRAY(irPtr, baPtr) \
+ (irPtr)->twoPtrValue.ptr1 = (void *) (baPtr)
int
TclIsPureByteArray(
Tcl_Obj * objPtr)
{
- return (objPtr->typePtr == &properByteArrayType);
+ return (NULL != Tcl_FetchIntRep(objPtr, &properByteArrayType));
}
/*
@@ -403,11 +406,11 @@ Tcl_SetByteArrayObj(
be >= 0. */
{
ByteArray *byteArrayPtr;
+ Tcl_ObjIntRep ir;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
}
- TclFreeIntRep(objPtr);
TclInvalidateStringRep(objPtr);
if (length < 0) {
@@ -420,8 +423,9 @@ Tcl_SetByteArrayObj(
if ((bytes != NULL) && (length > 0)) {
memcpy(byteArrayPtr->bytes, bytes, (size_t) length);
}
- objPtr->typePtr = &properByteArrayType;
- SET_BYTEARRAY(objPtr, byteArrayPtr);
+ SET_BYTEARRAY(&ir, byteArrayPtr);
+
+ Tcl_StoreIntRep(objPtr, &properByteArrayType, &ir);
}
/*
@@ -449,17 +453,24 @@ Tcl_GetByteArrayFromObj(
* array of bytes in the ByteArray object. */
{
ByteArray *baPtr;
+ const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType);
- if ((objPtr->typePtr != &properByteArrayType)
- && (objPtr->typePtr != &tclByteArrayType)) {
- SetByteArrayFromAny(NULL, objPtr);
+ if (irPtr == NULL) {
+ irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType);
+ if (irPtr == NULL) {
+ SetByteArrayFromAny(NULL, objPtr);
+ irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType);
+ }
+ }
}
- baPtr = GET_BYTEARRAY(objPtr);
+ baPtr = GET_BYTEARRAY(irPtr);
if (lengthPtr != NULL) {
*lengthPtr = baPtr->used;
}
- return (unsigned char *) baPtr->bytes;
+ return baPtr->bytes;
}
/*
@@ -490,23 +501,36 @@ Tcl_SetByteArrayLength(
int length) /* New length for internal byte array. */
{
ByteArray *byteArrayPtr;
+ unsigned newLength;
+ Tcl_ObjIntRep *irPtr;
+
+ assert(length >= 0);
+ newLength = (unsigned int)length;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength");
}
- if ((objPtr->typePtr != &properByteArrayType)
- && (objPtr->typePtr != &tclByteArrayType)) {
- SetByteArrayFromAny(NULL, objPtr);
+
+ irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType);
+ if (irPtr == NULL) {
+ SetByteArrayFromAny(NULL, objPtr);
+ irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType);
+ }
+ }
}
- byteArrayPtr = GET_BYTEARRAY(objPtr);
- if (length > byteArrayPtr->allocated) {
- byteArrayPtr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(length));
- byteArrayPtr->allocated = length;
- SET_BYTEARRAY(objPtr, byteArrayPtr);
+ byteArrayPtr = GET_BYTEARRAY(irPtr);
+ if (newLength > byteArrayPtr->allocated) {
+ byteArrayPtr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(newLength));
+ byteArrayPtr->allocated = newLength;
+ SET_BYTEARRAY(irPtr, byteArrayPtr);
}
TclInvalidateStringRep(objPtr);
- byteArrayPtr->used = length;
+ byteArrayPtr->used = newLength;
return byteArrayPtr->bytes;
}
@@ -536,12 +560,12 @@ SetByteArrayFromAny(
const char *src, *srcEnd;
unsigned char *dst;
ByteArray *byteArrayPtr;
- Tcl_UniChar ch = 0;
+ Tcl_ObjIntRep ir;
- if (objPtr->typePtr == &properByteArrayType) {
+ if (Tcl_FetchIntRep(objPtr, &properByteArrayType)) {
return TCL_OK;
}
- if (objPtr->typePtr == &tclByteArrayType) {
+ if (Tcl_FetchIntRep(objPtr, &tclByteArrayType)) {
return TCL_OK;
}
@@ -551,6 +575,7 @@ SetByteArrayFromAny(
byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
+ Tcl_UniChar ch = 0;
src += TclUtfToUniChar(src, &ch);
improper = improper || (ch > 255);
*dst++ = UCHAR(ch);
@@ -559,9 +584,9 @@ SetByteArrayFromAny(
byteArrayPtr->used = dst - byteArrayPtr->bytes;
byteArrayPtr->allocated = length;
- TclFreeIntRep(objPtr);
- objPtr->typePtr = improper ? &tclByteArrayType : &properByteArrayType;
- SET_BYTEARRAY(objPtr, byteArrayPtr);
+ SET_BYTEARRAY(&ir, byteArrayPtr);
+ Tcl_StoreIntRep(objPtr,
+ improper ? &tclByteArrayType : &properByteArrayType, &ir);
return TCL_OK;
}
@@ -586,8 +611,14 @@ static void
FreeByteArrayInternalRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
- ckfree(GET_BYTEARRAY(objPtr));
- objPtr->typePtr = NULL;
+ ckfree(GET_BYTEARRAY(Tcl_FetchIntRep(objPtr, &tclByteArrayType)));
+}
+
+static void
+FreeProperByteArrayInternalRep(
+ Tcl_Obj *objPtr) /* Object with internal rep to free. */
+{
+ ckfree(GET_BYTEARRAY(Tcl_FetchIntRep(objPtr, &properByteArrayType)));
}
/*
@@ -612,19 +643,41 @@ DupByteArrayInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- int length;
+ unsigned int length;
+ ByteArray *srcArrayPtr, *copyArrayPtr;
+ Tcl_ObjIntRep ir;
+
+ srcArrayPtr = GET_BYTEARRAY(Tcl_FetchIntRep(srcPtr, &tclByteArrayType));
+ length = srcArrayPtr->used;
+
+ copyArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
+ copyArrayPtr->used = length;
+ copyArrayPtr->allocated = length;
+ memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length);
+
+ SET_BYTEARRAY(&ir, copyArrayPtr);
+ Tcl_StoreIntRep(copyPtr, &tclByteArrayType, &ir);
+}
+
+static void
+DupProperByteArrayInternalRep(
+ Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
+ Tcl_Obj *copyPtr) /* Object with internal rep to set. */
+{
+ unsigned int length;
ByteArray *srcArrayPtr, *copyArrayPtr;
+ Tcl_ObjIntRep ir;
- srcArrayPtr = GET_BYTEARRAY(srcPtr);
+ srcArrayPtr = GET_BYTEARRAY(Tcl_FetchIntRep(srcPtr, &properByteArrayType));
length = srcArrayPtr->used;
copyArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
copyArrayPtr->used = length;
copyArrayPtr->allocated = length;
memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length);
- SET_BYTEARRAY(copyPtr, copyArrayPtr);
- copyPtr->typePtr = srcPtr->typePtr;
+ SET_BYTEARRAY(&ir, copyArrayPtr);
+ Tcl_StoreIntRep(copyPtr, &properByteArrayType, &ir);
}
/*
@@ -632,9 +685,7 @@ DupByteArrayInternalRep(
*
* UpdateStringOfByteArray --
*
- * Update the string representation for a ByteArray data object. Note:
- * This procedure does not invalidate an existing old string rep so
- * storage will be lost if this has not already been done.
+ * Update the string representation for a ByteArray data object.
*
* Results:
* None.
@@ -643,9 +694,6 @@ DupByteArrayInternalRep(
* The object's string is set to a valid string that results from the
* ByteArray-to-string conversion.
*
- * The object becomes a string object -- the internal rep is discarded
- * and the typePtr becomes NULL.
- *
*----------------------------------------------------------------------
*/
@@ -654,41 +702,35 @@ UpdateStringOfByteArray(
Tcl_Obj *objPtr) /* ByteArray object whose string rep to
* update. */
{
- int i, length, size;
- unsigned char *src;
- char *dst;
- ByteArray *byteArrayPtr;
-
- byteArrayPtr = GET_BYTEARRAY(objPtr);
- src = byteArrayPtr->bytes;
- length = byteArrayPtr->used;
+ const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType);
+ ByteArray *byteArrayPtr = GET_BYTEARRAY(irPtr);
+ unsigned char *src = byteArrayPtr->bytes;
+ unsigned int i, length = byteArrayPtr->used;
+ unsigned int size = length;
/*
* How much space will string rep need?
*/
- size = length;
- for (i = 0; i < length && size >= 0; i++) {
+ for (i = 0; i < length && size <= INT_MAX; i++) {
if ((src[i] == 0) || (src[i] > 127)) {
size++;
}
}
- if (size < 0) {
+ if (size > INT_MAX) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
- dst = ckalloc(size + 1);
- objPtr->bytes = dst;
- objPtr->length = size;
-
if (size == length) {
- memcpy(dst, src, (size_t) size);
- dst[size] = '\0';
+ char *dst = Tcl_InitStringRep(objPtr, (char *)src, size);
+ TclOOM(dst, size);
} else {
+ char *dst = Tcl_InitStringRep(objPtr, NULL, size);
+ TclOOM(dst, size);
for (i = 0; i < length; i++) {
dst += Tcl_UniCharToUtf(src[i], dst);
}
- *dst = '\0';
+ (void)Tcl_InitStringRep(objPtr, NULL, size);
}
}
@@ -718,7 +760,8 @@ TclAppendBytesToByteArray(
int len)
{
ByteArray *byteArrayPtr;
- int needed;
+ unsigned int length, needed;
+ Tcl_ObjIntRep *irPtr;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
@@ -731,24 +774,34 @@ TclAppendBytesToByteArray(
/* Append zero bytes is a no-op. */
return;
}
- if ((objPtr->typePtr != &properByteArrayType)
- && (objPtr->typePtr != &tclByteArrayType)) {
- SetByteArrayFromAny(NULL, objPtr);
+
+ length = (unsigned int)len;
+
+ irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType);
+ if (irPtr == NULL) {
+ SetByteArrayFromAny(NULL, objPtr);
+ irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType);
+ }
+ }
}
- byteArrayPtr = GET_BYTEARRAY(objPtr);
+ byteArrayPtr = GET_BYTEARRAY(irPtr);
- if (len > INT_MAX - byteArrayPtr->used) {
+ if (length > INT_MAX - byteArrayPtr->used) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
- needed = byteArrayPtr->used + len;
+ needed = byteArrayPtr->used + length;
/*
* If we need to, resize the allocated space in the byte array.
*/
if (needed > byteArrayPtr->allocated) {
ByteArray *ptr = NULL;
- int attempt;
+ unsigned int attempt;
if (needed <= INT_MAX/2) {
/* Try to allocate double the total space that is needed. */
@@ -758,7 +811,7 @@ TclAppendBytesToByteArray(
if (ptr == NULL) {
/* Try to allocate double the increment that is needed (plus). */
unsigned int limit = INT_MAX - needed;
- unsigned int extra = len + TCL_MIN_GROWTH;
+ unsigned int extra = length + TCL_MIN_GROWTH;
int growth = (int) ((extra > limit) ? limit : extra);
attempt = needed + growth;
@@ -771,13 +824,13 @@ TclAppendBytesToByteArray(
}
byteArrayPtr = ptr;
byteArrayPtr->allocated = attempt;
- SET_BYTEARRAY(objPtr, byteArrayPtr);
+ SET_BYTEARRAY(irPtr, byteArrayPtr);
}
if (bytes) {
- memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len);
+ memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, length);
}
- byteArrayPtr->used += len;
+ byteArrayPtr->used += length;
TclInvalidateStringRep(objPtr);
}
@@ -1978,10 +2031,11 @@ FormatNumber(
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
- if (src->typePtr != &tclDoubleType) {
+ const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(src, &tclDoubleType);
+ if (irPtr == NULL) {
return TCL_ERROR;
}
- dvalue = src->internalRep.doubleValue;
+ dvalue = irPtr->doubleValue;
}
CopyNumber(&dvalue, *cursorPtr, sizeof(double), type);
*cursorPtr += sizeof(double);
@@ -1997,10 +2051,11 @@ FormatNumber(
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
- if (src->typePtr != &tclDoubleType) {
+ const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(src, &tclDoubleType);
+ if (irPtr == NULL) {
return TCL_ERROR;
}
- dvalue = src->internalRep.doubleValue;
+ dvalue = irPtr->doubleValue;
}
/*
@@ -3003,6 +3058,11 @@ BinaryDecode64(
} else if (i > 1) {
c = '=';
} else {
+ if (strict && i <= 1) {
+ /* single resp. unfulfilled char (each 4th next single char)
+ * is rather bad64 error case in strict mode */
+ goto bad64;
+ }
cut += 3;
break;
}
@@ -3033,9 +3093,11 @@ BinaryDecode64(
value = (value << 6) | 0x3e;
} else if (c == '/') {
value = (value << 6) | 0x3f;
- } else if (c == '=') {
+ } else if (c == '=' && (
+ !strict || i > 1) /* "=" and "a=" is rather bad64 error case in strict mode */
+ ) {
value <<= 6;
- cut++;
+ if (i) cut++;
} else if (strict || !TclIsSpaceProc(c)) {
goto bad64;
} else {
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index e3fb98e..8b8290b 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -145,7 +145,7 @@ static void ValidateMemory(struct mem_header *memHeaderP,
*
* Initialize the locks used by the allocator. This is only appropriate
* to call in a single threaded environment, such as during
- * TclInitSubsystems.
+ * Tcl_InitSubsystems.
*
*----------------------------------------------------------------------
*/
diff --git a/generic/tclClock.c b/generic/tclClock.c
index bbfc83b..7f4f592 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -452,7 +452,7 @@ ClockGetdatefieldsObjCmd(
* that it isn't.
*/
- if (objv[1]->typePtr == &tclBignumType) {
+ if (Tcl_FetchIntRep(objv[1], &tclBignumType)) {
Tcl_SetObjResult(interp, literals[LIT_INTEGER_VALUE_TOO_LARGE]);
return TCL_ERROR;
}
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 334121f..626066d 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -1882,7 +1882,7 @@ PathJoinCmd(
Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, TclJoinPath(objc - 1, objv + 1));
+ Tcl_SetObjResult(interp, TclJoinPath(objc - 1, objv + 1, 0));
return TCL_OK;
}
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 434840e..3bd49da 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -539,9 +539,9 @@ InfoBodyCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
- const char *name;
+ const char *name, *bytes;
Proc *procPtr;
- Tcl_Obj *bodyPtr, *resultPtr;
+ int numBytes;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "procname");
@@ -566,18 +566,8 @@ InfoBodyCmd(
* the object do not invalidate the internal rep.
*/
- bodyPtr = procPtr->bodyPtr;
- if (bodyPtr->bytes == NULL) {
- /*
- * The string rep might not be valid if the procedure has never been
- * run before. [Bug #545644]
- */
-
- TclGetString(bodyPtr);
- }
- resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
-
- Tcl_SetObjResult(interp, resultPtr);
+ bytes = Tcl_GetStringFromObj(procPtr->bodyPtr, &numBytes);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes));
return TCL_OK;
}
@@ -2571,6 +2561,96 @@ Tcl_LlengthObjCmd(
/*
*----------------------------------------------------------------------
*
+ * Tcl_LpopObjCmd --
+ *
+ * This procedure is invoked to process the "lpop" Tcl command. See the
+ * user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_LpopObjCmd(
+ ClientData notUsed, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ register Tcl_Obj *const objv[])
+ /* Argument objects. */
+{
+ int listLen, result;
+ Tcl_Obj *elemPtr;
+ Tcl_Obj *listPtr, **elemPtrs;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "listvar ?index?");
+ return TCL_ERROR;
+ }
+
+ listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
+ if (listPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ result = TclListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ /*
+ * First, extract the element to be returned.
+ * TclLindexFlat adds a ref count which is handled.
+ */
+
+ if (objc == 2) {
+ elemPtr = elemPtrs[listLen - 1];
+ Tcl_IncrRefCount(elemPtr);
+ } else {
+ elemPtr = TclLindexFlat(interp, listPtr, objc-2, objv+2);
+
+ if (elemPtr == NULL) {
+ return TCL_ERROR;
+ }
+ }
+ Tcl_SetObjResult(interp, elemPtr);
+ Tcl_DecrRefCount(elemPtr);
+
+ /*
+ * Second, remove the element.
+ */
+
+ if (objc == 2) {
+ if (Tcl_IsShared(listPtr)) {
+ listPtr = TclListObjCopy(NULL, listPtr);
+ }
+ result = Tcl_ListObjReplace(interp, listPtr, listLen - 1, 1, 0, NULL);
+ if (result != TCL_OK) {
+ return result;
+ }
+ } else {
+ listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL);
+
+ if (listPtr == NULL) {
+ return TCL_ERROR;
+ }
+ }
+
+ listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG);
+ if (listPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_LrangeObjCmd --
*
* This procedure is invoked to process the "lrange" Tcl command. See the
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index f94c094..d21a521 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -1216,7 +1216,7 @@ Tcl_SplitObjCmd(
Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; stringPtr < end; stringPtr += len) {
- int fullchar;
+ int fullchar;
len = TclUtfToUniChar(stringPtr, &ch);
fullchar = ch;
@@ -1490,19 +1490,19 @@ StringIsCmd(
static const char *const isClasses[] = {
"alnum", "alpha", "ascii", "control",
- "boolean", "digit", "double", "entier",
- "false", "graph", "integer", "list",
- "lower", "print", "punct", "space",
- "true", "upper", "wideinteger", "wordchar",
- "xdigit", NULL
+ "boolean", "dict", "digit", "double",
+ "entier", "false", "graph", "integer",
+ "list", "lower", "print", "punct",
+ "space", "true", "upper", "wideinteger",
+ "wordchar", "xdigit", NULL
};
enum isClasses {
STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
- STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER,
- STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST,
- STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE,
- STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD,
- STR_IS_XDIGIT
+ STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE,
+ STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT,
+ STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT,
+ STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE,
+ STR_IS_WORD, STR_IS_XDIGIT
};
static const char *const isOptions[] = {
"-strict", "-failindex", NULL
@@ -1589,13 +1589,61 @@ StringIsCmd(
case STR_IS_CONTROL:
chcomp = Tcl_UniCharIsControl;
break;
+ case STR_IS_DICT: {
+ int dresult, dsize;
+
+ dresult = Tcl_DictObjSize(interp, objPtr, &dsize);
+ Tcl_ResetResult(interp);
+ result = (dresult == TCL_OK) ? 1 : 0;
+ if (dresult != TCL_OK && failVarObj != NULL) {
+ /*
+ * Need to figure out where the list parsing failed, which is
+ * fairly expensive. This is adapted from the core of
+ * SetDictFromAny().
+ */
+
+ const char *elemStart, *nextElem;
+ int lenRemain, elemSize;
+ register const char *p;
+
+ string1 = TclGetStringFromObj(objPtr, &length1);
+ end = string1 + length1;
+ failat = -1;
+ for (p=string1, lenRemain=length1; lenRemain > 0;
+ p=nextElem, lenRemain=end-nextElem) {
+ if (TCL_ERROR == TclFindElement(NULL, p, lenRemain,
+ &elemStart, &nextElem, &elemSize, NULL)) {
+ Tcl_Obj *tmpStr;
+
+ /*
+ * This is the simplest way of getting the number of
+ * characters parsed. Note that this is not the same as
+ * the number of bytes when parsing strings with non-ASCII
+ * characters in them.
+ *
+ * Skip leading spaces first. This is only really an issue
+ * if it is the first "element" that has the failure.
+ */
+
+ while (TclIsSpaceProc(*p)) {
+ p++;
+ }
+ TclNewStringObj(tmpStr, string1, p-string1);
+ failat = Tcl_GetCharLength(tmpStr);
+ TclDecrRefCount(tmpStr);
+ break;
+ }
+ }
+ }
+ break;
+ }
case STR_IS_DIGIT:
chcomp = Tcl_UniCharIsDigit;
break;
case STR_IS_DOUBLE: {
- if ((objPtr->typePtr == &tclDoubleType) ||
- (objPtr->typePtr == &tclIntType) ||
- (objPtr->typePtr == &tclBignumType)) {
+ if (Tcl_FetchIntRep(objPtr, &tclDoubleType) ||
+ Tcl_FetchIntRep(objPtr, &tclIntType) ||
+ Tcl_FetchIntRep(objPtr, &tclBignumType)) {
break;
}
string1 = TclGetStringFromObj(objPtr, &length1);
@@ -1624,8 +1672,8 @@ StringIsCmd(
break;
case STR_IS_INT:
case STR_IS_ENTIER:
- if ((objPtr->typePtr == &tclIntType) ||
- (objPtr->typePtr == &tclBignumType)) {
+ if (Tcl_FetchIntRep(objPtr, &tclIntType) ||
+ Tcl_FetchIntRep(objPtr, &tclBignumType)) {
break;
}
string1 = TclGetStringFromObj(objPtr, &length1);
@@ -1903,7 +1951,8 @@ StringMapCmd(
* inconsistencies (see test string-10.20.1 for illustration why!)
*/
- if (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL){
+ if (!TclHasStringRep(objv[objc-2])
+ && Tcl_FetchIntRep(objv[objc-2], &tclDictType)){
int i, done;
Tcl_DictSearch search;
@@ -2583,9 +2632,7 @@ StringEqualCmd(
*/
objv += objc-2;
-
match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength);
-
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1));
return TCL_OK;
}
@@ -2634,7 +2681,8 @@ StringCmpCmd(
return TCL_OK;
}
-int TclStringCmpOpts(
+int
+TclStringCmpOpts(
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[], /* Argument objects. */
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index b16b8b3..8b54a99 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -461,7 +461,7 @@ TclCompileStringIsCmd(
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
static const char *const isClasses[] = {
"alnum", "alpha", "ascii", "control",
- "boolean", "digit", "double", "entier",
+ "boolean", "dict", "digit", "double", "entier",
"false", "graph", "integer", "list",
"lower", "print", "punct", "space",
"true", "upper", "wideinteger", "wordchar",
@@ -469,7 +469,7 @@ TclCompileStringIsCmd(
};
enum isClasses {
STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
- STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER,
+ STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER,
STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST,
STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE,
STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD,
@@ -703,7 +703,19 @@ TclCompileStringIsCmd(
}
FIXJUMP1( end);
return TCL_OK;
-
+ case STR_IS_DICT:
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ OP4( BEGIN_CATCH4, range);
+ ExceptionRangeStarts(envPtr, range);
+ OP( DUP);
+ OP( DICT_VERIFY);
+ ExceptionRangeEnds(envPtr, range);
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ OP( POP);
+ OP( PUSH_RETURN_CODE);
+ OP( END_CATCH);
+ OP( LNOT);
+ return TCL_OK;
case STR_IS_LIST:
range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, range);
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index f8835b9..e96e264 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -2476,11 +2476,13 @@ CompileExprTree(
* already, then use it to share via the literal table.
*/
- if (objPtr->bytes) {
+ if (TclHasStringRep(objPtr)) {
Tcl_Obj *tableValue;
+ int numBytes;
+ const char *bytes
+ = Tcl_GetStringFromObj(objPtr, &numBytes);
- index = TclRegisterLiteral(envPtr, objPtr->bytes,
- objPtr->length, 0);
+ index = TclRegisterLiteral(envPtr, bytes, numBytes, 0);
tableValue = TclFetchLiteral(envPtr, index);
if ((tableValue->typePtr == NULL) &&
(objPtr->typePtr != NULL)) {
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index b5de230..f6e6b81 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -725,13 +725,14 @@ static const Tcl_ObjType substCodeType = {
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
};
+#define SubstFlags(objPtr) (objPtr)->internalRep.twoPtrValue.ptr2
/*
* Helper macros.
*/
#define TclIncrUInt4AtPtr(ptr, delta) \
- TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr));
+ TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr))
/*
*----------------------------------------------------------------------
@@ -974,7 +975,10 @@ static void
FreeByteCodeInternalRep(
register Tcl_Obj *objPtr) /* Object whose internal rep to free. */
{
- register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
+
+ ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr);
+ assert(codePtr != NULL);
TclReleaseByteCode(codePtr);
}
@@ -1304,21 +1308,23 @@ CompileSubstObj(
Interp *iPtr = (Interp *) interp;
ByteCode *codePtr = NULL;
- if (objPtr->typePtr == &substCodeType) {
+ ByteCodeGetIntRep(objPtr, &substCodeType, codePtr);
+
+ if (codePtr != NULL) {
Namespace *nsPtr = iPtr->varFramePtr->nsPtr;
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
- if (flags != PTR2INT(objPtr->internalRep.twoPtrValue.ptr2)
+ if (flags != PTR2INT(SubstFlags(objPtr))
|| ((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)
|| (codePtr->nsEpoch != nsPtr->resolverEpoch)
|| (codePtr->localCachePtr !=
iPtr->varFramePtr->localCachePtr)) {
- TclFreeIntRep(objPtr);
+ Tcl_StoreIntRep(objPtr, &substCodeType, NULL);
+ codePtr = NULL;
}
}
- if (objPtr->typePtr != &substCodeType) {
+ if (codePtr == NULL) {
CompileEnv compEnv;
int numBytes;
const char *bytes = TclGetStringFromObj(objPtr, &numBytes);
@@ -1332,8 +1338,7 @@ CompileSubstObj(
codePtr = TclInitByteCodeObj(objPtr, &substCodeType, &compEnv);
TclFreeCompileEnv(&compEnv);
- objPtr->internalRep.twoPtrValue.ptr1 = codePtr;
- objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(flags);
+ SubstFlags(objPtr) = INT2PTR(flags);
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -1372,7 +1377,10 @@ static void
FreeSubstCodeInternalRep(
register Tcl_Obj *objPtr) /* Object whose internal rep to free. */
{
- register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ register ByteCode *codePtr;
+
+ ByteCodeGetIntRep(objPtr, &substCodeType, codePtr);
+ assert(codePtr != NULL);
TclReleaseByteCode(codePtr);
}
@@ -2912,9 +2920,7 @@ TclInitByteCodeObj(
* by making its internal rep point to the just compiled ByteCode.
*/
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = codePtr;
- objPtr->typePtr = typePtr;
+ ByteCodeSetIntRep(objPtr, typePtr, codePtr);
return codePtr;
}
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index d827382..e5a8d52 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -266,7 +266,7 @@ typedef struct AuxDataType {
typedef struct AuxData {
const AuxDataType *type; /* Pointer to the AuxData type associated with
* this ClientData. */
- ClientData clientData; /* The compilation data itself. */
+ void *clientData; /* The compilation data itself. */
} AuxData;
/*
@@ -514,6 +514,23 @@ typedef struct ByteCode {
* created. */
#endif /* TCL_COMPILE_STATS */
} ByteCode;
+
+#define ByteCodeSetIntRep(objPtr, typePtr, codePtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ ir.twoPtrValue.ptr1 = (codePtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreIntRep((objPtr), (typePtr), &ir); \
+ } while (0)
+
+
+
+#define ByteCodeGetIntRep(objPtr, typePtr, codePtr) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = Tcl_FetchIntRep((objPtr), (typePtr)); \
+ (codePtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
/*
* Opcodes for the Tcl bytecode instructions. These must correspond to the
diff --git a/generic/tclDate.c b/generic/tclDate.c
index f720325..32c71de 100644
--- a/generic/tclDate.c
+++ b/generic/tclDate.c
@@ -2744,7 +2744,7 @@ TclDatelex(
int
TclClockOldscanObjCmd(
- ClientData clientData, /* Unused */
+ void *clientData, /* Unused */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of paraneters */
Tcl_Obj *const *objv) /* Parameters */
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 5f6ab07..ad8fbbc 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -143,7 +143,7 @@ EXTERN Tcl_Obj * Tcl_DbNewStringObj(const char *bytes, int length,
/* 29 */
EXTERN Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr);
/* 30 */
-EXTERN void TclFreeObj(Tcl_Obj *objPtr);
+EXTERN void TclOldFreeObj(Tcl_Obj *objPtr);
/* 31 */
EXTERN int Tcl_GetBoolean(Tcl_Interp *interp, const char *src,
int *boolPtr);
@@ -709,7 +709,7 @@ EXTERN void Tcl_SetErrorCode(Tcl_Interp *interp, ...);
/* 229 */
EXTERN void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr);
/* 230 */
-EXTERN const char * Tcl_SetPanicProc(
+EXTERN void Tcl_SetPanicProc(
TCL_NORETURN1 Tcl_PanicProc *panicProc);
/* 231 */
EXTERN int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth);
@@ -1875,6 +1875,26 @@ EXTERN Tcl_Obj * TclZipfs_TclLibrary(void);
EXTERN int TclZipfs_MountBuffer(Tcl_Interp *interp,
const char *mountPoint, unsigned char *data,
size_t datalen, int copy);
+/* 636 */
+EXTERN void Tcl_FreeIntRep(Tcl_Obj *objPtr);
+/* 637 */
+EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes,
+ unsigned int numBytes);
+/* 638 */
+EXTERN Tcl_ObjIntRep * Tcl_FetchIntRep(Tcl_Obj *objPtr,
+ const Tcl_ObjType *typePtr);
+/* 639 */
+EXTERN void Tcl_StoreIntRep(Tcl_Obj *objPtr,
+ const Tcl_ObjType *typePtr,
+ const Tcl_ObjIntRep *irPtr);
+/* 640 */
+EXTERN int Tcl_HasStringRep(Tcl_Obj *objPtr);
+/* 641 */
+EXTERN void Tcl_IncrRefCount(Tcl_Obj *objPtr);
+/* 642 */
+EXTERN void Tcl_DecrRefCount(Tcl_Obj *objPtr);
+/* 643 */
+EXTERN int Tcl_IsShared(Tcl_Obj *objPtr);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
@@ -1932,7 +1952,7 @@ typedef struct TclStubs {
Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */
Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, int length, const char *file, int line); /* 28 */
Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */
- void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */
+ void (*tclOldFreeObj) (Tcl_Obj *objPtr); /* 30 */
int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, int *boolPtr); /* 31 */
int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr); /* 32 */
unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */
@@ -2140,7 +2160,7 @@ typedef struct TclStubs {
void (*tcl_SetErrno) (int err); /* 227 */
void (*tcl_SetErrorCode) (Tcl_Interp *interp, ...); /* 228 */
void (*tcl_SetMaxBlockTime) (const Tcl_Time *timePtr); /* 229 */
- TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") const char * (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */
+ TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */
int (*tcl_SetRecursionLimit) (Tcl_Interp *interp, int depth); /* 231 */
void (*tcl_SetResult) (Tcl_Interp *interp, char *result, Tcl_FreeProc *freeProc); /* 232 */
int (*tcl_SetServiceMode) (int mode); /* 233 */
@@ -2154,7 +2174,7 @@ typedef struct TclStubs {
void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */
int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 242 */
void (*tcl_SplitPath) (const char *path, int *argcPtr, const char ***argvPtr); /* 243 */
- void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */
+ TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */
int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */
TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */
TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */
@@ -2546,6 +2566,14 @@ typedef struct TclStubs {
int (*tclZipfs_Unmount) (Tcl_Interp *interp, const char *mountPoint); /* 633 */
Tcl_Obj * (*tclZipfs_TclLibrary) (void); /* 634 */
int (*tclZipfs_MountBuffer) (Tcl_Interp *interp, const char *mountPoint, unsigned char *data, size_t datalen, int copy); /* 635 */
+ void (*tcl_FreeIntRep) (Tcl_Obj *objPtr); /* 636 */
+ char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 637 */
+ Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */
+ void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 639 */
+ int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */
+ void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */
+ void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */
+ int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
@@ -2632,8 +2660,8 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_DbNewStringObj) /* 28 */
#define Tcl_DuplicateObj \
(tclStubsPtr->tcl_DuplicateObj) /* 29 */
-#define TclFreeObj \
- (tclStubsPtr->tclFreeObj) /* 30 */
+#define TclOldFreeObj \
+ (tclStubsPtr->tclOldFreeObj) /* 30 */
#define Tcl_GetBoolean \
(tclStubsPtr->tcl_GetBoolean) /* 31 */
#define Tcl_GetBooleanFromObj \
@@ -3848,6 +3876,22 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tclZipfs_TclLibrary) /* 634 */
#define TclZipfs_MountBuffer \
(tclStubsPtr->tclZipfs_MountBuffer) /* 635 */
+#define Tcl_FreeIntRep \
+ (tclStubsPtr->tcl_FreeIntRep) /* 636 */
+#define Tcl_InitStringRep \
+ (tclStubsPtr->tcl_InitStringRep) /* 637 */
+#define Tcl_FetchIntRep \
+ (tclStubsPtr->tcl_FetchIntRep) /* 638 */
+#define Tcl_StoreIntRep \
+ (tclStubsPtr->tcl_StoreIntRep) /* 639 */
+#define Tcl_HasStringRep \
+ (tclStubsPtr->tcl_HasStringRep) /* 640 */
+#define Tcl_IncrRefCount \
+ (tclStubsPtr->tcl_IncrRefCount) /* 641 */
+#define Tcl_DecrRefCount \
+ (tclStubsPtr->tcl_DecrRefCount) /* 642 */
+#define Tcl_IsShared \
+ (tclStubsPtr->tcl_IsShared) /* 643 */
#endif /* defined(USE_TCL_STUBS) */
@@ -3858,6 +3902,8 @@ extern const TclStubs *tclStubsPtr;
# undef Tcl_FindExecutable
# undef Tcl_GetStringResult
# undef Tcl_Init
+# undef Tcl_SetPanicProc
+# undef Tcl_SetExitProc
# undef Tcl_ObjSetVar2
# undef Tcl_StaticPackage
# define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp())
@@ -3930,7 +3976,6 @@ extern const TclStubs *tclStubsPtr;
#undef Tcl_AddObjErrorInfo
#define Tcl_AddObjErrorInfo(interp, message, length) \
Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length))
-#undef Tcl_SetPanicProc
#ifdef TCL_NO_DEPRECATED
#undef Tcl_Eval
#define Tcl_Eval(interp, objPtr) \
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 1d952ec..13ff0f8 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -12,6 +12,7 @@
#include "tclInt.h"
#include "tommath.h"
+#include <assert.h>
/*
* Forward declaration.
@@ -149,13 +150,6 @@ typedef struct Dict {
} Dict;
/*
- * Accessor macro for converting between a Tcl_Obj* and a Dict. Note that this
- * must be assignable as well as readable.
- */
-
-#define DICT(dictObj) ((dictObj)->internalRep.twoPtrValue.ptr1)
-
-/*
* The structure below defines the dictionary object type by means of
* functions that can be invoked by generic object code.
*/
@@ -168,6 +162,21 @@ const Tcl_ObjType tclDictType = {
SetDictFromAny /* setFromAnyProc */
};
+#define DictSetIntRep(objPtr, dictRepPtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ ir.twoPtrValue.ptr1 = (dictRepPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreIntRep((objPtr), &tclDictType, &ir); \
+ } while (0)
+
+#define DictGetIntRep(objPtr, dictRepPtr) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = Tcl_FetchIntRep((objPtr), &tclDictType); \
+ (dictRepPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
* The type of the specially adapted version of the Tcl_Obj*-containing hash
* table defined in the tclObj.c code. This version differs in that it
@@ -363,10 +372,11 @@ DupDictInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
- Dict *oldDict = DICT(srcPtr);
- Dict *newDict = ckalloc(sizeof(Dict));
+ Dict *oldDict, *newDict = ckalloc(sizeof(Dict));
ChainEntry *cPtr;
+ DictGetIntRep(srcPtr, oldDict);
+
/*
* Copy values across from the old hash table.
*/
@@ -398,9 +408,7 @@ DupDictInternalRep(
* Store in the object.
*/
- DICT(copyPtr) = newDict;
- copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
- copyPtr->typePtr = &tclDictType;
+ DictSetIntRep(copyPtr, newDict);
}
/*
@@ -425,12 +433,13 @@ static void
FreeDictInternalRep(
Tcl_Obj *dictPtr)
{
- Dict *dict = DICT(dictPtr);
+ Dict *dict;
+
+ DictGetIntRep(dictPtr, dict);
if (dict->refCount-- <= 1) {
DeleteDict(dict);
}
- dictPtr->typePtr = NULL;
}
/*
@@ -489,7 +498,7 @@ UpdateStringOfDict(
{
#define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
- Dict *dict = DICT(dictPtr);
+ Dict *dict;
ChainEntry *cPtr;
Tcl_Obj *keyPtr, *valuePtr;
int i, length, bytesNeeded = 0;
@@ -501,12 +510,17 @@ UpdateStringOfDict(
* is not exposed by any API function...
*/
- int numElems = dict->table.numEntries * 2;
+ int numElems;
+
+ DictGetIntRep(dictPtr, dict);
+
+ assert (dict != NULL);
+
+ numElems = dict->table.numEntries * 2;
/* Handle empty list case first, simplifies what follows */
if (numElems == 0) {
- dictPtr->bytes = &tclEmptyString;
- dictPtr->length = 0;
+ Tcl_InitStringRep(dictPtr, NULL, 0);
return;
}
@@ -550,9 +564,8 @@ UpdateStringOfDict(
* Pass 2: copy into string rep buffer.
*/
- dictPtr->length = bytesNeeded - 1;
- dictPtr->bytes = ckalloc(bytesNeeded);
- dst = dictPtr->bytes;
+ dst = Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1);
+ TclOOM(dst, bytesNeeded);
for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry);
@@ -566,7 +579,7 @@ UpdateStringOfDict(
dst += TclConvertElement(elem, length, dst, flagPtr[i+1]);
*dst++ = ' ';
}
- dictPtr->bytes[dictPtr->length] = '\0';
+ (void)Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1);
if (flagPtr != localFlags) {
ckfree(flagPtr);
@@ -610,7 +623,7 @@ SetDictFromAny(
* the conversion from lists to dictionaries.
*/
- if (objPtr->typePtr == &tclListType) {
+ if (Tcl_FetchIntRep(objPtr, &tclListType)) {
int objc, i;
Tcl_Obj **objv;
@@ -665,10 +678,14 @@ SetDictFromAny(
TclNewStringObj(keyPtr, elemStart, elemSize);
} else {
/* Avoid double copy */
+ char *dst;
+
TclNewObj(keyPtr);
- keyPtr->bytes = ckalloc((unsigned) elemSize + 1);
- keyPtr->length = TclCopyAndCollapse(elemSize, elemStart,
- keyPtr->bytes);
+ Tcl_InvalidateStringRep(keyPtr);
+ dst = Tcl_InitStringRep(keyPtr, NULL, elemSize);
+ TclOOM(dst, elemSize); /* Consider error */
+ (void)Tcl_InitStringRep(keyPtr, NULL,
+ TclCopyAndCollapse(elemSize, elemStart, dst));
}
if (TclFindDictElement(interp, nextElem, (limit - nextElem),
@@ -681,10 +698,14 @@ SetDictFromAny(
TclNewStringObj(valuePtr, elemStart, elemSize);
} else {
/* Avoid double copy */
+ char *dst;
+
TclNewObj(valuePtr);
- valuePtr->bytes = ckalloc((unsigned) elemSize + 1);
- valuePtr->length = TclCopyAndCollapse(elemSize, elemStart,
- valuePtr->bytes);
+ Tcl_InvalidateStringRep(valuePtr);
+ dst = Tcl_InitStringRep(valuePtr, NULL, elemSize);
+ TclOOM(dst, elemSize); /* Consider error */
+ (void)Tcl_InitStringRep(valuePtr, NULL,
+ TclCopyAndCollapse(elemSize, elemStart, dst));
}
/* Store key and value in the hash table we're building. */
@@ -706,13 +727,10 @@ SetDictFromAny(
* Tcl_GetStringFromObj, to use that old internalRep.
*/
- TclFreeIntRep(objPtr);
dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
- DICT(objPtr) = dict;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclDictType;
+ DictSetIntRep(objPtr, dict);
return TCL_OK;
missingValue:
@@ -726,6 +744,23 @@ SetDictFromAny(
ckfree(dict);
return TCL_ERROR;
}
+
+static Dict *
+GetDictFromObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *dictPtr)
+{
+ Dict *dict;
+
+ DictGetIntRep(dictPtr, dict);
+ if (dict == NULL) {
+ if (SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return NULL;
+ }
+ DictGetIntRep(dictPtr, dict);
+ }
+ return dict;
+}
/*
*----------------------------------------------------------------------
@@ -770,11 +805,13 @@ TclTraceDictPath(
Dict *dict, *newDict;
int i;
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
- return NULL;
+ DictGetIntRep(dictPtr, dict);
+ if (dict == NULL) {
+ if (SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return NULL;
+ }
+ DictGetIntRep(dictPtr, dict);
}
- dict = DICT(dictPtr);
if (flags & DICT_PATH_UPDATE) {
dict->chain = NULL;
}
@@ -810,13 +847,17 @@ TclTraceDictPath(
Tcl_SetHashValue(hPtr, tmpObj);
} else {
tmpObj = Tcl_GetHashValue(hPtr);
- if (tmpObj->typePtr != &tclDictType
- && SetDictFromAny(interp, tmpObj) != TCL_OK) {
- return NULL;
+
+ DictGetIntRep(tmpObj, newDict);
+
+ if (newDict == NULL) {
+ if (SetDictFromAny(interp, tmpObj) != TCL_OK) {
+ return NULL;
+ }
}
}
- newDict = DICT(tmpObj);
+ DictGetIntRep(tmpObj, newDict);
if (flags & DICT_PATH_UPDATE) {
if (Tcl_IsShared(tmpObj)) {
TclDecrRefCount(tmpObj);
@@ -824,7 +865,7 @@ TclTraceDictPath(
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, tmpObj);
dict->epoch++;
- newDict = DICT(tmpObj);
+ DictGetIntRep(tmpObj, newDict);
}
newDict->chain = dictPtr;
@@ -859,17 +900,24 @@ static void
InvalidateDictChain(
Tcl_Obj *dictObj)
{
- Dict *dict = DICT(dictObj);
+ Dict *dict;
+
+ DictGetIntRep(dictObj, dict);
+ assert( dict != NULL);
do {
+ dict->refCount++;
TclInvalidateStringRep(dictObj);
+ TclFreeIntRep(dictObj);
+ DictSetIntRep(dictObj, dict);
+
dict->epoch++;
dictObj = dict->chain;
if (dictObj == NULL) {
break;
}
dict->chain = NULL;
- dict = DICT(dictObj);
+ DictGetIntRep(dictObj, dict);
} while (dict != NULL);
}
@@ -907,16 +955,16 @@ Tcl_DictObjPut(
Tcl_Panic("%s called with shared object", "Tcl_DictObjPut");
}
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ dict = GetDictFromObj(interp, dictPtr);
+ if (dict == NULL) {
return TCL_ERROR;
}
- if (dictPtr->bytes != NULL) {
- TclInvalidateStringRep(dictPtr);
- }
- dict = DICT(dictPtr);
+ TclInvalidateStringRep(dictPtr);
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
+ dict->refCount++;
+ TclFreeIntRep(dictPtr)
+ DictSetIntRep(dictPtr, dict);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr);
@@ -958,13 +1006,12 @@ Tcl_DictObjGet(
Dict *dict;
Tcl_HashEntry *hPtr;
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ dict = GetDictFromObj(interp, dictPtr);
+ if (dict == NULL) {
*valuePtrPtr = NULL;
return TCL_ERROR;
}
- dict = DICT(dictPtr);
hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
if (hPtr == NULL) {
*valuePtrPtr = NULL;
@@ -1005,16 +1052,13 @@ Tcl_DictObjRemove(
Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove");
}
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ dict = GetDictFromObj(interp, dictPtr);
+ if (dict == NULL) {
return TCL_ERROR;
}
- dict = DICT(dictPtr);
if (DeleteChainEntry(dict, keyPtr)) {
- if (dictPtr->bytes != NULL) {
- TclInvalidateStringRep(dictPtr);
- }
+ TclInvalidateStringRep(dictPtr);
dict->epoch++;
}
return TCL_OK;
@@ -1046,12 +1090,11 @@ Tcl_DictObjSize(
{
Dict *dict;
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ dict = GetDictFromObj(interp, dictPtr);
+ if (dict == NULL) {
return TCL_ERROR;
}
- dict = DICT(dictPtr);
*sizePtr = dict->table.numEntries;
return TCL_OK;
}
@@ -1098,12 +1141,11 @@ Tcl_DictObjFirst(
Dict *dict;
ChainEntry *cPtr;
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ dict = GetDictFromObj(interp, dictPtr);
+ if (dict == NULL) {
return TCL_ERROR;
}
- dict = DICT(dictPtr);
cPtr = dict->entryChainHead;
if (cPtr == NULL) {
searchPtr->epoch = 0;
@@ -1277,7 +1319,8 @@ Tcl_DictObjPutKeyList(
return TCL_ERROR;
}
- dict = DICT(dictPtr);
+ DictGetIntRep(dictPtr, dict);
+ assert(dict != NULL);
hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
@@ -1334,7 +1377,8 @@ Tcl_DictObjRemoveKeyList(
return TCL_ERROR;
}
- dict = DICT(dictPtr);
+ DictGetIntRep(dictPtr, dict);
+ assert(dict != NULL);
DeleteChainEntry(dict, keyv[keyc-1]);
InvalidateDictChain(dictPtr);
return TCL_OK;
@@ -1380,9 +1424,7 @@ Tcl_NewDictObj(void)
dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
- DICT(dictPtr) = dict;
- dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
- dictPtr->typePtr = &tclDictType;
+ DictSetIntRep(dictPtr, dict);
return dictPtr;
#endif
}
@@ -1430,9 +1472,7 @@ Tcl_DbNewDictObj(
dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
- DICT(dictPtr) = dict;
- dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
- dictPtr->typePtr = &tclDictType;
+ DictSetIntRep(dictPtr, dict);
return dictPtr;
#else /* !TCL_MEM_DEBUG */
return Tcl_NewDictObj();
@@ -1618,16 +1658,13 @@ DictReplaceCmd(
}
dictPtr = objv[1];
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ if (GetDictFromObj(interp, dictPtr) == NULL) {
return TCL_ERROR;
}
if (Tcl_IsShared(dictPtr)) {
dictPtr = Tcl_DuplicateObj(dictPtr);
}
- if (dictPtr->bytes != NULL) {
- TclInvalidateStringRep(dictPtr);
- }
+ TclInvalidateStringRep(dictPtr);
for (i=2 ; i<objc ; i+=2) {
Tcl_DictObjPut(NULL, dictPtr, objv[i], objv[i+1]);
}
@@ -1669,16 +1706,13 @@ DictRemoveCmd(
}
dictPtr = objv[1];
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ if (GetDictFromObj(interp, dictPtr) == NULL) {
return TCL_ERROR;
}
if (Tcl_IsShared(dictPtr)) {
dictPtr = Tcl_DuplicateObj(dictPtr);
}
- if (dictPtr->bytes != NULL) {
- TclInvalidateStringRep(dictPtr);
- }
+ TclInvalidateStringRep(dictPtr);
for (i=2 ; i<objc ; i++) {
Tcl_DictObjRemove(NULL, dictPtr, objv[i]);
}
@@ -1729,8 +1763,7 @@ DictMergeCmd(
*/
targetObj = objv[1];
- if (targetObj->typePtr != &tclDictType
- && SetDictFromAny(interp, targetObj) != TCL_OK) {
+ if (GetDictFromObj(interp, targetObj) == NULL) {
return TCL_ERROR;
}
@@ -1813,8 +1846,7 @@ DictKeysCmd(
* need. [Bug 1705778, leak K04]
*/
- if (objv[1]->typePtr != &tclDictType
- && SetDictFromAny(interp, objv[1]) != TCL_OK) {
+ if (GetDictFromObj(interp, objv[1]) == NULL) {
return TCL_ERROR;
}
@@ -2021,7 +2053,6 @@ DictInfoCmd(
int objc,
Tcl_Obj *const *objv)
{
- Tcl_Obj *dictPtr;
Dict *dict;
char *statsStr;
@@ -2030,12 +2061,10 @@ DictInfoCmd(
return TCL_ERROR;
}
- dictPtr = objv[1];
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ dict = GetDictFromObj(interp, objv[1]);
+ if (dict == NULL) {
return TCL_ERROR;
}
- dict = DICT(dictPtr);
statsStr = Tcl_HashStats(&dict->table);
Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1));
@@ -2096,12 +2125,11 @@ DictIncrCmd(
* soon be no good.
*/
- char *saved = dictPtr->bytes;
Tcl_Obj *oldPtr = dictPtr;
- dictPtr->bytes = NULL;
- dictPtr = Tcl_DuplicateObj(dictPtr);
- oldPtr->bytes = saved;
+ TclNewObj(dictPtr);
+ TclInvalidateStringRep(dictPtr);
+ DupDictInternalRep(oldPtr, dictPtr);
}
if (valuePtr == NULL) {
/*
@@ -2238,7 +2266,7 @@ DictLappendCmd(
if (allocatedValue) {
Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
- } else if (dictPtr->bytes != NULL) {
+ } else {
TclInvalidateStringRep(dictPtr);
}
diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
index 6580d59..6ea3397 100644
--- a/generic/tclDisassemble.c
+++ b/generic/tclDisassemble.c
@@ -38,7 +38,7 @@ static void UpdateStringOfInstName(Tcl_Obj *objPtr);
* reporting of inner contexts in errorstack without string allocation.
*/
-static const Tcl_ObjType tclInstNameType = {
+static const Tcl_ObjType instNameType = {
"instname", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
@@ -46,12 +46,21 @@ static const Tcl_ObjType tclInstNameType = {
NULL, /* setFromAnyProc */
};
-/*
- * How to get the bytecode out of a Tcl_Obj.
- */
+#define InstNameSetIntRep(objPtr, inst) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ ir.wideValue = (inst); \
+ Tcl_StoreIntRep((objPtr), &instNameType, &ir); \
+ } while (0)
+
+#define InstNameGetIntRep(objPtr, inst) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = Tcl_FetchIntRep((objPtr), &instNameType); \
+ assert(irPtr != NULL); \
+ (inst) = (size_t)irPtr->wideValue; \
+ } while (0)
-#define BYTECODE(objPtr) \
- ((ByteCode *) (objPtr)->internalRep.twoPtrValue.ptr1)
/*
*----------------------------------------------------------------------
@@ -245,14 +254,18 @@ DisassembleByteCodeObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
- ByteCode *codePtr = BYTECODE(objPtr);
+ ByteCode *codePtr;
unsigned char *codeStart, *codeLimit, *pc;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line;
- Interp *iPtr = (Interp *) *codePtr->interpHandle;
+ Interp *iPtr;
Tcl_Obj *bufferObj, *fileObj;
+ ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr);
+
+ iPtr = (Interp *) *codePtr->interpHandle;
+
TclNewObj(bufferObj);
if (!codePtr->refCount) {
return bufferObj; /* Already freed. */
@@ -796,9 +809,8 @@ TclNewInstNameObj(
{
Tcl_Obj *objPtr = Tcl_NewObj();
- objPtr->typePtr = &tclInstNameType;
- objPtr->internalRep.wideValue = (long) inst;
- objPtr->bytes = NULL;
+ TclInvalidateStringRep(objPtr);
+ InstNameSetIntRep(objPtr, (long) inst);
return objPtr;
}
@@ -817,20 +829,22 @@ static void
UpdateStringOfInstName(
Tcl_Obj *objPtr)
{
- size_t len, inst = (size_t)objPtr->internalRep.wideValue;
- char *s, buf[TCL_INTEGER_SPACE + 5];
+ size_t inst; /* NOTE: We know this is really an unsigned char */
+ char *dst;
+
+ InstNameGetIntRep(objPtr, inst);
if (inst > LAST_INST_OPCODE) {
- sprintf(buf, "inst_%" TCL_Z_MODIFIER "d", inst);
- s = buf;
+ dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5);
+ TclOOM(dst, TCL_INTEGER_SPACE + 5);
+ sprintf(dst, "inst_%" TCL_Z_MODIFIER "d", inst);
+ (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
} else {
- s = (char *) tclInstructionTable[inst].name;
+ const char *s = tclInstructionTable[inst].name;
+ unsigned int len = strlen(s);
+ dst = Tcl_InitStringRep(objPtr, s, len);
+ TclOOM(dst, len);
}
- len = strlen(s);
- /* assert (len < UINT_MAX) */
- objPtr->bytes = ckalloc(len + 1);
- memcpy(objPtr->bytes, s, len + 1);
- objPtr->length = len;
}
/*
@@ -942,13 +956,15 @@ DisassembleByteCodeAsDicts(
* procedure, if one exists. */
Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */
{
- ByteCode *codePtr = BYTECODE(objPtr);
+ ByteCode *codePtr;
Tcl_Obj *description, *literals, *variables, *instructions, *inst;
Tcl_Obj *aux, *exn, *commands, *file;
unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr;
int codeOffset, codeLength, sourceOffset, sourceLength;
int i, val, line;
+ ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr);
+
/*
* Get the literals from the bytecode.
*/
@@ -1286,6 +1302,7 @@ Tcl_DisassembleObjCmd(
Proc *procPtr = NULL;
Tcl_HashEntry *hPtr;
Object *oPtr;
+ ByteCode *codePtr;
Method *methodPtr;
if (objc < 2) {
@@ -1304,27 +1321,19 @@ Tcl_DisassembleObjCmd(
/*
* Compile (if uncompiled) and disassemble a lambda term.
- *
- * WARNING! Pokes inside the lambda objtype.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm");
return TCL_ERROR;
}
- if (objv[2]->typePtr == &tclLambdaType) {
- procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
- }
- if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) {
- result = tclLambdaType.setFromAnyProc(interp, objv[2]);
- if (result != TCL_OK) {
- return result;
- }
- procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
+
+ procPtr = TclGetLambdaFromObj(interp, objv[2], &nsObjPtr);
+ if (procPtr == NULL) {
+ return TCL_ERROR;
}
memset(&cmd, 0, sizeof(Command));
- nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2;
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
if (result != TCL_OK) {
return result;
@@ -1374,8 +1383,9 @@ Tcl_DisassembleObjCmd(
Tcl_WrongNumArgs(interp, 2, objv, "script");
return TCL_ERROR;
}
- if ((objv[2]->typePtr != &tclByteCodeType)
- && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) {
+
+ if ((NULL == Tcl_FetchIntRep(objv[2], &tclByteCodeType)) && (TCL_OK
+ != TclSetByteCodeFromAny(interp, objv[2], NULL, NULL))) {
return TCL_ERROR;
}
codeObjPtr = objv[2];
@@ -1575,7 +1585,7 @@ Tcl_DisassembleObjCmd(
"METHODTYPE", NULL);
return TCL_ERROR;
}
- if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
+ if (NULL == Tcl_FetchIntRep(procPtr->bodyPtr, &tclByteCodeType)) {
Command cmd;
/*
@@ -1603,7 +1613,9 @@ Tcl_DisassembleObjCmd(
* Do the actual disassembly.
*/
- if (BYTECODE(codeObjPtr)->flags & TCL_BYTECODE_PRECOMPILED) {
+ ByteCodeGetIntRep(codeObjPtr, &tclByteCodeType, codePtr);
+
+ if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not disassemble prebuilt bytecode", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 16cb26b..a08149e 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -279,6 +279,21 @@ static int Iso88591ToUtfProc(ClientData clientData,
static const Tcl_ObjType encodingType = {
"encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL
};
+#define EncodingSetIntRep(objPtr, encoding) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ ir.twoPtrValue.ptr1 = (encoding); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreIntRep((objPtr), &encodingType, &ir); \
+ } while (0)
+
+#define EncodingGetIntRep(objPtr, encoding) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = Tcl_FetchIntRep ((objPtr), &encodingType); \
+ (encoding) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
*----------------------------------------------------------------------
@@ -305,17 +320,16 @@ Tcl_GetEncodingFromObj(
Tcl_Obj *objPtr,
Tcl_Encoding *encodingPtr)
{
+ Tcl_Encoding encoding;
const char *name = TclGetString(objPtr);
- if (objPtr->typePtr != &encodingType) {
- Tcl_Encoding encoding = Tcl_GetEncoding(interp, name);
-
+ EncodingGetIntRep(objPtr, encoding);
+ if (encoding == NULL) {
+ encoding = Tcl_GetEncoding(interp, name);
if (encoding == NULL) {
return TCL_ERROR;
}
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = encoding;
- objPtr->typePtr = &encodingType;
+ EncodingSetIntRep(objPtr, encoding);
}
*encodingPtr = Tcl_GetEncoding(NULL, name);
return TCL_OK;
@@ -335,8 +349,10 @@ static void
FreeEncodingIntRep(
Tcl_Obj *objPtr)
{
- Tcl_FreeEncoding(objPtr->internalRep.twoPtrValue.ptr1);
- objPtr->typePtr = NULL;
+ Tcl_Encoding encoding;
+
+ EncodingGetIntRep(objPtr, encoding);
+ Tcl_FreeEncoding(encoding);
}
/*
@@ -354,8 +370,8 @@ DupEncodingIntRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes);
- dupPtr->typePtr = &encodingType;
+ Tcl_Encoding encoding = Tcl_GetEncoding(NULL, TclGetString(srcPtr));
+ EncodingSetIntRep(dupPtr, encoding);
}
/*
@@ -1444,10 +1460,10 @@ Tcl_UtfToExternal(
/*
*---------------------------------------------------------------------------
*
- * Tcl_SetPanicProc/Tcl_FindExecutable --
+ * Tcl_FindExecutable --
*
- * This function initializes everything needed for the Tcl library
- * to be able to operate.
+ * This function computes the absolute path name of the current
+ * application, given its argv[0] value.
*
* Results:
* None.
@@ -1458,30 +1474,13 @@ Tcl_UtfToExternal(
*
*---------------------------------------------------------------------------
*/
-MODULE_SCOPE const TclStubs tclStubs;
-
-static const struct {
- const TclStubs *stubs;
- const char version[16];
-} stubInfo = {
- &tclStubs, TCL_PATCH_LEVEL
-};
-
-const char *
-Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc)
-{
- TclSetPanicProc(panicProc);
- TclInitSubsystems();
- return stubInfo.version;
-}
-
#undef Tcl_FindExecutable
void
Tcl_FindExecutable(
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
- TclInitSubsystems();
+ Tcl_InitSubsystems();
TclpSetInitialEncodings();
TclpFindExecutable(argv0);
}
@@ -1740,7 +1739,9 @@ LoadTableEncoding(
};
Tcl_DStringInit(&lineString);
- Tcl_Gets(chan, &lineString);
+ if (Tcl_Gets(chan, &lineString) == TCL_IO_FAILURE) {
+ return NULL;
+ }
line = Tcl_DStringValue(&lineString);
fallback = (int) strtol(line, &line, 16);
@@ -1780,8 +1781,11 @@ LoadTableEncoding(
for (i = 0; i < numPages; i++) {
int ch;
const char *p;
+ int expected = 3 + 16 * (16 * 4 + 1);
- Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0);
+ if (Tcl_ReadChars(chan, objPtr, expected, 0) != expected) {
+ return NULL;
+ }
p = TclGetString(objPtr);
hi = (staticHex[UCHAR(p[0])] << 4) + staticHex[UCHAR(p[1])];
dataPtr->toUnicode[hi] = pageMemPtr;
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 84ed9e3..a5fd715 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -84,6 +84,21 @@ static const Tcl_ObjType ensembleCmdType = {
NULL /* setFromAnyProc */
};
+#define ECRSetIntRep(objPtr, ecRepPtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ ir.twoPtrValue.ptr1 = (ecRepPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreIntRep((objPtr), &ensembleCmdType, &ir); \
+ } while (0)
+
+#define ECRGetIntRep(objPtr, ecRepPtr) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = Tcl_FetchIntRep((objPtr), &ensembleCmdType); \
+ (ecRepPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
* The internal rep for caching ensemble subcommand lookups and spelling
* corrections.
@@ -1742,10 +1757,10 @@ NsEnsembleImplementationCmdNR(
* check here, and if we're still valid, we can jump straight to the
* part where we do the invocation of the subcommand.
*/
+ EnsembleCmdRep *ensembleCmd;
- if (subObj->typePtr==&ensembleCmdType){
- EnsembleCmdRep *ensembleCmd = subObj->internalRep.twoPtrValue.ptr1;
-
+ ECRGetIntRep(subObj, ensembleCmd);
+ if (ensembleCmd) {
if (ensembleCmd->epoch == ensemblePtr->epoch &&
ensembleCmd->token == (Command *)ensemblePtr->token) {
prefixObj = Tcl_GetHashValue(ensembleCmd->hPtr);
@@ -2064,8 +2079,8 @@ TclResetRewriteEnsemble(
*
* TclSpellFix --
*
- * Record a spelling correction that needs making in the
- * generation of the WrongNumArgs usage message.
+ * Record a spelling correction that needs making in the generation of
+ * the WrongNumArgs usage message.
*
* Results:
* None.
@@ -2082,9 +2097,10 @@ FreeER(
Tcl_Interp *interp,
int result)
{
- Tcl_Obj **tmp = (Tcl_Obj **)data[0];
+ Tcl_Obj **tmp = (Tcl_Obj **) data[0];
+ Tcl_Obj **store = (Tcl_Obj **) data[1];
- ckfree(tmp[2]);
+ ckfree(store);
ckfree(tmp);
return result;
}
@@ -2120,8 +2136,9 @@ TclSpellFix(
search = iPtr->ensembleRewrite.sourceObjs;
if (search[0] == NULL) {
/*
- * Awful casting abuse here...
+ * Awful casting abuse here!
*/
+
search = (Tcl_Obj *const *) search[1];
}
@@ -2142,7 +2159,10 @@ TclSpellFix(
return;
}
} else {
- /* Jump to the misspelled value. */
+ /*
+ * Jump to the misspelled value.
+ */
+
idx = iPtr->ensembleRewrite.numRemovedObjs + badIdx
- iPtr->ensembleRewrite.numInsertedObjs;
@@ -2155,17 +2175,25 @@ TclSpellFix(
search = iPtr->ensembleRewrite.sourceObjs;
if (search[0] == NULL) {
store = (Tcl_Obj **) search[2];
- } else {
+ } else {
Tcl_Obj **tmp = ckalloc(3 * sizeof(Tcl_Obj *));
+ store = ckalloc(size * sizeof(Tcl_Obj *));
+ memcpy(store, iPtr->ensembleRewrite.sourceObjs,
+ size * sizeof(Tcl_Obj *));
+
+ /*
+ * Awful casting abuse here! Note that the NULL in the first element
+ * indicates that the initial objects are a raw array in the second
+ * element and the rewritten ones are a raw array in the third.
+ */
+
tmp[0] = NULL;
tmp[1] = (Tcl_Obj *) iPtr->ensembleRewrite.sourceObjs;
- tmp[2] = (Tcl_Obj *) ckalloc(size * sizeof(Tcl_Obj *));
- memcpy(tmp[2], tmp[1], size * sizeof(Tcl_Obj *));
-
+ tmp[2] = (Tcl_Obj *) store;
iPtr->ensembleRewrite.sourceObjs = (Tcl_Obj *const *) tmp;
- TclNRAddCallback(interp, FreeER, tmp, NULL, NULL, NULL);
- store = (Tcl_Obj **)tmp[2];
+
+ TclNRAddCallback(interp, FreeER, tmp, store, NULL, NULL);
}
store[idx] = fix;
@@ -2378,8 +2406,8 @@ MakeCachedEnsembleCommand(
{
register EnsembleCmdRep *ensembleCmd;
- if (objPtr->typePtr == &ensembleCmdType) {
- ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
+ ECRGetIntRep(objPtr, ensembleCmd);
+ if (ensembleCmd) {
TclCleanupCommandMacro(ensembleCmd->token);
if (ensembleCmd->fix) {
Tcl_DecrRefCount(ensembleCmd->fix);
@@ -2390,10 +2418,8 @@ MakeCachedEnsembleCommand(
* our own.
*/
- TclFreeIntRep(objPtr);
ensembleCmd = ckalloc(sizeof(EnsembleCmdRep));
- objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd;
- objPtr->typePtr = &ensembleCmdType;
+ ECRSetIntRep(objPtr, ensembleCmd);
}
/*
@@ -2797,14 +2823,14 @@ static void
FreeEnsembleCmdRep(
Tcl_Obj *objPtr)
{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
+ EnsembleCmdRep *ensembleCmd;
+ ECRGetIntRep(objPtr, ensembleCmd);
TclCleanupCommandMacro(ensembleCmd->token);
if (ensembleCmd->fix) {
Tcl_DecrRefCount(ensembleCmd->fix);
}
ckfree(ensembleCmd);
- objPtr->typePtr = NULL;
}
/*
@@ -2830,11 +2856,12 @@ DupEnsembleCmdRep(
Tcl_Obj *objPtr,
Tcl_Obj *copyPtr)
{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
+ EnsembleCmdRep *ensembleCmd;
EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep));
- copyPtr->typePtr = &ensembleCmdType;
- copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy;
+ ECRGetIntRep(objPtr, ensembleCmd);
+ ECRSetIntRep(copyPtr, ensembleCopy);
+
ensembleCopy->epoch = ensembleCmd->epoch;
ensembleCopy->token = ensembleCmd->token;
ensembleCopy->token->refCount++;
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 913ff0f..1f41355 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -994,7 +994,7 @@ Tcl_Exit(
/*
*-------------------------------------------------------------------------
*
- * TclInitSubsystems --
+ * Tcl_InitSubsystems --
*
* Initialize various subsytems in Tcl. This should be called the first
* time an interp is created, or before any of the subsystems are used.
@@ -1017,10 +1017,10 @@ Tcl_Exit(
*/
void
-TclInitSubsystems(void)
+Tcl_InitSubsystems(void)
{
if (inExit != 0) {
- Tcl_Panic("TclInitSubsystems called while exiting");
+ Tcl_Panic("Tcl_InitSubsystems called while exiting");
}
if (subsystemsInitialized == 0) {
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 7355bc1..f38f7cd 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -748,20 +748,22 @@ ReleaseDictIterator(
{
Tcl_DictSearch *searchPtr;
Tcl_Obj *dictPtr;
+ const Tcl_ObjIntRep *irPtr;
+
+ irPtr = Tcl_FetchIntRep(objPtr, &dictIteratorType);
+ assert(irPtr != NULL);
/*
* First kill the search, and then release the reference to the dictionary
* that we were holding.
*/
- searchPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ searchPtr = irPtr->twoPtrValue.ptr1;
Tcl_DictObjDone(searchPtr);
ckfree(searchPtr);
- dictPtr = objPtr->internalRep.twoPtrValue.ptr2;
+ dictPtr = irPtr->twoPtrValue.ptr2;
TclDecrRefCount(dictPtr);
-
- objPtr->typePtr = NULL;
}
/*
@@ -1450,19 +1452,23 @@ CompileExprObj(
* Get the expression ByteCode from the object. If it exists, make sure it
* is valid in the current context.
*/
- if (objPtr->typePtr == &exprCodeType) {
+
+ ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr);
+
+ if (codePtr != NULL) {
Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)
|| (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) {
- TclFreeIntRep(objPtr);
+ Tcl_StoreIntRep(objPtr, &exprCodeType, NULL);
+ codePtr = NULL;
}
}
- if (objPtr->typePtr != &exprCodeType) {
+
+ if (codePtr == NULL) {
/*
* TIP #280: No invoker (yet) - Expression compilation.
*/
@@ -1562,7 +1568,9 @@ static void
FreeExprCodeInternalRep(
Tcl_Obj *objPtr)
{
- ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
+ ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr);
+ assert(codePtr != NULL);
TclReleaseByteCode(codePtr);
}
@@ -1600,7 +1608,8 @@ TclCompileObj(
* compilation). Otherwise, check that it is "fresh" enough.
*/
- if (objPtr->typePtr == &tclByteCodeType) {
+ ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr);
+ if (codePtr != NULL) {
/*
* Make sure the Bytecode hasn't been invalidated by, e.g., someone
* redefining a command with a compile procedure (this might make the
@@ -1618,7 +1627,6 @@ TclCompileObj(
* here.
*/
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
@@ -1746,7 +1754,7 @@ TclCompileObj(
iPtr->invokeWord = word;
TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
iPtr->invokeCmdFramePtr = NULL;
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr);
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -4760,7 +4768,7 @@ TEBCresume(
*/
if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK)
- && (value2Ptr->typePtr != &tclListType)
+ && (NULL == Tcl_FetchIntRep(value2Ptr, &tclListType))
&& (TclGetIntForIndexM(NULL, value2Ptr, objc-1,
&index) == TCL_OK)) {
TclDecrRefCount(value2Ptr);
@@ -7104,13 +7112,16 @@ TEBCresume(
TRACE_ERROR(interp);
goto gotError;
}
- TclNewObj(statePtr);
- statePtr->typePtr = &dictIteratorType;
- statePtr->internalRep.twoPtrValue.ptr1 = searchPtr;
- statePtr->internalRep.twoPtrValue.ptr2 = dictPtr;
+ {
+ Tcl_ObjIntRep ir;
+ TclNewObj(statePtr);
+ ir.twoPtrValue.ptr1 = searchPtr;
+ ir.twoPtrValue.ptr2 = dictPtr;
+ Tcl_StoreIntRep(statePtr, &dictIteratorType, &ir);
+ }
varPtr = LOCAL(opnd);
if (varPtr->value.objPtr) {
- if (varPtr->value.objPtr->typePtr == &dictIteratorType) {
+ if (Tcl_FetchIntRep(varPtr->value.objPtr, &dictIteratorType)) {
Tcl_Panic("mis-issued dictFirst!");
}
TclDecrRefCount(varPtr->value.objPtr);
@@ -7123,11 +7134,17 @@ TEBCresume(
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
statePtr = (*LOCAL(opnd)).value.objPtr;
- if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) {
- Tcl_Panic("mis-issued dictNext!");
+ {
+ const Tcl_ObjIntRep *irPtr;
+
+ if (statePtr &&
+ (irPtr = Tcl_FetchIntRep(statePtr, &dictIteratorType))) {
+ searchPtr = irPtr->twoPtrValue.ptr1;
+ Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done);
+ } else {
+ Tcl_Panic("mis-issued dictNext!");
+ }
}
- searchPtr = statePtr->internalRep.twoPtrValue.ptr1;
- Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done);
pushDictIteratorResult:
if (done) {
TclNewObj(emptyPtr);
@@ -9758,7 +9775,7 @@ EvalStatsCmd(
for (i = 0; i < globalTablePtr->numBuckets; i++) {
for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
entryPtr = entryPtr->nextPtr) {
- if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
+ if (NULL != Tcl_FetchIntRep(entryPtr->objPtr, &tclByteCodeType)) {
numByteCodeLits++;
}
(void) TclGetStringFromObj(entryPtr->objPtr, &length);
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index ea2a1c5..a4dded2 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -180,7 +180,7 @@ FileCopyRename(
}
jargv[0] = objv[objc - 1];
jargv[1] = source;
- newFileName = TclJoinPath(2, jargv);
+ newFileName = TclJoinPath(2, jargv, 1);
Tcl_IncrRefCount(newFileName);
result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag,
force);
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index 015cfc3..7dba19c 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -808,24 +808,24 @@ Tcl_FSJoinToPath(
Tcl_Obj *const objv[]) /* Path elements to join. */
{
if (pathPtr == NULL) {
- return TclJoinPath(objc, objv);
+ return TclJoinPath(objc, objv, 0);
}
if (objc == 0) {
- return TclJoinPath(1, &pathPtr);
+ return TclJoinPath(1, &pathPtr, 0);
}
if (objc == 1) {
Tcl_Obj *pair[2];
pair[0] = pathPtr;
pair[1] = objv[0];
- return TclJoinPath(2, pair);
+ return TclJoinPath(2, pair, 0);
} else {
int elemc = objc + 1;
Tcl_Obj *ret, **elemv = ckalloc(elemc*sizeof(Tcl_Obj *));
elemv[0] = pathPtr;
memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj *));
- ret = TclJoinPath(elemc, elemv);
+ ret = TclJoinPath(elemc, elemv, 0);
ckfree(elemv);
return ret;
}
diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y
index 9c67227..59f85bd 100644
--- a/generic/tclGetDate.y
+++ b/generic/tclGetDate.y
@@ -960,7 +960,7 @@ TclDatelex(
int
TclClockOldscanObjCmd(
- ClientData clientData, /* Unused */
+ void *clientData, /* Unused */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of paraneters */
Tcl_Obj *const *objv) /* Parameters */
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 10362d4..d144cbc 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -337,6 +337,22 @@ static const Tcl_ObjType chanObjType = {
NULL /* setFromAnyProc */
};
+#define ChanSetIntRep(objPtr, resPtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ (resPtr)->refCount++; \
+ ir.twoPtrValue.ptr1 = (resPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreIntRep((objPtr), &chanObjType, &ir); \
+ } while (0)
+
+#define ChanGetIntRep(objPtr, resPtr) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = Tcl_FetchIntRep((objPtr), &chanObjType); \
+ (resPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
#define BUSY_STATE(st, fl) \
((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \
(((st)->csPtrW) && ((fl) & TCL_WRITABLE)))
@@ -1515,12 +1531,12 @@ TclGetChannelFromObj(
return TCL_ERROR;
}
- if (objPtr->typePtr == &chanObjType) {
+ ChanGetIntRep(objPtr, resPtr);
+ if (resPtr) {
/*
* Confirm validity of saved lookup results.
*/
- resPtr = (ResolvedChanName *) objPtr->internalRep.twoPtrValue.ptr1;
statePtr = resPtr->statePtr;
if ((resPtr->interp == interp) /* Same interp context */
/* No epoch change in channel since lookup */
@@ -1537,7 +1553,7 @@ TclGetChannelFromObj(
if (chan == NULL) {
if (resPtr) {
- FreeChannelIntRep(objPtr);
+ Tcl_StoreIntRep(objPtr, &chanObjType, NULL);
}
return TCL_ERROR;
}
@@ -1548,14 +1564,10 @@ TclGetChannelFromObj(
*/
Tcl_Release((ClientData) resPtr->statePtr);
-
} else {
- TclFreeIntRep(objPtr);
-
resPtr = (ResolvedChanName *) ckalloc(sizeof(ResolvedChanName));
- resPtr->refCount = 1;
- objPtr->internalRep.twoPtrValue.ptr1 = (ClientData) resPtr;
- objPtr->typePtr = &chanObjType;
+ resPtr->refCount = 0;
+ ChanSetIntRep(objPtr, resPtr); /* Overwrites, if needed */
}
statePtr = ((Channel *)chan)->state;
resPtr->statePtr = statePtr;
@@ -11198,11 +11210,11 @@ DupChannelIntRep(
register Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
* currently have an internal rep.*/
{
- ResolvedChanName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedChanName *resPtr;
- resPtr->refCount++;
- copyPtr->internalRep.twoPtrValue.ptr1 = resPtr;
- copyPtr->typePtr = srcPtr->typePtr;
+ ChanGetIntRep(srcPtr, resPtr);
+ assert(resPtr);
+ ChanSetIntRep(copyPtr, resPtr);
}
/*
@@ -11225,9 +11237,10 @@ static void
FreeChannelIntRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
- ResolvedChanName *resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedChanName *resPtr;
- objPtr->typePtr = NULL;
+ ChanGetIntRep(objPtr, resPtr);
+ assert(resPtr);
if (resPtr->refCount-- > 1) {
return;
}
diff --git a/generic/tclIO.h b/generic/tclIO.h
index 07c54fa..15f0f78 100644
--- a/generic/tclIO.h
+++ b/generic/tclIO.h
@@ -96,7 +96,7 @@ typedef struct EventScriptRecord {
typedef struct Channel {
struct ChannelState *state; /* Split out state information */
- ClientData instanceData; /* Instance-specific data provided by creator
+ void *instanceData; /* Instance-specific data provided by creator
* of channel. */
const Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */
struct Channel *downChanPtr;/* Refers to channel this one was stacked
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index eeed0e5..c39c0dc 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -115,14 +115,18 @@ Tcl_GetIndexFromObj(
int flags, /* 0 or TCL_EXACT */
int *indexPtr) /* Place to store resulting integer index. */
{
+ if (!(flags & INDEX_TEMP_TABLE)) {
+
/*
* See if there is a valid cached result from a previous lookup (doing the
* check here saves the overhead of calling Tcl_GetIndexFromObjStruct in
* the common case where the result is cached).
*/
- if (!(flags & INDEX_TEMP_TABLE) && objPtr->typePtr == &indexType) {
- IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1;
+ const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objPtr, &indexType);
+
+ if (irPtr) {
+ IndexRep *indexRep = irPtr->twoPtrValue.ptr1;
/*
* Here's hoping we don't get hit by unfortunate packing constraints
@@ -135,6 +139,7 @@ Tcl_GetIndexFromObj(
return TCL_OK;
}
}
+ }
return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *),
msg, flags, indexPtr);
}
@@ -266,6 +271,7 @@ Tcl_GetIndexFromObjStruct(
const char *const *entryPtr;
Tcl_Obj *resultPtr;
IndexRep *indexRep;
+ const Tcl_ObjIntRep *irPtr;
/* Protect against invalid values, like -1 or 0. */
if (offset < (int)sizeof(char *)) {
@@ -275,13 +281,16 @@ Tcl_GetIndexFromObjStruct(
* See if there is a valid cached result from a previous lookup.
*/
- if (!(flags & INDEX_TEMP_TABLE) && objPtr->typePtr == &indexType) {
- indexRep = objPtr->internalRep.twoPtrValue.ptr1;
+ if (!(flags & INDEX_TEMP_TABLE)) {
+ irPtr = Tcl_FetchIntRep(objPtr, &indexType);
+ if (irPtr) {
+ indexRep = irPtr->twoPtrValue.ptr1;
if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
*indexPtr = indexRep->index;
return TCL_OK;
}
}
+ }
/*
* Lookup the value of the object in the table. Accept unique
@@ -337,17 +346,19 @@ Tcl_GetIndexFromObjStruct(
*/
if (!(flags & INDEX_TEMP_TABLE)) {
- if (objPtr->typePtr == &indexType) {
- indexRep = objPtr->internalRep.twoPtrValue.ptr1;
- } else {
- TclFreeIntRep(objPtr);
- indexRep = ckalloc(sizeof(IndexRep));
- objPtr->internalRep.twoPtrValue.ptr1 = indexRep;
- objPtr->typePtr = &indexType;
- }
- indexRep->tablePtr = (void *) tablePtr;
- indexRep->offset = offset;
- indexRep->index = index;
+ irPtr = Tcl_FetchIntRep(objPtr, &indexType);
+ if (irPtr) {
+ indexRep = irPtr->twoPtrValue.ptr1;
+ } else {
+ Tcl_ObjIntRep ir;
+
+ indexRep = ckalloc(sizeof(IndexRep));
+ ir.twoPtrValue.ptr1 = indexRep;
+ Tcl_StoreIntRep(objPtr, &indexType, &ir);
+ }
+ indexRep->tablePtr = (void *) tablePtr;
+ indexRep->offset = offset;
+ indexRep->index = index;
}
*indexPtr = index;
@@ -446,16 +457,10 @@ static void
UpdateStringOfIndex(
Tcl_Obj *objPtr)
{
- IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1;
- register char *buf;
- register unsigned len;
+ IndexRep *indexRep = Tcl_FetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1;
register const char *indexStr = EXPAND_OF(indexRep);
- len = strlen(indexStr);
- buf = ckalloc(len + 1);
- memcpy(buf, indexStr, len+1);
- objPtr->bytes = buf;
- objPtr->length = len;
+ Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr));
}
/*
@@ -481,12 +486,14 @@ DupIndex(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- IndexRep *srcIndexRep = srcPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_ObjIntRep ir;
IndexRep *dupIndexRep = ckalloc(sizeof(IndexRep));
- memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep));
- dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep;
- dupPtr->typePtr = &indexType;
+ memcpy(dupIndexRep, Tcl_FetchIntRep(srcPtr, &indexType)->twoPtrValue.ptr1,
+ sizeof(IndexRep));
+
+ ir.twoPtrValue.ptr1 = dupIndexRep;
+ Tcl_StoreIntRep(dupPtr, &indexType, &ir);
}
/*
@@ -510,7 +517,7 @@ static void
FreeIndex(
Tcl_Obj *objPtr)
{
- ckfree(objPtr->internalRep.twoPtrValue.ptr1);
+ ckfree(Tcl_FetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1);
objPtr->typePtr = NULL;
}
@@ -957,10 +964,10 @@ Tcl_WrongNumArgs(
/*
* Add the element, quoting it if necessary.
*/
+ const Tcl_ObjIntRep *irPtr;
- if (origObjv[i]->typePtr == &indexType) {
- register IndexRep *indexRep =
- origObjv[i]->internalRep.twoPtrValue.ptr1;
+ if ((irPtr = Tcl_FetchIntRep(origObjv[i], &indexType))) {
+ register IndexRep *indexRep = irPtr->twoPtrValue.ptr1;
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
@@ -1007,9 +1014,10 @@ Tcl_WrongNumArgs(
* the correct error message even if the subcommand was abbreviated.
* Otherwise, just use the string rep.
*/
+ const Tcl_ObjIntRep *irPtr;
- if (objv[i]->typePtr == &indexType) {
- register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1;
+ if ((irPtr = Tcl_FetchIntRep(objv[i], &indexType))) {
+ register IndexRep *indexRep = irPtr->twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL);
} else {
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 4c08fca..106b4e9 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -1024,6 +1024,10 @@ declare 256 {
int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr,
Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags)
}
+declare 257 {
+ void TclStaticPackage(Tcl_Interp *interp, const char *pkgName,
+ Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
+}
##############################################################################
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 47fb8c5..2f66302 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -272,7 +272,7 @@ typedef struct Namespace {
* synonym. */
char *fullName; /* The namespace's fully qualified name. This
* starts with ::. */
- ClientData clientData; /* An arbitrary value associated with this
+ void *clientData; /* An arbitrary value associated with this
* namespace. */
Tcl_NamespaceDeleteProc *deleteProc;
/* Procedure invoked when deleting the
@@ -543,7 +543,7 @@ typedef struct EnsembleConfig {
typedef struct VarTrace {
Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given by
* flags are performed on variable. */
- ClientData clientData; /* Argument to pass to proc. */
+ void *clientData; /* Argument to pass to proc. */
int flags; /* What events the trace procedure is
* interested in: OR-ed combination of
* TCL_TRACE_READS, TCL_TRACE_WRITES,
@@ -562,7 +562,7 @@ typedef struct CommandTrace {
Tcl_CommandTraceProc *traceProc;
/* Procedure to call when operations given by
* flags are performed on command. */
- ClientData clientData; /* Argument to pass to proc. */
+ void *clientData; /* Argument to pass to proc. */
int flags; /* What events the trace procedure is
* interested in: OR-ed combination of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
@@ -955,7 +955,7 @@ typedef struct CompiledLocal {
/* Customized variable resolution info
* supplied by the Tcl_ResolveCompiledVarProc
* associated with a namespace. Each variable
- * is marked by a unique ClientData tag during
+ * is marked by a unique tag during
* compilation, and that same tag is used to
* find the variable at runtime. */
char name[1]; /* Name of the local variable starts here. If
@@ -1016,7 +1016,7 @@ typedef struct Trace {
int level; /* Only trace commands at nesting level less
* than or equal to this. */
Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */
- ClientData clientData; /* Arbitrary value to pass to proc. */
+ void *clientData; /* Arbitrary value to pass to proc. */
struct Trace *nextPtr; /* Next in list of traces for this interp. */
int flags; /* Flags governing the trace - see
* Tcl_CreateObjTrace for details. */
@@ -1068,7 +1068,7 @@ typedef struct ActiveInterpTrace {
typedef struct AssocData {
Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */
- ClientData clientData; /* Value to pass to proc. */
+ void *clientData; /* Value to pass to proc. */
} AssocData;
/*
@@ -1146,7 +1146,7 @@ typedef struct CallFrame {
* recognized by the compiler. The compiler
* emits code that refers to these variables
* using an index into this array. */
- ClientData clientData; /* Pointer to some context that is used by
+ void *clientData; /* Pointer to some context that is used by
* object systems. The meaning of the contents
* of this field is defined by the code that
* sets it, and it should only ever be set by
@@ -1334,13 +1334,13 @@ typedef struct ContLineLoc {
* by [info frame]. Contains a sub-structure for each extra field.
*/
-typedef Tcl_Obj * (GetFrameInfoValueProc)(ClientData clientData);
+typedef Tcl_Obj * (GetFrameInfoValueProc)(void *clientData);
typedef struct {
const char *name; /* Name of this field. */
GetFrameInfoValueProc *proc; /* Function to generate a Tcl_Obj* from the
* clientData, or just use the clientData
* directly (after casting) if NULL. */
- ClientData clientData; /* Context for above function, or Tcl_Obj* if
+ void *clientData; /* Context for above function, or Tcl_Obj* if
* proc field is NULL. */
} ExtraFrameInfoField;
typedef struct {
@@ -1596,7 +1596,7 @@ typedef struct {
Tcl_ObjCmdProc *proc; /* The implementation of the subcommand. */
CompileProc *compileProc; /* The compiler for the subcommand. */
Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */
- ClientData clientData; /* Any clientData to give the command. */
+ void *clientData; /* Any clientData to give the command. */
int unsafe; /* Whether this command is to be hidden by
* default in a safe interpreter. */
} EnsembleImplMap;
@@ -1673,13 +1673,13 @@ typedef struct Command {
CompileProc *compileProc; /* Procedure called to compile command. NULL
* if no compile proc exists for command. */
Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */
- ClientData objClientData; /* Arbitrary value passed to object proc. */
+ void *objClientData; /* Arbitrary value passed to object proc. */
Tcl_CmdProc *proc; /* String-based command procedure. */
- ClientData clientData; /* Arbitrary value passed to string proc. */
+ void *clientData; /* Arbitrary value passed to string proc. */
Tcl_CmdDeleteProc *deleteProc;
/* Procedure invoked when deleting command to,
* e.g., free all client data. */
- ClientData deleteData; /* Arbitrary value passed to deleteProc. */
+ void *deleteData; /* Arbitrary value passed to deleteProc. */
int flags; /* Miscellaneous bits of information about
* command. See below for definitions. */
ImportRef *importRefPtr; /* List of each imported Command created in
@@ -1845,7 +1845,7 @@ typedef struct Interp {
/* Hash table used by tclBasic.c to keep track
* of hidden commands on a per-interp
* basis. */
- ClientData interpInfo; /* Information used by tclInterp.c to keep
+ void *interpInfo; /* Information used by tclInterp.c to keep
* track of master/slave interps on a
* per-interp basis. */
union {
@@ -2364,6 +2364,13 @@ typedef struct Interp {
#define TCL_ALIGN(x) (((int)(x) + 7) & ~7)
/*
+ * A common panic alert when memory allocation fails.
+ */
+
+#define TclOOM(ptr, size) \
+ ((size) && ((ptr)||(Tcl_Panic("unable to alloc %u bytes", (size)),1)))
+
+/*
* The following enum values are used to specify the runtime platform setting
* of the tclPlatform variable.
*/
@@ -2437,12 +2444,6 @@ typedef struct List {
#define ListRepPtr(listPtr) \
((List *) (listPtr)->internalRep.twoPtrValue.ptr1)
-#define ListSetIntRep(objPtr, listRepPtr) \
- (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(listRepPtr), \
- (objPtr)->internalRep.twoPtrValue.ptr2 = NULL, \
- (listRepPtr)->refCount++, \
- (objPtr)->typePtr = &tclListType
-
#define ListObjGetElements(listPtr, objc, objv) \
((objv) = &(ListRepPtr(listPtr)->elements), \
(objc) = ListRepPtr(listPtr)->elemCount)
@@ -2750,7 +2751,6 @@ MODULE_SCOPE const Tcl_ObjType tclBooleanType;
MODULE_SCOPE const Tcl_ObjType tclByteArrayType;
MODULE_SCOPE const Tcl_ObjType tclByteCodeType;
MODULE_SCOPE const Tcl_ObjType tclDoubleType;
-MODULE_SCOPE const Tcl_ObjType tclEndOffsetType;
MODULE_SCOPE const Tcl_ObjType tclIntType;
MODULE_SCOPE const Tcl_ObjType tclListType;
MODULE_SCOPE const Tcl_ObjType tclDictType;
@@ -2861,7 +2861,7 @@ typedef struct ForIterData {
typedef void* TclFindSymbolProc(Tcl_Interp* interp, Tcl_LoadHandle loadHandle,
const char* symbol);
struct Tcl_LoadHandle_ {
- ClientData clientData; /* Client data is the load handle in the
+ void *clientData; /* Client data is the load handle in the
* native filesystem if a module was loaded
* there, or an opaque pointer to a structure
* for further bookkeeping on load-from-VFS
@@ -3030,6 +3030,8 @@ MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp,
MODULE_SCOPE CmdFrame * TclGetCmdFrameForProcedure(Proc *procPtr);
MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp,
Tcl_Obj *value, int *code);
+MODULE_SCOPE Proc * TclGetLambdaFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, Tcl_Obj **nsObjPtrPtr);
MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, ClientData *clientDataPtr,
int *typePtr);
@@ -3078,11 +3080,11 @@ MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp);
MODULE_SCOPE void TclInitNamespaceSubsystem(void);
MODULE_SCOPE void TclInitNotifier(void);
MODULE_SCOPE void TclInitObjSubsystem(void);
-MODULE_SCOPE void TclInitSubsystems(void);
MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp);
MODULE_SCOPE int TclIsSpaceProc(char byte);
MODULE_SCOPE int TclIsBareword(char byte);
-MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[]);
+MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[],
+ int forceRelative);
MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result);
MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp,
@@ -3206,7 +3208,6 @@ MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp,
MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
Command *cmdPtr);
MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr);
-MODULE_SCOPE void TclSetPanicProc(TCL_NORETURN1 Tcl_PanicProc *proc);
MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr,
Tcl_Obj *newValue, Tcl_Encoding encoding);
MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result);
@@ -3328,7 +3329,7 @@ MODULE_SCOPE int TclChanPushObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE void TclClockInit(Tcl_Interp *interp);
MODULE_SCOPE int TclClockOldscanObjCmd(
- ClientData clientData, Tcl_Interp *interp,
+ void *clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Tcl_CloseObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
@@ -3453,6 +3454,9 @@ MODULE_SCOPE int Tcl_LmapObjCmd(ClientData clientData,
MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LpopObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
MODULE_SCOPE int Tcl_LrangeObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -4114,6 +4118,7 @@ MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr,
*/
MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr);
+MODULE_SCOPE void TclFreeObj(Tcl_Obj *objPtr);
MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr);
MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
@@ -4422,7 +4427,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
(objPtr)->length = 0; \
} else { \
(objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \
- memcpy((objPtr)->bytes, (bytePtr), (unsigned) (len)); \
+ memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (unsigned) (len)); \
(objPtr)->bytes[len] = '\0'; \
(objPtr)->length = (len); \
}
@@ -4484,6 +4489,18 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
/*
*----------------------------------------------------------------
+ * Macro used by the Tcl core to test whether an object has a
+ * string representation (or is a 'pure' internal value).
+ * The ANSI C "prototype" for this macro is:
+ *
+ * MODULE_SCOPE int TclHasStringRep(Tcl_Obj *objPtr);
+ *----------------------------------------------------------------
+ */
+
+#define TclHasStringRep(objPtr) ((objPtr)->bytes != NULL)
+
+/*
+ *----------------------------------------------------------------
* Macros used by the Tcl core to grow Tcl_Token arrays. They use the same
* growth algorithm as used in tclStringObj.c for growing strings. The ANSI C
* "prototype" for this macro is:
@@ -4701,18 +4718,18 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
#define TclSetIntObj(objPtr, i) \
do { \
+ Tcl_ObjIntRep ir; \
+ ir.wideValue = (Tcl_WideInt) i; \
TclInvalidateStringRep(objPtr); \
- TclFreeIntRep(objPtr); \
- (objPtr)->internalRep.wideValue = (Tcl_WideInt)(i); \
- (objPtr)->typePtr = &tclIntType; \
+ Tcl_StoreIntRep(objPtr, &tclIntType, &ir); \
} while (0)
#define TclSetDoubleObj(objPtr, d) \
- do { \
- TclInvalidateStringRep(objPtr); \
- TclFreeIntRep(objPtr); \
- (objPtr)->internalRep.doubleValue = (double)(d); \
- (objPtr)->typePtr = &tclDoubleType; \
+ do { \
+ Tcl_ObjIntRep ir; \
+ ir.doubleValue = (double) d; \
+ TclInvalidateStringRep(objPtr); \
+ Tcl_StoreIntRep(objPtr, &tclDoubleType, &ir); \
} while (0)
/*
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 03a2ed2..7131ce8 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -649,6 +649,11 @@ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp,
EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr,
Tcl_Var arrayPtr, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, const int flags);
+/* 257 */
+EXTERN void TclStaticPackage(Tcl_Interp *interp,
+ const char *pkgName,
+ Tcl_PackageInitProc *initProc,
+ Tcl_PackageInitProc *safeInitProc);
typedef struct TclIntStubs {
int magic;
@@ -911,6 +916,7 @@ typedef struct TclIntStubs {
Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */
int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */
int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */
+ void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */
} TclIntStubs;
extern const TclIntStubs *tclIntStubsPtr;
@@ -1352,6 +1358,8 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */
#define TclPtrUnsetVar \
(tclIntStubsPtr->tclPtrUnsetVar) /* 256 */
+#define TclStaticPackage \
+ (tclIntStubsPtr->tclStaticPackage) /* 257 */
#endif /* defined(USE_TCL_STUBS) */
@@ -1382,6 +1390,8 @@ extern const TclIntStubs *tclIntStubsPtr;
# undef TclGetCommandFullName
# undef TclCopyChannelOld
# undef TclSockMinimumBuffersOld
+# undef Tcl_StaticPackage
+# define Tcl_StaticPackage (tclIntStubsPtr->tclStaticPackage)
#endif
#endif /* _TCLINTDECLS */
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 1e75298..b1cc0c8 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -1826,7 +1826,7 @@ AliasNRCmd(
cmdc = prefc + objc - 1;
listPtr = Tcl_NewListObj(cmdc, NULL);
- listRep = listPtr->internalRep.twoPtrValue.ptr1;
+ listRep = ListRepPtr(listPtr);
listRep->elemCount = cmdc;
cmdv = &listRep->elements;
diff --git a/generic/tclLink.c b/generic/tclLink.c
index 53187d7..952df4e 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -416,7 +416,8 @@ LinkTraceProc(
case TCL_LINK_DOUBLE:
if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) {
#ifdef ACCEPT_NAN
- if (valueObj->typePtr != &tclDoubleType) {
+ Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(valueObj, &tclDoubleType);
+ if (irPtr == NULL) {
#endif
if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
@@ -425,7 +426,7 @@ LinkTraceProc(
}
#ifdef ACCEPT_NAN
}
- linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
+ linkPtr->lastValue.d = irPtr->doubleValue;
#endif
}
LinkedVar(double) = linkPtr->lastValue.d;
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 8314306..b7f73ed 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -12,6 +12,7 @@
*/
#include "tclInt.h"
+#include <assert.h>
/*
* Prototypes for functions defined later in this file:
@@ -46,6 +47,27 @@ const Tcl_ObjType tclListType = {
SetListFromAny /* setFromAnyProc */
};
+/* Macros to manipulate the List internal rep */
+
+#define ListSetIntRep(objPtr, listRepPtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ ir.twoPtrValue.ptr1 = (listRepPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ (listRepPtr)->refCount++; \
+ Tcl_StoreIntRep((objPtr), &tclListType, &ir); \
+ } while (0)
+
+#define ListGetIntRep(objPtr, listRepPtr) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = Tcl_FetchIntRep((objPtr), &tclListType); \
+ (listRepPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
+#define ListResetIntRep(objPtr, listRepPtr) \
+ Tcl_FetchIntRep((objPtr), &tclListType)->twoPtrValue.ptr1 = (listRepPtr)
+
#ifndef TCL_MIN_ELEMENT_GROWTH
#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *)
#endif
@@ -374,8 +396,7 @@ Tcl_SetListObj(
listRepPtr = NewListIntRep(objc, objv, 1);
ListSetIntRep(objPtr, listRepPtr);
} else {
- objPtr->bytes = &tclEmptyString;
- objPtr->length = 0;
+ Tcl_InitStringRep(objPtr, NULL, 0);
}
}
@@ -407,8 +428,10 @@ TclListObjCopy(
* to be returned. */
{
Tcl_Obj *copyPtr;
+ List *listRepPtr;
- if (listPtr->typePtr != &tclListType) {
+ ListGetIntRep(listPtr, listRepPtr);
+ if (NULL == listRepPtr) {
if (SetListFromAny(interp, listPtr) != TCL_OK) {
return NULL;
}
@@ -543,10 +566,13 @@ Tcl_ListObjGetElements(
{
register List *listRepPtr;
- if (listPtr->typePtr != &tclListType) {
- int result;
+ ListGetIntRep(listPtr, listRepPtr);
- if (listPtr->bytes == &tclEmptyString) {
+ if (listRepPtr == NULL) {
+ int result, length;
+
+ (void) Tcl_GetStringFromObj(listPtr, &length);
+ if (length == 0) {
*objcPtr = 0;
*objvPtr = NULL;
return TCL_OK;
@@ -555,8 +581,8 @@ Tcl_ListObjGetElements(
if (result != TCL_OK) {
return result;
}
+ ListGetIntRep(listPtr, listRepPtr);
}
- listRepPtr = ListRepPtr(listPtr);
*objcPtr = listRepPtr->elemCount;
*objvPtr = &listRepPtr->elements;
return TCL_OK;
@@ -653,10 +679,13 @@ Tcl_ListObjAppendElement(
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement");
}
- if (listPtr->typePtr != &tclListType) {
- int result;
- if (listPtr->bytes == &tclEmptyString) {
+ ListGetIntRep(listPtr, listRepPtr);
+ if (listRepPtr == NULL) {
+ int result, length;
+
+ (void) Tcl_GetStringFromObj(listPtr, &length);
+ if (length == 0) {
Tcl_SetListObj(listPtr, 1, &objPtr);
return TCL_OK;
}
@@ -664,9 +693,9 @@ Tcl_ListObjAppendElement(
if (result != TCL_OK) {
return result;
}
+ ListGetIntRep(listPtr, listRepPtr);
}
- listRepPtr = ListRepPtr(listPtr);
numElems = listRepPtr->elemCount;
numRequired = numElems + 1 ;
needGrow = (numRequired > listRepPtr->maxElemCount);
@@ -762,7 +791,11 @@ Tcl_ListObjAppendElement(
}
listRepPtr = newPtr;
}
- listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
+ ListResetIntRep(listPtr, listRepPtr);
+ listRepPtr->refCount++;
+ TclFreeIntRep(listPtr);
+ ListSetIntRep(listPtr, listRepPtr);
+ listRepPtr->refCount--;
/*
* Add objPtr to the end of listPtr's array of element pointers. Increment
@@ -817,10 +850,12 @@ Tcl_ListObjIndex(
{
register List *listRepPtr;
- if (listPtr->typePtr != &tclListType) {
- int result;
+ ListGetIntRep(listPtr, listRepPtr);
+ if (listRepPtr == NULL) {
+ int result, length;
- if (listPtr->bytes == &tclEmptyString) {
+ (void) Tcl_GetStringFromObj(listPtr, &length);
+ if (length == 0) {
*objPtrPtr = NULL;
return TCL_OK;
}
@@ -828,9 +863,9 @@ Tcl_ListObjIndex(
if (result != TCL_OK) {
return result;
}
+ ListGetIntRep(listPtr, listRepPtr);
}
- listRepPtr = ListRepPtr(listPtr);
if ((index < 0) || (index >= listRepPtr->elemCount)) {
*objPtrPtr = NULL;
} else {
@@ -870,10 +905,12 @@ Tcl_ListObjLength(
{
register List *listRepPtr;
- if (listPtr->typePtr != &tclListType) {
- int result;
+ ListGetIntRep(listPtr, listRepPtr);
+ if (listRepPtr == NULL) {
+ int result, length;
- if (listPtr->bytes == &tclEmptyString) {
+ (void) Tcl_GetStringFromObj(listPtr, &length);
+ if (length == 0) {
*intPtr = 0;
return TCL_OK;
}
@@ -881,9 +918,9 @@ Tcl_ListObjLength(
if (result != TCL_OK) {
return result;
}
+ ListGetIntRep(listPtr, listRepPtr);
}
- listRepPtr = ListRepPtr(listPtr);
*intPtr = listRepPtr->elemCount;
return TCL_OK;
}
@@ -943,9 +980,14 @@ Tcl_ListObjReplace(
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
- if (listPtr->typePtr != &tclListType) {
- if (listPtr->bytes == &tclEmptyString) {
- if (!objc) {
+
+ ListGetIntRep(listPtr, listRepPtr);
+ if (listRepPtr == NULL) {
+ int length;
+
+ (void) Tcl_GetStringFromObj(listPtr, &length);
+ if (length == 0) {
+ if (objc == 0) {
return TCL_OK;
}
Tcl_SetListObj(listPtr, objc, NULL);
@@ -956,6 +998,7 @@ Tcl_ListObjReplace(
return result;
}
}
+ ListGetIntRep(listPtr, listRepPtr);
}
/*
@@ -966,7 +1009,6 @@ Tcl_ListObjReplace(
* Resist any temptation to optimize this case.
*/
- listRepPtr = ListRepPtr(listPtr);
elemPtrs = &listRepPtr->elements;
numElems = listRepPtr->elemCount;
@@ -1020,7 +1062,7 @@ Tcl_ListObjReplace(
}
if (newPtr) {
listRepPtr = newPtr;
- listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
+ ListResetIntRep(listPtr, listRepPtr);
elemPtrs = &listRepPtr->elements;
listRepPtr->maxElemCount = attempt;
needGrow = numRequired > listRepPtr->maxElemCount;
@@ -1093,7 +1135,7 @@ Tcl_ListObjReplace(
}
}
- listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
+ ListResetIntRep(listPtr, listRepPtr);
listRepPtr->refCount++;
elemPtrs = &listRepPtr->elements;
@@ -1166,10 +1208,15 @@ Tcl_ListObjReplace(
listRepPtr->elemCount = numRequired;
/*
- * Invalidate and free any old string representation since it no longer
- * reflects the list's internal representation.
+ * Invalidate and free any old representations that may not agree
+ * with the revised list's internal representation.
*/
+ listRepPtr->refCount++;
+ TclFreeIntRep(listPtr);
+ ListSetIntRep(listPtr, listRepPtr);
+ listRepPtr->refCount--;
+
TclInvalidateStringRep(listPtr);
return TCL_OK;
}
@@ -1208,6 +1255,7 @@ TclLindexList(
int index; /* Index into the list. */
Tcl_Obj *indexListCopy;
+ List *listRepPtr;
/*
* Determine whether argPtr designates a list or a single index. We have
@@ -1215,7 +1263,8 @@ TclLindexList(
* shimmering; see TIP#22 and TIP#33 for the details.
*/
- if (argPtr->typePtr != &tclListType
+ ListGetIntRep(argPtr, listRepPtr);
+ if ((listRepPtr == NULL)
&& TclGetIntForIndexM(NULL , argPtr, 0, &index) == TCL_OK) {
/*
* argPtr designates a single index.
@@ -1246,13 +1295,12 @@ TclLindexList(
return TclLindexFlat(interp, listPtr, 1, &argPtr);
}
- {
- int indexCount = -1; /* Size of the array of list indices. */
- Tcl_Obj **indices = NULL; /* Array of list indices. */
+ ListGetIntRep(indexListCopy, listRepPtr);
- TclListObjGetElements(NULL, indexListCopy, &indexCount, &indices);
- listPtr = TclLindexFlat(interp, listPtr, indexCount, indices);
- }
+ assert(listRepPtr != NULL);
+
+ listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount,
+ &listRepPtr->elements);
Tcl_DecrRefCount(indexListCopy);
return listPtr;
}
@@ -1356,6 +1404,7 @@ TclLindexFlat(
*
* Core of the 'lset' command when objc == 4. Objv[2] may be either a
* scalar index or a list of indices.
+ * It also handles 'lpop' when given a NULL value.
*
* Results:
* Returns the new value of the list variable, or NULL if there was an
@@ -1380,13 +1429,14 @@ TclLsetList(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listPtr, /* Pointer to the list being modified. */
Tcl_Obj *indexArgPtr, /* Index or index-list arg to 'lset'. */
- Tcl_Obj *valuePtr) /* Value arg to 'lset'. */
+ Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */
{
int indexCount = 0; /* Number of indices in the index list. */
Tcl_Obj **indices = NULL; /* Vector of indices in the index list. */
Tcl_Obj *retValuePtr; /* Pointer to the list to be returned. */
int index; /* Current index in the list - discarded. */
Tcl_Obj *indexListCopy;
+ List *listRepPtr;
/*
* Determine whether the index arg designates a list or a single index.
@@ -1394,7 +1444,8 @@ TclLsetList(
* shimmering; see TIP #22 and #23 for details.
*/
- if (indexArgPtr->typePtr != &tclListType
+ ListGetIntRep(indexArgPtr, listRepPtr);
+ if (listRepPtr == NULL
&& TclGetIntForIndexM(NULL, indexArgPtr, 0, &index) == TCL_OK) {
/*
* indexArgPtr designates a single index.
@@ -1431,6 +1482,7 @@ TclLsetList(
* TclLsetFlat --
*
* Core engine of the 'lset' command.
+ * It also handles 'lpop' when given a NULL value.
*
* Results:
* Returns the new value of the list variable, or NULL if an error
@@ -1475,18 +1527,22 @@ TclLsetFlat(
int indexCount, /* Number of index args. */
Tcl_Obj *const indexArray[],
/* Index args. */
- Tcl_Obj *valuePtr) /* Value arg to 'lset'. */
+ Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */
{
int index, result, len;
Tcl_Obj *subListPtr, *retValuePtr, *chainPtr;
+ Tcl_ObjIntRep *irPtr;
/*
* If there are no indices, simply return the new value. (Without
* indices, [lset] is a synonym for [set].
+ * [lpop] does not use this but protect for NULL valuePtr just in case.
*/
if (indexCount == 0) {
- Tcl_IncrRefCount(valuePtr);
+ if (valuePtr != NULL) {
+ Tcl_IncrRefCount(valuePtr);
+ }
return valuePtr;
}
@@ -1546,12 +1602,14 @@ TclLsetFlat(
}
indexArray++;
- if (index < 0 || index > elemCount) {
+ if (index < 0 || index > elemCount
+ || (valuePtr == NULL && index >= elemCount)) {
/* ...the index points outside the sublist. */
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("list index out of range", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET",
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION",
+ valuePtr == NULL ? "LPOP" : "LSET",
"BADINDEX", NULL);
}
result = TCL_ERROR;
@@ -1609,7 +1667,8 @@ TclLsetFlat(
* them at that time.
*/
- parentList->internalRep.twoPtrValue.ptr2 = chainPtr;
+ irPtr = Tcl_FetchIntRep(parentList, &tclListType);
+ irPtr->twoPtrValue.ptr2 = chainPtr;
chainPtr = parentList;
}
} while (indexCount > 0);
@@ -1623,22 +1682,32 @@ TclLsetFlat(
while (chainPtr) {
Tcl_Obj *objPtr = chainPtr;
+ List *listRepPtr;
+
+ /*
+ * Clear away our intrep surgery mess.
+ */
+ irPtr = Tcl_FetchIntRep(objPtr, &tclListType);
+ listRepPtr = irPtr->twoPtrValue.ptr1;
+ chainPtr = irPtr->twoPtrValue.ptr2;
+
if (result == TCL_OK) {
+
/*
* We're going to store valuePtr, so spoil string reps of all
* containing lists.
*/
+ listRepPtr->refCount++;
+ TclFreeIntRep(objPtr);
+ ListSetIntRep(objPtr, listRepPtr);
+ listRepPtr->refCount--;
+
TclInvalidateStringRep(objPtr);
+ } else {
+ irPtr->twoPtrValue.ptr2 = NULL;
}
-
- /*
- * Clear away our intrep surgery mess.
- */
-
- chainPtr = objPtr->internalRep.twoPtrValue.ptr2;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
}
if (result != TCL_OK) {
@@ -1661,12 +1730,14 @@ TclLsetFlat(
len = -1;
TclListObjLength(NULL, subListPtr, &len);
- if (index == len) {
+ if (valuePtr == NULL) {
+ Tcl_ListObjReplace(NULL, subListPtr, index, 1, 0, NULL);
+ } else if (index == len) {
Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr);
} else {
TclListObjSetElement(NULL, subListPtr, index, valuePtr);
+ TclInvalidateStringRep(subListPtr);
}
- TclInvalidateStringRep(subListPtr);
Tcl_IncrRefCount(retValuePtr);
return retValuePtr;
}
@@ -1722,10 +1793,13 @@ TclListObjSetElement(
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "TclListObjSetElement");
}
- if (listPtr->typePtr != &tclListType) {
- int result;
- if (listPtr->bytes == &tclEmptyString) {
+ ListGetIntRep(listPtr, listRepPtr);
+ if (listRepPtr == NULL) {
+ int result, length;
+
+ (void) Tcl_GetStringFromObj(listPtr, &length);
+ if (length == 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("list index out of range", -1));
@@ -1738,9 +1812,9 @@ TclListObjSetElement(
if (result != TCL_OK) {
return result;
}
+ ListGetIntRep(listPtr, listRepPtr);
}
- listRepPtr = ListRepPtr(listPtr);
elemCount = listRepPtr->elemCount;
/*
@@ -1783,7 +1857,8 @@ TclListObjSetElement(
listRepPtr->refCount--;
- listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr = newPtr;
+ listRepPtr = newPtr;
+ ListResetIntRep(listPtr, listRepPtr);
}
elemPtrs = &listRepPtr->elements;
@@ -1805,6 +1880,18 @@ TclListObjSetElement(
elemPtrs[index] = valuePtr;
+ /*
+ * Invalidate outdated intreps.
+ */
+
+ ListGetIntRep(listPtr, listRepPtr);
+ listRepPtr->refCount++;
+ TclFreeIntRep(listPtr);
+ ListSetIntRep(listPtr, listRepPtr);
+ listRepPtr->refCount--;
+
+ TclInvalidateStringRep(listPtr);
+
return TCL_OK;
}
@@ -1820,9 +1907,8 @@ TclListObjSetElement(
* None.
*
* Side effects:
- * Frees listPtr's List* internal representation and sets listPtr's
- * internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts of all
- * element objects, which may free them.
+ * Frees listPtr's List* internal representation, if no longer shared.
+ * May decrement the ref counts of element objects, which may free them.
*
*----------------------------------------------------------------------
*/
@@ -1831,7 +1917,10 @@ static void
FreeListInternalRep(
Tcl_Obj *listPtr) /* List object with internal rep to free. */
{
- List *listRepPtr = ListRepPtr(listPtr);
+ List *listRepPtr;
+
+ ListGetIntRep(listPtr, listRepPtr);
+ assert(listRepPtr != NULL);
if (listRepPtr->refCount-- <= 1) {
Tcl_Obj **elemPtrs = &listRepPtr->elements;
@@ -1842,8 +1931,6 @@ FreeListInternalRep(
}
ckfree(listRepPtr);
}
-
- listPtr->typePtr = NULL;
}
/*
@@ -1868,8 +1955,10 @@ DupListInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- List *listRepPtr = ListRepPtr(srcPtr);
+ List *listRepPtr;
+ ListGetIntRep(srcPtr, listRepPtr);
+ assert(listRepPtr != NULL);
ListSetIntRep(copyPtr, listRepPtr);
}
@@ -1908,7 +1997,7 @@ SetListFromAny(
* describe duplicate keys).
*/
- if (objPtr->typePtr == &tclDictType && !objPtr->bytes) {
+ if (!TclHasStringRep(objPtr) && Tcl_FetchIntRep(objPtr, &tclDictType)) {
Tcl_Obj *keyPtr, *valuePtr;
Tcl_DictSearch search;
int done, size;
@@ -1966,10 +2055,12 @@ SetListFromAny(
while (nextElem < limit) {
const char *elemStart;
+ char *check;
int elemSize, literal;
if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem,
&elemStart, &nextElem, &elemSize, &literal)) {
+ fail:
while (--elemPtrs >= &listRepPtr->elements) {
Tcl_DecrRefCount(*elemPtrs);
}
@@ -1980,14 +2071,21 @@ SetListFromAny(
break;
}
- /* TODO: replace panic with error on alloc failure? */
- if (literal) {
- TclNewStringObj(*elemPtrs, elemStart, elemSize);
- } else {
- TclNewObj(*elemPtrs);
- (*elemPtrs)->bytes = ckalloc((unsigned) elemSize + 1);
- (*elemPtrs)->length = TclCopyAndCollapse(elemSize, elemStart,
- (*elemPtrs)->bytes);
+ TclNewObj(*elemPtrs);
+ TclInvalidateStringRep(*elemPtrs);
+ check = Tcl_InitStringRep(*elemPtrs, literal ? elemStart : NULL,
+ elemSize);
+ if (elemSize && check == NULL) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot construct list, out of memory", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ goto fail;
+ }
+ if (!literal) {
+ Tcl_InitStringRep(*elemPtrs, NULL,
+ TclCopyAndCollapse(elemSize, elemStart, check));
}
Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */
@@ -1997,12 +2095,11 @@ SetListFromAny(
}
/*
- * Free the old internalRep before setting the new one. We do this as late
+ * Store the new internalRep. We do this as late
* as possible to allow the conversion code, in particular
- * Tcl_GetStringFromObj, to use that old internalRep.
+ * Tcl_GetStringFromObj, to use the old internalRep.
*/
- TclFreeIntRep(objPtr);
ListSetIntRep(objPtr, listRepPtr);
return TCL_OK;
}
@@ -2034,12 +2131,17 @@ UpdateStringOfList(
{
# define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
- List *listRepPtr = ListRepPtr(listPtr);
- int numElems = listRepPtr->elemCount;
- int i, length, bytesNeeded = 0;
- const char *elem;
+ int numElems, i, length, bytesNeeded = 0;
+ const char *elem, *start;
char *dst;
Tcl_Obj **elemPtrs;
+ List *listRepPtr;
+
+ ListGetIntRep(listPtr, listRepPtr);
+
+ assert(listRepPtr != NULL);
+
+ numElems = listRepPtr->elemCount;
/*
* Mark the list as being canonical; although it will now have a string
@@ -2054,8 +2156,7 @@ UpdateStringOfList(
*/
if (numElems == 0) {
- listPtr->bytes = &tclEmptyString;
- listPtr->length = 0;
+ Tcl_InitStringRep(listPtr, NULL, 0);
return;
}
@@ -2084,22 +2185,23 @@ UpdateStringOfList(
if (bytesNeeded > INT_MAX - numElems + 1) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
- bytesNeeded += numElems;
+ bytesNeeded += numElems - 1;
/*
* Pass 2: copy into string rep buffer.
*/
- listPtr->length = bytesNeeded - 1;
- listPtr->bytes = ckalloc(bytesNeeded);
- dst = listPtr->bytes;
+ start = dst = Tcl_InitStringRep(listPtr, NULL, bytesNeeded);
+ TclOOM(dst, bytesNeeded);
for (i = 0; i < numElems; i++) {
flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
elem = TclGetStringFromObj(elemPtrs[i], &length);
dst += TclConvertElement(elem, length, dst, flagPtr[i]);
*dst++ = ' ';
}
- listPtr->bytes[listPtr->length] = '\0';
+
+ /* Set the string length to what was actually written, the safe choice */
+ (void) Tcl_InitStringRep(listPtr, NULL, dst - 1 - start);
if (flagPtr != localFlags) {
ckfree(flagPtr);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 2b8dd51..27aafc3 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -25,6 +25,7 @@
#include "tclInt.h"
#include "tclCompile.h" /* for TclLogCommandInfo visibility */
+#include <assert.h>
/*
* Thread-local storage used to avoid having a global lock on data that is not
@@ -152,6 +153,22 @@ static const Tcl_ObjType nsNameType = {
SetNsNameFromAny /* setFromAnyProc */
};
+#define NsNameSetIntRep(objPtr, nnPtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ (nnPtr)->refCount++; \
+ ir.twoPtrValue.ptr1 = (nnPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreIntRep((objPtr), &nsNameType, &ir); \
+ } while (0)
+
+#define NsNameGetIntRep(objPtr, nnPtr) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = Tcl_FetchIntRep((objPtr), &nsNameType); \
+ (nnPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
* Array of values describing how to implement each standard subcommand of the
* "namespace" command.
@@ -2898,15 +2915,16 @@ GetNamespaceFromObj(
Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */
{
ResolvedNsName *resNamePtr;
- Namespace *nsPtr, *refNsPtr;
- if (objPtr->typePtr == &nsNameType) {
+ NsNameGetIntRep(objPtr, resNamePtr);
+ if (resNamePtr) {
+ Namespace *nsPtr, *refNsPtr;
+
/*
* Check that the ResolvedNsName is still valid; avoid letting the ref
* cross interps.
*/
- resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
nsPtr = resNamePtr->nsPtr;
refNsPtr = resNamePtr->refNsPtr;
if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp)
@@ -2915,9 +2933,11 @@ GetNamespaceFromObj(
*nsPtrPtr = (Tcl_Namespace *) nsPtr;
return TCL_OK;
}
+ Tcl_StoreIntRep(objPtr, &nsNameType, NULL);
}
if (SetNsNameFromAny(interp, objPtr) == TCL_OK) {
- resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ NsNameGetIntRep(objPtr, resNamePtr);
+ assert(resNamePtr != NULL);
*nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr;
return TCL_OK;
}
@@ -4687,8 +4707,11 @@ FreeNsNameInternalRep(
register Tcl_Obj *objPtr) /* nsName object with internal representation
* to free. */
{
- ResolvedNsName *resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedNsName *resNamePtr;
+ NsNameGetIntRep(objPtr, resNamePtr);
+ assert(resNamePtr != NULL);
+
/*
* Decrement the reference count of the namespace. If there are no more
* references, free it up.
@@ -4704,7 +4727,6 @@ FreeNsNameInternalRep(
TclNsDecrRefCount(resNamePtr->nsPtr);
ckfree(resNamePtr);
}
- objPtr->typePtr = NULL;
}
/*
@@ -4731,11 +4753,11 @@ DupNsNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- ResolvedNsName *resNamePtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedNsName *resNamePtr;
- copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr;
- resNamePtr->refCount++;
- copyPtr->typePtr = &nsNameType;
+ NsNameGetIntRep(srcPtr, resNamePtr);
+ assert(resNamePtr != NULL);
+ NsNameSetIntRep(copyPtr, resNamePtr);
}
/*
@@ -4780,24 +4802,15 @@ SetNsNameFromAny(
TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS,
&nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
+ if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) {
+ return TCL_ERROR;
+ }
+
/*
* If we found a namespace, then create a new ResolvedNsName structure
* that holds a reference to it.
*/
- if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) {
- /*
- * Our failed lookup proves any previously cached nsName intrep is no
- * longer valid. Get rid of it so we no longer waste memory storing
- * it, nor time determining its invalidity again and again.
- */
-
- if (objPtr->typePtr == &nsNameType) {
- TclFreeIntRep(objPtr);
- }
- return TCL_ERROR;
- }
-
nsPtr->refCount++;
resNamePtr = ckalloc(sizeof(ResolvedNsName));
resNamePtr->nsPtr = nsPtr;
@@ -4806,10 +4819,8 @@ SetNsNameFromAny(
} else {
resNamePtr->refNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
}
- resNamePtr->refCount = 1;
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = resNamePtr;
- objPtr->typePtr = &nsNameType;
+ resNamePtr->refCount = 0;
+ NsNameSetIntRep(objPtr, resNamePtr);
return TCL_OK;
}
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 2491c2f..0440395 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -26,6 +26,7 @@ static const struct {
int flag;
} defineCmds[] = {
{"constructor", TclOODefineConstructorObjCmd, 0},
+ {"definitionnamespace", TclOODefineDefnNsObjCmd, 0},
{"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
{"destructor", TclOODefineDestructorObjCmd, 0},
{"export", TclOODefineExportObjCmd, 0},
@@ -445,6 +446,7 @@ InitClassSystemRoots(
{
Class fakeCls;
Object fakeObject;
+ Tcl_Obj *defNsName;
/* Stand up a phony class for bootstrapping. */
fPtr->objectCls = &fakeCls;
@@ -456,16 +458,25 @@ InitClassSystemRoots(
/* Corresponding TclOODecrRefCount in KillFoudation */
AddRef(fPtr->objectCls->thisPtr);
- /* This is why it is unnecessary in this routine to replace the
+ /*
+ * This is why it is unnecessary in this routine to replace the
* incremented reference count of fPtr->objectCls that was swallowed by
- * fakeObject. */
+ * fakeObject.
+ */
+
fPtr->objectCls->superclasses.num = 0;
ckfree(fPtr->objectCls->superclasses.list);
fPtr->objectCls->superclasses.list = NULL;
- /* special initialization for the primordial objects */
+ /*
+ * Special initialization for the primordial objects.
+ */
+
fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
fPtr->objectCls->flags |= ROOT_OBJECT;
+ TclNewLiteralStringObj(defNsName, "::oo::objdefine");
+ fPtr->objectCls->objDefinitionNs = defNsName;
+ Tcl_IncrRefCount(defNsName);
fPtr->classCls = TclOOAllocClass(interp,
AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
@@ -480,7 +491,10 @@ InitClassSystemRoots(
* KillFoundation.
*/
- /* Rewire bootstrapped objects. */
+ /*
+ * Rewire bootstrapped objects.
+ */
+
fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
AddRef(fPtr->classCls->thisPtr);
TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
@@ -491,6 +505,9 @@ InitClassSystemRoots(
fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
fPtr->classCls->flags |= ROOT_CLASS;
+ TclNewLiteralStringObj(defNsName, "::oo::define");
+ fPtr->classCls->clsDefinitionNs = defNsName;
+ Tcl_IncrRefCount(defNsName);
/* Standard initialization for new Objects */
TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls);
@@ -959,6 +976,19 @@ TclOOReleaseClassContents(
}
/*
+ * Stop using the class for definition information.
+ */
+
+ if (clsPtr->clsDefinitionNs) {
+ Tcl_DecrRefCount(clsPtr->clsDefinitionNs);
+ clsPtr->clsDefinitionNs = NULL;
+ }
+ if (clsPtr->objDefinitionNs) {
+ Tcl_DecrRefCount(clsPtr->objDefinitionNs);
+ clsPtr->objDefinitionNs = NULL;
+ }
+
+ /*
* Squelch method implementation chain caches.
*/
@@ -1057,7 +1087,6 @@ TclOOReleaseClassContents(
if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) {
Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
}
- oPtr->classPtr = NULL;
}
/*
@@ -1183,7 +1212,9 @@ ObjectNamespaceDeleted(
TclOORemoveFromInstances(oPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
- ckfree(oPtr->mixins.list);
+ if (oPtr->mixins.list != NULL) {
+ ckfree(oPtr->mixins.list);
+ }
}
FOREACH(filterObj, oPtr->filters) {
@@ -1384,6 +1415,10 @@ TclOORemoveFromMixins(
break;
}
}
+ if (oPtr->mixins.num == 0) {
+ ckfree(oPtr->mixins.list);
+ oPtr->mixins.list = NULL;
+ }
return res;
}
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index 9d5312c..36fc3bd 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -15,6 +15,7 @@
#endif
#include "tclInt.h"
#include "tclOOInt.h"
+#include <assert.h>
/*
* Structure containing a CallContext and any other values needed only during
@@ -31,6 +32,22 @@ struct ChainBuilder {
};
/*
+ * Structures used for traversing the class hierarchy to find out where
+ * definitions are supposed to be done.
+ */
+
+typedef struct {
+ Class *definerCls;
+ Tcl_Obj *namespaceName;
+} DefineEntry;
+
+typedef struct {
+ DefineEntry *list;
+ int num;
+ int size;
+} DefineChain;
+
+/*
* Extra flags used for call chain management.
*/
@@ -77,6 +94,9 @@ static void AddClassFiltersToCallContext(Object *const oPtr,
static void AddClassMethodNames(Class *clsPtr, const int flags,
Tcl_HashTable *const namesPtr,
Tcl_HashTable *const examinedClassesPtr);
+static inline void AddDefinitionNamespaceToChain(Class *const definerCls,
+ Tcl_Obj *const namespaceName,
+ DefineChain *const definePtr, int flags);
static inline void AddMethodToCallChain(Method *const mPtr,
struct ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters,
@@ -105,6 +125,10 @@ static int AddSimpleClassChainToCallContext(Class *classPtr,
struct ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters, int flags,
Class *const filterDecl);
+static void AddSimpleClassDefineNamespaces(Class *classPtr,
+ DefineChain *const definePtr, int flags);
+static inline void AddSimpleDefineNamespaces(Object *const oPtr,
+ DefineChain *const definePtr, int flags);
static int CmpStr(const void *ptr1, const void *ptr2);
static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr);
static Tcl_NRPostProc FinalizeMethodRefs;
@@ -128,6 +152,7 @@ static const Tcl_ObjType methodNameType = {
NULL,
NULL
};
+
/*
* ----------------------------------------------------------------------
@@ -222,11 +247,12 @@ StashCallChain(
Tcl_Obj *objPtr,
CallChain *callPtr)
{
+ Tcl_ObjIntRep ir;
+
callPtr->refCount++;
TclGetString(objPtr);
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &methodNameType;
- objPtr->internalRep.twoPtrValue.ptr1 = callPtr;
+ ir.twoPtrValue.ptr1 = callPtr;
+ Tcl_StoreIntRep(objPtr, &methodNameType, &ir);
}
void
@@ -253,21 +279,16 @@ DupMethodNameRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dstPtr)
{
- register CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1;
-
- dstPtr->typePtr = &methodNameType;
- dstPtr->internalRep.twoPtrValue.ptr1 = callPtr;
- callPtr->refCount++;
+ StashCallChain(dstPtr,
+ Tcl_FetchIntRep(srcPtr, &methodNameType)->twoPtrValue.ptr1);
}
static void
FreeMethodNameRep(
Tcl_Obj *objPtr)
{
- register CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1;
-
- TclOODeleteChain(callPtr);
- objPtr->typePtr = NULL;
+ TclOODeleteChain(
+ Tcl_FetchIntRep(objPtr, &methodNameType)->twoPtrValue.ptr1);
}
/*
@@ -1165,15 +1186,16 @@ TclOOGetCallContext(
* the object, and in the class).
*/
+ const Tcl_ObjIntRep *irPtr;
const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
- if (cacheInThisObj->typePtr == &methodNameType) {
- callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1;
+ if ((irPtr = Tcl_FetchIntRep(cacheInThisObj, &methodNameType))) {
+ callPtr = irPtr->twoPtrValue.ptr1;
if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
callPtr->refCount++;
goto returnContext;
}
- FreeMethodNameRep(cacheInThisObj);
+ Tcl_StoreIntRep(cacheInThisObj, &methodNameType, NULL);
}
if (oPtr->flags & USE_CLASS_CACHE) {
@@ -1836,6 +1858,246 @@ TclOORenderCallChain(
}
/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetDefineContextNamespace --
+ *
+ * Responsible for determining which namespace to use for definitions.
+ * This is done by building a define chain, which models (strongly!) the
+ * way that a call chain works but with a different internal model.
+ *
+ * Then it walks the chain to find the first namespace name that actually
+ * resolves to an existing namespace.
+ *
+ * Returns:
+ * Name of namespace, or NULL if none can be found. Note that this
+ * function does *not* set an error message in the interpreter on failure.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+#define DEFINE_CHAIN_STATIC_SIZE 4 /* Enough space to store most cases. */
+
+Tcl_Namespace *
+TclOOGetDefineContextNamespace(
+ Tcl_Interp *interp, /* In what interpreter should namespace names
+ * actually be resolved. */
+ Object *oPtr, /* The object to get the context for. */
+ int forClass) /* What sort of context are we looking for.
+ * If true, we are going to use this for
+ * [oo::define], otherwise, we are going to
+ * use this for [oo::objdefine]. */
+{
+ DefineChain define;
+ DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE];
+ DefineEntry *entryPtr;
+ Tcl_Namespace *nsPtr = NULL;
+ int i;
+
+ define.list = staticSpace;
+ define.num = 0;
+ define.size = DEFINE_CHAIN_STATIC_SIZE;
+
+ /*
+ * Add the actual define locations. We have to do this twice to handle
+ * class mixins right.
+ */
+
+ AddSimpleDefineNamespaces(oPtr, &define, forClass | BUILDING_MIXINS);
+ AddSimpleDefineNamespaces(oPtr, &define, forClass);
+
+ /*
+ * Go through the list until we find a namespace whose name we can
+ * resolve.
+ */
+
+ FOREACH_STRUCT(entryPtr, define) {
+ if (TclGetNamespaceFromObj(interp, entryPtr->namespaceName,
+ &nsPtr) == TCL_OK) {
+ break;
+ }
+ Tcl_ResetResult(interp);
+ }
+ if (define.list != staticSpace) {
+ ckfree(define.list);
+ }
+ return nsPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddSimpleDefineNamespaces --
+ *
+ * Adds to the definition chain all the definitions provided by an
+ * object's class and its mixins, taking into account everything they
+ * inherit from.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+AddSimpleDefineNamespaces(
+ Object *const oPtr, /* Object to add define chain entries for. */
+ DefineChain *const definePtr,
+ /* Where to add the define chain entries. */
+ int flags) /* What sort of define chain are we
+ * building. */
+{
+ Class *mixinPtr;
+ int i;
+
+ FOREACH(mixinPtr, oPtr->mixins) {
+ AddSimpleClassDefineNamespaces(mixinPtr, definePtr,
+ flags | TRAVERSED_MIXIN);
+ }
+
+ AddSimpleClassDefineNamespaces(oPtr->selfCls, definePtr, flags);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddSimpleClassDefineNamespaces --
+ *
+ * Adds to the definition chain all the definitions provided by a class
+ * and its superclasses and its class mixins.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AddSimpleClassDefineNamespaces(
+ Class *classPtr, /* Class to add the define chain entries for. */
+ DefineChain *const definePtr,
+ /* Where to add the define chain entries. */
+ int flags) /* What sort of define chain are we
+ * building. */
+{
+ int i;
+ Class *superPtr;
+
+ /*
+ * We hard-code the tail-recursive form. It's by far the most common case
+ * *and* it is much more gentle on the stack.
+ */
+
+ tailRecurse:
+ FOREACH(superPtr, classPtr->mixins) {
+ AddSimpleClassDefineNamespaces(superPtr, definePtr,
+ flags | TRAVERSED_MIXIN);
+ }
+
+ if (flags & ~(TRAVERSED_MIXIN | BUILDING_MIXINS)) {
+ AddDefinitionNamespaceToChain(classPtr, classPtr->clsDefinitionNs,
+ definePtr, flags);
+ } else {
+ AddDefinitionNamespaceToChain(classPtr, classPtr->objDefinitionNs,
+ definePtr, flags);
+ }
+
+ switch (classPtr->superclasses.num) {
+ case 1:
+ classPtr = classPtr->superclasses.list[0];
+ goto tailRecurse;
+ default:
+ FOREACH(superPtr, classPtr->superclasses) {
+ AddSimpleClassDefineNamespaces(superPtr, definePtr, flags);
+ }
+ case 0:
+ return;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddDefinitionNamespaceToChain --
+ *
+ * Adds a single item to the definition chain (if it is meaningful),
+ * reallocating the space for the chain if necessary.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+AddDefinitionNamespaceToChain(
+ Class *const definerCls, /* What class defines this entry. */
+ Tcl_Obj *const namespaceName, /* The name for this entry (or NULL, a
+ * no-op). */
+ DefineChain *const definePtr,
+ /* The define chain to add the method
+ * implementation to. */
+ int flags) /* Used to check if we're mixin-consistent
+ * only. Mixin-consistent means that either
+ * we're looking to add things from a mixin
+ * and we have passed a mixin, or we're not
+ * looking to add things from a mixin and have
+ * not passed a mixin. */
+{
+ int i;
+
+ /*
+ * Return if this entry is blank. This is also where we enforce
+ * mixin-consistency.
+ */
+
+ if (namespaceName == NULL || !MIXIN_CONSISTENT(flags)) {
+ return;
+ }
+
+ /*
+ * First test whether the method is already in the call chain.
+ */
+
+ for (i=0 ; i<definePtr->num ; i++) {
+ if (definePtr->list[i].definerCls == definerCls) {
+ /*
+ * Call chain semantics states that methods come as *late* in the
+ * call chain as possible. This is done by copying down the
+ * following methods. Note that this does not change the number of
+ * method invocations in the call chain; it just rearranges them.
+ *
+ * We skip changing anything if the place we found was already at
+ * the end of the list.
+ */
+
+ if (i < definePtr->num - 1) {
+ memmove(&definePtr->list[i], &definePtr->list[i + 1],
+ sizeof(DefineEntry) * (definePtr->num - i - 1));
+ definePtr->list[i].definerCls = definerCls;
+ definePtr->list[i].namespaceName = namespaceName;
+ }
+ return;
+ }
+ }
+
+ /*
+ * Need to really add the define. This is made a bit more complex by the
+ * fact that we are using some "static" space initially, and only start
+ * realloc-ing if the chain gets long.
+ */
+
+ if (definePtr->num == definePtr->size) {
+ definePtr->size *= 2;
+ if (definePtr->num == DEFINE_CHAIN_STATIC_SIZE) {
+ DefineEntry *staticList = definePtr->list;
+
+ definePtr->list =
+ ckalloc(sizeof(DefineEntry) * definePtr->size);
+ memcpy(definePtr->list, staticList,
+ sizeof(DefineEntry) * definePtr->num);
+ } else {
+ definePtr->list = ckrealloc(definePtr->list,
+ sizeof(DefineEntry) * definePtr->size);
+ }
+ }
+ definePtr->list[i].definerCls = definerCls;
+ definePtr->list[i].namespaceName = namespaceName;
+ definePtr->num++;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index b4ff283..e7c948a 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -63,6 +63,8 @@ static inline int MagicDefinitionInvoke(Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv);
static inline Class * GetClassInOuterContext(Tcl_Interp *interp,
Tcl_Obj *className, const char *errMsg);
+static inline Tcl_Namespace *GetNamespaceInOuterContext(Tcl_Interp *interp,
+ Tcl_Obj *namespaceName);
static inline int InitDefineContext(Tcl_Interp *interp,
Tcl_Namespace *namespacePtr, Object *oPtr,
int objc, Tcl_Obj *const objv[]);
@@ -828,8 +830,7 @@ InitDefineContext(
if (namespacePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "cannot process definitions; support namespace deleted",
- -1));
+ "no definition namespace available", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -888,12 +889,12 @@ TclOOGetDefineCmdContext(
/*
* ----------------------------------------------------------------------
*
- * GetClassInOuterContext --
+ * GetClassInOuterContext, GetNamespaceInOuterContext --
*
- * Wrapper round Tcl_GetObjectFromObj to perform the lookup in the
- * context that called oo::define (or equivalent). Note that this may
- * have to go up multiple levels to get the level that we started doing
- * definitions at.
+ * Wrappers round Tcl_GetObjectFromObj and TclGetNamespaceFromObj to
+ * perform the lookup in the context that called oo::define (or
+ * equivalent). Note that this may have to go up multiple levels to get
+ * the level that we started doing definitions at.
*
* ----------------------------------------------------------------------
*/
@@ -928,6 +929,31 @@ GetClassInOuterContext(
}
return oPtr->classPtr;
}
+
+static inline Tcl_Namespace *
+GetNamespaceInOuterContext(
+ Tcl_Interp *interp,
+ Tcl_Obj *namespaceName)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Namespace *nsPtr;
+ int result;
+ CallFrame *savedFramePtr = iPtr->varFramePtr;
+
+ while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE
+ || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) {
+ if (iPtr->varFramePtr->callerVarPtr == NULL) {
+ Tcl_Panic("getting outer context when already in global context");
+ }
+ iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr;
+ }
+ result = TclGetNamespaceFromObj(interp, namespaceName, &nsPtr);
+ iPtr->varFramePtr = savedFramePtr;
+ if (result != TCL_OK) {
+ return NULL;
+ }
+ return nsPtr;
+}
/*
* ----------------------------------------------------------------------
@@ -1053,7 +1079,7 @@ TclOODefineObjCmd(
int objc,
Tcl_Obj *const *objv)
{
- Foundation *fPtr = TclOOGetFoundation(interp);
+ Tcl_Namespace *nsPtr;
Object *oPtr;
int result;
@@ -1068,7 +1094,7 @@ TclOODefineObjCmd(
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "%s does not refer to a class",TclGetString(objv[1])));
+ "%s does not refer to a class", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
@@ -1079,7 +1105,8 @@ TclOODefineObjCmd(
* command(s).
*/
- if (InitDefineContext(interp, fPtr->defineNs, oPtr, objc,objv) != TCL_OK){
+ nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 1);
+ if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
@@ -1095,7 +1122,7 @@ TclOODefineObjCmd(
}
TclDecrRefCount(objNameObj);
} else {
- result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv);
+ result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv);
}
TclOODecrRefCount(oPtr);
@@ -1128,7 +1155,7 @@ TclOOObjDefObjCmd(
int objc,
Tcl_Obj *const *objv)
{
- Foundation *fPtr = TclOOGetFoundation(interp);
+ Tcl_Namespace *nsPtr;
Object *oPtr;
int result;
@@ -1147,7 +1174,8 @@ TclOOObjDefObjCmd(
* command(s).
*/
- if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
+ nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0);
+ if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
@@ -1163,7 +1191,7 @@ TclOOObjDefObjCmd(
}
TclDecrRefCount(objNameObj);
} else {
- result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv);
+ result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv);
}
TclOODecrRefCount(oPtr);
@@ -1196,7 +1224,7 @@ TclOODefineSelfObjCmd(
int objc,
Tcl_Obj *const *objv)
{
- Foundation *fPtr = TclOOGetFoundation(interp);
+ Tcl_Namespace *nsPtr;
Object *oPtr;
int result, private;
@@ -1217,7 +1245,8 @@ TclOODefineSelfObjCmd(
* command(s).
*/
- if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
+ nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0);
+ if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
if (private) {
@@ -1236,7 +1265,7 @@ TclOODefineSelfObjCmd(
}
TclDecrRefCount(objNameObj);
} else {
- result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv);
+ result = MagicDefinitionInvoke(interp, nsPtr, 1, objc, objv);
}
TclOODecrRefCount(oPtr);
@@ -1449,6 +1478,8 @@ TclOODefineClassObjCmd(
TclOODeleteDescendants(interp, oPtr);
oPtr->flags &= ~DONT_DELETE;
TclOOReleaseClassContents(interp, oPtr);
+ ckfree(oPtr->classPtr);
+ oPtr->classPtr = NULL;
} else if (!wasClass && willBeClass) {
TclOOAllocClass(interp, oPtr);
}
@@ -1534,6 +1565,91 @@ TclOODefineConstructorObjCmd(
/*
* ----------------------------------------------------------------------
*
+ * TclOODefineDefnNsObjCmd --
+ *
+ * Implementation of the "definitionnamespace" subcommand of the
+ * "oo::define" command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineDefnNsObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ static const char *kindList[] = {
+ "-class",
+ "-instance",
+ NULL
+ };
+ int kind = 0;
+ Object *oPtr;
+ Tcl_Namespace *nsPtr;
+ Tcl_Obj *nsNamePtr, **storagePtr;
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!oPtr->classPtr) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr->flags & (ROOT_OBJECT | ROOT_CLASS)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not modify the definition namespace of the root classes",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse the arguments and work out what the user wants to do.
+ */
+
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?kind? namespace");
+ return TCL_ERROR;
+ }
+ if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[1], kindList, "kind", 0,
+ &kind) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (!Tcl_GetString(objv[objc - 1])[0]) {
+ nsNamePtr = NULL;
+ } else {
+ nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]);
+ if (nsPtr == NULL) {
+ return TCL_ERROR;
+ }
+ nsNamePtr = Tcl_NewStringObj(nsPtr->fullName, -1);
+ Tcl_IncrRefCount(nsNamePtr);
+ }
+
+ /*
+ * Update the correct field of the class definition.
+ */
+
+ if (kind) {
+ storagePtr = &oPtr->classPtr->objDefinitionNs;
+ } else {
+ storagePtr = &oPtr->classPtr->clsDefinitionNs;
+ }
+ if (*storagePtr != NULL) {
+ Tcl_DecrRefCount(*storagePtr);
+ }
+ *storagePtr = nsNamePtr;
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOODefineDeleteMethodObjCmd --
*
* Implementation of the "deletemethod" subcommand of the "oo::define"
@@ -1831,15 +1947,31 @@ TclOODefineMethodObjCmd(
int objc,
Tcl_Obj *const *objv)
{
+ /*
+ * Table of export modes for methods and their corresponding enum.
+ */
+
+ static const char *const exportModes[] = {
+ "-export",
+ "-private",
+ "-unexport",
+ NULL
+ };
+ enum ExportMode {
+ MODE_EXPORT,
+ MODE_PRIVATE,
+ MODE_UNEXPORT
+ } exportMode;
+
int isInstanceMethod = (clientData != NULL);
Object *oPtr;
- int isPublic;
+ int isPublic = 0;
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "name args body");
+ if (objc < 4 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?option? args body");
return TCL_ERROR;
}
-
+
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
@@ -1850,10 +1982,29 @@ TclOODefineMethodObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
- isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
- ? PUBLIC_METHOD : 0;
- if (IsPrivateDefine(interp)) {
- isPublic = TRUE_PRIVATE_METHOD;
+ if (objc == 5) {
+ if (Tcl_GetIndexFromObj(interp, objv[2], exportModes, "export flag",
+ 0, (int *) &exportMode) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (exportMode) {
+ case MODE_EXPORT:
+ isPublic = PUBLIC_METHOD;
+ break;
+ case MODE_PRIVATE:
+ isPublic = TRUE_PRIVATE_METHOD;
+ break;
+ case MODE_UNEXPORT:
+ isPublic = 0;
+ break;
+ }
+ } else {
+ if (IsPrivateDefine(interp)) {
+ isPublic = TRUE_PRIVATE_METHOD;
+ } else {
+ isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
+ ? PUBLIC_METHOD : 0;
+ }
}
/*
@@ -1862,12 +2013,12 @@ TclOODefineMethodObjCmd(
if (isInstanceMethod) {
if (TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1],
- objv[2], objv[3], NULL) == NULL) {
+ objv[objc - 2], objv[objc - 1], NULL) == NULL) {
return TCL_ERROR;
}
} else {
if (TclOONewProcMethod(interp, oPtr->classPtr, isPublic, objv[1],
- objv[2], objv[3], NULL) == NULL) {
+ objv[objc - 2], objv[objc - 1], NULL) == NULL) {
return TCL_ERROR;
}
}
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index fe433e4..fefeb0f 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -33,6 +33,7 @@ static Tcl_ObjCmdProc InfoObjectVariablesCmd;
static Tcl_ObjCmdProc InfoClassCallCmd;
static Tcl_ObjCmdProc InfoClassConstrCmd;
static Tcl_ObjCmdProc InfoClassDefnCmd;
+static Tcl_ObjCmdProc InfoClassDefnNsCmd;
static Tcl_ObjCmdProc InfoClassDestrCmd;
static Tcl_ObjCmdProc InfoClassFiltersCmd;
static Tcl_ObjCmdProc InfoClassForwardCmd;
@@ -73,6 +74,7 @@ static const EnsembleImplMap infoClassCmds[] = {
{"call", InfoClassCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"constructor", InfoClassConstrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"definition", InfoClassDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"definitionnamespace", InfoClassDefnNsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
@@ -116,12 +118,14 @@ TclOOInitInfo(
*/
infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
- Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict);
- Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1),
- Tcl_NewStringObj("::oo::InfoObject", -1));
- Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("class", -1),
- Tcl_NewStringObj("::oo::InfoClass", -1));
- Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict);
+ if (infoCmd) {
+ Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict);
+ Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1),
+ Tcl_NewStringObj("::oo::InfoObject", -1));
+ Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("class", -1),
+ Tcl_NewStringObj("::oo::InfoClass", -1));
+ Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict);
+ }
}
/*
@@ -1033,6 +1037,56 @@ InfoClassDefnCmd(
/*
* ----------------------------------------------------------------------
*
+ * InfoClassDefnNsCmd --
+ *
+ * Implements [info class definitionnamespace $clsName ?$kind?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassDefnNsCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ static const char *kindList[] = {
+ "-class",
+ "-instance",
+ NULL
+ };
+ int kind = 0;
+ Tcl_Obj *nsNamePtr;
+ Class *clsPtr;
+
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className ?kind?");
+ return TCL_ERROR;
+ }
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[2], kindList, "kind", 0,
+ &kind) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (kind) {
+ nsNamePtr = clsPtr->objDefinitionNs;
+ } else {
+ nsNamePtr = clsPtr->clsDefinitionNs;
+ }
+ if (nsNamePtr) {
+ Tcl_SetObjResult(interp, nsNamePtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* InfoClassDestrCmd --
*
* Implements [info class destructor $clsName]
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 47e5cf0..c1a9010 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -47,7 +47,7 @@ typedef struct Method {
* special flag record which is just used for
* the setting of the flags field. */
int refCount;
- ClientData clientData; /* Type-specific data. */
+ void *clientData; /* Type-specific data. */
Tcl_Obj *namePtr; /* Name of the method. */
struct Object *declaringObjectPtr;
/* The object that declares this method, or
@@ -84,7 +84,7 @@ typedef struct ProcedureMethod {
* body bytecodes. */
int flags; /* Flags to control features. */
int refCount;
- ClientData clientData;
+ void *clientData;
TclOO_PmCDDeleteProc *deleteClientdataProc;
TclOO_PmCDCloneProc *cloneClientdataProc;
ProcErrorProc *errProc; /* Replacement error handler. */
@@ -304,6 +304,24 @@ typedef struct Class {
PrivateVariableList privateVariables;
/* Configurations for the variable resolver
* used inside methods. */
+ Tcl_Obj *clsDefinitionNs; /* Name of the namespace to use for
+ * definitions commands of instances of this
+ * class in when those instances are defined
+ * as classes. If NULL, use the value from the
+ * class hierarchy. It's an error at
+ * [oo::define] call time if this namespace is
+ * defined but doesn't exist; we also check at
+ * setting time but don't check between
+ * times. */
+ Tcl_Obj *objDefinitionNs; /* Name of the namespace to use for
+ * definitions commands of instances of this
+ * class in when those instances are defined
+ * as instances. If NULL, use the value from
+ * the class hierarchy. It's an error at
+ * [oo::objdefine]/[self] call time if this
+ * namespace is defined but doesn't exist; we
+ * also check at setting time but don't check
+ * between times. */
} Class;
/*
@@ -441,6 +459,9 @@ MODULE_SCOPE int TclOOObjDefObjCmd(ClientData clientData,
MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineDefnNsObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
@@ -553,6 +574,8 @@ MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
Tcl_Obj *methodNameObj, int flags,
Object *contextObjPtr, Class *contextClsPtr,
Tcl_Obj *cacheInThisObj);
+MODULE_SCOPE Tcl_Namespace *TclOOGetDefineContextNamespace(
+ Tcl_Interp *interp, Object *oPtr, int forClass);
MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr,
Tcl_Obj *methodNameObj, int flags);
MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp);
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index ad14a1a..db31795 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -67,7 +67,7 @@ static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv, int toRewrite,
int rewriteLength, Tcl_Obj *const *rewriteObjs,
int *lengthPtr);
-static int InvokeProcedureMethod(ClientData clientData,
+static int InvokeProcedureMethod(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static Tcl_NRPostProc FinalizeForwardCall;
@@ -77,22 +77,22 @@ static int PushMethodCallFrame(Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv,
PMFrameData *fdPtr);
static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr);
-static void DeleteProcedureMethod(ClientData clientData);
+static void DeleteProcedureMethod(void *clientData);
static int CloneProcedureMethod(Tcl_Interp *interp,
- ClientData clientData, ClientData *newClientData);
+ void *clientData, void **newClientData);
static void MethodErrorHandler(Tcl_Interp *interp,
Tcl_Obj *procNameObj);
static void ConstructorErrorHandler(Tcl_Interp *interp,
Tcl_Obj *procNameObj);
static void DestructorErrorHandler(Tcl_Interp *interp,
Tcl_Obj *procNameObj);
-static Tcl_Obj * RenderDeclarerName(ClientData clientData);
-static int InvokeForwardMethod(ClientData clientData,
+static Tcl_Obj * RenderDeclarerName(void *clientData);
+static int InvokeForwardMethod(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
-static void DeleteForwardMethod(ClientData clientData);
+static void DeleteForwardMethod(void *clientData);
static int CloneForwardMethod(Tcl_Interp *interp,
- ClientData clientData, ClientData *newClientData);
+ void *clientData, void **newClientData);
static int ProcedureMethodVarResolver(Tcl_Interp *interp,
const char *varName, Tcl_Namespace *contextNs,
int flags, Tcl_Var *varPtr);
@@ -146,7 +146,7 @@ Tcl_NewInstanceMethod(
/* The type of method this is, which defines
* how to invoke, delete and clone the
* method. */
- ClientData clientData) /* Some data associated with the particular
+ void *clientData) /* Some data associated with the particular
* method to be created. */
{
register Object *oPtr = (Object *) object;
@@ -218,7 +218,7 @@ Tcl_NewMethod(
/* The type of method this is, which defines
* how to invoke, delete and clone the
* method. */
- ClientData clientData) /* Some data associated with the particular
+ void *clientData) /* Some data associated with the particular
* method to be created. */
{
register Class *clsPtr = (Class *) cls;
@@ -458,7 +458,7 @@ TclOOMakeProcInstanceMethod(
* NULL. */
const Tcl_MethodType *typePtr,
/* The type of the method to create. */
- ClientData clientData, /* The per-method type-specific data. */
+ void *clientData, /* The per-method type-specific data. */
Proc **procPtrPtr) /* A pointer to the variable in which to write
* the procedure record reference. Presumably
* inside the structure indicated by the
@@ -571,7 +571,7 @@ TclOOMakeProcMethod(
* NULL. */
const Tcl_MethodType *typePtr,
/* The type of the method to create. */
- ClientData clientData, /* The per-method type-specific data. */
+ void *clientData, /* The per-method type-specific data. */
Proc **procPtrPtr) /* A pointer to the variable in which to write
* the procedure record reference. Presumably
* inside the structure indicated by the
@@ -666,7 +666,7 @@ TclOOMakeProcMethod(
static int
InvokeProcedureMethod(
- ClientData clientData, /* Pointer to some per-method context. */
+ void *clientData, /* Pointer to some per-method context. */
Tcl_Interp *interp,
Tcl_ObjectContext context, /* The method calling context. */
int objc, /* Number of arguments. */
@@ -745,7 +745,7 @@ InvokeProcedureMethod(
static int
FinalizePMCall(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -799,6 +799,7 @@ PushMethodCallFrame(
register int result;
const char *namePtr;
CallFrame **framePtrPtr = &fdPtr->framePtr;
+ ByteCode *codePtr;
/*
* Compute basic information on the basis of the type of method it is.
@@ -864,10 +865,8 @@ PushMethodCallFrame(
* alternative is *so* slow...
*/
- if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) {
- ByteCode *codePtr =
- pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
-
+ ByteCodeGetIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, codePtr);
+ if (codePtr) {
codePtr->nsPtr = nsPtr;
}
result = TclProcCompileProc(interp, pmPtr->procPtr,
@@ -978,10 +977,8 @@ ProcedureMethodVarResolver(
* Must not retain reference to resolved information. [Bug 3105999]
*/
- if (rPtr != NULL) {
- rPtr->deleteProc(rPtr);
- }
- return (*varPtr? TCL_OK : TCL_CONTINUE);
+ rPtr->deleteProc(rPtr);
+ return (*varPtr ? TCL_OK : TCL_CONTINUE);
}
static Tcl_Var
@@ -1153,7 +1150,7 @@ ProcedureMethodCompiledVarResolver(
static Tcl_Obj *
RenderDeclarerName(
- ClientData clientData)
+ void *clientData)
{
struct PNI *pni = clientData;
Tcl_Object object = Tcl_MethodDeclarerObject(pni->method);
@@ -1295,7 +1292,7 @@ DeleteProcedureMethodRecord(
static void
DeleteProcedureMethod(
- ClientData clientData)
+ void *clientData)
{
register ProcedureMethod *pmPtr = clientData;
@@ -1307,8 +1304,8 @@ DeleteProcedureMethod(
static int
CloneProcedureMethod(
Tcl_Interp *interp,
- ClientData clientData,
- ClientData *newClientData)
+ void *clientData,
+ void **newClientData)
{
ProcedureMethod *pmPtr = clientData;
ProcedureMethod *pm2Ptr;
@@ -1341,7 +1338,7 @@ CloneProcedureMethod(
bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr);
Tcl_GetString(bodyObj);
- TclFreeIntRep(bodyObj);
+ Tcl_StoreIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL);
/*
* Create the actual copy of the method record, manufacturing a new proc
@@ -1461,7 +1458,7 @@ TclOONewForwardMethod(
static int
InvokeForwardMethod(
- ClientData clientData, /* Pointer to some per-method context. */
+ void *clientData, /* Pointer to some per-method context. */
Tcl_Interp *interp,
Tcl_ObjectContext context, /* The method calling context. */
int objc, /* Number of arguments. */
@@ -1495,7 +1492,7 @@ InvokeForwardMethod(
static int
FinalizeForwardCall(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -1517,7 +1514,7 @@ FinalizeForwardCall(
static void
DeleteForwardMethod(
- ClientData clientData)
+ void *clientData)
{
ForwardMethod *fmPtr = clientData;
@@ -1528,8 +1525,8 @@ DeleteForwardMethod(
static int
CloneForwardMethod(
Tcl_Interp *interp,
- ClientData clientData,
- ClientData *newClientData)
+ void *clientData,
+ void **newClientData)
{
ForwardMethod *fmPtr = clientData;
ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod));
@@ -1570,9 +1567,7 @@ TclOOGetMethodBody(
if (mPtr->typePtr == &procMethodType) {
ProcedureMethod *pmPtr = mPtr->clientData;
- if (pmPtr->procPtr->bodyPtr->bytes == NULL) {
- (void) Tcl_GetString(pmPtr->procPtr->bodyPtr);
- }
+ (void) TclGetString(pmPtr->procPtr->bodyPtr);
return pmPtr->procPtr->bodyPtr;
}
return NULL;
@@ -1680,7 +1675,7 @@ int
Tcl_MethodIsType(
Tcl_Method method,
const Tcl_MethodType *typePtr,
- ClientData *clientDataPtr)
+ void **clientDataPtr)
{
Method *mPtr = (Method *) method;
@@ -1718,7 +1713,7 @@ TclOONewProcInstanceMethodEx(
TclOO_PreCallProc *preCallPtr,
TclOO_PostCallProc *postCallPtr,
ProcErrorProc *errProc,
- ClientData clientData,
+ void *clientData,
Tcl_Obj *nameObj, /* The name of the method, which must not be
* NULL. */
Tcl_Obj *argsObj, /* The formal argument list for the method,
@@ -1755,7 +1750,7 @@ TclOONewProcMethodEx(
TclOO_PreCallProc *preCallPtr,
TclOO_PostCallProc *postCallPtr,
ProcErrorProc *errProc,
- ClientData clientData,
+ void *clientData,
Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
* if so, up to caller to manage storage
* (e.g., because it is a constructor or
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 2213ce3..ab637dd 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -98,9 +98,9 @@ static const char *tclOOSetupScript =
"\t\t\tif {![info object isa class $d]} {\n"
"\t\t\t\tcontinue\n"
"\t\t\t}\n"
-"\t\t\tdefine $delegate superclass -append $d\n"
+"\t\t\tdefine $delegate ::oo::define::superclass -append $d\n"
"\t\t}\n"
-"\t\tobjdefine $class mixin -append $delegate\n"
+"\t\tobjdefine $class ::oo::objdefine::mixin -append $delegate\n"
"\t}\n"
"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
"\t\tset originDelegate [DelegateName $originObject]\n"
diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl
index a48eab5..5e0145f 100644
--- a/generic/tclOOScript.tcl
+++ b/generic/tclOOScript.tcl
@@ -153,9 +153,9 @@
if {![info object isa class $d]} {
continue
}
- define $delegate superclass -append $d
+ define $delegate ::oo::define::superclass -append $d
}
- objdefine $class mixin -append $delegate
+ objdefine $class ::oo::objdefine::mixin -append $delegate
}
# ----------------------------------------------------------------------
@@ -176,7 +176,7 @@
&& ![info object isa class $targetDelegate]
} then {
copy $originDelegate $targetDelegate
- objdefine $targetObject mixin -set \
+ objdefine $targetObject ::oo::objdefine::mixin -set \
{*}[lmap c [info object mixin $targetObject] {
if {$c eq $originDelegate} {set targetDelegate} {set c}
}]
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 5a8ce3b..9edb75f 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -17,6 +17,7 @@
#include "tclInt.h"
#include "tommath.h"
#include <math.h>
+#include <assert.h>
/*
* Table of all object types.
@@ -1065,9 +1066,8 @@ TclDbInitNewObj(
* debugging. */
{
objPtr->refCount = 0;
- objPtr->bytes = &tclEmptyString;
- objPtr->length = 0;
objPtr->typePtr = NULL;
+ TclInitStringRep(objPtr, NULL, 0);
#if TCL_THREADS
/*
@@ -1725,6 +1725,91 @@ Tcl_GetStringFromObj(
/*
*----------------------------------------------------------------------
*
+ * Tcl_InitStringRep --
+ *
+ * This function is called in several configurations to provide all
+ * the tools needed to set an object's string representation. The
+ * function is determined by the arguments.
+ *
+ * (objPtr->bytes != NULL && bytes != NULL) || (numBytes < 0)
+ * Invalid call -- panic!
+ *
+ * objPtr->bytes == NULL && bytes == NULL && numBytes >= 0
+ * Allocation only - allocate space for (numBytes+1) chars.
+ * store in objPtr->bytes and return. Also sets
+ * objPtr->length to 0 and objPtr->bytes[0] to NUL.
+ *
+ * objPtr->bytes == NULL && bytes != NULL && numBytes >= 0
+ * Allocate and copy. bytes is assumed to point to chars to
+ * copy into the string rep. objPtr->length = numBytes. Allocate
+ * array of (numBytes + 1) chars. store in objPtr->bytes. Copy
+ * numBytes chars from bytes to objPtr->bytes; Set
+ * objPtr->bytes[numBytes] to NUL and return objPtr->bytes.
+ * Caller must guarantee there are numBytes chars at bytes to
+ * be copied.
+ *
+ * objPtr->bytes != NULL && bytes == NULL && numBytes >= 0
+ * Truncate. Set objPtr->length to numBytes and
+ * objPr->bytes[numBytes] to NUL. Caller has to guarantee
+ * that a prior allocating call allocated enough bytes for
+ * this to be valid. Return objPtr->bytes.
+ *
+ * Caller is expected to ascertain that the bytes copied into
+ * the string rep make up complete valid UTF-8 characters.
+ *
+ * Results:
+ * A pointer to the string rep of objPtr.
+ *
+ * Side effects:
+ * As described above.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tcl_InitStringRep(
+ Tcl_Obj *objPtr, /* Object whose string rep is to be set */
+ const char *bytes,
+ unsigned int numBytes)
+{
+ assert(objPtr->bytes == NULL || bytes == NULL);
+
+ if (numBytes > INT_MAX) {
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+ }
+
+ /* Allocate */
+ if (objPtr->bytes == NULL) {
+ /* Allocate only as empty - extend later if bytes copied */
+ objPtr->length = 0;
+ if (numBytes) {
+ objPtr->bytes = attemptckalloc(numBytes + 1);
+ if (objPtr->bytes == NULL) {
+ return NULL;
+ }
+ if (bytes) {
+ /* Copy */
+ memcpy(objPtr->bytes, bytes, numBytes);
+ objPtr->length = (int) numBytes;
+ }
+ } else {
+ TclInitStringRep(objPtr, NULL, 0);
+ }
+ } else {
+ /* objPtr->bytes != NULL bytes == NULL - Truncate */
+ objPtr->bytes = ckrealloc(objPtr->bytes, numBytes + 1);
+ objPtr->length = (int)numBytes;
+ }
+
+ /* Terminate */
+ objPtr->bytes[objPtr->length] = '\0';
+
+ return objPtr->bytes;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_InvalidateStringRep --
*
* This function is called to invalidate an object's string
@@ -1751,6 +1836,123 @@ Tcl_InvalidateStringRep(
/*
*----------------------------------------------------------------------
*
+ * Tcl_HasStringRep --
+ *
+ * This function reports whether object has a string representation.
+ *
+ * Results:
+ * Boolean.
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_HasStringRep(
+ Tcl_Obj *objPtr) /* Object to test */
+{
+ return TclHasStringRep(objPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_StoreIntRep --
+ *
+ * This function is called to set the object's internal
+ * representation to match a particular type.
+ *
+ * It is the caller's responsibility to guarantee that
+ * the value of the submitted IntRep is in agreement with
+ * the value of any existing string rep.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Calls the freeIntRepProc of the current Tcl_ObjType, if any.
+ * Sets the internalRep and typePtr fields to the submitted values.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_StoreIntRep(
+ Tcl_Obj *objPtr, /* Object whose internal rep should be set. */
+ const Tcl_ObjType *typePtr, /* New type for the object */
+ const Tcl_ObjIntRep *irPtr) /* New IntRep for the object */
+{
+ /* Clear out any existing IntRep ( "shimmer" ) */
+ TclFreeIntRep(objPtr);
+
+ /* When irPtr == NULL, just leave objPtr with no IntRep for typePtr */
+ if (irPtr) {
+ /* Copy the new IntRep into place */
+ objPtr->internalRep = *irPtr;
+
+ /* Set the type to match */
+ objPtr->typePtr = typePtr;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FetchIntRep --
+ *
+ * This function is called to retrieve the object's internal
+ * representation matching a requested type, if any.
+ *
+ * Results:
+ * A read-only pointer to the associated Tcl_ObjIntRep, or
+ * NULL if no such internal representation exists.
+ *
+ * Side effects:
+ * Calls the freeIntRepProc of the current Tcl_ObjType, if any.
+ * Sets the internalRep and typePtr fields to the submitted values.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_ObjIntRep *
+Tcl_FetchIntRep(
+ Tcl_Obj *objPtr, /* Object to fetch from. */
+ const Tcl_ObjType *typePtr) /* Requested type */
+{
+ /* If objPtr type doesn't match request, nothing can be fetched */
+ if (objPtr->typePtr != typePtr) {
+ return NULL;
+ }
+
+ /* Type match! objPtr IntRep is the one sought. */
+ return &(objPtr->internalRep);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FreeIntRep --
+ *
+ * This function is called to free an object's internal representation.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Calls the freeIntRepProc of the current Tcl_ObjType, if any.
+ * Sets typePtr field to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_FreeIntRep(
+ Tcl_Obj *objPtr) /* Object whose internal rep should be freed. */
+{
+ TclFreeIntRep(objPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_NewBooleanObj --
*
* This function is normally called when not debugging: i.e., when
@@ -1835,6 +2037,7 @@ Tcl_DbNewBooleanObj(
register Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
+ /* Optimized TclInvalidateStringRep() */
objPtr->bytes = NULL;
objPtr->internalRep.wideValue = (boolValue != 0);
@@ -2221,6 +2424,7 @@ Tcl_DbNewDoubleObj(
register Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
+ /* Optimized TclInvalidateStringRep() */
objPtr->bytes = NULL;
objPtr->internalRep.doubleValue = dblValue;
@@ -2381,15 +2585,12 @@ static void
UpdateStringOfDouble(
register Tcl_Obj *objPtr) /* Double obj with string rep to update. */
{
- char buffer[TCL_DOUBLE_SPACE];
- register int len;
+ char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE);
- Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer);
- len = strlen(buffer);
+ TclOOM(dst, TCL_DOUBLE_SPACE + 1);
- objPtr->bytes = ckalloc(len + 1);
- memcpy(objPtr->bytes, buffer, (unsigned) len + 1);
- objPtr->length = len;
+ Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst);
+ (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
}
/*
@@ -2462,7 +2663,7 @@ Tcl_NewIntObj(
*
*----------------------------------------------------------------------
*/
-
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_SetIntObj
void
Tcl_SetIntObj(
@@ -2475,6 +2676,7 @@ Tcl_SetIntObj(
TclSetIntObj(objPtr, intValue);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2578,14 +2780,11 @@ static void
UpdateStringOfInt(
register Tcl_Obj *objPtr) /* Int object whose string rep to update. */
{
- char buffer[TCL_INTEGER_SPACE];
- register int len;
-
- len = TclFormatInt(buffer, objPtr->internalRep.wideValue);
+ char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE);
- objPtr->bytes = ckalloc(len + 1);
- memcpy(objPtr->bytes, buffer, (unsigned) len + 1);
- objPtr->length = len;
+ TclOOM(dst, TCL_INTEGER_SPACE + 1);
+ (void) Tcl_InitStringRep(objPtr, NULL,
+ TclFormatInt(dst, objPtr->internalRep.wideValue));
}
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG)
@@ -2593,14 +2792,11 @@ static void
UpdateStringOfOldInt(
register Tcl_Obj *objPtr) /* Int object whose string rep to update. */
{
- char buffer[TCL_INTEGER_SPACE];
- register int len;
+ char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE);
- len = TclFormatInt(buffer, objPtr->internalRep.longValue);
-
- objPtr->bytes = ckalloc(len + 1);
- memcpy(objPtr->bytes, buffer, (unsigned) len + 1);
- objPtr->length = len;
+ TclOOM(dst, TCL_INTEGER_SPACE + 1);
+ (void) Tcl_InitStringRep(objPtr, NULL,
+ TclFormatInt(dst, objPtr->internalRep.longValue));
}
#endif
@@ -2706,6 +2902,7 @@ Tcl_DbNewLongObj(
register Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
+ /* Optimized TclInvalidateStringRep */
objPtr->bytes = NULL;
objPtr->internalRep.wideValue = longValue;
@@ -2746,6 +2943,7 @@ Tcl_DbNewLongObj(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_SetLongObj
void
Tcl_SetLongObj(
@@ -2759,6 +2957,7 @@ Tcl_SetLongObj(
TclSetIntObj(objPtr, longValue);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -3262,12 +3461,10 @@ UpdateStringOfBignum(
{
mp_int bignumVal;
int size;
- int status;
char *stringVal;
UNPACK_BIGNUM(objPtr, bignumVal);
- status = mp_radix_size(&bignumVal, 10, &size);
- if (status != MP_OKAY) {
+ if (MP_OKAY != mp_radix_size(&bignumVal, 10, &size)) {
Tcl_Panic("radix size failure in UpdateStringOfBignum");
}
if (size < 2) {
@@ -3282,13 +3479,14 @@ UpdateStringOfBignum(
Tcl_Panic("UpdateStringOfBignum: string length limit exceeded");
}
- stringVal = ckalloc(size);
- status = mp_toradix_n(&bignumVal, stringVal, 10, size);
- if (status != MP_OKAY) {
+
+ stringVal = Tcl_InitStringRep(objPtr, NULL, size - 1);
+
+ TclOOM(stringVal, size);
+ if (MP_OKAY != mp_toradix_n(&bignumVal, stringVal, 10, size)) {
Tcl_Panic("conversion failure in UpdateStringOfBignum");
}
- objPtr->bytes = stringVal;
- objPtr->length = size - 1; /* size includes a trailing NUL byte. */
+ (void) Tcl_InitStringRep(objPtr, NULL, size - 1);
}
/*
@@ -3408,11 +3606,17 @@ GetBignumFromObj(
mp_init_copy(bignumValue, &temp);
} else {
UNPACK_BIGNUM(objPtr, *bignumValue);
+ /* Optimized TclFreeIntRep */
objPtr->internalRep.twoPtrValue.ptr1 = NULL;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = NULL;
+ /*
+ * TODO: If objPtr has a string rep, this leaves
+ * it undisturbed. Not clear that's proper. Pure
+ * bignum values are converted to empty string.
+ */
if (objPtr->bytes == NULL) {
- TclInitStringRep(objPtr, &tclEmptyString, 0);
+ TclInitStringRep(objPtr, NULL, 0);
}
}
return TCL_OK;
@@ -3658,6 +3862,71 @@ TclGetNumberFromObj(
/*
*----------------------------------------------------------------------
*
+ * Tcl_IncrRefCount --
+ *
+ * Increments the reference count of the object.
+ *
+ * Results:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#undef Tcl_IncrRefCount
+void
+Tcl_IncrRefCount(
+ Tcl_Obj *objPtr) /* The object we are registering a reference to. */
+{
+ ++(objPtr)->refCount;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DecrRefCount --
+ *
+ * Decrements the reference count of the object.
+ *
+ * Results:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#undef Tcl_DecrRefCount
+void
+Tcl_DecrRefCount(
+ Tcl_Obj *objPtr) /* The object we are releasing a reference to. */
+{
+ if (objPtr->refCount-- <= 1) {
+ TclFreeObj(objPtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_IsShared --
+ *
+ * Tests if the object has a ref count greater than one.
+ *
+ * Results:
+ * Boolean value that is the result of the test.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#undef Tcl_IsShared
+int
+Tcl_IsShared(
+ Tcl_Obj *objPtr) /* The object to test for being shared. */
+{
+ return ((objPtr)->refCount > 1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_DbIncrRefCount --
*
* This function is normally called when debugging: i.e., when
diff --git a/generic/tclPanic.c b/generic/tclPanic.c
index 1eeafaa..4fce082 100644
--- a/generic/tclPanic.c
+++ b/generic/tclPanic.c
@@ -32,7 +32,7 @@ static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL;
/*
*----------------------------------------------------------------------
*
- * TclSetPanicProc --
+ * Tcl_SetPanicProc --
*
* Replace the default panic behavior with the specified function.
*
@@ -46,7 +46,7 @@ static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL;
*/
void
-TclSetPanicProc(
+Tcl_SetPanicProc(
TCL_NORETURN1 Tcl_PanicProc *proc)
{
#if defined(_WIN32)
@@ -58,6 +58,7 @@ TclSetPanicProc(
else
#endif
panicProc = proc;
+ Tcl_InitSubsystems();
}
/*
diff --git a/generic/tclParse.c b/generic/tclParse.c
index 00b83a1..4b6c4be 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -890,7 +890,7 @@ TclParseBackslash(
count += TclParseHex(p+1, (numBytes > 3) ? 2 : numBytes-2, &result);
if (count == 2) {
/*
- * No hexadigits -> This is just "x".
+ * No hexdigits -> This is just "x".
*/
result = 'x';
@@ -905,7 +905,7 @@ TclParseBackslash(
count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-2, &result);
if (count == 2) {
/*
- * No hexadigits -> This is just "u".
+ * No hexdigits -> This is just "u".
*/
result = 'u';
}
@@ -914,7 +914,7 @@ TclParseBackslash(
count += TclParseHex(p+1, (numBytes > 9) ? 8 : numBytes-2, &result);
if (count == 2) {
/*
- * No hexadigits -> This is just "U".
+ * No hexdigits -> This is just "U".
*/
result = 'U';
}
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 2453c46..ea8a7ec 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -36,7 +36,7 @@ static int MakePathFromNormalized(Tcl_Interp *interp,
* internally.
*/
-static const Tcl_ObjType tclFsPathType = {
+static const Tcl_ObjType fsPathType = {
"path", /* name */
FreeFsPathInternalRep, /* freeIntRepProc */
DupFsPathInternalRep, /* dupIntRepProc */
@@ -51,19 +51,14 @@ static const Tcl_ObjType tclFsPathType = {
* represent relative or absolute paths, and has certain optimisations when
* used to represent paths which are already normalized and absolute.
*
- * Note that both 'translatedPathPtr' and 'normPathPtr' can be a circular
- * reference to the container Tcl_Obj of this FsPath.
- *
* There are two cases, with the first being the most common:
*
* (i) flags == 0, => Ordinary path.
*
- * translatedPathPtr contains the translated path (which may be a circular
- * reference to the object itself). If it is NULL then the path is pure
- * normalized (and the normPathPtr will be a circular reference). cwdPtr is
- * null for an absolute path, and non-null for a relative path (unless the cwd
- * has never been set, in which case the cwdPtr may also be null for a
- * relative path).
+ * translatedPathPtr contains the translated path. If it is NULL then the path
+ * is pure normalized. cwdPtr is null for an absolute path, and non-null for a
+ * relative path (unless the cwd has never been set, in which case the cwdPtr
+ * may also be null for a relative path).
*
* (ii) flags != 0, => Special path, see TclNewFSPathObj
*
@@ -79,11 +74,7 @@ typedef struct FsPath {
* Tcl_Obj's string rep is already both
* translated and normalized. */
Tcl_Obj *normPathPtr; /* Normalized absolute path, without ., .. or
- * ~user sequences. If the Tcl_Obj containing
- * this FsPath is already normalized, this may
- * be a circular reference back to the
- * container. If that is NOT the case, we have
- * a refCount on the object. */
+ * ~user sequences. */
Tcl_Obj *cwdPtr; /* If null, path is absolute, else this points
* to the cwd object used for this path. We
* have a refCount on the object. */
@@ -110,9 +101,14 @@ typedef struct FsPath {
* fields.
*/
-#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.twoPtrValue.ptr1)
+#define PATHOBJ(pathPtr) ((FsPath *) (Tcl_FetchIntRep((pathPtr), &fsPathType)->twoPtrValue.ptr1))
#define SETPATHOBJ(pathPtr,fsPathPtr) \
- ((pathPtr)->internalRep.twoPtrValue.ptr1 = (void *) (fsPathPtr))
+ do { \
+ Tcl_ObjIntRep ir; \
+ ir.twoPtrValue.ptr1 = (void *) (fsPathPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreIntRep((pathPtr), &fsPathType, &ir); \
+ } while (0)
#define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags)
/*
@@ -564,7 +560,9 @@ TclPathPart(
Tcl_Obj *pathPtr, /* Path to take dirname of */
Tcl_PathPart portion) /* Requested portion of name */
{
- if (pathPtr->typePtr == &tclFsPathType) {
+ Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType);
+
+ if (irPtr) {
FsPath *fsPathPtr = PATHOBJ(pathPtr);
if (PATHFLAGS(pathPtr) != 0) {
@@ -829,7 +827,7 @@ Tcl_FSJoinPath(
* reference count. */
int elements) /* Number of elements to use (-1 = all) */
{
- Tcl_Obj *copy, *res;
+ Tcl_Obj *res;
int objc;
Tcl_Obj **objv;
@@ -838,17 +836,17 @@ Tcl_FSJoinPath(
}
elements = ((elements >= 0) && (elements <= objc)) ? elements : objc;
- copy = TclListObjCopy(NULL, listObj);
Tcl_ListObjGetElements(NULL, listObj, &objc, &objv);
- res = TclJoinPath(elements, objv);
- Tcl_DecrRefCount(copy);
+ res = TclJoinPath(elements, objv, 0);
return res;
}
Tcl_Obj *
TclJoinPath(
- int elements,
- Tcl_Obj * const objv[])
+ int elements, /* Number of elements to use (-1 = all) */
+ Tcl_Obj * const objv[], /* Path elements to join */
+ int forceRelative) /* If non-zero, assume all more paths are
+ * relative (e. g. simple normalization) */
{
Tcl_Obj *res = NULL;
int i;
@@ -864,6 +862,7 @@ TclJoinPath(
if (elements == 2) {
Tcl_Obj *elt = objv[0];
+ Tcl_ObjIntRep *eltIr = Tcl_FetchIntRep(elt, &fsPathType);
/*
* This is a special case where we can be much more efficient, where
@@ -877,12 +876,15 @@ TclJoinPath(
* to be an absolute path. Added a check for that elt is absolute.
*/
- if ((elt->typePtr == &tclFsPathType)
+ if ((eltIr)
&& !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))
- && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) {
- Tcl_Obj *tailObj = objv[1];
- Tcl_PathType type = TclGetPathType(tailObj, NULL, NULL, NULL);
+ && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) {
+ Tcl_Obj *tailObj = objv[1];
+ Tcl_PathType type;
+ /* if forceRelative - second path is relative */
+ type = forceRelative ? TCL_PATH_RELATIVE :
+ TclGetPathType(tailObj, NULL, NULL, NULL);
if (type == TCL_PATH_RELATIVE) {
const char *str;
int len;
@@ -960,7 +962,9 @@ TclJoinPath(
strElt = TclGetStringFromObj(elt, &strEltLen);
driveNameLength = 0;
- type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
+ /* if forceRelative - all paths excepting first one are relative */
+ type = (forceRelative && (i > 0)) ? TCL_PATH_RELATIVE :
+ TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
if (type != TCL_PATH_RELATIVE) {
/*
* Zero out the current result.
@@ -1154,6 +1158,8 @@ Tcl_FSConvertToPathType(
Tcl_Obj *pathPtr) /* Object to convert to a valid, current path
* type. */
{
+ Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType);
+
/*
* While it is bad practice to examine an object's type directly, this is
* actually the best thing to do here. The reason is that if we are
@@ -1164,39 +1170,16 @@ Tcl_FSConvertToPathType(
* path.
*/
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (irPtr) {
if (TclFSEpochOk(PATHOBJ(pathPtr)->filesystemEpoch)) {
return TCL_OK;
}
- if (pathPtr->bytes == NULL) {
- UpdateStringOfFsPath(pathPtr);
- }
- FreeFsPathInternalRep(pathPtr);
+ TclGetString(pathPtr);
+ Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
}
return SetFsPathFromAny(interp, pathPtr);
-
- /*
- * We used to have more complex code here:
- *
- * FsPath *fsPathPtr = PATHOBJ(pathPtr);
- * if (fsPathPtr->cwdPtr == NULL || PATHFLAGS(pathPtr) != 0) {
- * return TCL_OK;
- * } else {
- * if (TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) {
- * return TCL_OK;
- * } else {
- * if (pathPtr->bytes == NULL) {
- * UpdateStringOfFsPath(pathPtr);
- * }
- * FreeFsPathInternalRep(pathPtr);
- * return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType);
- * }
- * }
- *
- * But we no longer believe this is necessary.
- */
}
/*
@@ -1328,9 +1311,7 @@ TclNewFSPathObj(
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = TCLPATH_APPENDED;
- pathPtr->typePtr = &tclFsPathType;
- pathPtr->bytes = NULL;
- pathPtr->length = 0;
+ TclInvalidateStringRep(pathPtr);
/*
* Look for path components made up of only "."
@@ -1357,6 +1338,7 @@ TclNewFSPathObj(
count = 0;
state = 1;
}
+ break;
case 1: /* Scanning for next dirsep */
switch (*p) {
case '/':
@@ -1430,8 +1412,9 @@ TclFSMakePathRelative(
{
int cwdLen, len;
const char *tempStr;
+ Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType);
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (irPtr) {
FsPath *fsPathPtr = PATHOBJ(pathPtr);
if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) {
@@ -1498,31 +1481,12 @@ MakePathFromNormalized(
Tcl_Obj *pathPtr) /* The object to convert. */
{
FsPath *fsPathPtr;
+ Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType);
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (irPtr) {
return TCL_OK;
}
- /*
- * Free old representation
- */
-
- if (pathPtr->typePtr != NULL) {
- if (pathPtr->bytes == NULL) {
- if (pathPtr->typePtr->updateStringProc == NULL) {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "can't find object string representation", -1));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF",
- NULL);
- }
- return TCL_ERROR;
- }
- pathPtr->typePtr->updateStringProc(pathPtr);
- }
- TclFreeIntRep(pathPtr);
- }
-
fsPathPtr = ckalloc(sizeof(FsPath));
/*
@@ -1531,11 +1495,7 @@ MakePathFromNormalized(
fsPathPtr->translatedPathPtr = NULL;
- /*
- * Circular reference by design.
- */
-
- fsPathPtr->normPathPtr = pathPtr;
+ Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr));
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsPtr = NULL;
@@ -1544,7 +1504,6 @@ MakePathFromNormalized(
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
- pathPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
@@ -1595,25 +1554,12 @@ Tcl_FSNewNativePath(
* safe.
*/
- if (pathPtr->typePtr != NULL) {
- if (pathPtr->bytes == NULL) {
- if (pathPtr->typePtr->updateStringProc == NULL) {
- return NULL;
- }
- pathPtr->typePtr->updateStringProc(pathPtr);
- }
- TclFreeIntRep(pathPtr);
- }
-
+ Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
fsPathPtr = ckalloc(sizeof(FsPath));
fsPathPtr->translatedPathPtr = NULL;
- /*
- * Circular reference, by design.
- */
-
- fsPathPtr->normPathPtr = pathPtr;
+ Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr));
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = clientData;
fsPathPtr->fsPtr = fromFilesystem;
@@ -1621,7 +1567,6 @@ Tcl_FSNewNativePath(
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
- pathPtr->typePtr = &tclFsPathType;
return pathPtr;
}
@@ -1668,20 +1613,22 @@ Tcl_FSGetTranslatedPath(
Tcl_Obj *translatedCwdPtr = Tcl_FSGetTranslatedPath(interp,
srcFsPathPtr->cwdPtr);
+ Tcl_ObjIntRep *translatedCwdIrPtr;
+
if (translatedCwdPtr == NULL) {
return NULL;
}
retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1,
&srcFsPathPtr->normPathPtr);
- srcFsPathPtr->translatedPathPtr = retObj;
- if (translatedCwdPtr->typePtr == &tclFsPathType) {
+ Tcl_IncrRefCount(srcFsPathPtr->translatedPathPtr = retObj);
+ translatedCwdIrPtr = Tcl_FetchIntRep(translatedCwdPtr, &fsPathType);
+ if (translatedCwdIrPtr) {
srcFsPathPtr->filesystemEpoch
= PATHOBJ(translatedCwdPtr)->filesystemEpoch;
} else {
srcFsPathPtr->filesystemEpoch = 0;
}
- Tcl_IncrRefCount(retObj);
Tcl_DecrRefCount(translatedCwdPtr);
} else {
/*
@@ -1791,9 +1738,7 @@ Tcl_FSGetNormalizedPath(
return NULL;
}
/* TODO: Figure out why this is needed. */
- if (pathPtr->bytes == NULL) {
- UpdateStringOfFsPath(pathPtr);
- }
+ TclGetString(pathPtr);
TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen);
if (tailLen) {
@@ -1845,7 +1790,7 @@ Tcl_FSGetNormalizedPath(
/*
* NOTE: here we are (dangerously?) assuming that origDir points
- * to a Tcl_Obj with Tcl_ObjType == &tclFsPathType. The
+ * to a Tcl_Obj with Tcl_ObjType == &fsPathType. The
* pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr);
* above that set the pathType value should have established that,
* but it's far less clear on what basis we know there's been no
@@ -1863,6 +1808,7 @@ Tcl_FSGetNormalizedPath(
/*
* That's our reference to copy used.
*/
+ copy = NULL;
TclDecrRefCount(dir);
TclDecrRefCount(origDir);
@@ -1875,7 +1821,7 @@ Tcl_FSGetNormalizedPath(
/*
* That's our reference to copy used.
*/
-
+ copy = NULL;
TclDecrRefCount(dir);
}
PATHFLAGS(pathPtr) = 0;
@@ -1887,10 +1833,8 @@ Tcl_FSGetNormalizedPath(
if (fsPathPtr->cwdPtr != NULL) {
if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) {
- if (pathPtr->bytes == NULL) {
- UpdateStringOfFsPath(pathPtr);
- }
- FreeFsPathInternalRep(pathPtr);
+ TclGetString(pathPtr);
+ Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) {
return NULL;
}
@@ -1916,7 +1860,6 @@ Tcl_FSGetNormalizedPath(
}
if (fsPathPtr->normPathPtr == NULL) {
Tcl_Obj *useThisCwd = NULL;
- int pureNormalized = 1;
/*
* Since normPathPtr is NULL, but this is a valid path object, we know
@@ -1966,7 +1909,6 @@ Tcl_FSGetNormalizedPath(
return NULL;
}
- pureNormalized = 0;
Tcl_DecrRefCount(absolutePath);
absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath);
Tcl_IncrRefCount(absolutePath);
@@ -1986,7 +1928,6 @@ Tcl_FSGetNormalizedPath(
if (absolutePath == NULL) {
return NULL;
}
- pureNormalized = 0;
#endif /* _WIN32 */
}
}
@@ -1995,35 +1936,12 @@ Tcl_FSGetNormalizedPath(
* Already has refCount incremented.
*/
+ if (fsPathPtr->normPathPtr) {
+ Tcl_DecrRefCount(fsPathPtr->normPathPtr);
+ }
fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp,
absolutePath);
- /*
- * Check if path is pure normalized (this can only be the case if it
- * is an absolute path).
- */
-
- if (pureNormalized) {
- int normPathLen, pathLen;
- const char *normPath;
-
- path = TclGetStringFromObj(pathPtr, &pathLen);
- normPath = TclGetStringFromObj(fsPathPtr->normPathPtr, &normPathLen);
- if ((pathLen == normPathLen) && !memcmp(path, normPath, pathLen)) {
- /*
- * The path was already normalized. Get rid of the duplicate.
- */
-
- TclDecrRefCount(fsPathPtr->normPathPtr);
-
- /*
- * We do *not* increment the refCount for this circular
- * reference.
- */
-
- fsPathPtr->normPathPtr = pathPtr;
- }
- }
if (useThisCwd != NULL) {
/*
* We just need to free an object we allocated above for relative
@@ -2169,8 +2087,9 @@ TclFSEnsureEpochOk(
const Tcl_Filesystem **fsPtrPtr)
{
FsPath *srcFsPathPtr;
+ Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType);
- if (pathPtr->typePtr != &tclFsPathType) {
+ if (irPtr == NULL) {
return TCL_OK;
}
@@ -2186,10 +2105,8 @@ TclFSEnsureEpochOk(
* We have to discard the stale representation and recalculate it.
*/
- if (pathPtr->bytes == NULL) {
- UpdateStringOfFsPath(pathPtr);
- }
- FreeFsPathInternalRep(pathPtr);
+ TclGetString(pathPtr);
+ Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
return TCL_ERROR;
}
@@ -2229,12 +2146,13 @@ TclFSSetPathDetails(
ClientData clientData)
{
FsPath *srcFsPathPtr;
+ Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType);;
/*
* Make sure pathPtr is of the correct type.
*/
- if (pathPtr->typePtr != &tclFsPathType) {
+ if (irPtr == NULL) {
if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
return;
}
@@ -2332,8 +2250,9 @@ SetFsPathFromAny(
FsPath *fsPathPtr;
Tcl_Obj *transPtr;
char *name;
+ Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType);
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (irPtr) {
return TCL_OK;
}
@@ -2357,36 +2276,29 @@ SetFsPathFromAny(
* Handle tilde substitutions, if needed.
*/
- if (name[0] == '~') {
+ if (len && name[0] == '~') {
Tcl_DString temp;
int split;
char separator = '/';
+ /*
+ * We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc.
+ * split becomes value 1 for '~/...' as well as for '~'.
+ */
split = FindSplitPos(name, separator);
- if (split != len) {
- /*
- * We have multiple pieces '~user/foo/bar...'
- */
-
- name[split] = '\0';
- }
/*
* Do some tilde substitution.
*/
- if (name[1] == '\0') {
+ if (split == 1) {
/*
- * We have just '~'
+ * We have just '~' (or '~/...')
*/
const char *dir;
Tcl_DString dirString;
- if (split != len) {
- name[split] = separator;
- }
-
dir = TclGetEnv("HOME", &dirString);
if (dir == NULL) {
if (interp) {
@@ -2406,23 +2318,26 @@ SetFsPathFromAny(
* We have a user name '~user'
*/
+ const char *expandedUser;
+ Tcl_DString userName;
+
+ Tcl_DStringInit(&userName);
+ Tcl_DStringAppend(&userName, name+1, split-1);
+ expandedUser = Tcl_DStringValue(&userName);
+
Tcl_DStringInit(&temp);
- if (TclpGetUserHome(name+1, &temp) == NULL) {
+ if (TclpGetUserHome(expandedUser, &temp) == NULL) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "user \"%s\" doesn't exist", name+1));
+ "user \"%s\" doesn't exist", expandedUser));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER",
NULL);
}
+ Tcl_DStringFree(&userName);
Tcl_DStringFree(&temp);
- if (split != len) {
- name[split] = separator;
- }
return TCL_ERROR;
}
- if (split != len) {
- name[split] = separator;
- }
+ Tcl_DStringFree(&userName);
}
transPtr = TclDStringToObj(&temp);
@@ -2459,13 +2374,17 @@ SetFsPathFromAny(
pair[0] = transPtr;
pair[1] = Tcl_NewStringObj(name+split+1, -1);
- transPtr = TclJoinPath(2, pair);
- Tcl_DecrRefCount(pair[0]);
- Tcl_DecrRefCount(pair[1]);
+ transPtr = TclJoinPath(2, pair, 1);
+ if (transPtr != pair[0]) {
+ Tcl_DecrRefCount(pair[0]);
+ }
+ if (transPtr != pair[1]) {
+ Tcl_DecrRefCount(pair[1]);
+ }
}
}
} else {
- transPtr = TclJoinPath(1, &pathPtr);
+ transPtr = TclJoinPath(1, &pathPtr, 1);
}
/*
@@ -2475,27 +2394,21 @@ SetFsPathFromAny(
fsPathPtr = ckalloc(sizeof(FsPath));
- fsPathPtr->translatedPathPtr = transPtr;
- if (transPtr != pathPtr) {
- Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
- /* Redo translation when $env(HOME) changes */
- fsPathPtr->filesystemEpoch = TclFSEpoch();
+ if (transPtr == pathPtr) {
+ transPtr = Tcl_DuplicateObj(pathPtr);
+ fsPathPtr->filesystemEpoch = 0;
} else {
- fsPathPtr->filesystemEpoch = 0;
+ fsPathPtr->filesystemEpoch = TclFSEpoch();
}
+ Tcl_IncrRefCount(transPtr);
+ fsPathPtr->translatedPathPtr = transPtr;
fsPathPtr->normPathPtr = NULL;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsPtr = NULL;
- /*
- * Free old representation before installing our new one.
- */
-
- TclFreeIntRep(pathPtr);
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
- pathPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
@@ -2518,6 +2431,7 @@ FreeFsPathInternalRep(
}
if (fsPathPtr->cwdPtr != NULL) {
TclDecrRefCount(fsPathPtr->cwdPtr);
+ fsPathPtr->cwdPtr = NULL;
}
if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsPtr != NULL) {
Tcl_FSFreeInternalRepProc *freeProc =
@@ -2530,7 +2444,6 @@ FreeFsPathInternalRep(
}
ckfree(fsPathPtr);
- pathPtr->typePtr = NULL;
}
static void
@@ -2543,24 +2456,14 @@ DupFsPathInternalRep(
SETPATHOBJ(copyPtr, copyFsPathPtr);
- if (srcFsPathPtr->translatedPathPtr == srcPtr) {
- /* Cycle in src -> make cycle in copy. */
- copyFsPathPtr->translatedPathPtr = copyPtr;
- } else {
- copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
- if (copyFsPathPtr->translatedPathPtr != NULL) {
- Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
- }
+ copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
+ if (copyFsPathPtr->translatedPathPtr != NULL) {
+ Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
}
- if (srcFsPathPtr->normPathPtr == srcPtr) {
- /* Cycle in src -> make cycle in copy. */
- copyFsPathPtr->normPathPtr = copyPtr;
- } else {
- copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr;
- if (copyFsPathPtr->normPathPtr != NULL) {
- Tcl_IncrRefCount(copyFsPathPtr->normPathPtr);
- }
+ copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr;
+ if (copyFsPathPtr->normPathPtr != NULL) {
+ Tcl_IncrRefCount(copyFsPathPtr->normPathPtr);
}
copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr;
@@ -2586,8 +2489,6 @@ DupFsPathInternalRep(
}
copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr;
copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch;
-
- copyPtr->typePtr = &tclFsPathType;
}
/*
@@ -2619,11 +2520,15 @@ UpdateStringOfFsPath(
}
copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr);
+ if (Tcl_IsShared(copy)) {
+ copy = Tcl_DuplicateObj(copy);
+ }
+ Tcl_IncrRefCount(copy);
+ /* Steal copy's string rep */
pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen);
pathPtr->length = cwdLen;
- copy->bytes = &tclEmptyString;
- copy->length = 0;
+ TclInitStringRep(copy, NULL, 0);
TclDecrRefCount(copy);
}
@@ -2653,6 +2558,8 @@ TclNativePathInFilesystem(
Tcl_Obj *pathPtr,
ClientData *clientDataPtr)
{
+ Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType);
+
/*
* A special case is required to handle the empty path "". This is a valid
* path (i.e. the user should be able to do 'file exists ""' without
@@ -2660,7 +2567,7 @@ TclNativePathInFilesystem(
* semantics of Tcl (at present anyway), so we have to abide by them here.
*/
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (irPtr) {
if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') {
/*
* We reject the empty path "".
@@ -2675,7 +2582,7 @@ TclNativePathInFilesystem(
} else {
/*
* It is somewhat unusual to reach this code path without the object
- * being of tclFsPathType. However, we do our best to deal with the
+ * being of fsPathType. However, we do our best to deal with the
* situation.
*/
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 32c3b2e..f1822a2 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -15,6 +15,7 @@
#include "tclInt.h"
#include "tclCompile.h"
+#include <assert.h>
/*
* Variables that are part of the [apply] command implementation and which
@@ -67,6 +68,22 @@ const Tcl_ObjType tclProcBodyType = {
* should panic instead. */
};
+#define ProcSetIntRep(objPtr, procPtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ (procPtr)->refCount++; \
+ ir.twoPtrValue.ptr1 = (procPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreIntRep((objPtr), &tclProcBodyType, &ir); \
+ } while (0)
+
+#define ProcGetIntRep(objPtr, procPtr) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = Tcl_FetchIntRep((objPtr), &tclProcBodyType); \
+ (procPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
* The [upvar]/[uplevel] level reference type. Uses the longValue field
* to remember the integer value of a parsed #<integer> format.
@@ -89,13 +106,31 @@ static const Tcl_ObjType levelReferenceType = {
* will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO.
*/
-const Tcl_ObjType tclLambdaType = {
+static const Tcl_ObjType lambdaType = {
"lambdaExpr", /* name */
FreeLambdaInternalRep, /* freeIntRepProc */
DupLambdaInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetLambdaFromAny /* setFromAnyProc */
};
+
+#define LambdaSetIntRep(objPtr, procPtr, nsObjPtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ ir.twoPtrValue.ptr1 = (procPtr); \
+ ir.twoPtrValue.ptr2 = (nsObjPtr); \
+ Tcl_IncrRefCount((nsObjPtr)); \
+ Tcl_StoreIntRep((objPtr), &lambdaType, &ir); \
+ } while (0)
+
+#define LambdaGetIntRep(objPtr, procPtr, nsObjPtr) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = Tcl_FetchIntRep((objPtr), &lambdaType); \
+ (procPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \
+ (nsObjPtr) = irPtr ? irPtr->twoPtrValue.ptr2 : NULL; \
+ } while (0)
+
/*
*----------------------------------------------------------------------
@@ -294,7 +329,7 @@ Tcl_ProcObjCmd(
* of all procs whose argument list is just _args_
*/
- if (objv[3]->typePtr == &tclProcBodyType) {
+ if (Tcl_FetchIntRep(objv[3], &tclProcBodyType)) {
goto done;
}
@@ -370,7 +405,7 @@ TclCreateProc(
{
Interp *iPtr = (Interp *) interp;
- register Proc *procPtr;
+ register Proc *procPtr = NULL;
int i, result, numArgs, plen;
const char *bytes, *argname, *argnamei;
char argnamelast;
@@ -378,7 +413,8 @@ TclCreateProc(
Tcl_Obj *defPtr, *errorObj, **argArray;
int precompiled = 0;
- if (bodyPtr->typePtr == &tclProcBodyType) {
+ ProcGetIntRep(bodyPtr, procPtr);
+ if (procPtr != NULL) {
/*
* Because the body is a TclProProcBody, the actual body is already
* compiled, and it is not shared with anyone else, so it's OK not to
@@ -391,7 +427,6 @@ TclCreateProc(
* will be holding a reference to it.
*/
- procPtr = bodyPtr->internalRep.twoPtrValue.ptr1;
procPtr->iPtr = iPtr;
procPtr->refCount++;
precompiled = 1;
@@ -733,6 +768,7 @@ TclObjGetFrame(
{
register Interp *iPtr = (Interp *) interp;
int curLevel, level, result;
+ const Tcl_ObjIntRep *irPtr;
const char *name = NULL;
Tcl_WideInt w;
@@ -758,8 +794,8 @@ TclObjGetFrame(
level = curLevel - level;
result = 1;
}
- } else if (objPtr->typePtr == &levelReferenceType) {
- level = (int) objPtr->internalRep.wideValue;
+ } else if ((irPtr = Tcl_FetchIntRep(objPtr, &levelReferenceType))) {
+ level = irPtr->wideValue;
result = 1;
} else {
name = TclGetString(objPtr);
@@ -768,9 +804,10 @@ TclObjGetFrame(
if (level < 0 || (level > 0 && name[1] == '-')) {
result = -1;
} else {
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &levelReferenceType;
- objPtr->internalRep.wideValue = level;
+ Tcl_ObjIntRep ir;
+
+ ir.wideValue = level;
+ Tcl_StoreIntRep(objPtr, &levelReferenceType, &ir);
result = 1;
}
} else {
@@ -1094,10 +1131,10 @@ TclInitCompiledLocals(
ByteCode *codePtr;
bodyPtr = framePtr->procPtr->bodyPtr;
- if (bodyPtr->typePtr != &tclByteCodeType) {
+ ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr);
+ if (codePtr == NULL) {
Tcl_Panic("body object for proc attached to frame is not a byte code type");
}
- codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
if (framePtr->numCompiledLocals) {
if (!codePtr->localCachePtr) {
@@ -1260,7 +1297,7 @@ InitLocalCache(
Proc *procPtr)
{
Interp *iPtr = procPtr->iPtr;
- ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
int localCt = procPtr->numCompiledLocals;
int numArgs = procPtr->numArgs, i = 0;
@@ -1270,6 +1307,8 @@ InitLocalCache(
CompiledLocal *localPtr;
int new;
+ ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
+
/*
* Cache the names and initial values of local variables; store the
* cache in both the framePtr for this execution and in the codePtr
@@ -1337,11 +1376,13 @@ InitArgsAndLocals(
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
register Proc *procPtr = framePtr->procPtr;
- ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
register Var *varPtr, *defPtr;
int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax;
Tcl_Obj *const *argObjs;
+ ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
+
/*
* Make sure that the local cache of variable names and initial values has
* been initialised properly .
@@ -1516,7 +1557,8 @@ TclPushProcCallFrame(
* local variables are found while compiling.
*/
- if (procPtr->bodyPtr->typePtr == &tclByteCodeType) {
+ ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
+ if (codePtr != NULL) {
Interp *iPtr = (Interp *) interp;
/*
@@ -1528,7 +1570,6 @@ TclPushProcCallFrame(
* commands and/or resolver changes are considered).
*/
- codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)
@@ -1726,7 +1767,7 @@ TclNRInterpProcCore(
*/
procPtr->refCount++;
- codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
+ ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc,
NULL, NULL);
@@ -1860,7 +1901,9 @@ TclProcCompileProc(
{
Interp *iPtr = (Interp *) interp;
Tcl_CallFrame *framePtr;
- ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
+
+ ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr);
/*
* If necessary, compile the procedure's body. The compiler will allocate
@@ -1876,7 +1919,7 @@ TclProcCompileProc(
* are not recompiled, even if things have changed.
*/
- if (bodyPtr->typePtr == &tclByteCodeType) {
+ if (codePtr != NULL) {
if (((Interp *) *codePtr->interpHandle == iPtr)
&& (codePtr->compileEpoch == iPtr->compileEpoch)
&& (codePtr->nsPtr == nsPtr)
@@ -1895,11 +1938,12 @@ TclProcCompileProc(
codePtr->compileEpoch = iPtr->compileEpoch;
codePtr->nsPtr = nsPtr;
} else {
- TclFreeIntRep(bodyPtr);
+ Tcl_StoreIntRep(bodyPtr, &tclByteCodeType, NULL);
+ codePtr = NULL;
}
}
- if (bodyPtr->typePtr != &tclByteCodeType) {
+ if (codePtr == NULL) {
Tcl_HashEntry *hePtr;
#ifdef TCL_COMPILE_DEBUG
@@ -2248,10 +2292,7 @@ TclNewProcBodyObj(
TclNewObj(objPtr);
if (objPtr) {
- objPtr->typePtr = &tclProcBodyType;
- objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
-
- procPtr->refCount++;
+ ProcSetIntRep(objPtr, procPtr);
}
return objPtr;
@@ -2279,11 +2320,10 @@ ProcBodyDup(
Tcl_Obj *srcPtr, /* Object to copy. */
Tcl_Obj *dupPtr) /* Target object for the duplication. */
{
- Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ Proc *procPtr;
+ ProcGetIntRep(srcPtr, procPtr);
- dupPtr->typePtr = &tclProcBodyType;
- dupPtr->internalRep.twoPtrValue.ptr1 = procPtr;
- procPtr->refCount++;
+ ProcSetIntRep(dupPtr, procPtr);
}
/*
@@ -2309,7 +2349,9 @@ static void
ProcBodyFree(
Tcl_Obj *objPtr) /* The object to clean up. */
{
- Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ Proc *procPtr;
+
+ ProcGetIntRep(objPtr, procPtr);
if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
@@ -2335,15 +2377,15 @@ DupLambdaInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
- Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2;
+ Proc *procPtr;
+ Tcl_Obj *nsObjPtr;
- copyPtr->internalRep.twoPtrValue.ptr1 = procPtr;
- copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
+ LambdaGetIntRep(srcPtr, procPtr, nsObjPtr);
+ assert(procPtr != NULL);
procPtr->refCount++;
- Tcl_IncrRefCount(nsObjPtr);
- copyPtr->typePtr = &tclLambdaType;
+
+ LambdaSetIntRep(copyPtr, procPtr, nsObjPtr);
}
static void
@@ -2351,14 +2393,16 @@ FreeLambdaInternalRep(
register Tcl_Obj *objPtr) /* CmdName object with internal representation
* to free. */
{
- Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
- Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2;
+ Proc *procPtr;
+ Tcl_Obj *nsObjPtr;
+
+ LambdaGetIntRep(objPtr, procPtr, nsObjPtr);
+ assert(procPtr != NULL);
if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
}
TclDecrRefCount(nsObjPtr);
- objPtr->typePtr = NULL;
}
static int
@@ -2379,7 +2423,7 @@ SetLambdaFromAny(
/*
* Convert objPtr to list type first; if it cannot be converted, or if its
- * length is not 2, then it cannot be converted to tclLambdaType.
+ * length is not 2, then it cannot be converted to lambdaType.
*/
result = TclListObjGetElements(NULL, objPtr, &objc, &objv);
@@ -2520,21 +2564,42 @@ SetLambdaFromAny(
}
}
- Tcl_IncrRefCount(nsObjPtr);
-
/*
* Free the list internalrep of objPtr - this will free argsPtr, but
* bodyPtr retains a reference from the Proc structure. Then finish the
- * conversion to tclLambdaType.
+ * conversion to lambdaType.
*/
- TclFreeIntRep(objPtr);
-
- objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
- objPtr->typePtr = &tclLambdaType;
+ LambdaSetIntRep(objPtr, procPtr, nsObjPtr);
return TCL_OK;
}
+
+Proc *
+TclGetLambdaFromObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ Tcl_Obj **nsObjPtrPtr)
+{
+ Proc *procPtr;
+ Tcl_Obj *nsObjPtr;
+
+ LambdaGetIntRep(objPtr, procPtr, nsObjPtr);
+
+ if (procPtr == NULL) {
+ if (SetLambdaFromAny(interp, objPtr) != TCL_OK) {
+ return NULL;
+ }
+ LambdaGetIntRep(objPtr, procPtr, nsObjPtr);
+ }
+
+ assert(procPtr != NULL);
+ if (procPtr->iPtr != (Interp *)interp) {
+ return NULL;
+ }
+
+ *nsObjPtrPtr = nsObjPtr;
+ return procPtr;
+}
/*
*----------------------------------------------------------------------
@@ -2570,7 +2635,6 @@ TclNRApplyObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Interp *iPtr = (Interp *) interp;
Proc *procPtr = NULL;
Tcl_Obj *lambdaPtr, *nsObjPtr;
int result;
@@ -2588,24 +2652,17 @@ TclNRApplyObjCmd(
*/
lambdaPtr = objv[1];
- if (lambdaPtr->typePtr == &tclLambdaType) {
- procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
- }
+ procPtr = TclGetLambdaFromObj(interp, lambdaPtr, &nsObjPtr);
- if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) {
- result = SetLambdaFromAny(interp, lambdaPtr);
- if (result != TCL_OK) {
- return result;
- }
- procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
+ if (procPtr == NULL) {
+ return TCL_ERROR;
}
/*
- * Find the namespace where this lambda should run, and push a call frame
- * for that namespace. Note that TclObjInterpProc() will pop it.
+ * Push a call frame for the lambda namespace.
+ * Note that TclObjInterpProc() will pop it.
*/
- nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2;
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
if (result != TCL_OK) {
return TCL_ERROR;
diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c
index 5f8dc20..a01ace3 100644
--- a/generic/tclRegexp.c
+++ b/generic/tclRegexp.c
@@ -13,6 +13,7 @@
#include "tclInt.h"
#include "tclRegexp.h"
+#include <assert.h>
/*
*----------------------------------------------------------------------
@@ -107,6 +108,23 @@ const Tcl_ObjType tclRegexpType = {
NULL, /* updateStringProc */
SetRegexpFromAny /* setFromAnyProc */
};
+
+#define RegexpSetIntRep(objPtr, rePtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ (rePtr)->refCount++; \
+ ir.twoPtrValue.ptr1 = (rePtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreIntRep((objPtr), &tclRegexpType, &ir); \
+ } while (0)
+
+#define RegexpGetIntRep(objPtr, rePtr) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = Tcl_FetchIntRep((objPtr), &tclRegexpType); \
+ (rePtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
*----------------------------------------------------------------------
@@ -580,14 +598,9 @@ Tcl_GetRegExpFromObj(
TclRegexp *regexpPtr;
const char *pattern;
- /*
- * This is OK because we only actually interpret this value properly as a
- * TclRegexp* when the type is tclRegexpType.
- */
-
- regexpPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ RegexpGetIntRep(objPtr, regexpPtr);
- if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) {
+ if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) {
pattern = TclGetStringFromObj(objPtr, &length);
regexpPtr = CompileRegexp(interp, pattern, length, flags);
@@ -595,21 +608,7 @@ Tcl_GetRegExpFromObj(
return NULL;
}
- /*
- * Add a reference to the regexp so it will persist even if it is
- * pushed out of the current thread's regexp cache. This reference
- * will be removed when the object's internal rep is freed.
- */
-
- regexpPtr->refCount++;
-
- /*
- * Free the old representation and set our type.
- */
-
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = regexpPtr;
- objPtr->typePtr = &tclRegexpType;
+ RegexpSetIntRep(objPtr, regexpPtr);
}
return (Tcl_RegExp) regexpPtr;
}
@@ -756,7 +755,11 @@ static void
FreeRegexpInternalRep(
Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */
{
- TclRegexp *regexpRepPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ TclRegexp *regexpRepPtr;
+
+ RegexpGetIntRep(objPtr, regexpRepPtr);
+
+ assert(regexpRepPtr != NULL);
/*
* If this is the last reference to the regexp, free it.
@@ -765,7 +768,6 @@ FreeRegexpInternalRep(
if (regexpRepPtr->refCount-- <= 1) {
FreeRegexp(regexpRepPtr);
}
- objPtr->typePtr = NULL;
}
/*
@@ -790,11 +792,13 @@ DupRegexpInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- TclRegexp *regexpPtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ TclRegexp *regexpPtr;
+
+ RegexpGetIntRep(srcPtr, regexpPtr);
+
+ assert(regexpPtr != NULL);
- regexpPtr->refCount++;
- copyPtr->internalRep.twoPtrValue.ptr1 = srcPtr->internalRep.twoPtrValue.ptr1;
- copyPtr->typePtr = &tclRegexpType;
+ RegexpSetIntRep(copyPtr, regexpPtr);
}
/*
diff --git a/generic/tclScan.c b/generic/tclScan.c
index 6a1311f..ae9f505 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -135,7 +135,7 @@ BuildCharSet(
* as well as the dash.
*/
- if (*format == ']') {
+ if (*format == ']' || !cset->ranges) {
cset->chars[cset->nchars++] = start;
cset->chars[cset->nchars++] = ch;
} else {
@@ -1009,8 +1009,10 @@ Tcl_ScanObjCmd(
double dvalue;
if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {
#ifdef ACCEPT_NAN
- if (objPtr->typePtr == &tclDoubleType) {
- dvalue = objPtr->internalRep.doubleValue;
+ const Tcl_ObjIntRep *irPtr
+ = Tcl_FetchIntRep(objPtr, &tclDoubleType);
+ if (irPtr) {
+ dvalue = irPtr->doubleValue;
} else
#endif
{
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index fa55bb0..f7d287b 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -3360,7 +3360,8 @@ TclStringCat(
*---------------------------------------------------------------------------
*/
-int TclStringCmp(
+int
+TclStringCmp(
Tcl_Obj *value1Ptr,
Tcl_Obj *value2Ptr,
int checkEq, /* comparison is only for equality */
@@ -3377,7 +3378,6 @@ int TclStringCmp(
*/
match = 0;
} else {
-
if (!nocase && TclIsPureByteArray(value1Ptr)
&& TclIsPureByteArray(value2Ptr)) {
/*
@@ -3418,11 +3418,11 @@ int TclStringCmp(
s2 = (char *) Tcl_GetUnicode(value2Ptr);
if (
#ifdef WORDS_BIGENDIAN
- 1
+ 1
#else
- checkEq
+ checkEq
#endif
- ) {
+ ) {
memCmpFn = memcmp;
s1len *= sizeof(Tcl_UniChar);
s2len *= sizeof(Tcl_UniChar);
@@ -3432,7 +3432,8 @@ int TclStringCmp(
}
}
} else {
- if ((empty = TclCheckEmptyString(value1Ptr)) > 0) {
+ empty = TclCheckEmptyString(value1Ptr);
+ if (empty > 0) {
switch (TclCheckEmptyString(value2Ptr)) {
case -1:
s1 = 0;
@@ -4211,7 +4212,7 @@ UpdateStringOfString(
stringPtr->allocated = 0;
if (stringPtr->numChars == 0) {
- TclInitStringRep(objPtr, &tclEmptyString, 0);
+ TclInitStringRep(objPtr, NULL, 0);
} else {
(void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode,
stringPtr->numChars);
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index ed61bbd..feabc3b 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -56,6 +56,8 @@
#undef TclWinGetSockOpt
#undef TclWinSetSockOpt
#undef TclWinNToHS
+#undef TclStaticPackage
+#define TclStaticPackage Tcl_StaticPackage
/* See bug 510001: TclSockMinimumBuffers needs plat imp */
#if defined(_WIN64) || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
@@ -93,6 +95,9 @@ static int TclSockMinimumBuffersOld(int sock, int size)
# define Tcl_CreateMathFunc 0
# define Tcl_GetMathFuncInfo 0
# define Tcl_ListMathFuncs 0
+# define Tcl_SetIntObj 0
+# define Tcl_SetLongObj 0
+
#else
#define TclSetStartupScriptPath setStartupScriptPath
static void TclSetStartupScriptPath(Tcl_Obj *path)
@@ -230,11 +235,68 @@ Tcl_WinUtfToTChar(
int len,
Tcl_DString *dsPtr)
{
+#if TCL_UTF_MAX > 4
+ Tcl_UniChar ch = 0;
+ wchar_t *w, *wString;
+ const char *p, *end;
+ int oldLength;
+#endif
+
Tcl_DStringInit(dsPtr);
if (!string) {
return NULL;
}
+#if TCL_UTF_MAX > 4
+
+ if (len < 0) {
+ len = strlen(string);
+ }
+
+ /*
+ * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in
+ * bytes.
+ */
+
+ oldLength = Tcl_DStringLength(dsPtr);
+
+ Tcl_DStringSetLength(dsPtr,
+ oldLength + (int) ((len + 1) * sizeof(wchar_t)));
+ wString = (wchar_t *) (Tcl_DStringValue(dsPtr) + oldLength);
+
+ w = wString;
+ p = string;
+ end = string + len - 4;
+ while (p < end) {
+ p += TclUtfToUniChar(p, &ch);
+ if (ch > 0xFFFF) {
+ *w++ = (wchar_t) (0xD800 + ((ch -= 0x10000) >> 10));
+ *w++ = (wchar_t) (0xDC00 | (ch & 0x3FF));
+ } else {
+ *w++ = ch;
+ }
+ }
+ end += 4;
+ while (p < end) {
+ if (Tcl_UtfCharComplete(p, end-p)) {
+ p += TclUtfToUniChar(p, &ch);
+ } else {
+ ch = UCHAR(*p++);
+ }
+ if (ch > 0xFFFF) {
+ *w++ = (wchar_t) (0xD800 + ((ch -= 0x10000) >> 10));
+ *w++ = (wchar_t) (0xDC00 | (ch & 0x3FF));
+ } else {
+ *w++ = ch;
+ }
+ }
+ *w = '\0';
+ Tcl_DStringSetLength(dsPtr,
+ oldLength + ((char *) w - (char *) wString));
+
+ return (char *)wString;
+#else
return (char *)Tcl_UtfToUniCharDString(string, len, dsPtr);
+#endif
}
char *
@@ -243,6 +305,12 @@ Tcl_WinTCharToUtf(
int len,
Tcl_DString *dsPtr)
{
+#if TCL_UTF_MAX > 4
+ const wchar_t *w, *wEnd;
+ char *p, *result;
+ int oldLength, blen = 1;
+#endif
+
Tcl_DStringInit(dsPtr);
if (!string) {
return NULL;
@@ -252,7 +320,32 @@ Tcl_WinTCharToUtf(
} else {
len /= 2;
}
+#if TCL_UTF_MAX > 4
+ oldLength = Tcl_DStringLength(dsPtr);
+ Tcl_DStringSetLength(dsPtr, oldLength + (len + 1) * 4);
+ result = Tcl_DStringValue(dsPtr) + oldLength;
+
+ p = result;
+ wEnd = (wchar_t *)string + len;
+ for (w = (wchar_t *)string; w < wEnd; ) {
+ if (!blen && ((*w & 0xFC00) != 0xDC00)) {
+ /* Special case for handling upper surrogates. */
+ p += Tcl_UniCharToUtf(-1, p);
+ }
+ blen = Tcl_UniCharToUtf(*w, p);
+ p += blen;
+ w++;
+ }
+ if (!blen) {
+ /* Special case for handling upper surrogates. */
+ p += Tcl_UniCharToUtf(-1, p);
+ }
+ Tcl_DStringSetLength(dsPtr, oldLength + (p - result));
+
+ return result;
+#else
return Tcl_UniCharToUtfDString((Tcl_UniChar *)string, len, dsPtr);
+#endif
}
#if defined(TCL_WIDE_INT_IS_LONG)
@@ -401,6 +494,7 @@ static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsig
# define Tcl_SetPanicProc 0
# define Tcl_FindExecutable 0
# define Tcl_GetUnicode 0
+# define TclOldFreeObj 0
#else /* TCL_NO_DEPRECATED */
# define Tcl_SeekOld seekOld
# define Tcl_TellOld tellOld
@@ -421,7 +515,7 @@ static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsig
# define TclGetCommandFullName Tcl_GetCommandFullName
# define TclpLocaltime_unix TclpLocaltime
# define TclpGmtime_unix TclpGmtime
-# define Tcl_SetPanicProc (const char *(*)(TCL_NORETURN1 Tcl_PanicProc *))TclSetPanicProc
+# define TclOldFreeObj TclFreeObj
static int
seekOld(
@@ -720,6 +814,7 @@ static const TclIntStubs tclIntStubs = {
TclPtrIncrObjVar, /* 254 */
TclPtrObjMakeUpvar, /* 255 */
TclPtrUnsetVar, /* 256 */
+ TclStaticPackage, /* 257 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
@@ -972,7 +1067,7 @@ const TclStubs tclStubs = {
Tcl_DbNewObj, /* 27 */
Tcl_DbNewStringObj, /* 28 */
Tcl_DuplicateObj, /* 29 */
- TclFreeObj, /* 30 */
+ TclOldFreeObj, /* 30 */
Tcl_GetBoolean, /* 31 */
Tcl_GetBooleanFromObj, /* 32 */
Tcl_GetByteArrayFromObj, /* 33 */
@@ -1586,6 +1681,14 @@ const TclStubs tclStubs = {
TclZipfs_Unmount, /* 633 */
TclZipfs_TclLibrary, /* 634 */
TclZipfs_MountBuffer, /* 635 */
+ Tcl_FreeIntRep, /* 636 */
+ Tcl_InitStringRep, /* 637 */
+ Tcl_FetchIntRep, /* 638 */
+ Tcl_StoreIntRep, /* 639 */
+ Tcl_HasStringRep, /* 640 */
+ Tcl_IncrRefCount, /* 641 */
+ Tcl_DecrRefCount, /* 642 */
+ Tcl_IsShared, /* 643 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 2cdd356..0e298ee 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -159,227 +159,227 @@ static TestChannel *firstDetached;
* Forward declarations for procedures defined later in this file:
*/
-static int AsyncHandlerProc(ClientData clientData,
+static int AsyncHandlerProc(void *clientData,
Tcl_Interp *interp, int code);
#if TCL_THREADS
-static Tcl_ThreadCreateType AsyncThreadProc(ClientData);
+static Tcl_ThreadCreateType AsyncThreadProc(void *);
#endif
static void CleanupTestSetassocdataTests(
- ClientData clientData, Tcl_Interp *interp);
-static void CmdDelProc1(ClientData clientData);
-static void CmdDelProc2(ClientData clientData);
-static int CmdProc1(ClientData clientData,
+ void *clientData, Tcl_Interp *interp);
+static void CmdDelProc1(void *clientData);
+static void CmdDelProc2(void *clientData);
+static int CmdProc1(void *clientData,
Tcl_Interp *interp, int argc, const char **argv);
-static int CmdProc2(ClientData clientData,
+static int CmdProc2(void *clientData,
Tcl_Interp *interp, int argc, const char **argv);
static void CmdTraceDeleteProc(
- ClientData clientData, Tcl_Interp *interp,
+ void *clientData, Tcl_Interp *interp,
int level, char *command, Tcl_CmdProc *cmdProc,
- ClientData cmdClientData, int argc,
+ void *cmdClientData, int argc,
const char *argv[]);
-static void CmdTraceProc(ClientData clientData,
+static void CmdTraceProc(void *clientData,
Tcl_Interp *interp, int level, char *command,
- Tcl_CmdProc *cmdProc, ClientData cmdClientData,
+ Tcl_CmdProc *cmdProc, void *cmdClientData,
int argc, const char *argv[]);
static int CreatedCommandProc(
- ClientData clientData, Tcl_Interp *interp,
+ void *clientData, Tcl_Interp *interp,
int argc, const char **argv);
static int CreatedCommandProc2(
- ClientData clientData, Tcl_Interp *interp,
+ void *clientData, Tcl_Interp *interp,
int argc, const char **argv);
-static void DelCallbackProc(ClientData clientData,
+static void DelCallbackProc(void *clientData,
Tcl_Interp *interp);
-static int DelCmdProc(ClientData clientData,
+static int DelCmdProc(void *clientData,
Tcl_Interp *interp, int argc, const char **argv);
-static void DelDeleteProc(ClientData clientData);
-static void EncodingFreeProc(ClientData clientData);
-static int EncodingToUtfProc(ClientData clientData,
+static void DelDeleteProc(void *clientData);
+static void EncodingFreeProc(void *clientData);
+static int EncodingToUtfProc(void *clientData,
const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
int dstLen, int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr);
-static int EncodingFromUtfProc(ClientData clientData,
+static int EncodingFromUtfProc(void *clientData,
const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
int dstLen, int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr);
-static void ExitProcEven(ClientData clientData);
-static void ExitProcOdd(ClientData clientData);
-static int GetTimesObjCmd(ClientData clientData,
+static void ExitProcEven(void *clientData);
+static void ExitProcOdd(void *clientData);
+static int GetTimesObjCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static void MainLoop(void);
-static int NoopCmd(ClientData clientData,
+static int NoopCmd(void *clientData,
Tcl_Interp *interp, int argc, const char **argv);
-static int NoopObjCmd(ClientData clientData,
+static int NoopObjCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int ObjTraceProc(ClientData clientData,
+static int ObjTraceProc(void *clientData,
Tcl_Interp *interp, int level, const char *command,
Tcl_Command commandToken, int objc,
Tcl_Obj *const objv[]);
-static void ObjTraceDeleteProc(ClientData clientData);
+static void ObjTraceDeleteProc(void *clientData);
static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr);
static void SpecialFree(char *blockPtr);
static int StaticInitProc(Tcl_Interp *interp);
-static int TestasyncCmd(ClientData dummy,
+static int TestasyncCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestbytestringObjCmd(ClientData clientData,
+static int TestbytestringObjCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TeststringbytesObjCmd(ClientData clientData,
+static int TeststringbytesObjCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TestcmdinfoCmd(ClientData dummy,
+static int TestcmdinfoCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestcmdtokenCmd(ClientData dummy,
+static int TestcmdtokenCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestcmdtraceCmd(ClientData dummy,
+static int TestcmdtraceCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestconcatobjCmd(ClientData dummy,
+static int TestconcatobjCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestcreatecommandCmd(ClientData dummy,
+static int TestcreatecommandCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestdcallCmd(ClientData dummy,
+static int TestdcallCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestdelCmd(ClientData dummy,
+static int TestdelCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestdelassocdataCmd(ClientData dummy,
+static int TestdelassocdataCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestdoubledigitsObjCmd(ClientData dummy,
+static int TestdoubledigitsObjCmd(void *dummy,
Tcl_Interp* interp,
int objc, Tcl_Obj* const objv[]);
-static int TestdstringCmd(ClientData dummy,
+static int TestdstringCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestencodingObjCmd(ClientData dummy,
+static int TestencodingObjCmd(void *dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TestevalexObjCmd(ClientData dummy,
+static int TestevalexObjCmd(void *dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TestevalobjvObjCmd(ClientData dummy,
+static int TestevalobjvObjCmd(void *dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TesteventObjCmd(ClientData unused,
+static int TesteventObjCmd(void *unused,
Tcl_Interp *interp, int argc,
Tcl_Obj *const objv[]);
static int TesteventProc(Tcl_Event *event, int flags);
static int TesteventDeleteProc(Tcl_Event *event,
- ClientData clientData);
-static int TestexithandlerCmd(ClientData dummy,
+ void *clientData);
+static int TestexithandlerCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestexprlongCmd(ClientData dummy,
+static int TestexprlongCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestexprlongobjCmd(ClientData dummy,
+static int TestexprlongobjCmd(void *dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TestexprdoubleCmd(ClientData dummy,
+static int TestexprdoubleCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestexprdoubleobjCmd(ClientData dummy,
+static int TestexprdoubleobjCmd(void *dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TestexprparserObjCmd(ClientData dummy,
+static int TestexprparserObjCmd(void *dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TestexprstringCmd(ClientData dummy,
+static int TestexprstringCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestfileCmd(ClientData dummy,
+static int TestfileCmd(void *dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
-static int TestfilelinkCmd(ClientData dummy,
+static int TestfilelinkCmd(void *dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
-static int TestfeventCmd(ClientData dummy,
+static int TestfeventCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestgetassocdataCmd(ClientData dummy,
+static int TestgetassocdataCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestgetintCmd(ClientData dummy,
+static int TestgetintCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestlongsizeCmd(ClientData dummy,
+static int TestlongsizeCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestgetplatformCmd(ClientData dummy,
+static int TestgetplatformCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestgetvarfullnameCmd(
- ClientData dummy, Tcl_Interp *interp,
+ void *dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
-static int TestinterpdeleteCmd(ClientData dummy,
+static int TestinterpdeleteCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestlinkCmd(ClientData dummy,
+static int TestlinkCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestlocaleCmd(ClientData dummy,
+static int TestlocaleCmd(void *dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TestmainthreadCmd(ClientData dummy,
+static int TestmainthreadCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestsetmainloopCmd(ClientData dummy,
+static int TestsetmainloopCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestexitmainloopCmd(ClientData dummy,
+static int TestexitmainloopCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestpanicCmd(ClientData dummy,
+static int TestpanicCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp,
+static int TestparseargsCmd(void *dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
-static int TestparserObjCmd(ClientData dummy,
+static int TestparserObjCmd(void *dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TestparsevarObjCmd(ClientData dummy,
+static int TestparsevarObjCmd(void *dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TestparsevarnameObjCmd(ClientData dummy,
+static int TestparsevarnameObjCmd(void *dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TestpreferstableObjCmd(ClientData dummy,
+static int TestpreferstableObjCmd(void *dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TestprintObjCmd(ClientData dummy,
+static int TestprintObjCmd(void *dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TestregexpObjCmd(ClientData dummy,
+static int TestregexpObjCmd(void *dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TestreturnObjCmd(ClientData dummy,
+static int TestreturnObjCmd(void *dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static void TestregexpXflags(const char *string,
int length, int *cflagsPtr, int *eflagsPtr);
-static int TestsaveresultCmd(ClientData dummy,
+static int TestsaveresultCmd(void *dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static void TestsaveresultFree(char *blockPtr);
-static int TestsetassocdataCmd(ClientData dummy,
+static int TestsetassocdataCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestsetCmd(ClientData dummy,
+static int TestsetCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int Testset2Cmd(ClientData dummy,
+static int Testset2Cmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestseterrorcodeCmd(ClientData dummy,
+static int TestseterrorcodeCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestsetobjerrorcodeCmd(
- ClientData dummy, Tcl_Interp *interp,
+ void *dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
-static int TestsetplatformCmd(ClientData dummy,
+static int TestsetplatformCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TeststaticpkgCmd(ClientData dummy,
+static int TeststaticpkgCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TesttranslatefilenameCmd(ClientData dummy,
+static int TesttranslatefilenameCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestupvarCmd(ClientData dummy,
+static int TestupvarCmd(void *dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestWrongNumArgsObjCmd(
- ClientData clientData, Tcl_Interp *interp,
+ void *clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int TestGetIndexFromObjStructObjCmd(
- ClientData clientData, Tcl_Interp *interp,
+ void *clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
-static int TestChannelCmd(ClientData clientData,
+static int TestChannelCmd(void *clientData,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestChannelEventCmd(ClientData clientData,
+static int TestChannelEventCmd(void *clientData,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestSocketCmd(ClientData clientData,
+static int TestSocketCmd(void *clientData,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestFilesystemObjCmd(ClientData dummy,
+static int TestFilesystemObjCmd(void *dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int TestSimpleFilesystemObjCmd(
- ClientData dummy, Tcl_Interp *interp, int objc,
+ void *dummy, Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static void TestReport(const char *cmd, Tcl_Obj *arg1,
Tcl_Obj *arg2);
@@ -415,31 +415,31 @@ static Tcl_FSListVolumesProc SimpleListVolumes;
static Tcl_FSPathInFilesystemProc SimplePathInFilesystem;
static Tcl_Obj * SimpleRedirect(Tcl_Obj *pathPtr);
static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory;
-static int TestNumUtfCharsCmd(ClientData clientData,
+static int TestNumUtfCharsCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TestFindFirstCmd(ClientData clientData,
+static int TestFindFirstCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TestFindLastCmd(ClientData clientData,
+static int TestFindLastCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TestHashSystemHashCmd(ClientData clientData,
+static int TestHashSystemHashCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static Tcl_NRPostProc NREUnwind_callback;
-static int TestNREUnwind(ClientData clientData,
+static int TestNREUnwind(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TestNRELevels(ClientData clientData,
+static int TestNRELevels(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static int TestInterpResolverCmd(ClientData clientData,
+static int TestInterpResolverCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
#if defined(HAVE_CPUID) || defined(_WIN32)
-static int TestcpuidCmd(ClientData dummy,
+static int TestcpuidCmd(void *dummy,
Tcl_Interp* interp, int objc,
Tcl_Obj *const objv[]);
#endif
@@ -681,9 +681,9 @@ Tcltest_Init(
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
- (ClientData) TCL_LEAVE_ERR_MSG, NULL);
+ INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testset2", Testset2Cmd,
- (ClientData) TCL_LEAVE_ERR_MSG, NULL);
+ INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
@@ -711,7 +711,7 @@ Tcltest_Init(
NULL, NULL);
#if defined(HAVE_CPUID) || defined(_WIN32)
Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
#endif
Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind,
NULL, NULL);
@@ -821,7 +821,7 @@ Tcltest_SafeInit(
/* ARGSUSED */
static int
TestasyncCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -946,7 +946,7 @@ TestasyncCmd(
static int
AsyncHandlerProc(
- ClientData clientData, /* If of TestAsyncHandler structure.
+ void *clientData, /* If of TestAsyncHandler structure.
* in global list. */
Tcl_Interp *interp, /* Interpreter in which command was
* executed, or NULL. */
@@ -1006,7 +1006,7 @@ AsyncHandlerProc(
#if TCL_THREADS
static Tcl_ThreadCreateType
AsyncThreadProc(
- ClientData clientData) /* Parameter is the id of a
+ void *clientData) /* Parameter is the id of a
* TestAsyncHandler, defined above. */
{
TestAsyncHandler *asyncPtr;
@@ -1048,7 +1048,7 @@ AsyncThreadProc(
/* ARGSUSED */
static int
TestcmdinfoCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1061,7 +1061,7 @@ TestcmdinfoCmd(
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
- Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original",
+ Tcl_CreateCommand(interp, argv[2], CmdProc1, (void *) "original",
CmdDelProc1);
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_DStringInit(&delString);
@@ -1098,11 +1098,11 @@ TestcmdinfoCmd(
}
} else if (strcmp(argv[1], "modify") == 0) {
info.proc = CmdProc2;
- info.clientData = (ClientData) "new_command_data";
+ info.clientData = (void *) "new_command_data";
info.objProc = NULL;
info.objClientData = NULL;
info.deleteProc = CmdDelProc2;
- info.deleteData = (ClientData) "new_delete_data";
+ info.deleteData = (void *) "new_delete_data";
if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
} else {
@@ -1119,7 +1119,7 @@ TestcmdinfoCmd(
/*ARGSUSED*/
static int
CmdProc1(
- ClientData clientData, /* String to return. */
+ void *clientData, /* String to return. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1131,7 +1131,7 @@ CmdProc1(
/*ARGSUSED*/
static int
CmdProc2(
- ClientData clientData, /* String to return. */
+ void *clientData, /* String to return. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1142,7 +1142,7 @@ CmdProc2(
static void
CmdDelProc1(
- ClientData clientData) /* String to save. */
+ void *clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1);
@@ -1151,7 +1151,7 @@ CmdDelProc1(
static void
CmdDelProc2(
- ClientData clientData) /* String to save. */
+ void *clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1);
@@ -1178,7 +1178,7 @@ CmdDelProc2(
/* ARGSUSED */
static int
TestcmdtokenCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1194,7 +1194,7 @@ TestcmdtokenCmd(
}
if (strcmp(argv[1], "create") == 0) {
token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
- (ClientData) "original", NULL);
+ (void *) "original", NULL);
sprintf(buf, "%p", (void *)token);
Tcl_AppendResult(interp, buf, NULL);
} else if (strcmp(argv[1], "name") == 0) {
@@ -1242,7 +1242,7 @@ TestcmdtokenCmd(
/* ARGSUSED */
static int
TestcmdtraceCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1298,7 +1298,7 @@ TestcmdtraceCmd(
deleteCalled = 0;
cmdTrace = Tcl_CreateObjTrace(interp, 50000,
TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc,
- (ClientData) &deleteCalled, ObjTraceDeleteProc);
+ &deleteCalled, ObjTraceDeleteProc);
result = Tcl_EvalEx(interp, argv[2], -1, 0);
Tcl_DeleteTrace(interp, cmdTrace);
if (!deleteCalled) {
@@ -1331,7 +1331,7 @@ TestcmdtraceCmd(
static void
CmdTraceProc(
- ClientData clientData, /* Pointer to buffer in which the
+ void *clientData, /* Pointer to buffer in which the
* command and arguments are appended.
* Accumulates test result. */
Tcl_Interp *interp, /* Current interpreter. */
@@ -1339,7 +1339,7 @@ CmdTraceProc(
char *command, /* The command being traced (after
* substitutions). */
Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */
- ClientData cmdClientData, /* Client data associated with command
+ void *cmdClientData, /* Client data associated with command
* procedure. */
int argc, /* Number of arguments. */
const char *argv[]) /* Argument strings. */
@@ -1358,13 +1358,13 @@ CmdTraceProc(
static void
CmdTraceDeleteProc(
- ClientData clientData, /* Unused. */
+ void *clientData, /* Unused. */
Tcl_Interp *interp, /* Current interpreter. */
int level, /* Current trace level. */
char *command, /* The command being traced (after
* substitutions). */
Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */
- ClientData cmdClientData, /* Client data associated with command
+ void *cmdClientData, /* Client data associated with command
* procedure. */
int argc, /* Number of arguments. */
const char *argv[]) /* Argument strings. */
@@ -1380,7 +1380,7 @@ CmdTraceDeleteProc(
static int
ObjTraceProc(
- ClientData clientData, /* unused */
+ void *clientData, /* unused */
Tcl_Interp *interp, /* Tcl interpreter */
int level, /* Execution level */
const char *command, /* Command being executed */
@@ -1408,7 +1408,7 @@ ObjTraceProc(
static void
ObjTraceDeleteProc(
- ClientData clientData)
+ void *clientData)
{
int *intPtr = (int *) clientData;
*intPtr = 1; /* Record that the trace was deleted */
@@ -1437,7 +1437,7 @@ ObjTraceDeleteProc(
static int
TestcreatecommandCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1467,7 +1467,7 @@ TestcreatecommandCmd(
static int
CreatedCommandProc(
- ClientData clientData, /* String to return. */
+ void *clientData, /* String to return. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1489,7 +1489,7 @@ CreatedCommandProc(
static int
CreatedCommandProc2(
- ClientData clientData, /* String to return. */
+ void *clientData, /* String to return. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1528,7 +1528,7 @@ CreatedCommandProc2(
/* ARGSUSED */
static int
TestdcallCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1543,10 +1543,10 @@ TestdcallCmd(
}
if (id < 0) {
Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc,
- (ClientData) INT2PTR(-id));
+ INT2PTR(-id));
} else {
Tcl_CallWhenDeleted(delInterp, DelCallbackProc,
- (ClientData) INT2PTR(id));
+ INT2PTR(id));
}
}
Tcl_DeleteInterp(delInterp);
@@ -1560,7 +1560,7 @@ TestdcallCmd(
static void
DelCallbackProc(
- ClientData clientData, /* Numerical value to append to delString. */
+ void *clientData, /* Numerical value to append to delString. */
Tcl_Interp *interp) /* Interpreter being deleted. */
{
int id = PTR2INT(clientData);
@@ -1593,7 +1593,7 @@ DelCallbackProc(
/* ARGSUSED */
static int
TestdelCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1616,14 +1616,14 @@ TestdelCmd(
dPtr->deleteCmd = ckalloc(strlen(argv[3]) + 1);
strcpy(dPtr->deleteCmd, argv[3]);
- Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr,
+ Tcl_CreateCommand(slave, argv[2], DelCmdProc, dPtr,
DelDeleteProc);
return TCL_OK;
}
static int
DelCmdProc(
- ClientData clientData, /* String result to return. */
+ void *clientData, /* String result to return. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1638,7 +1638,7 @@ DelCmdProc(
static void
DelDeleteProc(
- ClientData clientData) /* String command to evaluate. */
+ void *clientData) /* String command to evaluate. */
{
DelCmd *dPtr = clientData;
@@ -1668,7 +1668,7 @@ DelDeleteProc(
static int
TestdelassocdataCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1704,7 +1704,7 @@ TestdelassocdataCmd(
*/
static int
-TestdoubledigitsObjCmd(ClientData unused,
+TestdoubledigitsObjCmd(void *unused,
/* NULL */
Tcl_Interp* interp,
/* Tcl interpreter */
@@ -1798,7 +1798,7 @@ TestdoubledigitsObjCmd(ClientData unused,
/* ARGSUSED */
static int
TestdstringCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1925,7 +1925,7 @@ static void SpecialFree(blockPtr)
/* ARGSUSED */
static int
TestencodingObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1970,7 +1970,7 @@ TestencodingObjCmd(
type.toUtfProc = EncodingToUtfProc;
type.fromUtfProc = EncodingFromUtfProc;
type.freeProc = EncodingFreeProc;
- type.clientData = (ClientData) encodingPtr;
+ type.clientData = encodingPtr;
type.nullSize = 1;
Tcl_CreateEncoding(&type);
@@ -1993,7 +1993,7 @@ TestencodingObjCmd(
static int
EncodingToUtfProc(
- ClientData clientData, /* TclEncoding structure. */
+ void *clientData, /* TclEncoding structure. */
const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
@@ -2025,7 +2025,7 @@ EncodingToUtfProc(
static int
EncodingFromUtfProc(
- ClientData clientData, /* TclEncoding structure. */
+ void *clientData, /* TclEncoding structure. */
const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
@@ -2057,7 +2057,7 @@ EncodingFromUtfProc(
static void
EncodingFreeProc(
- ClientData clientData) /* ClientData associated with type. */
+ void *clientData) /* ClientData associated with type. */
{
TclEncoding *encodingPtr = clientData;
@@ -2085,7 +2085,7 @@ EncodingFreeProc(
static int
TestevalexObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2130,7 +2130,7 @@ TestevalexObjCmd(
static int
TestevalobjvObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2179,7 +2179,7 @@ TestevalobjvObjCmd(
static int
TesteventObjCmd(
- ClientData unused, /* Not used */
+ void *unused, /* Not used */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter vector */
@@ -2315,7 +2315,7 @@ TesteventProc(
static int
TesteventDeleteProc(
Tcl_Event *event, /* Event to examine */
- ClientData clientData) /* Tcl_Obj containing the name of the event(s)
+ void *clientData) /* Tcl_Obj containing the name of the event(s)
* to remove */
{
TestEvent *ev; /* Event to examine */
@@ -2358,7 +2358,7 @@ TesteventDeleteProc(
static int
TestexithandlerCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2375,10 +2375,10 @@ TestexithandlerCmd(
}
if (strcmp(argv[1], "create") == 0) {
Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
- (ClientData) INT2PTR(value));
+ INT2PTR(value));
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
- (ClientData) INT2PTR(value));
+ INT2PTR(value));
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create or delete", NULL);
@@ -2389,7 +2389,7 @@ TestexithandlerCmd(
static void
ExitProcOdd(
- ClientData clientData) /* Integer value to print. */
+ void *clientData) /* Integer value to print. */
{
char buf[16 + TCL_INTEGER_SPACE];
size_t len;
@@ -2403,7 +2403,7 @@ ExitProcOdd(
static void
ExitProcEven(
- ClientData clientData) /* Integer value to print. */
+ void *clientData) /* Integer value to print. */
{
char buf[16 + TCL_INTEGER_SPACE];
size_t len;
@@ -2434,7 +2434,7 @@ ExitProcEven(
static int
TestexprlongCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2477,7 +2477,7 @@ TestexprlongCmd(
static int
TestexprlongobjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument objects. */
@@ -2519,7 +2519,7 @@ TestexprlongobjCmd(
static int
TestexprdoubleCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2563,7 +2563,7 @@ TestexprdoubleCmd(
static int
TestexprdoubleobjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument objects. */
@@ -2605,7 +2605,7 @@ TestexprdoubleobjCmd(
static int
TestexprstringCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2637,7 +2637,7 @@ TestexprstringCmd(
static int
TestfilelinkCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -2704,7 +2704,7 @@ TestfilelinkCmd(
static int
TestgetassocdataCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2742,7 +2742,7 @@ TestgetassocdataCmd(
static int
TestgetplatformCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2783,7 +2783,7 @@ TestgetplatformCmd(
/* ARGSUSED */
static int
TestinterpdeleteCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2824,7 +2824,7 @@ TestinterpdeleteCmd(
/* ARGSUSED */
static int
TestlinkCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -3292,7 +3292,7 @@ TestlinkCmd(
static int
TestlocaleCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -3354,7 +3354,7 @@ TestlocaleCmd(
/* ARGSUSED */
static void
CleanupTestSetassocdataTests(
- ClientData clientData, /* Data to be released. */
+ void *clientData, /* Data to be released. */
Tcl_Interp *interp) /* Interpreter being deleted. */
{
ckfree(clientData);
@@ -3379,7 +3379,7 @@ CleanupTestSetassocdataTests(
static int
TestparserObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -3435,7 +3435,7 @@ TestparserObjCmd(
static int
TestexprparserObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -3582,7 +3582,7 @@ PrintParse(
static int
TestparsevarObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -3623,7 +3623,7 @@ TestparsevarObjCmd(
static int
TestparsevarnameObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -3686,7 +3686,7 @@ TestparsevarnameObjCmd(
static int
TestpreferstableObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -3715,7 +3715,7 @@ TestpreferstableObjCmd(
static int
TestprintObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -3757,7 +3757,7 @@ TestprintObjCmd(
/* ARGSUSED */
static int
TestregexpObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4081,7 +4081,7 @@ TestregexpXflags(
/* ARGSUSED */
static int
TestreturnObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4109,7 +4109,7 @@ TestreturnObjCmd(
static int
TestsetassocdataCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4136,8 +4136,7 @@ TestsetassocdataCmd(
ckfree(oldData);
}
- Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests,
- (ClientData) buf);
+ Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, buf);
return TCL_OK;
}
@@ -4161,7 +4160,7 @@ TestsetassocdataCmd(
static int
TestsetplatformCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4210,7 +4209,7 @@ TestsetplatformCmd(
static int
TeststaticpkgCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4228,7 +4227,7 @@ TeststaticpkgCmd(
if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) {
return TCL_ERROR;
}
- tclStubsPtr->tcl_StaticPackage((loaded) ? interp : NULL, argv[1],
+ Tcl_StaticPackage((loaded) ? interp : NULL, argv[1],
StaticInitProc, (safe) ? StaticInitProc : NULL);
return TCL_OK;
}
@@ -4261,7 +4260,7 @@ StaticInitProc(
static int
TesttranslatefilenameCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4303,7 +4302,7 @@ TesttranslatefilenameCmd(
/* ARGSUSED */
static int
TestupvarCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4356,7 +4355,7 @@ TestupvarCmd(
/* ARGSUSED */
static int
TestseterrorcodeCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4409,7 +4408,7 @@ TestseterrorcodeCmd(
/* ARGSUSED */
static int
TestsetobjerrorcodeCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -4438,7 +4437,7 @@ TestsetobjerrorcodeCmd(
/* ARGSUSED */
static int
TestfeventCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4510,7 +4509,7 @@ TestfeventCmd(
static int
TestpanicCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4531,7 +4530,7 @@ TestpanicCmd(
static int
TestfileCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
Tcl_Obj *const argv[]) /* The argument objects. */
@@ -4613,7 +4612,7 @@ TestfileCmd(
static int
TestgetvarfullnameCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -4687,7 +4686,7 @@ TestgetvarfullnameCmd(
static int
GetTimesObjCmd(
- ClientData unused, /* Unused. */
+ void *unused, /* Unused. */
Tcl_Interp *interp, /* The current interpreter. */
int notused1, /* Number of arguments. */
Tcl_Obj *const notused2[]) /* The argument objects. */
@@ -4866,7 +4865,7 @@ GetTimesObjCmd(
static int
NoopCmd(
- ClientData unused, /* Unused. */
+ void *unused, /* Unused. */
Tcl_Interp *interp, /* The current interpreter. */
int argc, /* The number of arguments. */
const char **argv) /* The argument strings. */
@@ -4893,7 +4892,7 @@ NoopCmd(
static int
NoopObjCmd(
- ClientData unused, /* Not used. */
+ void *unused, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -4918,7 +4917,7 @@ NoopObjCmd(
static int
TeststringbytesObjCmd(
- ClientData unused, /* Not used. */
+ void *unused, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -4954,7 +4953,7 @@ TeststringbytesObjCmd(
static int
TestbytestringObjCmd(
- ClientData unused, /* Not used. */
+ void *unused, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -4991,7 +4990,7 @@ TestbytestringObjCmd(
/* ARGSUSED */
static int
TestsetCmd(
- ClientData data, /* Additional flags for Get/SetVar2. */
+ void *data, /* Additional flags for Get/SetVar2. */
register Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -5023,7 +5022,7 @@ TestsetCmd(
}
static int
Testset2Cmd(
- ClientData data, /* Additional flags for Get/SetVar2. */
+ void *data, /* Additional flags for Get/SetVar2. */
register Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -5074,7 +5073,7 @@ Testset2Cmd(
/* ARGSUSED */
static int
TestsaveresultCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
register Tcl_Interp *interp,/* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -5205,7 +5204,7 @@ TestsaveresultFree(
static int
TestmainthreadCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
register Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -5266,7 +5265,7 @@ MainLoop(void)
static int
TestsetmainloopCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
register Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -5295,7 +5294,7 @@ TestsetmainloopCmd(
static int
TestexitmainloopCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
register Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -5324,7 +5323,7 @@ TestexitmainloopCmd(
/* ARGSUSED */
static int
TestChannelCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Interpreter for result. */
int argc, /* Count of additional args. */
const char **argv) /* Additional arg strings. */
@@ -5793,7 +5792,7 @@ TestChannelCmd(
/* ARGSUSED */
static int
TestChannelEventCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -5847,7 +5846,7 @@ TestChannelEventCmd(
Tcl_IncrRefCount(esPtr->scriptPtr);
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
- TclChannelEventScriptInvoker, (ClientData) esPtr);
+ TclChannelEventScriptInvoker, esPtr);
return TCL_OK;
}
@@ -5891,7 +5890,7 @@ TestChannelEventCmd(
prevEsPtr->nextPtr = esPtr->nextPtr;
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
- TclChannelEventScriptInvoker, (ClientData) esPtr);
+ TclChannelEventScriptInvoker, esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
ckfree(esPtr);
@@ -5932,7 +5931,7 @@ TestChannelEventCmd(
esPtr = nextEsPtr) {
nextEsPtr = esPtr->nextPtr;
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
- TclChannelEventScriptInvoker, (ClientData) esPtr);
+ TclChannelEventScriptInvoker, esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
ckfree(esPtr);
}
@@ -5978,7 +5977,7 @@ TestChannelEventCmd(
}
esPtr->mask = mask;
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
- TclChannelEventScriptInvoker, (ClientData) esPtr);
+ TclChannelEventScriptInvoker, esPtr);
return TCL_OK;
}
Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of "
@@ -6006,7 +6005,7 @@ TestChannelEventCmd(
/* ARGSUSED */
static int
TestSocketCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Interpreter for result. */
int argc, /* Count of additional args. */
const char **argv) /* Additional arg strings. */
@@ -6073,7 +6072,7 @@ TestSocketCmd(
static int
TestWrongNumArgsObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -6129,7 +6128,7 @@ TestWrongNumArgsObjCmd(
static int
TestGetIndexFromObjStructObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -6183,7 +6182,7 @@ TestGetIndexFromObjStructObjCmd(
static int
TestFilesystemObjCmd(
- ClientData dummy,
+ void *dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6199,7 +6198,7 @@ TestFilesystemObjCmd(
return TCL_ERROR;
}
if (boolVal) {
- res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem);
+ res = Tcl_FSRegister(interp, &testReportingFilesystem);
msg = (res == TCL_OK) ? "registered" : "failed";
} else {
res = Tcl_FSUnregister(&testReportingFilesystem);
@@ -6212,7 +6211,7 @@ TestFilesystemObjCmd(
static int
TestReportInFilesystem(
Tcl_Obj *pathPtr,
- ClientData *clientDataPtr)
+ void **clientDataPtr)
{
static Tcl_Obj *lastPathPtr = NULL;
Tcl_Obj *newPathPtr;
@@ -6234,7 +6233,7 @@ TestReportInFilesystem(
return -1;
}
lastPathPtr = NULL;
- *clientDataPtr = (ClientData) newPathPtr;
+ *clientDataPtr = newPathPtr;
return TCL_OK;
}
@@ -6252,7 +6251,7 @@ TestReportGetNativePath(
static void
TestReportFreeInternalRep(
- ClientData clientData)
+ void *clientData)
{
Tcl_Obj *nativeRep = (Tcl_Obj *) clientData;
@@ -6264,7 +6263,7 @@ TestReportFreeInternalRep(
static ClientData
TestReportDupInternalRep(
- ClientData clientData)
+ void *clientData)
{
Tcl_Obj *original = (Tcl_Obj *) clientData;
@@ -6530,7 +6529,7 @@ TestReportNormalizePath(
static int
SimplePathInFilesystem(
Tcl_Obj *pathPtr,
- ClientData *clientDataPtr)
+ void **clientDataPtr)
{
const char *str = Tcl_GetString(pathPtr);
@@ -6559,7 +6558,7 @@ SimplePathInFilesystem(
static int
TestSimpleFilesystemObjCmd(
- ClientData dummy,
+ void *dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6575,7 +6574,7 @@ TestSimpleFilesystemObjCmd(
return TCL_ERROR;
}
if (boolVal) {
- res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem);
+ res = Tcl_FSRegister(interp, &simpleFilesystem);
msg = (res == TCL_OK) ? "registered" : "failed";
} else {
res = Tcl_FSUnregister(&simpleFilesystem);
@@ -6719,7 +6718,7 @@ SimpleListVolumes(void)
static int
TestNumUtfCharsCmd(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6742,7 +6741,7 @@ TestNumUtfCharsCmd(
static int
TestFindFirstCmd(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6764,7 +6763,7 @@ TestFindFirstCmd(
static int
TestFindLastCmd(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6806,7 +6805,7 @@ TestFindLastCmd(
static int
TestcpuidCmd(
- ClientData dummy,
+ void *dummy,
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const * objv) /* Parameter vector */
@@ -6842,7 +6841,7 @@ TestcpuidCmd(
static int
TestHashSystemHashCmd(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6918,7 +6917,7 @@ TestHashSystemHashCmd(
*/
static int
TestgetintCmd(
- ClientData dummy,
+ void *dummy,
Tcl_Interp *interp,
int argc,
const char **argv)
@@ -6945,7 +6944,7 @@ TestgetintCmd(
*/
static int
TestlongsizeCmd(
- ClientData dummy,
+ void *dummy,
Tcl_Interp *interp,
int argc,
const char **argv)
@@ -6960,7 +6959,7 @@ TestlongsizeCmd(
static int
NREUnwind_callback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -6987,7 +6986,7 @@ NREUnwind_callback(
static int
TestNREUnwind(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -7005,7 +7004,7 @@ TestNREUnwind(
static int
TestNRELevels(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -7061,7 +7060,7 @@ TestNRELevels(
static int
TestconcatobjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -7082,17 +7081,11 @@ TestconcatobjCmd(
list1Ptr = Tcl_NewStringObj("foo bar sum", -1);
Tcl_ListObjLength(NULL, list1Ptr, &len);
- if (list1Ptr->bytes != NULL) {
- ckfree(list1Ptr->bytes);
- list1Ptr->bytes = NULL;
- }
+ Tcl_InvalidateStringRep(list1Ptr);
list2Ptr = Tcl_NewStringObj("eeny meeny", -1);
Tcl_ListObjLength(NULL, list2Ptr, &len);
- if (list2Ptr->bytes != NULL) {
- ckfree(list2Ptr->bytes);
- list2Ptr->bytes = NULL;
- }
+ Tcl_InvalidateStringRep(list2Ptr);
/*
* Verify that concat'ing a list obj with one or more empty strings does
@@ -7364,7 +7357,7 @@ TestconcatobjCmd(
static int
TestparseargsCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Arguments. */
@@ -7603,7 +7596,7 @@ InterpCompiledVarResolver(
static int
TestInterpResolverCmd(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
index 3f1abc2..5ef1ffa 100644
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.c
@@ -1062,7 +1062,7 @@ GetBlocks(
* TclInitThreadAlloc --
*
* Initializes the allocator cache-maintenance structures.
- * It is done early and protected during the TclInitSubsystems().
+ * It is done early and protected during the Tcl_InitSubsystems().
*
* Results:
* None.
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 1742eb7..e9b1107 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -508,7 +508,7 @@ ThreadCreate(
joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
Tcl_MutexLock(&threadMutex);
- if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
+ if (Tcl_CreateThread(&id, NewTestThread, &ctrl,
TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp, "can't create a new thread", NULL);
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index 54854d0..ccfd179 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -789,7 +789,7 @@ Tcl_AfterObjCmd(
AfterInfo *afterPtr;
AfterAssocData *assocPtr;
int length;
- int index;
+ int index = -1;
static const char *const afterSubCmds[] = {
"cancel", "idle", "info", NULL
};
@@ -818,12 +818,9 @@ Tcl_AfterObjCmd(
* First lets see if the command was passed a number as the first argument.
*/
- if (objv[1]->typePtr == &tclIntType
- || objv[1]->typePtr == &tclBignumType
- || (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0,
- &index) != TCL_OK)) {
- index = -1;
- if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index)
+ != TCL_OK) {
const char *arg = Tcl_GetString(objv[1]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 8663eae..db48f7a 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -537,9 +537,7 @@ TraceExecutionObjCmd(
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
- if (tcmdPtr->startCmd != NULL) {
- ckfree(tcmdPtr->startCmd);
- }
+ ckfree(tcmdPtr->startCmd);
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
/*
@@ -1349,9 +1347,7 @@ TraceCommandProc(
if (tcmdPtr->stepTrace != NULL) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
- if (tcmdPtr->startCmd != NULL) {
- ckfree(tcmdPtr->startCmd);
- }
+ ckfree(tcmdPtr->startCmd);
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
/*
@@ -1814,9 +1810,7 @@ TraceExecutionProc(
&& (strcmp(command, tcmdPtr->startCmd) == 0)) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
- if (tcmdPtr->startCmd != NULL) {
- ckfree(tcmdPtr->startCmd);
- }
+ ckfree(tcmdPtr->startCmd);
}
/*
@@ -1941,9 +1935,7 @@ TraceExecutionProc(
if (tcmdPtr->stepTrace != NULL) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
- if (tcmdPtr->startCmd != NULL) {
- ckfree(tcmdPtr->startCmd);
- }
+ ckfree(tcmdPtr->startCmd);
}
}
if (call) {
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 385bdd3..a56a99a 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -113,8 +113,6 @@ static int GetEndOffsetFromObj(Tcl_Obj *objPtr,
static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr);
static int GetWideForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
Tcl_WideInt endValue, Tcl_WideInt *widePtr);
-static int SetEndOffsetFromAny(Tcl_Interp *interp,
- Tcl_Obj *objPtr);
static int FindElement(Tcl_Interp *interp, const char *string,
int stringLength, const char *typeStr,
const char *typeCode, const char **elementPtr,
@@ -127,7 +125,8 @@ static int FindElement(Tcl_Interp *interp, const char *string,
* stored directly in the wideValue, so no memory management is required
* for it. This is a caching intrep, keeping the result of a parse
* around. This type is only created from a pre-existing string, so an
- * updateStringProc will never be called and need not exist.
+ * updateStringProc will never be called and need not exist. The type
+ * is unregistered, so has no need of a setFromAnyProc either.
*/
static const Tcl_ObjType endOffsetType = {
@@ -135,7 +134,7 @@ static const Tcl_ObjType endOffsetType = {
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
- SetEndOffsetFromAny
+ NULL /* setFromAnyProc */
};
/*
@@ -1051,6 +1050,23 @@ TclScanElement(
return 2;
}
+#if COMPAT
+ /*
+ * We have an established history in TclConvertElement() when quoting
+ * because of a leading hash character to force what would be the
+ * CONVERT_MASK mode into the CONVERT_BRACE mode. That is, we format
+ * the element #{a"b} like this:
+ * {#{a"b}}
+ * and not like this:
+ * \#{a\"b}
+ * This is inconsistent with [list x{a"b}], but we will not change that now.
+ * Set that preference here so that we compute a tight size requirement.
+ */
+ if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
+ preferBrace = 1;
+ }
+#endif
+
if ((*p == '{') || (*p == '"')) {
/*
* Must escape or protect so leading character of value is not
@@ -1391,9 +1407,9 @@ TclConvertElement(
*/
if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) {
- src = &tclEmptyString;
- length = 0;
- conversion = CONVERT_BRACE;
+ p[0] = '{';
+ p[1] = '}';
+ return 2;
}
/*
@@ -2090,7 +2106,7 @@ Tcl_ConcatObj(
resPtr = NULL;
for (i = 0; i < objc; i++) {
objPtr = objv[i];
- if (objPtr->bytes && objPtr->length == 0) {
+ if (!TclListObjIsCanonical(objPtr)) {
continue;
}
if (resPtr) {
@@ -3660,10 +3676,12 @@ TclFormatInt(
* GetWideForIndex --
*
* This function produces a wide integer value corresponding to the
- * list index held in *objPtr. The parsing supports all values
+ * index value held in *objPtr. The parsing supports all values
* recognized as any size of integer, and the syntaxes end[-+]$integer
* and $integer[-+]$integer. The argument endValue is used to give
- * the meaning of the literal index value "end".
+ * the meaning of the literal index value "end". Index arithmetic
+ * on arguments outside the wide integer range are only accepted
+ * when interp is a working interpreter, not NULL.
*
* Results:
* When parsing of *objPtr successfully recognizes an index value,
@@ -3705,9 +3723,9 @@ GetWideForIndex(
/* objPtr holds an integer outside the signed wide range */
/* Truncate to the signed wide range. */
if (mp_isneg((mp_int *)cd)) {
- *widePtr = LLONG_MIN;
+ *widePtr = WIDE_MIN;
} else {
- *widePtr = LLONG_MAX;
+ *widePtr = WIDE_MAX;
}
return TCL_OK;
}
@@ -3776,7 +3794,7 @@ GetWideForIndex(
if ((t1 == TCL_NUMBER_INT) && (t2 == TCL_NUMBER_INT)) {
/* Both are wide, do wide-integer math */
if (*opPtr == '-') {
- if ((w2 == LLONG_MIN) && (interp != NULL)) {
+ if ((w2 == WIDE_MIN) && (interp != NULL)) {
goto extreme;
}
w2 = -w2;
@@ -3786,16 +3804,16 @@ GetWideForIndex(
/* Different signs, sum cannot overflow */
*widePtr = w1 + w2;
} else if (w1 >= 0) {
- if (w1 < LLONG_MAX - w2) {
+ if (w1 < WIDE_MAX - w2) {
*widePtr = w1 + w2;
} else {
- *widePtr = LLONG_MAX;
+ *widePtr = WIDE_MAX;
}
} else {
- if (w1 > LLONG_MIN - w2) {
+ if (w1 > WIDE_MIN - w2) {
*widePtr = w1 + w2;
} else {
- *widePtr = LLONG_MIN;
+ *widePtr = WIDE_MIN;
}
}
} else if (interp == NULL) {
@@ -3825,9 +3843,9 @@ GetWideForIndex(
/* sum holds an integer outside the signed wide range */
/* Truncate to the signed wide range. */
if (mp_isneg((mp_int *)cd)) {
- *widePtr = LLONG_MIN;
+ *widePtr = WIDE_MIN;
} else {
- *widePtr = LLONG_MAX;
+ *widePtr = WIDE_MAX;
}
}
Tcl_DecrRefCount(sum);
@@ -3902,20 +3920,19 @@ TclGetIntForIndex(
}
return TCL_OK;
}
-
/*
*----------------------------------------------------------------------
*
* GetEndOffsetFromObj --
*
- * Look for a string of the form "end[+-]offset" and convert it to an
- * internal representation holding the offset.
+ * Look for a string of the form "end[+-]offset" and convert it to an
+ * internal representation holding the offset.
*
* Results:
- * Tcl return code.
+ * Tcl return code.
*
* Side effects:
- * May store a Tcl_ObjType.
+ * May store a Tcl_ObjType.
*
*----------------------------------------------------------------------
*/
@@ -3928,131 +3945,87 @@ GetEndOffsetFromObj(
Tcl_WideInt *widePtr) /* Location filled in with an integer
* representing an index. */
{
- if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) {
- Tcl_WideInt offset = objPtr->internalRep.wideValue;
+ Tcl_ObjIntRep *irPtr;
+ Tcl_WideInt offset = 0; /* Offset in the "end-offset" expression */
- if ((endValue ^ offset) < 0) {
- /* Different signs, sum cannot overflow */
- *widePtr = endValue + offset;
- } else if (endValue >= 0) {
- if (endValue < LLONG_MAX - offset) {
- *widePtr = endValue + offset;
- } else {
- *widePtr = LLONG_MAX;
- }
- } else {
- if (endValue > LLONG_MIN - offset) {
- *widePtr = endValue + offset;
- } else {
- *widePtr = LLONG_MIN;
- }
+ while ((irPtr = Tcl_FetchIntRep(objPtr, &endOffsetType)) == NULL) {
+ Tcl_ObjIntRep ir;
+ int length;
+ const char *bytes = TclGetStringFromObj(objPtr, &length);
+
+ if ((length < 3) || (length == 4)) {
+ /* Too short to be "end" or to be "end-$integer" */
+ return TCL_ERROR;
+ }
+ if ((*bytes != 'e') || (strncmp(bytes, "end", 3) != 0)) {
+ /* Value doesn't start with "end" */
+ return TCL_ERROR;
}
- return TCL_OK;
- }
- return TCL_ERROR;
-}
-/*
- *----------------------------------------------------------------------
- *
- * SetEndOffsetFromAny --
- *
- * Look for a string of the form "end[+-]offset" and convert it to an
- * internal representation holding the offset.
- *
- * Results:
- * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed.
- *
- * Side effects:
- * If interp is not NULL, stores an error message in the interpreter
- * result.
- *
- *----------------------------------------------------------------------
- */
+ if (length > 4) {
+ ClientData cd;
+ int t;
-static int
-SetEndOffsetFromAny(
- Tcl_Interp *interp, /* Tcl interpreter or NULL */
- Tcl_Obj *objPtr) /* Pointer to the object to parse */
-{
- Tcl_WideInt offset; /* Offset in the "end-offset" expression */
- register const char *bytes; /* String rep of the object */
- int length; /* Length of the object's string rep */
+ /* Parse for the "end-..." or "end+..." formats */
- /*
- * If it's already the right type, we're fine.
- */
+ if ((bytes[3] != '-') && (bytes[3] != '+')) {
+ /* No operator where we need one */
+ return TCL_ERROR;
+ }
+ if (TclIsSpaceProc(bytes[4])) {
+ /* Space after + or - not permitted. */
+ return TCL_ERROR;
+ }
- if (objPtr->typePtr == &endOffsetType) {
- return TCL_OK;
- }
+ /* Parse the integer offset */
+ if (TCL_OK != TclParseNumber(NULL, objPtr, NULL,
+ bytes+4, length-4, NULL, TCL_PARSE_INTEGER_ONLY)) {
+ /* Not a recognized integer format */
+ return TCL_ERROR;
+ }
- /*
- * Check for a string rep of the right form.
- */
+ /* Got an integer offset; pull it from where parser left it. */
+ TclGetNumberFromObj(NULL, objPtr, &cd, &t);
- bytes = TclGetStringFromObj(objPtr, &length);
- if ((*bytes != 'e') || (strncmp(bytes, "end",
- (size_t)((length > 3) ? 3 : length)) != 0)) {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad index \"%s\": must be end?[+-]integer?", bytes));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
+ if (t == TCL_NUMBER_BIG) {
+ /* Truncate to the signed wide range. */
+ if (mp_isneg((mp_int *)cd)) {
+ offset = (bytes[3] == '-') ? WIDE_MAX : WIDE_MIN;
+ } else {
+ offset = (bytes[3] == '-') ? WIDE_MIN : WIDE_MAX;
+ }
+ } else {
+ /* assert (t == TCL_NUMBER_INT); */
+ offset = (*(Tcl_WideInt *)cd);
+ if (bytes[3] == '-') {
+ offset = (offset == WIDE_MIN) ? WIDE_MAX : -offset;
+ }
+ }
}
- return TCL_ERROR;
- }
-
- /*
- * Convert the string rep.
- */
- if (length <= 3) {
- offset = 0;
- } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) {
- /*
- * This is our limited string expression evaluator. Pass everything
- * after "end-" to TclParseNumber.
- */
+ /* Success. Store the new internal rep. */
+ ir.wideValue = offset;
+ Tcl_StoreIntRep(objPtr, &endOffsetType, &ir);
+ }
- if (TclIsSpaceProc(bytes[4])) {
- goto badIndexFormat;
- }
- if (TclParseNumber(NULL, objPtr, NULL, bytes+4, length-4, NULL,
- TCL_PARSE_INTEGER_ONLY) != TCL_OK) {
- return TCL_ERROR;
- }
- if (objPtr->typePtr != &tclIntType) {
- goto badIndexFormat;
- }
- offset = objPtr->internalRep.wideValue;
- if (bytes[3] == '-') {
+ offset = irPtr->wideValue;
- /* TODO: Review overflow concerns here! */
- offset = -offset;
- }
+ if ((endValue ^ offset) < 0) {
+ /* Different signs, sum cannot overflow */
+ *widePtr = endValue + offset;
+ } else if (endValue >= 0) {
+ if (endValue < WIDE_MAX - offset) {
+ *widePtr = endValue + offset;
+ } else {
+ *widePtr = WIDE_MAX;
+ }
} else {
- /*
- * Conversion failed. Report the error.
- */
-
- badIndexFormat:
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad index \"%s\": must be end?[+-]integer?", bytes));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
- }
- return TCL_ERROR;
+ if (endValue > WIDE_MIN - offset) {
+ *widePtr = endValue + offset;
+ } else {
+ *widePtr = WIDE_MIN;
+ }
}
-
- /*
- * The conversion succeeded. Free the old internal rep and set the new
- * one.
- */
-
- TclFreeIntRep(objPtr);
- objPtr->internalRep.wideValue = offset;
- objPtr->typePtr = &endOffsetType;
-
return TCL_OK;
}
@@ -4124,7 +4097,7 @@ TclIndexEncode(
int idx, numType, code = TclGetNumberFromObj(NULL, objPtr, &cd, &numType);
if ((code == TCL_OK) && (numType == TCL_NUMBER_INT)) {
- /* We parsed a value in the range LLONG_MIN...LLONG_MAX */
+ /* We parsed a value in the range WIDE_MIN...WIDE_MAX */
wide = (*(Tcl_WideInt *)cd);
integerEncode:
if (wide < TCL_INDEX_START) {
@@ -4140,7 +4113,7 @@ TclIndexEncode(
} else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &wide)) {
/*
* We parsed an end+offset index value.
- * wide holds the offset value in the range LLONG_MIN...LLONG_MAX.
+ * wide holds the offset value in the range WIDE_MIN...WIDE_MAX.
*/
if (wide > 0) {
/*
diff --git a/generic/tclVar.c b/generic/tclVar.c
index cafa6a3..dfe883f 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -254,10 +254,49 @@ static const Tcl_ObjType localVarNameType = {
FreeLocalVarName, DupLocalVarName, NULL, NULL
};
-static const Tcl_ObjType tclParsedVarNameType = {
+#define LocalSetIntRep(objPtr, index, namePtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ Tcl_Obj *ptr = (namePtr); \
+ if (ptr) {Tcl_IncrRefCount(ptr);} \
+ ir.twoPtrValue.ptr1 = ptr; \
+ ir.twoPtrValue.ptr2 = INT2PTR(index); \
+ Tcl_StoreIntRep((objPtr), &localVarNameType, &ir); \
+ } while (0)
+
+#define LocalGetIntRep(objPtr, index, name) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = Tcl_FetchIntRep((objPtr), &localVarNameType); \
+ (name) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \
+ (index) = irPtr ? PTR2INT(irPtr->twoPtrValue.ptr2) : -1; \
+ } while (0)
+
+static const Tcl_ObjType parsedVarNameType = {
"parsedVarName",
FreeParsedVarName, DupParsedVarName, NULL, NULL
};
+
+#define ParsedSetIntRep(objPtr, arrayPtr, elem) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ Tcl_Obj *ptr1 = (arrayPtr); \
+ Tcl_Obj *ptr2 = (elem); \
+ if (ptr1) {Tcl_IncrRefCount(ptr1);} \
+ if (ptr2) {Tcl_IncrRefCount(ptr2);} \
+ ir.twoPtrValue.ptr1 = ptr1; \
+ ir.twoPtrValue.ptr2 = ptr2; \
+ Tcl_StoreIntRep((objPtr), &parsedVarNameType, &ir); \
+ } while (0)
+
+#define ParsedGetIntRep(objPtr, parsed, array, elem) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = Tcl_FetchIntRep((objPtr), &parsedVarNameType); \
+ (parsed) = (irPtr != NULL); \
+ (array) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \
+ (elem) = irPtr ? irPtr->twoPtrValue.ptr2 : NULL; \
+ } while (0)
Var *
TclVarHashCreateVar(
@@ -482,9 +521,8 @@ TclLookupVar(
*
* Side effects:
* New hashtable entries may be created if createPart1 or createPart2
- * are 1. The object part1Ptr is converted to one of localVarNameType,
- * tclNsVarNameType or tclParsedVarNameType and caches as much of the
- * lookup as it can.
+ * are 1. The object part1Ptr is converted to one of localVarNameType
+ * or parsedVarNameType and caches as much of the lookup as it can.
* When createPart1 is 1, callers must IncrRefCount part1Ptr if they
* plan to DecrRefCount it.
*
@@ -571,15 +609,15 @@ TclObjLookupVarEx(
* structure. */
const char *errMsg = NULL;
int index, parsed = 0;
- const Tcl_ObjType *typePtr = part1Ptr->typePtr;
- *arrayPtrPtr = NULL;
+ int localIndex;
+ Tcl_Obj *namePtr, *arrayPtr, *elem;
- if (typePtr == &localVarNameType) {
- int localIndex;
+ *arrayPtrPtr = NULL;
- localVarNameTypeHandling:
- localIndex = PTR2INT(part1Ptr->internalRep.twoPtrValue.ptr2);
+ restart:
+ LocalGetIntRep(part1Ptr, localIndex, namePtr);
+ if (localIndex >= 0) {
if (HasLocalVars(varFramePtr)
&& !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
&& (localIndex < varFramePtr->numCompiledLocals)) {
@@ -587,7 +625,6 @@ TclObjLookupVarEx(
* Use the cached index if the names coincide.
*/
- Tcl_Obj *namePtr = part1Ptr->internalRep.twoPtrValue.ptr1;
Tcl_Obj *checkNamePtr = localName(varFramePtr, localIndex);
if ((!namePtr && (checkNamePtr == part1Ptr)) ||
@@ -600,12 +637,11 @@ TclObjLookupVarEx(
}
/*
- * If part1Ptr is a tclParsedVarNameType, separate it into the pre-parsed
- * parts.
+ * If part1Ptr is a parsedVarNameType, retrieve the pre-parsed parts.
*/
- if (typePtr == &tclParsedVarNameType) {
- if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) {
+ ParsedGetIntRep(part1Ptr, parsed, arrayPtr, elem);
+ if (parsed && arrayPtr) {
if (part2Ptr != NULL) {
/*
* ERROR: part1Ptr is already an array element, cannot specify
@@ -619,14 +655,9 @@ TclObjLookupVarEx(
}
return NULL;
}
- part2Ptr = part1Ptr->internalRep.twoPtrValue.ptr2;
- part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1;
- typePtr = part1Ptr->typePtr;
- if (typePtr == &localVarNameType) {
- goto localVarNameTypeHandling;
- }
- }
- parsed = 1;
+ part2Ptr = elem;
+ part1Ptr = arrayPtr;
+ goto restart;
}
if (!parsed) {
@@ -641,8 +672,6 @@ TclObjLookupVarEx(
const char *part2 = strchr(part1, '(');
if (part2) {
- Tcl_Obj *arrayPtr;
-
if (part2Ptr != NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg,
@@ -657,13 +686,7 @@ TclObjLookupVarEx(
part2Ptr = Tcl_NewStringObj(part2 + 1,
len - (part2 - part1) - 2);
- TclFreeIntRep(part1Ptr);
-
- Tcl_IncrRefCount(arrayPtr);
- part1Ptr->internalRep.twoPtrValue.ptr1 = arrayPtr;
- Tcl_IncrRefCount(part2Ptr);
- part1Ptr->internalRep.twoPtrValue.ptr2 = part2Ptr;
- part1Ptr->typePtr = &tclParsedVarNameType;
+ ParsedSetIntRep(part1Ptr, arrayPtr, part2Ptr);
part1Ptr = arrayPtr;
}
@@ -691,7 +714,6 @@ TclObjLookupVarEx(
* Cache the newly found variable if possible.
*/
- TclFreeIntRep(part1Ptr);
if (index >= 0) {
/*
* An indexed local variable.
@@ -699,26 +721,36 @@ TclObjLookupVarEx(
Tcl_Obj *cachedNamePtr = localName(varFramePtr, index);
- part1Ptr->typePtr = &localVarNameType;
- if (part1Ptr != cachedNamePtr) {
- part1Ptr->internalRep.twoPtrValue.ptr1 = cachedNamePtr;
- Tcl_IncrRefCount(cachedNamePtr);
- if (cachedNamePtr->typePtr != &localVarNameType
- || cachedNamePtr->internalRep.twoPtrValue.ptr1 != NULL) {
- TclFreeIntRep(cachedNamePtr);
- }
+ if (part1Ptr == cachedNamePtr) {
+ cachedNamePtr = NULL;
} else {
- part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
+ /*
+ * [80304238ac] Trickiness here. We will store and incr the
+ * refcount on cachedNamePtr. Trouble is that it's possible
+ * (see test var-22.1) for cachedNamePtr to have an intrep
+ * that contains a stored and refcounted part1Ptr. This
+ * would be a reference cycle which leads to a memory leak.
+ *
+ * The solution here is to wipe away all intrep(s) in
+ * cachedNamePtr and leave it as string only. This is
+ * radical and destructive, so a better idea would be welcome.
+ */
+ TclFreeIntRep(cachedNamePtr);
+
+ /*
+ * Now go ahead and convert it the the "localVarName" type,
+ * since we suspect at least some use of the value as a
+ * varname and we want to resolve it quickly.
+ */
+ LocalSetIntRep(cachedNamePtr, index, NULL);
}
- part1Ptr->internalRep.twoPtrValue.ptr2 = INT2PTR(index);
+ LocalSetIntRep(part1Ptr, index, cachedNamePtr);
} else {
/*
* At least mark part1Ptr as already parsed.
*/
- part1Ptr->typePtr = &tclParsedVarNameType;
- part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
- part1Ptr->internalRep.twoPtrValue.ptr2 = NULL;
+ ParsedSetIntRep(part1Ptr, NULL, NULL);
}
donePart1:
@@ -5764,12 +5796,15 @@ static void
FreeLocalVarName(
Tcl_Obj *objPtr)
{
- Tcl_Obj *namePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ int index;
+ Tcl_Obj *namePtr;
+
+ LocalGetIntRep(objPtr, index, namePtr);
+ index++; /* Compiler warning bait. */
if (namePtr) {
Tcl_DecrRefCount(namePtr);
}
- objPtr->typePtr = NULL;
}
static void
@@ -5777,17 +5812,14 @@ DupLocalVarName(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- Tcl_Obj *namePtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ int index;
+ Tcl_Obj *namePtr;
+ LocalGetIntRep(srcPtr, index, namePtr);
if (!namePtr) {
namePtr = srcPtr;
}
- dupPtr->internalRep.twoPtrValue.ptr1 = namePtr;
- Tcl_IncrRefCount(namePtr);
-
- dupPtr->internalRep.twoPtrValue.ptr2 =
- srcPtr->internalRep.twoPtrValue.ptr2;
- dupPtr->typePtr = &localVarNameType;
+ LocalSetIntRep(dupPtr, index, namePtr);
}
/*
@@ -5803,14 +5835,16 @@ static void
FreeParsedVarName(
Tcl_Obj *objPtr)
{
- register Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1;
- register Tcl_Obj *elem = objPtr->internalRep.twoPtrValue.ptr2;
+ register Tcl_Obj *arrayPtr, *elem;
+ int parsed;
+
+ ParsedGetIntRep(objPtr, parsed, arrayPtr, elem);
+ parsed++; /* Silence compiler. */
if (arrayPtr != NULL) {
TclDecrRefCount(arrayPtr);
TclDecrRefCount(elem);
}
- objPtr->typePtr = NULL;
}
static void
@@ -5818,17 +5852,13 @@ DupParsedVarName(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- register Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1;
- register Tcl_Obj *elem = srcPtr->internalRep.twoPtrValue.ptr2;
+ register Tcl_Obj *arrayPtr, *elem;
+ int parsed;
- if (arrayPtr != NULL) {
- Tcl_IncrRefCount(arrayPtr);
- Tcl_IncrRefCount(elem);
- }
+ ParsedGetIntRep(srcPtr, parsed, arrayPtr, elem);
- dupPtr->internalRep.twoPtrValue.ptr1 = arrayPtr;
- dupPtr->internalRep.twoPtrValue.ptr2 = elem;
- dupPtr->typePtr = &tclParsedVarNameType;
+ parsed++; /* Silence compiler. */
+ ParsedSetIntRep(dupPtr, arrayPtr, elem);
}
/*
diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c
index 428be15..6acb5db 100644
--- a/generic/tclZipfs.c
+++ b/generic/tclZipfs.c
@@ -291,6 +291,11 @@ static const char pwrot[16] = {
/*
* Table to compute CRC32.
*/
+#ifdef Z_U4
+ typedef Z_U4 z_crc_t;
+#else
+ typedef unsigned long z_crc_t;
+#endif
static const z_crc_t crc32tab[256] = {
0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419,
@@ -356,7 +361,7 @@ static inline int DescribeMounted(Tcl_Interp *interp,
static inline int ListMountPoints(Tcl_Interp *interp);
static int ZipfsAppHookFindTclInit(const char *archive);
static int ZipFSPathInFilesystemProc(Tcl_Obj *pathPtr,
- ClientData *clientDataPtr);
+ void **clientDataPtr);
static Tcl_Obj * ZipFSFilesystemPathTypeProc(Tcl_Obj *pathPtr);
static Tcl_Obj * ZipFSFilesystemSeparatorProc(Tcl_Obj *pathPtr);
static int ZipFSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
@@ -377,17 +382,17 @@ static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path,
Tcl_LoadHandle *loadHandle,
Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
static void ZipfsSetup(void);
-static int ZipChannelClose(ClientData instanceData,
+static int ZipChannelClose(void *instanceData,
Tcl_Interp *interp);
-static int ZipChannelGetFile(ClientData instanceData,
- int direction, ClientData *handlePtr);
-static int ZipChannelRead(ClientData instanceData, char *buf,
+static int ZipChannelGetFile(void *instanceData,
+ int direction, void **handlePtr);
+static int ZipChannelRead(void *instanceData, char *buf,
int toRead, int *errloc);
-static int ZipChannelSeek(ClientData instanceData, long offset,
+static int ZipChannelSeek(void *instanceData, long offset,
int mode, int *errloc);
-static void ZipChannelWatchChannel(ClientData instanceData,
+static void ZipChannelWatchChannel(void *instanceData,
int mask);
-static int ZipChannelWrite(ClientData instanceData,
+static int ZipChannelWrite(void *instanceData,
const char *buf, int toWrite, int *errloc);
/*
@@ -1089,7 +1094,7 @@ ZipFSOpenArchive(
ZipFile *zf)
{
size_t i;
- ClientData handle;
+ void *handle;
zf->nameLength = 0;
zf->isMemBuffer = 0;
@@ -1862,7 +1867,7 @@ TclZipfs_Unmount(
static int
ZipFSMountObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1896,7 +1901,7 @@ ZipFSMountObjCmd(
static int
ZipFSMountBufferObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1948,7 +1953,7 @@ ZipFSMountBufferObjCmd(
static int
ZipFSRootObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1975,7 +1980,7 @@ ZipFSRootObjCmd(
static int
ZipFSUnmountObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2006,7 +2011,7 @@ ZipFSUnmountObjCmd(
static int
ZipFSMkKeyObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2785,7 +2790,7 @@ ZipFSMkZipOrImgObjCmd(
static int
ZipFSMkZipObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2805,7 +2810,7 @@ ZipFSMkZipObjCmd(
static int
ZipFSLMkZipObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2842,7 +2847,7 @@ ZipFSLMkZipObjCmd(
static int
ZipFSMkImgObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2863,7 +2868,7 @@ ZipFSMkImgObjCmd(
static int
ZipFSLMkImgObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2900,7 +2905,7 @@ ZipFSLMkImgObjCmd(
static int
ZipFSCanonicalObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2956,7 +2961,7 @@ ZipFSCanonicalObjCmd(
static int
ZipFSExistsObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3009,7 +3014,7 @@ ZipFSExistsObjCmd(
static int
ZipFSInfoObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3059,7 +3064,7 @@ ZipFSInfoObjCmd(
static int
ZipFSListObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3274,7 +3279,7 @@ TclZipfs_TclLibrary(void)
static int
ZipFSTclLibraryObjCmd(
- ClientData clientData, /* Not used. */
+ void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3308,7 +3313,7 @@ ZipFSTclLibraryObjCmd(
static int
ZipChannelClose(
- ClientData instanceData,
+ void *instanceData,
Tcl_Interp *interp) /* Current interpreter. */
{
ZipChannel *info = instanceData;
@@ -3366,7 +3371,7 @@ ZipChannelClose(
static int
ZipChannelRead(
- ClientData instanceData,
+ void *instanceData,
char *buf,
int toRead,
int *errloc)
@@ -3439,7 +3444,7 @@ ZipChannelRead(
static int
ZipChannelWrite(
- ClientData instanceData,
+ void *instanceData,
const char *buf,
int toWrite,
int *errloc)
@@ -3486,7 +3491,7 @@ ZipChannelWrite(
static int
ZipChannelSeek(
- ClientData instanceData,
+ void *instanceData,
long offset,
int mode,
int *errloc)
@@ -3558,7 +3563,7 @@ ZipChannelSeek(
static void
ZipChannelWatchChannel(
- ClientData instanceData,
+ void *instanceData,
int mask)
{
return;
@@ -3583,9 +3588,9 @@ ZipChannelWatchChannel(
static int
ZipChannelGetFile(
- ClientData instanceData,
+ void *instanceData,
int direction,
- ClientData *handlePtr)
+ void **handlePtr)
{
return TCL_ERROR;
}
@@ -4330,7 +4335,7 @@ ZipFSMatchInDirectoryProc(
static int
ZipFSPathInFilesystemProc(
Tcl_Obj *pathPtr,
- ClientData *clientDataPtr)
+ void **clientDataPtr)
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
@@ -4654,7 +4659,7 @@ ZipFSLoadFile(
TCL_PATH_DIRNAME);
}
if (objs[0]) {
- altPath = TclJoinPath(2, objs);
+ altPath = TclJoinPath(2, objs, 0);
if (altPath) {
Tcl_IncrRefCount(altPath);
if (Tcl_FSAccess(altPath, R_OK) == 0) {
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index d4a8ecb..cc86de7 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -196,7 +196,7 @@ static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr);
static int ZlibStreamSubcmd(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static inline void ZlibTransformEventTimerKill(ZlibChannelData *cd);
-static void ZlibTransformTimerRun(ClientData clientData);
+static void ZlibTransformTimerRun(void *clientData);
/*
* Type of zlib-based compressing and decompressing channels.
@@ -882,7 +882,7 @@ Tcl_ZlibStreamInit(
static void
ZlibStreamCmdDelete(
- ClientData cd)
+ void *cd)
{
ZlibStreamHandle *zshPtr = cd;
@@ -1488,7 +1488,7 @@ Tcl_ZlibStreamGet(
count = 0;
for (i=0; i<listLen; i++) {
Tcl_ListObjIndex(NULL, zshPtr->outData, i, &itemObj);
- itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen);
+ (void) Tcl_GetByteArrayFromObj(itemObj, &itemLen);
if (i == 0) {
count += itemLen - zshPtr->outPos;
} else {
@@ -1918,7 +1918,7 @@ Tcl_ZlibAdler32(
static int
ZlibCmd(
- ClientData notUsed,
+ void *notUsed,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2514,7 +2514,7 @@ ZlibPushSubcmd(
static int
ZlibStreamCmd(
- ClientData cd,
+ void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2640,7 +2640,7 @@ ZlibStreamCmd(
static int
ZlibStreamAddCmd(
- ClientData cd,
+ void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2764,7 +2764,7 @@ ZlibStreamAddCmd(
static int
ZlibStreamPutCmd(
- ClientData cd,
+ void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2853,7 +2853,7 @@ ZlibStreamPutCmd(
static int
ZlibStreamHeaderCmd(
- ClientData cd,
+ void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2892,7 +2892,7 @@ ZlibStreamHeaderCmd(
static int
ZlibTransformClose(
- ClientData instanceData,
+ void *instanceData,
Tcl_Interp *interp)
{
ZlibChannelData *cd = instanceData;
@@ -2983,7 +2983,7 @@ ZlibTransformClose(
static int
ZlibTransformInput(
- ClientData instanceData,
+ void *instanceData,
char *buf,
int toRead,
int *errorCodePtr)
@@ -3097,7 +3097,7 @@ ZlibTransformInput(
static int
ZlibTransformOutput(
- ClientData instanceData,
+ void *instanceData,
const char *buf,
int toWrite,
int *errorCodePtr)
@@ -3218,7 +3218,7 @@ ZlibTransformFlush(
static int
ZlibTransformSetOption( /* not used */
- ClientData instanceData,
+ void *instanceData,
Tcl_Interp *interp,
const char *optionName,
const char *value)
@@ -3331,7 +3331,7 @@ ZlibTransformSetOption( /* not used */
static int
ZlibTransformGetOption(
- ClientData instanceData,
+ void *instanceData,
Tcl_Interp *interp,
const char *optionName,
Tcl_DString *dsPtr)
@@ -3451,7 +3451,7 @@ ZlibTransformGetOption(
static void
ZlibTransformWatch(
- ClientData instanceData,
+ void *instanceData,
int mask)
{
ZlibChannelData *cd = instanceData;
@@ -3474,7 +3474,7 @@ ZlibTransformWatch(
static int
ZlibTransformEventHandler(
- ClientData instanceData,
+ void *instanceData,
int interestMask)
{
ZlibChannelData *cd = instanceData;
@@ -3495,7 +3495,7 @@ ZlibTransformEventTimerKill(
static void
ZlibTransformTimerRun(
- ClientData clientData)
+ void *clientData)
{
ZlibChannelData *cd = clientData;
@@ -3516,9 +3516,9 @@ ZlibTransformTimerRun(
static int
ZlibTransformGetHandle(
- ClientData instanceData,
+ void *instanceData,
int direction,
- ClientData *handlePtr)
+ void **handlePtr)
{
ZlibChannelData *cd = instanceData;
@@ -3537,7 +3537,7 @@ ZlibTransformGetHandle(
static int
ZlibTransformBlockMode(
- ClientData instanceData,
+ void *instanceData,
int mode)
{
ZlibChannelData *cd = instanceData;
diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl
index 4cf73d0..7aa67fa 100644
--- a/library/dde/pkgIndex.tcl
+++ b/library/dde/pkgIndex.tcl
@@ -1,7 +1,7 @@
if {([info commands ::tcl::pkgconfig] eq "")
|| ([info sharedlibextension] ne ".dll")} return
if {[::tcl::pkgconfig get debug]} {
- package ifneeded dde 1.4.0 [list load [file join $dir tcldde14g.dll] dde]
+ package ifneeded dde 1.4.1 [list load [file join $dir tcldde14g.dll] dde]
} else {
- package ifneeded dde 1.4.0 [list load [file join $dir tcldde14.dll] dde]
+ package ifneeded dde 1.4.1 [list load [file join $dir tcldde14.dll] dde]
}
diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl
new file mode 100644
index 0000000..309ca7a
--- /dev/null
+++ b/library/http/cookiejar.tcl
@@ -0,0 +1,745 @@
+# cookiejar.tcl --
+#
+# Implementation of an HTTP cookie storage engine using SQLite. The
+# implementation is done as a TclOO class, and includes a punycode
+# encoder and decoder (though only the encoder is currently used).
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# Dependencies
+package require Tcl 8.6
+package require http 2.8.4
+package require sqlite3
+package require tcl::idna 1.0
+
+#
+# Configuration for the cookiejar package, plus basic support procedures.
+#
+
+# This is the class that we are creating
+if {![llength [info commands ::http::cookiejar]]} {
+ ::oo::class create ::http::cookiejar
+}
+
+namespace eval [info object namespace ::http::cookiejar] {
+ proc setInt {*var val} {
+ upvar 1 ${*var} var
+ if {[catch {incr dummy $val} msg]} {
+ return -code error $msg
+ }
+ set var $val
+ }
+ proc setInterval {trigger *var val} {
+ upvar 1 ${*var} var
+ if {![string is integer -strict $val] || $val < 1} {
+ return -code error "expected positive integer but got \"$val\""
+ }
+ set var $val
+ {*}$trigger
+ }
+ proc setBool {*var val} {
+ upvar 1 ${*var} var
+ if {[catch {if {$val} {}} msg]} {
+ return -code error $msg
+ }
+ set var [expr {!!$val}]
+ }
+
+ proc setLog {*var val} {
+ upvar 1 ${*var} var
+ set var [::tcl::prefix match -message "log level" \
+ {debug info warn error} $val]
+ }
+
+ # Keep this in sync with pkgIndex.tcl and with the install directories in
+ # Makefiles
+ variable version 0.1
+
+ variable domainlist \
+ http://publicsuffix.org/list/effective_tld_names.dat
+ variable domainfile \
+ [file join [file dirname [info script]] effective_tld_names.txt.gz]
+ # The list is directed to from http://publicsuffix.org/list/
+ variable loglevel info
+ variable vacuumtrigger 200
+ variable retainlimit 100
+ variable offline false
+ variable purgeinterval 60000
+ variable refreshinterval 10000000
+ variable domaincache {}
+
+ # Some support procedures, none particularly useful in general
+ namespace eval support {
+ # Set up a logger if the http package isn't actually loaded yet.
+ if {![llength [info commands ::http::Log]]} {
+ proc ::http::Log args {
+ # Do nothing by default...
+ }
+ }
+
+ namespace export *
+ proc locn {secure domain path {key ""}} {
+ if {$key eq ""} {
+ format "%s://%s%s" [expr {$secure?"https":"http"}] \
+ [::tcl::idna encode $domain] $path
+ } else {
+ format "%s://%s%s?%s" \
+ [expr {$secure?"https":"http"}] [::tcl::idna encode $domain] \
+ $path $key
+ }
+ }
+ proc splitDomain domain {
+ set pieces [split $domain "."]
+ for {set i [llength $pieces]} {[incr i -1] >= 0} {} {
+ lappend result [join [lrange $pieces $i end] "."]
+ }
+ return $result
+ }
+ proc splitPath path {
+ set pieces [split [string trimleft $path "/"] "/"]
+ for {set j -1} {$j < [llength $pieces]} {incr j} {
+ lappend result /[join [lrange $pieces 0 $j] "/"]
+ }
+ return $result
+ }
+ proc isoNow {} {
+ set ms [clock milliseconds]
+ set ts [expr {$ms / 1000}]
+ set ms [format %03d [expr {$ms % 1000}]]
+ clock format $ts -format "%Y%m%dT%H%M%S.${ms}Z" -gmt 1
+ }
+ proc log {level msg args} {
+ namespace upvar [info object namespace ::http::cookiejar] \
+ loglevel loglevel
+ set who [uplevel 1 self class]
+ set mth [uplevel 1 self method]
+ set map {debug 0 info 1 warn 2 error 3}
+ if {[string map $map $level] >= [string map $map $loglevel]} {
+ set msg [format $msg {*}$args]
+ set LVL [string toupper $level]
+ ::http::Log "[isoNow] $LVL $who $mth - $msg"
+ }
+ }
+ }
+}
+
+# Now we have enough information to provide the package.
+package provide cookiejar \
+ [set [info object namespace ::http::cookiejar]::version]
+
+# The implementation of the cookiejar package
+::oo::define ::http::cookiejar {
+ self {
+ method configure {{optionName "\u0000\u0000"} {optionValue "\u0000\u0000"}} {
+ set tbl {
+ -domainfile {domainfile set}
+ -domainlist {domainlist set}
+ -domainrefresh {refreshinterval setInterval}
+ -loglevel {loglevel setLog}
+ -offline {offline setBool}
+ -purgeold {purgeinterval setInterval}
+ -retain {retainlimit setInt}
+ -vacuumtrigger {vacuumtrigger setInt}
+ }
+ dict lappend tbl -domainrefresh [namespace code {
+ my IntervalTrigger PostponeRefresh
+ }]
+ dict lappend tbl -purgeold [namespace code {
+ my IntervalTrigger PostponePurge
+ }]
+ if {$optionName eq "\u0000\u0000"} {
+ return [dict keys $tbl]
+ }
+ set opt [::tcl::prefix match -message "option" \
+ [dict keys $tbl] $optionName]
+ set setter [lassign [dict get $tbl $opt] varname]
+ namespace upvar [namespace current] $varname var
+ if {$optionValue ne "\u0000\u0000"} {
+ {*}$setter var $optionValue
+ }
+ return $var
+ }
+
+ method IntervalTrigger {method} {
+ # TODO: handle subclassing
+ foreach obj [info class instances [self]] {
+ [info object namespace $obj]::my $method
+ }
+ }
+ }
+
+ variable purgeTimer deletions refreshTimer
+ constructor {{path ""}} {
+ namespace import [info object namespace [self class]]::support::*
+
+ if {$path eq ""} {
+ sqlite3 [namespace current]::db :memory:
+ set storeorigin "constructed cookie store in memory"
+ } else {
+ sqlite3 [namespace current]::db $path
+ db timeout 500
+ set storeorigin "loaded cookie store from $path"
+ }
+
+ set deletions 0
+ db transaction {
+ db eval {
+ --;# Store the persistent cookies in this table.
+ --;# Deletion policy: once they expire, or if explicitly
+ --;# killed.
+ CREATE TABLE IF NOT EXISTS persistentCookies (
+ id INTEGER PRIMARY KEY,
+ secure INTEGER NOT NULL,
+ domain TEXT NOT NULL COLLATE NOCASE,
+ path TEXT NOT NULL,
+ key TEXT NOT NULL,
+ value TEXT NOT NULL,
+ originonly INTEGER NOT NULL,
+ expiry INTEGER NOT NULL,
+ lastuse INTEGER NOT NULL,
+ creation INTEGER NOT NULL);
+ CREATE UNIQUE INDEX IF NOT EXISTS persistentUnique
+ ON persistentCookies (domain, path, key);
+ CREATE INDEX IF NOT EXISTS persistentLookup
+ ON persistentCookies (domain, path);
+
+ --;# Store the session cookies in this table.
+ --;# Deletion policy: at cookiejar instance deletion, if
+ --;# explicitly killed, or if the number of session cookies is
+ --;# too large and the cookie has not been used recently.
+ CREATE TEMP TABLE sessionCookies (
+ id INTEGER PRIMARY KEY,
+ secure INTEGER NOT NULL,
+ domain TEXT NOT NULL COLLATE NOCASE,
+ path TEXT NOT NULL,
+ key TEXT NOT NULL,
+ originonly INTEGER NOT NULL,
+ value TEXT NOT NULL,
+ lastuse INTEGER NOT NULL,
+ creation INTEGER NOT NULL);
+ CREATE UNIQUE INDEX sessionUnique
+ ON sessionCookies (domain, path, key);
+ CREATE INDEX sessionLookup ON sessionCookies (domain, path);
+
+ --;# View to allow for simple looking up of a cookie.
+ --;# Deletion policy: NOT SUPPORTED via this view.
+ CREATE TEMP VIEW cookies AS
+ SELECT id, domain, (
+ CASE originonly WHEN 1 THEN path ELSE '.' || path END
+ ) AS path, key, value, secure, 1 AS persistent
+ FROM persistentCookies
+ UNION
+ SELECT id, domain, (
+ CASE originonly WHEN 1 THEN path ELSE '.' || path END
+ ) AS path, key, value, secure, 0 AS persistent
+ FROM sessionCookies;
+
+ --;# Encoded domain permission policy; if forbidden is 1, no
+ --;# cookie may be ever set for the domain, and if forbidden
+ --;# is 0, cookies *may* be created for the domain (overriding
+ --;# the forbiddenSuper table).
+ --;# Deletion policy: normally not modified.
+ CREATE TABLE IF NOT EXISTS domains (
+ domain TEXT PRIMARY KEY NOT NULL,
+ forbidden INTEGER NOT NULL);
+
+ --;# Domains that may not have a cookie defined for direct
+ --;# child domains of them.
+ --;# Deletion policy: normally not modified.
+ CREATE TABLE IF NOT EXISTS forbiddenSuper (
+ domain TEXT PRIMARY KEY);
+
+ --;# When we last retrieved the domain list.
+ CREATE TABLE IF NOT EXISTS domainCacheMetadata (
+ id INTEGER PRIMARY KEY,
+ retrievalDate INTEGER,
+ installDate INTEGER);
+ }
+
+ set cookieCount "no"
+ db eval {
+ SELECT COUNT(*) AS cookieCount FROM persistentCookies
+ }
+ log info "%s with %s entries" $storeorigin $cookieCount
+
+ my PostponePurge
+
+ if {$path ne ""} {
+ if {[db exists {SELECT 1 FROM domains}]} {
+ my RefreshDomains
+ } else {
+ my InitDomainList
+ my PostponeRefresh
+ }
+ } else {
+ set data [my GetDomainListOffline metadata]
+ my InstallDomainData $data $metadata
+ my PostponeRefresh
+ }
+ }
+ }
+
+ method PostponePurge {} {
+ namespace upvar [info object namespace [self class]] \
+ purgeinterval interval
+ catch {after cancel $purgeTimer}
+ set purgeTimer [after $interval [namespace code {my PurgeCookies}]]
+ }
+
+ method PostponeRefresh {} {
+ namespace upvar [info object namespace [self class]] \
+ refreshinterval interval
+ catch {after cancel $refreshTimer}
+ set refreshTimer [after $interval [namespace code {my RefreshDomains}]]
+ }
+
+ method RefreshDomains {} {
+ # TODO: domain list refresh policy
+ my PostponeRefresh
+ }
+
+ method HttpGet {url {timeout 0} {maxRedirects 5}} {
+ for {set r 0} {$r < $maxRedirects} {incr r} {
+ set tok [::http::geturl $url -timeout $timeout]
+ try {
+ if {[::http::status $tok] eq "timeout"} {
+ return -code error "connection timed out"
+ } elseif {[::http::ncode $tok] == 200} {
+ return [::http::data $tok]
+ } elseif {[::http::ncode $tok] >= 400} {
+ return -code error [::http::error $tok]
+ } elseif {[dict exists [::http::meta $tok] Location]} {
+ set url [dict get [::http::meta $tok] Location]
+ continue
+ }
+ return -code error \
+ "unexpected state: [::http::code $tok]"
+ } finally {
+ ::http::cleanup $tok
+ }
+ }
+ return -code error "too many redirects"
+ }
+ method GetDomainListOnline {metaVar} {
+ upvar 1 $metaVar meta
+ namespace upvar [info object namespace [self class]] \
+ domainlist url domaincache cache
+ lassign $cache when data
+ if {$when > [clock seconds] - 3600} {
+ log debug "using cached value created at %s" \
+ [clock format $when -format {%Y%m%dT%H%M%SZ} -gmt 1]
+ dict set meta retrievalDate $when
+ return $data
+ }
+ log debug "loading domain list from %s" $url
+ try {
+ set when [clock seconds]
+ set data [my HttpGet $url]
+ set cache [list $when $data]
+ # TODO: Should we use the Last-Modified header instead?
+ dict set meta retrievalDate $when
+ return $data
+ } on error msg {
+ log error "failed to fetch list of forbidden cookie domains from %s: %s" \
+ $url $msg
+ return {}
+ }
+ }
+ method GetDomainListOffline {metaVar} {
+ upvar 1 $metaVar meta
+ namespace upvar [info object namespace [self class]] \
+ domainfile filename
+ log debug "loading domain list from %s" $filename
+ try {
+ set f [open $filename]
+ try {
+ if {[string match *.gz $filename]} {
+ zlib push gunzip $f
+ }
+ fconfigure $f -encoding utf-8
+ dict set meta retrievalDate [file mtime $filename]
+ return [read $f]
+ } finally {
+ close $f
+ }
+ } on error {msg opt} {
+ log error "failed to read list of forbidden cookie domains from %s: %s" \
+ $filename $msg
+ return -options $opt $msg
+ }
+ }
+ method InitDomainList {} {
+ namespace upvar [info object namespace [self class]] \
+ offline offline
+ if {!$offline} {
+ try {
+ set data [my GetDomainListOnline metadata]
+ if {[string length $data]} {
+ my InstallDomainData $data $metadata
+ return
+ }
+ } on error {} {
+ log warn "attempting to fall back to built in version"
+ }
+ }
+ set data [my GetDomainListOffline metadata]
+ my InstallDomainData $data $metadata
+ }
+
+ method InstallDomainData {data meta} {
+ set n [db total_changes]
+ db transaction {
+ foreach line [split $data "\n"] {
+ if {[string trim $line] eq ""} {
+ continue
+ } elseif {[string match //* $line]} {
+ continue
+ } elseif {[string match !* $line]} {
+ set line [string range $line 1 end]
+ set idna [string tolower [::tcl::idna encode $line]]
+ set utf [::tcl::idna decode [string tolower $line]]
+ db eval {
+ INSERT OR REPLACE INTO domains (domain, forbidden)
+ VALUES ($utf, 0);
+ }
+ if {$idna ne $utf} {
+ db eval {
+ INSERT OR REPLACE INTO domains (domain, forbidden)
+ VALUES ($idna, 0);
+ }
+ }
+ } else {
+ if {[string match {\*.*} $line]} {
+ set line [string range $line 2 end]
+ set idna [string tolower [::tcl::idna encode $line]]
+ set utf [::tcl::idna decode [string tolower $line]]
+ db eval {
+ INSERT OR REPLACE INTO forbiddenSuper (domain)
+ VALUES ($utf);
+ }
+ if {$idna ne $utf} {
+ db eval {
+ INSERT OR REPLACE INTO forbiddenSuper (domain)
+ VALUES ($idna);
+ }
+ }
+ } else {
+ set idna [string tolower [::tcl::idna encode $line]]
+ set utf [::tcl::idna decode [string tolower $line]]
+ }
+ db eval {
+ INSERT OR REPLACE INTO domains (domain, forbidden)
+ VALUES ($utf, 1);
+ }
+ if {$idna ne $utf} {
+ db eval {
+ INSERT OR REPLACE INTO domains (domain, forbidden)
+ VALUES ($idna, 1);
+ }
+ }
+ }
+ if {$utf ne [::tcl::idna decode [string tolower $idna]]} {
+ log warn "mismatch in IDNA handling for %s (%d, %s, %s)" \
+ $idna $line $utf [::tcl::idna decode $idna]
+ }
+ }
+
+ dict with meta {
+ set installDate [clock seconds]
+ db eval {
+ INSERT OR REPLACE INTO domainCacheMetadata
+ (id, retrievalDate, installDate)
+ VALUES (1, $retrievalDate, $installDate);
+ }
+ }
+ }
+ set n [expr {[db total_changes] - $n}]
+ log info "constructed domain info with %d entries" $n
+ }
+
+ # This forces the rebuild of the domain data, loading it from
+ method forceLoadDomainData {} {
+ db transaction {
+ db eval {
+ DELETE FROM domains;
+ DELETE FROM forbiddenSuper;
+ INSERT OR REPLACE INTO domainCacheMetadata
+ (id, retrievalDate, installDate)
+ VALUES (1, -1, -1);
+ }
+ my InitDomainList
+ }
+ }
+
+ destructor {
+ catch {
+ after cancel $purgeTimer
+ }
+ catch {
+ after cancel $refreshTimer
+ }
+ catch {
+ db close
+ }
+ return
+ }
+
+ method GetCookiesForHostAndPath {listVar secure host path fullhost} {
+ upvar 1 $listVar result
+ log debug "check for cookies for %s" [locn $secure $host $path]
+ set exact [expr {$host eq $fullhost}]
+ db eval {
+ SELECT key, value FROM persistentCookies
+ WHERE domain = $host AND path = $path AND secure <= $secure
+ AND (NOT originonly OR domain = $fullhost)
+ AND originonly = $exact
+ } {
+ lappend result $key $value
+ db eval {
+ UPDATE persistentCookies SET lastuse = $now WHERE id = $id
+ }
+ }
+ set now [clock seconds]
+ db eval {
+ SELECT id, key, value FROM sessionCookies
+ WHERE domain = $host AND path = $path AND secure <= $secure
+ AND (NOT originonly OR domain = $fullhost)
+ AND originonly = $exact
+ } {
+ lappend result $key $value
+ db eval {
+ UPDATE sessionCookies SET lastuse = $now WHERE id = $id
+ }
+ }
+ }
+
+ method getCookies {proto host path} {
+ set result {}
+ set paths [splitPath $path]
+ if {[regexp {[^0-9.]} $host]} {
+ set domains [splitDomain [string tolower [::tcl::idna encode $host]]]
+ } else {
+ # Ugh, it's a numeric domain! Restrict it to just itself...
+ set domains [list $host]
+ }
+ set secure [string equal -nocase $proto "https"]
+ # Open question: how to move these manipulations into the database
+ # engine (if that's where they *should* be).
+ #
+ # Suggestion from kbk:
+ #LENGTH(theColumn) <= LENGTH($queryStr) AND
+ #SUBSTR(theColumn, LENGTH($queryStr) LENGTH(theColumn)+1) = $queryStr
+ #
+ # However, we instead do most of the work in Tcl because that lets us
+ # do the splitting exactly right, and it's far easier to work with
+ # strings in Tcl than in SQL.
+ db transaction {
+ foreach domain $domains {
+ foreach p $paths {
+ my GetCookiesForHostAndPath result $secure $domain $p $host
+ }
+ }
+ return $result
+ }
+ }
+
+ method BadDomain options {
+ if {![dict exists $options domain]} {
+ log error "no domain present in options"
+ return 0
+ }
+ dict with options {}
+ if {$domain ne $origin} {
+ log debug "cookie domain varies from origin (%s, %s)" \
+ $domain $origin
+ if {[string match .* $domain]} {
+ set dotd $domain
+ } else {
+ set dotd .$domain
+ }
+ if {![string equal -length [string length $dotd] \
+ [string reverse $dotd] [string reverse $origin]]} {
+ log warn "bad cookie: domain not suffix of origin"
+ return 1
+ }
+ }
+ if {![regexp {[^0-9.]} $domain]} {
+ if {$domain eq $origin} {
+ # May set for itself
+ return 0
+ }
+ log warn "bad cookie: for a numeric address"
+ return 1
+ }
+ db eval {
+ SELECT forbidden FROM domains WHERE domain = $domain
+ } {
+ if {$forbidden} {
+ log warn "bad cookie: for a forbidden address"
+ }
+ return $forbidden
+ }
+ if {[regexp {^[^.]+\.(.+)$} $domain -> super] && [db exists {
+ SELECT 1 FROM forbiddenSuper WHERE domain = $super
+ }]} then {
+ log warn "bad cookie: for a forbidden address"
+ return 1
+ }
+ return 0
+ }
+
+ # A defined extension point to allow users to easily impose extra policies
+ # on whether to accept cookies from a particular domain and path.
+ method policyAllow {operation domain path} {
+ return true
+ }
+
+ method storeCookie {options} {
+ db transaction {
+ if {[my BadDomain $options]} {
+ return
+ }
+ set now [clock seconds]
+ set persistent [dict exists $options expires]
+ dict with options {}
+ if {!$persistent} {
+ if {![my policyAllow session $domain $path]} {
+ log warn "bad cookie: $domain prohibited by user policy"
+ return
+ }
+ db eval {
+ INSERT OR REPLACE INTO sessionCookies (
+ secure, domain, path, key, value, originonly, creation,
+ lastuse)
+ VALUES ($secure, $domain, $path, $key, $value, $hostonly,
+ $now, $now);
+ DELETE FROM persistentCookies
+ WHERE domain = $domain AND path = $path AND key = $key
+ AND secure <= $secure AND originonly = $hostonly
+ }
+ incr deletions [db changes]
+ log debug "defined session cookie for %s" \
+ [locn $secure $domain $path $key]
+ } elseif {$expires < $now} {
+ if {![my policyAllow delete $domain $path]} {
+ log warn "bad cookie: $domain prohibited by user policy"
+ return
+ }
+ db eval {
+ DELETE FROM persistentCookies
+ WHERE domain = $domain AND path = $path AND key = $key
+ AND secure <= $secure AND originonly = $hostonly
+ }
+ set del [db changes]
+ db eval {
+ DELETE FROM sessionCookies
+ WHERE domain = $domain AND path = $path AND key = $key
+ AND secure <= $secure AND originonly = $hostonly
+ }
+ incr deletions [incr del [db changes]]
+ log debug "deleted %d cookies for %s" \
+ $del [locn $secure $domain $path $key]
+ } else {
+ if {![my policyAllow set $domain $path]} {
+ log warn "bad cookie: $domain prohibited by user policy"
+ return
+ }
+ db eval {
+ INSERT OR REPLACE INTO persistentCookies (
+ secure, domain, path, key, value, originonly, expiry,
+ creation, lastuse)
+ VALUES ($secure, $domain, $path, $key, $value, $hostonly,
+ $expires, $now, $now);
+ DELETE FROM sessionCookies
+ WHERE domain = $domain AND path = $path AND key = $key
+ AND secure <= $secure AND originonly = $hostonly
+ }
+ incr deletions [db changes]
+ log debug "defined persistent cookie for %s, expires at %s" \
+ [locn $secure $domain $path $key] \
+ [clock format $expires]
+ }
+ }
+ }
+
+ method PurgeCookies {} {
+ namespace upvar [info object namespace [self class]] \
+ vacuumtrigger trigger retainlimit retain
+ my PostponePurge
+ set now [clock seconds]
+ log debug "purging cookies that expired before %s" [clock format $now]
+ db transaction {
+ db eval {
+ DELETE FROM persistentCookies WHERE expiry < $now
+ }
+ incr deletions [db changes]
+ db eval {
+ DELETE FROM persistentCookies WHERE id IN (
+ SELECT id FROM persistentCookies ORDER BY lastuse ASC
+ LIMIT -1 OFFSET $retain)
+ }
+ incr deletions [db changes]
+ db eval {
+ DELETE FROM sessionCookies WHERE id IN (
+ SELECT id FROM sessionCookies ORDER BY lastuse
+ LIMIT -1 OFFSET $retain)
+ }
+ incr deletions [db changes]
+ }
+
+ # Once we've deleted a fair bit, vacuum the database. Must be done
+ # outside a transaction.
+ if {$deletions > $trigger} {
+ set deletions 0
+ log debug "vacuuming cookie database"
+ catch {
+ db eval {
+ VACUUM
+ }
+ }
+ }
+ }
+
+ forward Database db
+
+ method lookup {{host ""} {key ""}} {
+ set host [string tolower [::tcl::idna encode $host]]
+ db transaction {
+ if {$host eq ""} {
+ set result {}
+ db eval {
+ SELECT DISTINCT domain FROM cookies
+ ORDER BY domain
+ } {
+ lappend result [::tcl::idna decode [string tolower $domain]]
+ }
+ return $result
+ } elseif {$key eq ""} {
+ set result {}
+ db eval {
+ SELECT DISTINCT key FROM cookies
+ WHERE domain = $host
+ ORDER BY key
+ } {
+ lappend result $key
+ }
+ return $result
+ } else {
+ db eval {
+ SELECT value FROM cookies
+ WHERE domain = $host AND key = $key
+ LIMIT 1
+ } {
+ return $value
+ }
+ return -code error "no such key for that host"
+ }
+ }
+ }
+}
+
+# Local variables:
+# mode: tcl
+# fill-column: 78
+# End:
diff --git a/library/http/effective_tld_names.txt.gz b/library/http/effective_tld_names.txt.gz
new file mode 100644
index 0000000..9ce2b69
--- /dev/null
+++ b/library/http/effective_tld_names.txt.gz
Binary files differ
diff --git a/library/http/http.tcl b/library/http/http.tcl
index f82bced..7236bae 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -20,6 +20,7 @@ namespace eval http {
if {![info exists http]} {
array set http {
-accept */*
+ -cookiejar {}
-pipeline 1
-postfresh 0
-proxyhost {}
@@ -127,6 +128,18 @@ namespace eval http {
set defaultKeepalive 0
}
+ # Regular expression used to parse cookies
+ variable CookieRE {(?x) # EXPANDED SYNTAX
+ \s* # Ignore leading spaces
+ ([^][\u0000- ()<>@,;:\\""/?={}\u007f-\uffff]+) # Match the name
+ = # LITERAL: Equal sign
+ ([!\u0023-+\u002D-:<-\u005B\u005D-~]*) # Match the value
+ (?:
+ \s* ; \s* # LITERAL: semicolon
+ ([^\u0000]+) # Match the options
+ )?
+ }
+
namespace export geturl config reset wait formatQuery quoteString
namespace export register unregister registerError
# - Useful, but not exported: data, size, status, code, cleanup, error,
@@ -892,8 +905,12 @@ proc http::geturl {url args} {
}
return -code error "Illegal characters in URL path"
}
+ if {![regexp {^[^?#]+} $srvurl state(path)]} {
+ set state(path) /
+ }
} else {
set srvurl /
+ set state(path) /
}
if {$proto eq ""} {
set proto http
@@ -1354,12 +1371,16 @@ proc http::Connected {token proto phost srvurl} {
puts $sock "$how $srvurl HTTP/$state(-protocol)"
if {[dict exists $state(-headers) Host]} {
# Allow Host spoofing. [Bug 928154]
- puts $sock "Host: [dict get $state(-headers) Host]"
+ set hostHdr [dict get $state(-headers) Host]
+ regexp {^[^:]+} $hostHdr state(host)
+ puts $sock "Host: $hostHdr"
} elseif {$port == $defport} {
# Don't add port in this case, to handle broken servers. [Bug
# #504508]
+ set state(host) $host
puts $sock "Host: $host"
} else {
+ set state(host) $host
puts $sock "Host: $host:$port"
}
puts $sock "User-Agent: $http(-useragent)"
@@ -1421,6 +1442,22 @@ proc http::Connected {token proto phost srvurl} {
seek $state(-querychannel) $start
}
+ # Note that we don't do Cookie2; that's much nastier and not normally
+ # observed in practice either. It also doesn't fix the multitude of
+ # bugs in the basic cookie spec.
+ if {$http(-cookiejar) ne ""} {
+ set cookies ""
+ set separator ""
+ foreach {key value} [{*}$http(-cookiejar) \
+ getCookies $proto $host $state(path)] {
+ append cookies $separator $key = $value
+ set separator "; "
+ }
+ if {$cookies ne ""} {
+ puts $sock "Cookie: $cookies"
+ }
+ }
+
# Flush the request header and set up the fileevent that will either
# push the POST data or read the response.
#
@@ -2693,6 +2730,11 @@ proc http::Event {sock token} {
set state(connection) \
[string trim [string tolower $value]]
}
+ set-cookie {
+ if {$http(-cookiejar) ne ""} {
+ ParseCookie $token [string trim $value]
+ }
+ }
}
lappend state(meta) $key [string trim $value]
}
@@ -2990,6 +3032,83 @@ proc http::IsBinaryContentType {type} {
return true
}
+proc http::ParseCookie {token value} {
+ variable http
+ variable CookieRE
+ variable $token
+ upvar 0 $token state
+
+ if {![regexp $CookieRE $value -> cookiename cookieval opts]} {
+ # Bad cookie! No biscuit!
+ return
+ }
+
+ # Convert the options into a list before feeding into the cookie store;
+ # ugly, but quite easy.
+ set realopts {hostonly 1 path / secure 0 httponly 0}
+ dict set realopts origin $state(host)
+ dict set realopts domain $state(host)
+ foreach option [split [regsub -all {;\s+} $opts \u0000] \u0000] {
+ regexp {^(.*?)(?:=(.*))?$} $option -> optname optval
+ switch -exact -- [string tolower $optname] {
+ expires {
+ if {[catch {
+ #Sun, 06 Nov 1994 08:49:37 GMT
+ dict set realopts expires \
+ [clock scan $optval -format "%a, %d %b %Y %T %Z"]
+ }] && [catch {
+ # Google does this one
+ #Mon, 01-Jan-1990 00:00:00 GMT
+ dict set realopts expires \
+ [clock scan $optval -format "%a, %d-%b-%Y %T %Z"]
+ }] && [catch {
+ # This is in the RFC, but it is also in the original
+ # Netscape cookie spec, now online at:
+ # <URL:http://curl.haxx.se/rfc/cookie_spec.html>
+ #Sunday, 06-Nov-94 08:49:37 GMT
+ dict set realopts expires \
+ [clock scan $optval -format "%A, %d-%b-%y %T %Z"]
+ }]} {catch {
+ #Sun Nov 6 08:49:37 1994
+ dict set realopts expires \
+ [clock scan $optval -gmt 1 -format "%a %b %d %T %Y"]
+ }}
+ }
+ max-age {
+ # Normalize
+ if {[string is integer -strict $optval]} {
+ dict set realopts expires [expr {[clock seconds] + $optval}]
+ }
+ }
+ domain {
+ # From the domain-matches definition [RFC 2109, section 2]:
+ # Host A's name domain-matches host B's if [...]
+ # A is a FQDN string and has the form NB, where N is a
+ # non-empty name string, B has the form .B', and B' is a
+ # FQDN string. (So, x.y.com domain-matches .y.com but
+ # not y.com.)
+ if {$optval ne "" && ![string match *. $optval]} {
+ dict set realopts domain [string trimleft $optval "."]
+ dict set realopts hostonly [expr {
+ ! [string match .* $optval]
+ }]
+ }
+ }
+ path {
+ if {[string match /* $optval]} {
+ dict set realopts path $optval
+ }
+ }
+ secure - httponly {
+ dict set realopts [string tolower $optname] 1
+ }
+ }
+ }
+ dict set realopts key $cookiename
+ dict set realopts value $cookieval
+ {*}$http(-cookiejar) storeCookie $realopts
+}
+
# http::getTextLine --
#
# Get one line with the stream in crlf mode.
diff --git a/library/http/idna.tcl b/library/http/idna.tcl
new file mode 100644
index 0000000..2a7d289
--- /dev/null
+++ b/library/http/idna.tcl
@@ -0,0 +1,292 @@
+# cookiejar.tcl --
+#
+# Implementation of IDNA (Internationalized Domain Names for
+# Applications) encoding/decoding system, built on a punycode engine
+# developed directly from the code in RFC 3492, Appendix C (with
+# substantial modifications).
+#
+# This implementation includes code from that RFC, translated to Tcl; the
+# other parts are:
+# Copyright (c) 2014 Donal K. Fellows
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+namespace eval ::tcl::idna {
+ namespace ensemble create -command puny -map {
+ encode punyencode
+ decode punydecode
+ }
+ namespace ensemble create -command ::tcl::idna -map {
+ encode IDNAencode
+ decode IDNAdecode
+ puny puny
+ version {::apply {{} {package present tcl::idna} ::}}
+ }
+
+ proc IDNAencode hostname {
+ set parts {}
+ # Split term from RFC 3490, Sec 3.1
+ foreach part [split $hostname "\u002E\u3002\uFF0E\uFF61"] {
+ if {[regexp {[^-A-Za-z0-9]} $part]} {
+ if {[regexp {[^-A-Za-z0-9\u00a1-\uffff]} $part ch]} {
+ scan $ch %c c
+ if {$ch < "!" || $ch > "~"} {
+ set ch [format "\\u%04x" $c]
+ }
+ throw [list IDNA INVALID_NAME_CHARACTER $ch] \
+ "bad character \"$ch\" in DNS name"
+ }
+ set part xn--[punyencode $part]
+ # Length restriction from RFC 5890, Sec 2.3.1
+ if {[string length $part] > 63} {
+ throw [list IDNA OVERLONG_PART $part] \
+ "hostname part too long"
+ }
+ }
+ lappend parts $part
+ }
+ return [join $parts .]
+ }
+ proc IDNAdecode hostname {
+ set parts {}
+ # Split term from RFC 3490, Sec 3.1
+ foreach part [split $hostname "\u002E\u3002\uFF0E\uFF61"] {
+ if {[string match -nocase "xn--*" $part]} {
+ set part [punydecode [string range $part 4 end]]
+ }
+ lappend parts $part
+ }
+ return [join $parts .]
+ }
+
+ variable digits [split "abcdefghijklmnopqrstuvwxyz0123456789" ""]
+ # Bootstring parameters for Punycode
+ variable base 36
+ variable tmin 1
+ variable tmax 26
+ variable skew 38
+ variable damp 700
+ variable initial_bias 72
+ variable initial_n 0x80
+
+ variable max_codepoint 0x10FFFF
+
+ proc adapt {delta first numchars} {
+ variable base
+ variable tmin
+ variable tmax
+ variable damp
+ variable skew
+
+ set delta [expr {$delta / ($first ? $damp : 2)}]
+ incr delta [expr {$delta / $numchars}]
+ set k 0
+ while {$delta > ($base - $tmin) * $tmax / 2} {
+ set delta [expr {$delta / ($base-$tmin)}]
+ incr k $base
+ }
+ return [expr {$k + ($base-$tmin+1) * $delta / ($delta+$skew)}]
+ }
+
+ # Main punycode encoding function
+ proc punyencode {string {case ""}} {
+ variable digits
+ variable tmin
+ variable tmax
+ variable base
+ variable initial_n
+ variable initial_bias
+
+ if {![string is boolean $case]} {
+ return -code error "\"$case\" must be boolean"
+ }
+
+ set in {}
+ foreach char [set string [split $string ""]] {
+ scan $char "%c" ch
+ lappend in $ch
+ }
+ set output {}
+
+ # Initialize the state:
+ set n $initial_n
+ set delta 0
+ set bias $initial_bias
+
+ # Handle the basic code points:
+ foreach ch $string {
+ if {$ch < "\u0080"} {
+ if {$case eq ""} {
+ append output $ch
+ } elseif {[string is true $case]} {
+ append output [string toupper $ch]
+ } elseif {[string is false $case]} {
+ append output [string tolower $ch]
+ }
+ }
+ }
+
+ set b [string length $output]
+
+ # h is the number of code points that have been handled, b is the
+ # number of basic code points.
+
+ if {$b > 0} {
+ append output "-"
+ }
+
+ # Main encoding loop:
+
+ for {set h $b} {$h < [llength $in]} {incr delta; incr n} {
+ # All non-basic code points < n have been handled already. Find
+ # the next larger one:
+
+ set m inf
+ foreach ch $in {
+ if {$ch >= $n && $ch < $m} {
+ set m $ch
+ }
+ }
+
+ # Increase delta enough to advance the decoder's <n,i> state to
+ # <m,0>, but guard against overflow:
+
+ if {$m-$n > (0xffffffff-$delta)/($h+1)} {
+ throw {PUNYCODE OVERFLOW} "overflow in delta computation"
+ }
+ incr delta [expr {($m-$n) * ($h+1)}]
+ set n $m
+
+ foreach ch $in {
+ if {$ch < $n && ([incr delta] & 0xffffffff) == 0} {
+ throw {PUNYCODE OVERFLOW} "overflow in delta computation"
+ }
+
+ if {$ch != $n} {
+ continue
+ }
+
+ # Represent delta as a generalized variable-length integer:
+
+ for {set q $delta; set k $base} true {incr k $base} {
+ set t [expr {min(max($k-$bias, $tmin), $tmax)}]
+ if {$q < $t} {
+ break
+ }
+ append output \
+ [lindex $digits [expr {$t + ($q-$t)%($base-$t)}]]
+ set q [expr {($q-$t) / ($base-$t)}]
+ }
+
+ append output [lindex $digits $q]
+ set bias [adapt $delta [expr {$h==$b}] [expr {$h+1}]]
+ set delta 0
+ incr h
+ }
+ }
+
+ return $output
+ }
+
+ # Main punycode decode function
+ proc punydecode {string {case ""}} {
+ variable tmin
+ variable tmax
+ variable base
+ variable initial_n
+ variable initial_bias
+ variable max_codepoint
+
+ if {![string is boolean $case]} {
+ return -code error "\"$case\" must be boolean"
+ }
+
+ # Initialize the state:
+
+ set n $initial_n
+ set i 0
+ set first 1
+ set bias $initial_bias
+
+ # Split the string into the "real" ASCII characters and the ones to
+ # feed into the main decoder. Note that we don't need to check the
+ # result of [regexp] because that RE will technically match any string
+ # at all.
+
+ regexp {^(?:(.*)-)?([^-]*)$} $string -> pre post
+ if {[string is true -strict $case]} {
+ set pre [string toupper $pre]
+ } elseif {[string is false -strict $case]} {
+ set pre [string tolower $pre]
+ }
+ set output [split $pre ""]
+ set out [llength $output]
+
+ # Main decoding loop:
+
+ for {set in 0} {$in < [string length $post]} {incr in} {
+ # Decode a generalized variable-length integer into delta, which
+ # gets added to i. The overflow checking is easier if we increase
+ # i as we go, then subtract off its starting value at the end to
+ # obtain delta.
+
+ for {set oldi $i; set w 1; set k $base} 1 {incr in} {
+ if {[set ch [string index $post $in]] eq ""} {
+ throw {PUNYCODE BAD_INPUT LENGTH} "exceeded input data"
+ }
+ if {[string match -nocase {[a-z]} $ch]} {
+ scan [string toupper $ch] %c digit
+ incr digit -65
+ } elseif {[string match {[0-9]} $ch]} {
+ set digit [expr {$ch + 26}]
+ } else {
+ throw {PUNYCODE BAD_INPUT CHAR} \
+ "bad decode character \"$ch\""
+ }
+ incr i [expr {$digit * $w}]
+ set t [expr {min(max($tmin, $k-$bias), $tmax)}]
+ if {$digit < $t} {
+ set bias [adapt [expr {$i-$oldi}] $first [incr out]]
+ set first 0
+ break
+ }
+ if {[set w [expr {$w * ($base - $t)}]] > 0x7fffffff} {
+ throw {PUNYCODE OVERFLOW} \
+ "excessively large integer computed in digit decode"
+ }
+ incr k $base
+ }
+
+ # i was supposed to wrap around from out+1 to 0, incrementing n
+ # each time, so we'll fix that now:
+
+ if {[incr n [expr {$i / $out}]] > 0x7fffffff} {
+ throw {PUNYCODE OVERFLOW} \
+ "excessively large integer computed in character choice"
+ } elseif {$n > $max_codepoint} {
+ if {$n >= 0x00d800 && $n < 0x00e000} {
+ # Bare surrogate?!
+ throw {PUNYCODE NON_BMP} \
+ [format "unsupported character U+%06x" $n]
+ }
+ throw {PUNYCODE NON_UNICODE} "bad codepoint $n"
+ }
+ set i [expr {$i % $out}]
+
+ # Insert n at position i of the output:
+
+ set output [linsert $output $i [format "%c" $n]]
+ incr i
+ }
+
+ return [join $output ""]
+ }
+}
+
+package provide tcl::idna 1.0
+
+# Local variables:
+# mode: tcl
+# fill-column: 78
+# End:
diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl
index 4f74635..3bc111f 100644
--- a/library/http/pkgIndex.tcl
+++ b/library/http/pkgIndex.tcl
@@ -1,2 +1,4 @@
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
package ifneeded http 2.9.0 [list tclPkgSetup $dir http 2.9.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
+package ifneeded cookiejar 0.1 [list source [file join $dir cookiejar.tcl]]
+package ifneeded tcl::idna 1.0 [list source [file join $dir idna.tcl]]
diff --git a/library/init.tcl b/library/init.tcl
index 51339d0..1ccce27 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -798,20 +798,3 @@ proc tcl::CopyDirectory {action src dest} {
}
return
}
-set isafe [interp issafe]
-###
-# Package manifest for all Tcl packages included in the /library file system
-###
-set isafe [interp issafe]
-set dir [file dirname [info script]]
-foreach {safe package version file} {
- 0 http 2.9.0 {http http.tcl}
- 1 msgcat 1.7.0 {msgcat msgcat.tcl}
- 1 opt 0.4.7 {opt optparse.tcl}
- 0 platform 1.0.14 {platform platform.tcl}
- 0 platform::shell 1.1.4 {platform shell.tcl}
- 1 tcltest 2.4.1 {tcltest tcltest.tcl}
-} {
- if {$isafe && !$safe} continue
- package ifneeded $package $version [list source [file join $dir {*}$file]]
-}
diff --git a/library/manifest.txt b/library/manifest.txt
new file mode 100644
index 0000000..11a755a
--- /dev/null
+++ b/library/manifest.txt
@@ -0,0 +1,18 @@
+###
+# Package manifest for all Tcl packages included in the /library file system
+###
+apply {{dir} {
+ set ::test [info script]
+ set isafe [interp issafe]
+ foreach {safe package version file} {
+ 0 http 2.9.0 {http http.tcl}
+ 1 msgcat 1.7.0 {msgcat msgcat.tcl}
+ 1 opt 0.4.7 {opt optparse.tcl}
+ 0 platform 1.0.14 {platform platform.tcl}
+ 0 platform::shell 1.1.4 {platform shell.tcl}
+ 1 tcltest 2.5.0 {tcltest tcltest.tcl}
+ } {
+ if {$isafe && !$safe} continue
+ package ifneeded $package $version [list source [file join $dir {*}$file]]
+ }
+}} $dir
diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl
index 129cd9c..9f7d54a 100644
--- a/library/msgcat/msgcat.tcl
+++ b/library/msgcat/msgcat.tcl
@@ -187,7 +187,7 @@ namespace eval msgcat::mcutil {
# Find the translation for the given string based on the current
# locale setting. Check the local namespace first, then look in each
# parent namespace until the source is found. If additional args are
-# specified, use the format command to work them into the traslated
+# specified, use the format command to work them into the translated
# string.
# If no catalog item is found, mcunknown is called in the caller frame
# and its result is returned.
@@ -209,7 +209,7 @@ proc msgcat::mc {args} {
# Find the translation for the given string based on the current
# locale setting. Check the passed namespace first, then look in each
# parent namespace until the source is found. If additional args are
-# specified, use the format command to work them into the traslated
+# specified, use the format command to work them into the translated
# string.
# If no catalog item is found, mcunknown is called in the caller frame
# and its result is returned.
@@ -1105,7 +1105,7 @@ proc msgcat::mcflmset {pairs} {
return -code error "must only be used inside a message catalog loaded\
with ::msgcat::mcload"
}
- tailcal mcmset $FileLocale $pairs
+ tailcall mcmset $FileLocale $pairs
}
# msgcat::mcunknown --
@@ -1116,7 +1116,7 @@ proc msgcat::mcflmset {pairs} {
# by an application specific routine for error reporting
# purposes. The default behavior is to return the source string.
# If additional args are specified, the format command will be used
-# to work them into the traslated string.
+# to work them into the translated string.
#
# Arguments:
# locale The current locale.
@@ -1137,9 +1137,9 @@ proc msgcat::mcunknown {args} {
# - Default global handler, if mcunknown is not redefined.
# - Per package handler, if the package sets unknowncmd to the empty
# string.
-# It returna the source string if the argument list is empty.
+# It returns the source string if the argument list is empty.
# If additional args are specified, the format command will be used
-# to work them into the traslated string.
+# to work them into the translated string.
#
# Arguments:
# locale (unused) The current locale.
@@ -1279,7 +1279,7 @@ proc msgcat::mcutil::getsystemlocale {} {
# On Vista and later:
# HCU/Control Panel/Desktop : PreferredUILanguages is for language packs,
- # HCU/Control Pannel/International : localName is the default locale.
+ # HCU/Control Panel/International : localName is the default locale.
#
# They contain the local string as RFC5646, composed of:
# [a-z]{2,3} : language
@@ -1315,8 +1315,8 @@ proc msgcat::mcutil::getsystemlocale {} {
}
#
# Keep trying to match against smaller and smaller suffixes
- # of the registry value, since the latter hexadigits appear
- # to determine general language and earlier hexadigits determine
+ # of the registry value, since the latter hexdigits appear
+ # to determine general language and earlier hexdigits determine
# more precise information, such as territory. For example,
# 0409 - English - United States
# 0809 - English - United Kingdom
diff --git a/library/package.tcl b/library/package.tcl
index c72fbfb..6c87ec1 100644
--- a/library/package.tcl
+++ b/library/package.tcl
@@ -493,7 +493,11 @@ proc tclPkgUnknown {name args} {
# $file was not readable; silently ignore
continue
} on error msg {
- tclLog "error reading package index file $file: $msg"
+ if {[regexp {version conflict for package} $msg]} {
+ # In case of version conflict, silently ignore
+ continue
+ }
+ tclLog "error reading package index file $file: $msg"
} on ok {} {
set procdDirs($dir) 1
}
@@ -511,6 +515,10 @@ proc tclPkgUnknown {name args} {
# $file was not readable; silently ignore
continue
} on error msg {
+ if {[regexp {version conflict for package} $msg]} {
+ # In case of version conflict, silently ignore
+ continue
+ }
tclLog "error reading package index file $file: $msg"
} on ok {} {
set procdDirs($dir) 1
@@ -595,6 +603,10 @@ proc tcl::MacOSXPkgUnknown {original name args} {
# $file was not readable; silently ignore
continue
} on error msg {
+ if {[regexp {version conflict for package} $msg]} {
+ # In case of version conflict, silently ignore
+ continue
+ }
tclLog "error reading package index file $file: $msg"
} on ok {} {
set procdDirs($dir) 1
diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl
index eadb1bd..fde3ffe 100644
--- a/library/tcltest/pkgIndex.tcl
+++ b/library/tcltest/pkgIndex.tcl
@@ -9,4 +9,4 @@
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
-package ifneeded tcltest 2.4.1 [list source [file join $dir tcltest.tcl]]
+package ifneeded tcltest 2.5.0 [list source [file join $dir tcltest.tcl]]
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index f1b6082..d67a900 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -22,7 +22,7 @@ namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
- variable Version 2.4.1
+ variable Version 2.5.0
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
@@ -1841,6 +1841,9 @@ proc tcltest::SubstArguments {argList} {
# is optional; default is {}.
# returnCodes - Expected return codes. This attribute is
# optional; default is {0 2}.
+# errorCode - Expected error code. This attribute is
+# optional; default is {*}. It is a glob pattern.
+# If given, returnCodes defaults to {1}.
# setup - Code to run before $script (above). This
# attribute is optional; default is {}.
# cleanup - Code to run after $script (above). This
@@ -1882,7 +1885,7 @@ proc tcltest::test {name description args} {
# Pre-define everything to null except output and errorOutput. We
# determine whether or not to trap output based on whether or not
# these variables (output & errorOutput) are defined.
- lassign {} constraints setup cleanup body result returnCodes match
+ lassign {} constraints setup cleanup body result returnCodes errorCode match
# Set the default match mode
set match exact
@@ -1892,6 +1895,9 @@ proc tcltest::test {name description args} {
# 'return' being used in the test script).
set returnCodes [list 0 2]
+ # Set the default error code pattern
+ set errorCode "*"
+
# The old test format can't have a 3rd argument (constraints or
# script) that starts with '-'.
if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} {
@@ -1901,7 +1907,7 @@ proc tcltest::test {name description args} {
set testAttributes($element) $value
}
foreach item {constraints match setup body cleanup \
- result returnCodes output errorOutput} {
+ result returnCodes errorCode output errorOutput} {
if {[info exists testAttributes(-$item)]} {
set testAttributes(-$item) [uplevel 1 \
::concat $testAttributes(-$item)]
@@ -1912,7 +1918,7 @@ proc tcltest::test {name description args} {
}
set validFlags {-setup -cleanup -body -result -returnCodes \
- -match -output -errorOutput -constraints}
+ -errorCode -match -output -errorOutput -constraints}
foreach flag [array names testAttributes] {
if {$flag ni $validFlags} {
@@ -1944,6 +1950,10 @@ proc tcltest::test {name description args} {
foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
}
+ # errorCode without returnCode 1 is meaningless
+ if {$errorCode ne "*" && 1 ni $returnCodes} {
+ set returnCodes 1
+ }
} else {
# This is parsing for the old test command format; it is here
# for backward compatibility.
@@ -1976,7 +1986,7 @@ proc tcltest::test {name description args} {
set code [catch {uplevel 1 $setup} setupMsg]
if {$code == 1} {
set errorInfo(setup) $::errorInfo
- set errorCode(setup) $::errorCode
+ set errorCodeRes(setup) $::errorCode
}
set setupFailure [expr {$code != 0}]
@@ -2003,7 +2013,7 @@ proc tcltest::test {name description args} {
lassign $testResult actualAnswer returnCode
if {$returnCode == 1} {
set errorInfo(body) $::errorInfo
- set errorCode(body) $::errorCode
+ set errorCodeRes(body) $::errorCode
}
}
@@ -2012,6 +2022,11 @@ proc tcltest::test {name description args} {
if {!$setupFailure && ($returnCode ni $returnCodes)} {
set codeFailure 1
}
+ set errorCodeFailure 0
+ if {!$setupFailure && !$codeFailure && $returnCode == 1 && \
+ ![string match $errorCode $errorCodeRes(body)]} {
+ set errorCodeFailure 1
+ }
# If expected output/error strings exist, we have to compare
# them. If the comparison fails, then so did the test.
@@ -2055,7 +2070,7 @@ proc tcltest::test {name description args} {
set code [catch {uplevel 1 $cleanup} cleanupMsg]
if {$code == 1} {
set errorInfo(cleanup) $::errorInfo
- set errorCode(cleanup) $::errorCode
+ set errorCodeRes(cleanup) $::errorCode
}
set cleanupFailure [expr {$code != 0}]
@@ -2106,7 +2121,7 @@ proc tcltest::test {name description args} {
variable numTests
if {!($setupFailure || $cleanupFailure || $coreFailure
|| $outputFailure || $errorFailure || $codeFailure
- || $scriptFailure)} {
+ || $errorCodeFailure || $scriptFailure)} {
if {$testLevel == 1} {
incr numTests(Passed)
if {[IsVerbose pass]} {
@@ -2159,7 +2174,7 @@ proc tcltest::test {name description args} {
failed:\n$setupMsg"
if {[info exists errorInfo(setup)]} {
puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)"
- puts [outputChannel] "---- errorCode(setup): $errorCode(setup)"
+ puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)"
}
}
if {$scriptFailure} {
@@ -2171,6 +2186,10 @@ proc tcltest::test {name description args} {
($match matching):\n$result"
}
}
+ if {$errorCodeFailure} {
+ puts [outputChannel] "---- Error code was: '$errorCodeRes(body)'"
+ puts [outputChannel] "---- Error code should have been: '$errorCode'"
+ }
if {$codeFailure} {
switch -- $returnCode {
0 { set msg "Test completed normally" }
@@ -2186,7 +2205,7 @@ proc tcltest::test {name description args} {
if {[IsVerbose error]} {
if {[info exists errorInfo(body)] && (1 ni $returnCodes)} {
puts [outputChannel] "---- errorInfo: $errorInfo(body)"
- puts [outputChannel] "---- errorCode: $errorCode(body)"
+ puts [outputChannel] "---- errorCode: $errorCodeRes(body)"
}
}
}
@@ -2212,7 +2231,7 @@ proc tcltest::test {name description args} {
puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
if {[info exists errorInfo(cleanup)]} {
puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)"
- puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)"
+ puts [outputChannel] "---- errorCode(cleanup): $errorCodeRes(cleanup)"
}
}
if {$coreFailure} {
@@ -2722,7 +2741,7 @@ proc tcltest::GetMatchingDirectories {rootdir} {
# shell being tested
#
# Results:
-# None.
+# Whether there were any failures.
#
# Side effects:
# None.
@@ -2733,6 +2752,7 @@ proc tcltest::runAllTests { {shell ""} } {
variable numTests
variable failFiles
variable DefaultValue
+ set failFilesAccum {}
FillFilesExisted
if {[llength [info level 0]] == 1} {
@@ -2822,6 +2842,7 @@ proc tcltest::runAllTests { {shell ""} } {
}
if {$Failed > 0} {
lappend failFiles $testFile
+ lappend failFilesAccum $testFile
}
} elseif {[regexp [join {
{^Number of tests skipped }
@@ -2868,7 +2889,7 @@ proc tcltest::runAllTests { {shell ""} } {
puts [outputChannel] ""
puts [outputChannel] [string repeat ~ 44]
}
- return
+ return [expr {[info exists testFileFailures] || [llength $failFilesAccum]}]
}
#####################################################################
diff --git a/library/tzdata/Africa/Casablanca b/library/tzdata/Africa/Casablanca
index 33ad99b..3207e59 100644
--- a/library/tzdata/Africa/Casablanca
+++ b/library/tzdata/Africa/Casablanca
@@ -2,229 +2,59 @@
set TZData(:Africa/Casablanca) {
{-9223372036854775808 -1820 0 LMT}
- {-1773012580 0 0 WET}
- {-956361600 3600 1 WEST}
- {-950490000 0 0 WET}
- {-942019200 3600 1 WEST}
- {-761187600 0 0 WET}
- {-617241600 3600 1 WEST}
- {-605149200 0 0 WET}
- {-81432000 3600 1 WEST}
- {-71110800 0 0 WET}
- {141264000 3600 1 WEST}
- {147222000 0 0 WET}
- {199756800 3600 1 WEST}
- {207702000 0 0 WET}
- {231292800 3600 1 WEST}
- {244249200 0 0 WET}
- {265507200 3600 1 WEST}
- {271033200 0 0 WET}
- {448243200 3600 0 CET}
- {504918000 0 0 WET}
- {1212278400 3600 1 WEST}
- {1220223600 0 0 WET}
- {1243814400 3600 1 WEST}
- {1250809200 0 0 WET}
- {1272758400 3600 1 WEST}
- {1281222000 0 0 WET}
- {1301788800 3600 1 WEST}
- {1312066800 0 0 WET}
- {1335664800 3600 1 WEST}
- {1342749600 0 0 WET}
- {1345428000 3600 1 WEST}
- {1348970400 0 0 WET}
- {1367114400 3600 1 WEST}
- {1373162400 0 0 WET}
- {1376100000 3600 1 WEST}
- {1382839200 0 0 WET}
- {1396144800 3600 1 WEST}
- {1403920800 0 0 WET}
- {1406944800 3600 1 WEST}
- {1414288800 0 0 WET}
- {1427594400 3600 1 WEST}
- {1434247200 0 0 WET}
- {1437271200 3600 1 WEST}
- {1445738400 0 0 WET}
- {1459044000 3600 1 WEST}
- {1465092000 0 0 WET}
- {1468116000 3600 1 WEST}
- {1477792800 0 0 WET}
- {1490493600 3600 1 WEST}
- {1495332000 0 0 WET}
- {1498960800 3600 1 WEST}
- {1509242400 0 0 WET}
- {1521943200 3600 1 WEST}
- {1526176800 0 0 WET}
- {1529200800 3600 1 WEST}
- {1540692000 0 0 WET}
- {1553997600 3600 1 WEST}
- {1557021600 0 0 WET}
- {1560045600 3600 1 WEST}
- {1572141600 0 0 WET}
- {1585447200 3600 1 WEST}
- {1587261600 0 0 WET}
- {1590285600 3600 1 WEST}
- {1603591200 0 0 WET}
- {1616896800 3600 1 WEST}
- {1618106400 0 0 WET}
- {1621130400 3600 1 WEST}
- {1635645600 0 0 WET}
- {1651975200 3600 1 WEST}
- {1667095200 0 0 WET}
- {1682215200 3600 1 WEST}
- {1698544800 0 0 WET}
- {1713060000 3600 1 WEST}
- {1729994400 0 0 WET}
- {1743904800 3600 1 WEST}
- {1761444000 0 0 WET}
- {1774749600 3600 1 WEST}
- {1792893600 0 0 WET}
- {1806199200 3600 1 WEST}
- {1824948000 0 0 WET}
- {1837648800 3600 1 WEST}
- {1856397600 0 0 WET}
- {1869098400 3600 1 WEST}
- {1887847200 0 0 WET}
- {1901152800 3600 1 WEST}
- {1919296800 0 0 WET}
- {1932602400 3600 1 WEST}
- {1950746400 0 0 WET}
- {1964052000 3600 1 WEST}
- {1982800800 0 0 WET}
- {1995501600 3600 1 WEST}
- {2014250400 0 0 WET}
- {2026951200 3600 1 WEST}
- {2045700000 0 0 WET}
- {2058400800 3600 1 WEST}
- {2077149600 0 0 WET}
- {2090455200 3600 1 WEST}
- {2107994400 0 0 WET}
- {2108602800 0 0 WET}
- {2121904800 3600 1 WEST}
- {2138234400 0 0 WET}
- {2140052400 0 0 WET}
- {2153354400 3600 1 WEST}
- {2172103200 0 0 WET}
- {2184804000 3600 1 WEST}
- {2203552800 0 0 WET}
- {2216253600 3600 1 WEST}
- {2235002400 0 0 WET}
- {2248308000 3600 1 WEST}
- {2266452000 0 0 WET}
- {2279757600 3600 1 WEST}
- {2297901600 0 0 WET}
- {2311207200 3600 1 WEST}
- {2329351200 0 0 WET}
- {2342656800 3600 1 WEST}
- {2361405600 0 0 WET}
- {2374106400 3600 1 WEST}
- {2392855200 0 0 WET}
- {2405556000 3600 1 WEST}
- {2424304800 0 0 WET}
- {2437610400 3600 1 WEST}
- {2455754400 0 0 WET}
- {2469060000 3600 1 WEST}
- {2487204000 0 0 WET}
- {2500509600 3600 1 WEST}
- {2519258400 0 0 WET}
- {2531959200 3600 1 WEST}
- {2550708000 0 0 WET}
- {2563408800 3600 1 WEST}
- {2582157600 0 0 WET}
- {2595463200 3600 1 WEST}
- {2613607200 0 0 WET}
- {2626912800 3600 1 WEST}
- {2645056800 0 0 WET}
- {2658362400 3600 1 WEST}
- {2676506400 0 0 WET}
- {2689812000 3600 1 WEST}
- {2708560800 0 0 WET}
- {2721261600 3600 1 WEST}
- {2740010400 0 0 WET}
- {2752711200 3600 1 WEST}
- {2771460000 0 0 WET}
- {2784765600 3600 1 WEST}
- {2802909600 0 0 WET}
- {2816215200 3600 1 WEST}
- {2834359200 0 0 WET}
- {2847664800 3600 1 WEST}
- {2866413600 0 0 WET}
- {2879114400 3600 1 WEST}
- {2897863200 0 0 WET}
- {2910564000 3600 1 WEST}
- {2929312800 0 0 WET}
- {2942013600 3600 1 WEST}
- {2960762400 0 0 WET}
- {2974068000 3600 1 WEST}
- {2992212000 0 0 WET}
- {3005517600 3600 1 WEST}
- {3023661600 0 0 WET}
- {3036967200 3600 1 WEST}
- {3055716000 0 0 WET}
- {3068416800 3600 1 WEST}
- {3087165600 0 0 WET}
- {3099866400 3600 1 WEST}
- {3118615200 0 0 WET}
- {3131920800 3600 1 WEST}
- {3150064800 0 0 WET}
- {3163370400 3600 1 WEST}
- {3181514400 0 0 WET}
- {3194820000 3600 1 WEST}
- {3212964000 0 0 WET}
- {3226269600 3600 1 WEST}
- {3245018400 0 0 WET}
- {3257719200 3600 1 WEST}
- {3276468000 0 0 WET}
- {3289168800 3600 1 WEST}
- {3307917600 0 0 WET}
- {3321223200 3600 1 WEST}
- {3339367200 0 0 WET}
- {3352672800 3600 1 WEST}
- {3370816800 0 0 WET}
- {3384122400 3600 1 WEST}
- {3402871200 0 0 WET}
- {3415572000 3600 1 WEST}
- {3434320800 0 0 WET}
- {3447021600 3600 1 WEST}
- {3465770400 0 0 WET}
- {3479076000 3600 1 WEST}
- {3497220000 0 0 WET}
- {3510525600 3600 1 WEST}
- {3528669600 0 0 WET}
- {3541975200 3600 1 WEST}
- {3560119200 0 0 WET}
- {3573424800 3600 1 WEST}
- {3592173600 0 0 WET}
- {3604874400 3600 1 WEST}
- {3623623200 0 0 WET}
- {3636324000 3600 1 WEST}
- {3655072800 0 0 WET}
- {3668378400 3600 1 WEST}
- {3686522400 0 0 WET}
- {3699828000 3600 1 WEST}
- {3717972000 0 0 WET}
- {3731277600 3600 1 WEST}
- {3750026400 0 0 WET}
- {3762727200 3600 1 WEST}
- {3781476000 0 0 WET}
- {3794176800 3600 1 WEST}
- {3812925600 0 0 WET}
- {3825626400 3600 1 WEST}
- {3844375200 0 0 WET}
- {3857680800 3600 1 WEST}
- {3875824800 0 0 WET}
- {3889130400 3600 1 WEST}
- {3907274400 0 0 WET}
- {3920580000 3600 1 WEST}
- {3939328800 0 0 WET}
- {3952029600 3600 1 WEST}
- {3970778400 0 0 WET}
- {3983479200 3600 1 WEST}
- {4002228000 0 0 WET}
- {4015533600 3600 1 WEST}
- {4033677600 0 0 WET}
- {4046983200 3600 1 WEST}
- {4065127200 0 0 WET}
- {4078432800 3600 1 WEST}
- {4096576800 0 0 WET}
+ {-1773012580 0 0 +00}
+ {-956361600 3600 1 +00}
+ {-950490000 0 0 +00}
+ {-942019200 3600 1 +00}
+ {-761187600 0 0 +00}
+ {-617241600 3600 1 +00}
+ {-605149200 0 0 +00}
+ {-81432000 3600 1 +00}
+ {-71110800 0 0 +00}
+ {141264000 3600 1 +00}
+ {147222000 0 0 +00}
+ {199756800 3600 1 +00}
+ {207702000 0 0 +00}
+ {231292800 3600 1 +00}
+ {244249200 0 0 +00}
+ {265507200 3600 1 +00}
+ {271033200 0 0 +00}
+ {448243200 3600 0 +01}
+ {504918000 0 0 +00}
+ {1212278400 3600 1 +00}
+ {1220223600 0 0 +00}
+ {1243814400 3600 1 +00}
+ {1250809200 0 0 +00}
+ {1272758400 3600 1 +00}
+ {1281222000 0 0 +00}
+ {1301788800 3600 1 +00}
+ {1312066800 0 0 +00}
+ {1335664800 3600 1 +00}
+ {1342749600 0 0 +00}
+ {1345428000 3600 1 +00}
+ {1348970400 0 0 +00}
+ {1367114400 3600 1 +00}
+ {1373162400 0 0 +00}
+ {1376100000 3600 1 +00}
+ {1382839200 0 0 +00}
+ {1396144800 3600 1 +00}
+ {1403920800 0 0 +00}
+ {1406944800 3600 1 +00}
+ {1414288800 0 0 +00}
+ {1427594400 3600 1 +00}
+ {1434247200 0 0 +00}
+ {1437271200 3600 1 +00}
+ {1445738400 0 0 +00}
+ {1459044000 3600 1 +00}
+ {1465092000 0 0 +00}
+ {1468116000 3600 1 +00}
+ {1477792800 0 0 +00}
+ {1490493600 3600 1 +00}
+ {1495332000 0 0 +00}
+ {1498960800 3600 1 +00}
+ {1509242400 0 0 +00}
+ {1521943200 3600 1 +00}
+ {1526176800 0 0 +00}
+ {1529200800 3600 1 +00}
+ {1540598400 3600 0 +01}
}
diff --git a/library/tzdata/Africa/El_Aaiun b/library/tzdata/Africa/El_Aaiun
index 7bdc496..e0f5e1c 100644
--- a/library/tzdata/Africa/El_Aaiun
+++ b/library/tzdata/Africa/El_Aaiun
@@ -3,217 +3,47 @@
set TZData(:Africa/El_Aaiun) {
{-9223372036854775808 -3168 0 LMT}
{-1136070432 -3600 0 -01}
- {198291600 0 0 WET}
- {199756800 3600 1 WEST}
- {207702000 0 0 WET}
- {231292800 3600 1 WEST}
- {244249200 0 0 WET}
- {265507200 3600 1 WEST}
- {271033200 0 0 WET}
- {1212278400 3600 1 WEST}
- {1220223600 0 0 WET}
- {1243814400 3600 1 WEST}
- {1250809200 0 0 WET}
- {1272758400 3600 1 WEST}
- {1281222000 0 0 WET}
- {1301788800 3600 1 WEST}
- {1312066800 0 0 WET}
- {1335664800 3600 1 WEST}
- {1342749600 0 0 WET}
- {1345428000 3600 1 WEST}
- {1348970400 0 0 WET}
- {1367114400 3600 1 WEST}
- {1373162400 0 0 WET}
- {1376100000 3600 1 WEST}
- {1382839200 0 0 WET}
- {1396144800 3600 1 WEST}
- {1403920800 0 0 WET}
- {1406944800 3600 1 WEST}
- {1414288800 0 0 WET}
- {1427594400 3600 1 WEST}
- {1434247200 0 0 WET}
- {1437271200 3600 1 WEST}
- {1445738400 0 0 WET}
- {1459044000 3600 1 WEST}
- {1465092000 0 0 WET}
- {1468116000 3600 1 WEST}
- {1477792800 0 0 WET}
- {1490493600 3600 1 WEST}
- {1495332000 0 0 WET}
- {1498960800 3600 1 WEST}
- {1509242400 0 0 WET}
- {1521943200 3600 1 WEST}
- {1526176800 0 0 WET}
- {1529200800 3600 1 WEST}
- {1540692000 0 0 WET}
- {1553997600 3600 1 WEST}
- {1557021600 0 0 WET}
- {1560045600 3600 1 WEST}
- {1572141600 0 0 WET}
- {1585447200 3600 1 WEST}
- {1587261600 0 0 WET}
- {1590285600 3600 1 WEST}
- {1603591200 0 0 WET}
- {1616896800 3600 1 WEST}
- {1618106400 0 0 WET}
- {1621130400 3600 1 WEST}
- {1635645600 0 0 WET}
- {1651975200 3600 1 WEST}
- {1667095200 0 0 WET}
- {1682215200 3600 1 WEST}
- {1698544800 0 0 WET}
- {1713060000 3600 1 WEST}
- {1729994400 0 0 WET}
- {1743904800 3600 1 WEST}
- {1761444000 0 0 WET}
- {1774749600 3600 1 WEST}
- {1792893600 0 0 WET}
- {1806199200 3600 1 WEST}
- {1824948000 0 0 WET}
- {1837648800 3600 1 WEST}
- {1856397600 0 0 WET}
- {1869098400 3600 1 WEST}
- {1887847200 0 0 WET}
- {1901152800 3600 1 WEST}
- {1919296800 0 0 WET}
- {1932602400 3600 1 WEST}
- {1950746400 0 0 WET}
- {1964052000 3600 1 WEST}
- {1982800800 0 0 WET}
- {1995501600 3600 1 WEST}
- {2014250400 0 0 WET}
- {2026951200 3600 1 WEST}
- {2045700000 0 0 WET}
- {2058400800 3600 1 WEST}
- {2077149600 0 0 WET}
- {2090455200 3600 1 WEST}
- {2107994400 0 0 WET}
- {2108602800 0 0 WET}
- {2121904800 3600 1 WEST}
- {2138234400 0 0 WET}
- {2140052400 0 0 WET}
- {2153354400 3600 1 WEST}
- {2172103200 0 0 WET}
- {2184804000 3600 1 WEST}
- {2203552800 0 0 WET}
- {2216253600 3600 1 WEST}
- {2235002400 0 0 WET}
- {2248308000 3600 1 WEST}
- {2266452000 0 0 WET}
- {2279757600 3600 1 WEST}
- {2297901600 0 0 WET}
- {2311207200 3600 1 WEST}
- {2329351200 0 0 WET}
- {2342656800 3600 1 WEST}
- {2361405600 0 0 WET}
- {2374106400 3600 1 WEST}
- {2392855200 0 0 WET}
- {2405556000 3600 1 WEST}
- {2424304800 0 0 WET}
- {2437610400 3600 1 WEST}
- {2455754400 0 0 WET}
- {2469060000 3600 1 WEST}
- {2487204000 0 0 WET}
- {2500509600 3600 1 WEST}
- {2519258400 0 0 WET}
- {2531959200 3600 1 WEST}
- {2550708000 0 0 WET}
- {2563408800 3600 1 WEST}
- {2582157600 0 0 WET}
- {2595463200 3600 1 WEST}
- {2613607200 0 0 WET}
- {2626912800 3600 1 WEST}
- {2645056800 0 0 WET}
- {2658362400 3600 1 WEST}
- {2676506400 0 0 WET}
- {2689812000 3600 1 WEST}
- {2708560800 0 0 WET}
- {2721261600 3600 1 WEST}
- {2740010400 0 0 WET}
- {2752711200 3600 1 WEST}
- {2771460000 0 0 WET}
- {2784765600 3600 1 WEST}
- {2802909600 0 0 WET}
- {2816215200 3600 1 WEST}
- {2834359200 0 0 WET}
- {2847664800 3600 1 WEST}
- {2866413600 0 0 WET}
- {2879114400 3600 1 WEST}
- {2897863200 0 0 WET}
- {2910564000 3600 1 WEST}
- {2929312800 0 0 WET}
- {2942013600 3600 1 WEST}
- {2960762400 0 0 WET}
- {2974068000 3600 1 WEST}
- {2992212000 0 0 WET}
- {3005517600 3600 1 WEST}
- {3023661600 0 0 WET}
- {3036967200 3600 1 WEST}
- {3055716000 0 0 WET}
- {3068416800 3600 1 WEST}
- {3087165600 0 0 WET}
- {3099866400 3600 1 WEST}
- {3118615200 0 0 WET}
- {3131920800 3600 1 WEST}
- {3150064800 0 0 WET}
- {3163370400 3600 1 WEST}
- {3181514400 0 0 WET}
- {3194820000 3600 1 WEST}
- {3212964000 0 0 WET}
- {3226269600 3600 1 WEST}
- {3245018400 0 0 WET}
- {3257719200 3600 1 WEST}
- {3276468000 0 0 WET}
- {3289168800 3600 1 WEST}
- {3307917600 0 0 WET}
- {3321223200 3600 1 WEST}
- {3339367200 0 0 WET}
- {3352672800 3600 1 WEST}
- {3370816800 0 0 WET}
- {3384122400 3600 1 WEST}
- {3402871200 0 0 WET}
- {3415572000 3600 1 WEST}
- {3434320800 0 0 WET}
- {3447021600 3600 1 WEST}
- {3465770400 0 0 WET}
- {3479076000 3600 1 WEST}
- {3497220000 0 0 WET}
- {3510525600 3600 1 WEST}
- {3528669600 0 0 WET}
- {3541975200 3600 1 WEST}
- {3560119200 0 0 WET}
- {3573424800 3600 1 WEST}
- {3592173600 0 0 WET}
- {3604874400 3600 1 WEST}
- {3623623200 0 0 WET}
- {3636324000 3600 1 WEST}
- {3655072800 0 0 WET}
- {3668378400 3600 1 WEST}
- {3686522400 0 0 WET}
- {3699828000 3600 1 WEST}
- {3717972000 0 0 WET}
- {3731277600 3600 1 WEST}
- {3750026400 0 0 WET}
- {3762727200 3600 1 WEST}
- {3781476000 0 0 WET}
- {3794176800 3600 1 WEST}
- {3812925600 0 0 WET}
- {3825626400 3600 1 WEST}
- {3844375200 0 0 WET}
- {3857680800 3600 1 WEST}
- {3875824800 0 0 WET}
- {3889130400 3600 1 WEST}
- {3907274400 0 0 WET}
- {3920580000 3600 1 WEST}
- {3939328800 0 0 WET}
- {3952029600 3600 1 WEST}
- {3970778400 0 0 WET}
- {3983479200 3600 1 WEST}
- {4002228000 0 0 WET}
- {4015533600 3600 1 WEST}
- {4033677600 0 0 WET}
- {4046983200 3600 1 WEST}
- {4065127200 0 0 WET}
- {4078432800 3600 1 WEST}
- {4096576800 0 0 WET}
+ {198291600 0 0 +00}
+ {199756800 3600 1 +00}
+ {207702000 0 0 +00}
+ {231292800 3600 1 +00}
+ {244249200 0 0 +00}
+ {265507200 3600 1 +00}
+ {271033200 0 0 +00}
+ {1212278400 3600 1 +00}
+ {1220223600 0 0 +00}
+ {1243814400 3600 1 +00}
+ {1250809200 0 0 +00}
+ {1272758400 3600 1 +00}
+ {1281222000 0 0 +00}
+ {1301788800 3600 1 +00}
+ {1312066800 0 0 +00}
+ {1335664800 3600 1 +00}
+ {1342749600 0 0 +00}
+ {1345428000 3600 1 +00}
+ {1348970400 0 0 +00}
+ {1367114400 3600 1 +00}
+ {1373162400 0 0 +00}
+ {1376100000 3600 1 +00}
+ {1382839200 0 0 +00}
+ {1396144800 3600 1 +00}
+ {1403920800 0 0 +00}
+ {1406944800 3600 1 +00}
+ {1414288800 0 0 +00}
+ {1427594400 3600 1 +00}
+ {1434247200 0 0 +00}
+ {1437271200 3600 1 +00}
+ {1445738400 0 0 +00}
+ {1459044000 3600 1 +00}
+ {1465092000 0 0 +00}
+ {1468116000 3600 1 +00}
+ {1477792800 0 0 +00}
+ {1490493600 3600 1 +00}
+ {1495332000 0 0 +00}
+ {1498960800 3600 1 +00}
+ {1509242400 0 0 +00}
+ {1521943200 3600 1 +00}
+ {1526176800 0 0 +00}
+ {1529200800 3600 1 +00}
+ {1540598400 3600 0 +01}
}
diff --git a/library/tzdata/Pacific/Honolulu b/library/tzdata/Pacific/Honolulu
index 5e70598..7d03b45 100644
--- a/library/tzdata/Pacific/Honolulu
+++ b/library/tzdata/Pacific/Honolulu
@@ -4,8 +4,9 @@ set TZData(:Pacific/Honolulu) {
{-9223372036854775808 -37886 0 LMT}
{-2334101314 -37800 0 HST}
{-1157283000 -34200 1 HDT}
- {-1155436200 -37800 0 HST}
- {-880198200 -34200 1 HDT}
+ {-1155436200 -34200 0 HST}
+ {-880201800 -34200 1 HWT}
+ {-769395600 -34200 1 HPT}
{-765376200 -37800 0 HST}
{-712150200 -36000 0 HST}
}
diff --git a/macosx/GNUmakefile b/macosx/GNUmakefile
index 43f8419..45ea416 100644
--- a/macosx/GNUmakefile
+++ b/macosx/GNUmakefile
@@ -180,8 +180,10 @@ ifeq (${BUILD_STYLE}_${EMBEDDED_BUILD},Development_)
# Deployment build can be installed on top
# of Development build without overwriting
# the debug library
- @cd "${INSTALL_ROOT}${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION}" && \
- ln -f "${PRODUCT_NAME}" "${PRODUCT_NAME}_debug"
+ @if [ -d "${INSTALL_ROOT}${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION}" ]; then \
+ cd "${INSTALL_ROOT}${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION}"; \
+ ln -f "${PRODUCT_NAME}" "${PRODUCT_NAME}_debug"; \
+ fi
endif
clean-${PROJECT}: %-${PROJECT}:
diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c
index 3adc808..f09a441 100644
--- a/macosx/tclMacOSXFCmd.c
+++ b/macosx/tclMacOSXFCmd.c
@@ -692,24 +692,28 @@ UpdateStringOfOSType(
register Tcl_Obj *objPtr) /* OSType object whose string rep to
* update. */
{
- char string[5];
+ const int size = TCL_UTF_MAX * 4;
+ char *dst = Tcl_InitStringRep(objPtr, NULL, size);
OSType osType = (OSType) objPtr->internalRep.longValue;
- Tcl_DString ds;
- Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman");
- unsigned len;
-
- string[0] = (char) (osType >> 24);
- string[1] = (char) (osType >> 16);
- string[2] = (char) (osType >> 8);
- string[3] = (char) (osType);
- string[4] = '\0';
- Tcl_ExternalToUtfDString(encoding, string, -1, &ds);
- len = (unsigned) Tcl_DStringLength(&ds) + 1;
- objPtr->bytes = ckalloc(len);
- memcpy(objPtr->bytes, Tcl_DStringValue(&ds), len);
- objPtr->length = Tcl_DStringLength(&ds);
- Tcl_DStringFree(&ds);
+ int written = 0;
+ Tcl_Encoding encoding;
+ char src[5];
+
+ TclOOM(dst, size);
+
+ src[0] = (char) (osType >> 24);
+ src[1] = (char) (osType >> 16);
+ src[2] = (char) (osType >> 8);
+ src[3] = (char) (osType);
+ src[4] = '\0';
+
+ encoding = Tcl_GetEncoding(NULL, "macRoman");
+ Tcl_ExternalToUtf(NULL, encoding, src, -1, /* flags */ 0,
+ /* statePtr */ NULL, dst, size, /* srcReadPtr */ NULL,
+ /* dstWrotePtr */ &written, /* dstCharsPtr */ NULL);
Tcl_FreeEncoding(encoding);
+
+ (void)Tcl_InitStringRep(objPtr, NULL, written);
}
/*
diff --git a/tests/all.tcl b/tests/all.tcl
index e14bd9c..89a4f1a 100644
--- a/tests/all.tcl
+++ b/tests/all.tcl
@@ -22,5 +22,7 @@ if {[singleProcess]} {
interp debug {} -frame 1
}
-runAllTests
+set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)]
+unset -nocomplain env(ERROR_ON_FAILURES)
+if {[runAllTests] && $ErrorOnFailures} {exit 1}
proc exit args {}
diff --git a/tests/assemble.test b/tests/assemble.test
index d7c47a9..05c1f9b 100644
--- a/tests/assemble.test
+++ b/tests/assemble.test
@@ -12,7 +12,7 @@
# Commands covered: assemble
if {"::tcltest" ni [namespace children]} {
- package require tcltest 2.2
+ package require tcltest 2.5
namespace import -force ::tcltest::*
}
namespace eval tcl::unsupported {namespace export assemble}
@@ -852,10 +852,11 @@ test assemble-8.5 {bad context} {
-body {
namespace eval assem {
set x 1
- list [catch {assemble {load x}} result opts] $result [dict get $opts -errorcode]
+ assemble {load x}
}
}
- -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}}
+ -result {cannot use this instruction to create a variable in a non-proc context}
+ -errorCode {TCL ASSEM LVT}
-cleanup {namespace delete assem}
}
test assemble-8.6 {load1} {
@@ -1110,10 +1111,10 @@ test assemble-9.6 {concat} {
}
test assemble-9.7 {concat} {
-body {
- list [catch {assemble {concat 0}} result] $result $::errorCode
+ assemble {concat 0}
}
- -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
- -cleanup {unset result}
+ -result {operand must be positive}
+ -errorCode {TCL ASSEM POSITIVE}
}
# assemble-10 -- eval and expr
diff --git a/tests/binary.test b/tests/binary.test
index 54e8e94..7dc60ff 100644
--- a/tests/binary.test
+++ b/tests/binary.test
@@ -2720,6 +2720,46 @@ test binary-73.30 {binary decode base64} -body {
test binary-73.31 {binary decode base64} -body {
list [string length [set r [binary decode base64 WA==WFla]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
+test binary-73.32 {binary decode base64, bug [00d04c4f12]} -body {
+ list \
+ [string length [binary decode base64 =]] \
+ [string length [binary decode base64 " ="]] \
+ [string length [binary decode base64 " ="]] \
+ [string length [binary decode base64 "\r\n\t="]] \
+} -result [lrepeat 4 0]
+test binary-73.33 {binary decode base64, bug [00d04c4f12]} -body {
+ list \
+ [string length [binary decode base64 ==]] \
+ [string length [binary decode base64 " =="]] \
+ [string length [binary decode base64 " =="]] \
+ [string length [binary decode base64 " =="]] \
+} -result [lrepeat 4 0]
+test binary-73.34 {binary decode base64, (compatibility) unfulfilled base64 (single char) in non-strict mode} -body {
+ list \
+ [expr {[binary decode base64 a] eq [binary decode base64 ""]}] \
+ [expr {[binary decode base64 abcda] eq [binary decode base64 "abcd"]}]
+} -result [lrepeat 2 1]
+test binary-73.35 {binary decode base64, bad base64 in strict mode} -body {
+ set r {}
+ foreach c {a " a" " a" " a" " a" abcda abcdabcda a= a== abcda= abcda==} {
+ lappend r \
+ [catch {binary decode base64 $c}] \
+ [catch {binary decode base64 -strict $c}]
+ }
+ set r
+} -result [lrepeat 11 0 1]
+test binary-73.36 {binary decode base64: check encoded & decoded equals original} -body {
+ set r {}
+ for {set i 0} {$i < 255 && [llength $r] < 20} {incr i} {
+ foreach c {1 2 3 4 5 6 7 8} {
+ set c [string repeat [format %c $i] $c]
+ if {[set a [binary decode base64 [set x [binary encode base64 $c]]]] ne $c} {
+ lappend r "encode & decode is wrong on string `$c` (encoded: $x): `$a` != `$c`"
+ }
+ }
+ }
+ join $r \n
+} -result {}
test binary-74.1 {binary encode uuencode} -body {
binary encode uuencode
diff --git a/tests/clock.test b/tests/clock.test
index 4ec4db2..3ad5c9f 100644
--- a/tests/clock.test
+++ b/tests/clock.test
@@ -250,6 +250,16 @@ proc ::testClock::registry { cmd path key } {
return [dict get $reg $path $key]
}
+proc timeWithinDuration {duration start end} {
+ regexp {([\d.]+)(s|ms|us)} $duration -> duration unit
+ set delta [expr {$end - $start}]
+ expr {
+ ($delta > 0) && ($delta <= $duration) ?
+ "ok" :
+ "test should have taken 0-$duration $unit, actually took $delta"}
+}
+
+
# Test some of the basics of [clock format]
test clock-1.0 "clock format - wrong # args" {
@@ -35425,7 +35435,7 @@ test clock-33.2 {clock clicks tests} {
set start [clock clicks]
after 10
set end [clock clicks]
- expr "$end > $start"
+ expr {$end > $start}
} {1}
test clock-33.3 {clock clicks tests} {
list [catch {clock clicks foo} msg] $msg
@@ -35440,27 +35450,21 @@ test clock-33.4a {clock milliseconds} {
} {}
test clock-33.5 {clock clicks tests, millisecond timing test} {
# This test can fail on a system that is so heavily loaded that
- # the test takes >60 ms to run.
+ # the test takes >120 ms to run.
set start [clock clicks -milli]
after 10
set end [clock clicks -milli]
- # 60 msecs seems to be the max time slice under Windows 95/98
- expr {
- ($end > $start) && (($end - $start) <= 60) ?
- "ok" :
- "test should have taken 0-60 ms, actually took [expr $end - $start]"}
+ # 60 msecs seems to be the max time slice under Windows 95/98;
+ timeWithinDuration 120ms $start $end
} {ok}
test clock-33.5a {clock tests, millisecond timing test} {
# This test can fail on a system that is so heavily loaded that
- # the test takes >60 ms to run.
+ # the test takes >120 ms to run.
set start [clock milliseconds]
after 10
set end [clock milliseconds]
# 60 msecs seems to be the max time slice under Windows 95/98
- expr {
- ($end > $start) && (($end - $start) <= 60) ?
- "ok" :
- "test should have taken 0-60 ms, actually took [expr $end - $start]"}
+ timeWithinDuration 120ms $start $end
} {ok}
test clock-33.6 {clock clicks, milli with too much abbreviation} {
list [catch { clock clicks ? } msg] $msg
@@ -35471,20 +35475,20 @@ test clock-33.7 {clock clicks, milli with too much abbreviation} {
test clock-33.8 {clock clicks test, microsecond timing test} {
# This test can fail on a system that is so heavily loaded that
- # the test takes >60 ms to run.
+ # the test takes >120 ms to run.
set start [clock clicks -micro]
after 10
set end [clock clicks -micro]
- expr {($end > $start) && (($end - $start) <= 60000)}
-} {1}
+ timeWithinDuration 120000us $start $end
+} {ok}
test clock-33.8a {clock test, microsecond timing test} {
# This test can fail on a system that is so heavily loaded that
- # the test takes >60 ms to run.
+ # the test takes >120 ms to run.
set start [clock microseconds]
after 10
set end [clock microseconds]
- expr {($end > $start) && (($end - $start) <= 60000)}
-} {1}
+ timeWithinDuration 120000us $start $end
+} {ok}
test clock-33.9 {clock clicks test, millis align with seconds} {
set t1 [clock seconds]
@@ -35826,7 +35830,7 @@ test clock-35.3 {clock seconds tests} {
set start [clock seconds]
after 2000
set end [clock seconds]
- expr "$end > $start"
+ expr {$end > $start}
} {1}
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index e8933d6..88c0367 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -566,6 +566,13 @@ test cmdAH-9.51 {Tcl_FileObjCmd: tail} testsetplatform {
testsetplatform windows
file tail {foo\bar}
} bar
+test cmdAH-9.52 {Tcl_FileObjCmd: tail / normalize, bug 7a9dc52b29} {
+ list \
+ [file tail {~/~foo}] \
+ [file tail {~/test/~foo}] \
+ [file tail [file normalize {~/~foo}]] \
+ [file tail [file normalize {~/test/~foo}]]
+} [lrepeat 4 ./~foo]
# rootname
test cmdAH-10.1 {Tcl_FileObjCmd: rootname} -returnCodes error -body {
diff --git a/tests/dict.test b/tests/dict.test
index a6b0cb4..904ec53 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -10,7 +10,7 @@
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
+ package require tcltest 2.5
namespace import -force ::tcltest::*
}
@@ -175,11 +175,7 @@ test dict-4.12 {dict replace command: canonicality is forced} {
} {a e c d}
test dict-4.13 {dict replace command: type check is mandatory} -body {
dict replace { a b c d e }
-} -returnCodes error -result {missing value to go with key}
-test dict-4.13a {dict replace command: type check is mandatory} {
- catch {dict replace { a b c d e }} -> opt
- dict get $opt -errorcode
-} {TCL VALUE DICTIONARY}
+} -errorCode {TCL VALUE DICTIONARY} -result {missing value to go with key}
test dict-4.14 {dict replace command: type check is mandatory} -body {
dict replace { a b {}c d }
} -returnCodes error -result {dict element in braces followed by "c" instead of space}
@@ -203,11 +199,7 @@ test dict-4.16a {dict replace command: type check is mandatory} {
} {TCL VALUE DICTIONARY QUOTE}
test dict-4.17 {dict replace command: type check is mandatory} -body {
dict replace " a b \{c d "
-} -returnCodes error -result {unmatched open brace in dict}
-test dict-4.17a {dict replace command: type check is mandatory} {
- catch {dict replace " a b \{c d "} -> opt
- dict get $opt -errorcode
-} {TCL VALUE DICTIONARY BRACE}
+} -errorCode {TCL VALUE DICTIONARY BRACE} -result {unmatched open brace in dict}
test dict-4.18 {dict replace command: canonicality forcing doesn't leak} {
set example { a b c d }
list $example [dict replace $example]
diff --git a/tests/event.test b/tests/event.test
index ef0947f..5c111f8 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -527,7 +527,7 @@ test event-11.4 {Tcl_VwaitCmd procedure} -setup {
} -body {
after 100 {set x x-done}
after 200 {set y y-done}
- after 300 {set z z-done}
+ after 400 {set z z-done}
after idle {set q q-done}
set x before
set y before
diff --git a/tests/http.test b/tests/http.test
index b6a7251..cf30348 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -82,7 +82,7 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} {
test http-1.1 {http::config} {
http::config -useragent UserAgent
http::config
-} [list -accept */* -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1]
+} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1]
test http-1.2 {http::config} {
http::config -proxyfilter
} http::ProxyRequired
@@ -97,10 +97,10 @@ test http-1.4 {http::config} {
set x [http::config]
http::config {*}$savedconf
set x
-} {-accept */* -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1}
+} {-accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1}
test http-1.5 {http::config} -returnCodes error -body {
http::config -proxyhost {} -junk 8080
-} -result {Unknown option -junk, must be: -accept, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip}
+} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip}
test http-1.6 {http::config} -setup {
set oldenc [http::config -urlencoding]
} -body {
@@ -670,6 +670,451 @@ test http-7.4 {http::formatQuery} -setup {
http::config -urlencoding $enc
} -result {%3F}
+package require -exact tcl::idna 1.0
+
+test http-idna-1.1 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna
+} -result {wrong # args: should be "::tcl::idna subcommand ?arg ...?"}
+test http-idna-1.2 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna ?
+} -result {unknown or ambiguous subcommand "?": must be decode, encode, puny, or version}
+test http-idna-1.3 {IDNA package: basics} -body {
+ ::tcl::idna version
+} -result 1.0
+test http-idna-1.4 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna version what
+} -result {wrong # args: should be "::tcl::idna version"}
+test http-idna-1.5 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny
+} -result {wrong # args: should be "::tcl::idna puny subcommand ?arg ...?"}
+test http-idna-1.6 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny ?
+} -result {unknown or ambiguous subcommand "?": must be decode, or encode}
+test http-idna-1.7 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny encode
+} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"}
+test http-idna-1.8 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny encode a b c
+} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"}
+test http-idna-1.9 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny decode
+} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"}
+test http-idna-1.10 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny decode a b c
+} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"}
+test http-idna-1.11 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna decode
+} -result {wrong # args: should be "::tcl::idna decode hostname"}
+test http-idna-1.12 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna encode
+} -result {wrong # args: should be "::tcl::idna encode hostname"}
+
+test http-idna-2.1 {puny encode: functional test} {
+ ::tcl::idna puny encode abc
+} abc-
+test http-idna-2.2 {puny encode: functional test} {
+ ::tcl::idna puny encode a\u20acb\u20acc
+} abc-k50ab
+test http-idna-2.3 {puny encode: functional test} {
+ ::tcl::idna puny encode ABC
+} ABC-
+test http-idna-2.4 {puny encode: functional test} {
+ ::tcl::idna puny encode A\u20ACB\u20ACC
+} ABC-k50ab
+test http-idna-2.5 {puny encode: functional test} {
+ ::tcl::idna puny encode ABC 0
+} abc-
+test http-idna-2.6 {puny encode: functional test} {
+ ::tcl::idna puny encode A\u20ACB\u20ACC 0
+} abc-k50ab
+test http-idna-2.7 {puny encode: functional test} {
+ ::tcl::idna puny encode ABC 1
+} ABC-
+test http-idna-2.8 {puny encode: functional test} {
+ ::tcl::idna puny encode A\u20ACB\u20ACC 1
+} ABC-k50ab
+test http-idna-2.9 {puny encode: functional test} {
+ ::tcl::idna puny encode abc 0
+} abc-
+test http-idna-2.10 {puny encode: functional test} {
+ ::tcl::idna puny encode a\u20ACb\u20ACc 0
+} abc-k50ab
+test http-idna-2.11 {puny encode: functional test} {
+ ::tcl::idna puny encode abc 1
+} ABC-
+test http-idna-2.12 {puny encode: functional test} {
+ ::tcl::idna puny encode a\u20ACb\u20ACc 1
+} ABC-k50ab
+test http-idna-2.13 {puny encode: edge cases} {
+ ::tcl::idna puny encode ""
+} ""
+test http-idna-2.14-A {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644
+ u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F
+ }]] ""]
+} egbpdaj6bu4bxfgehfvwxn
+test http-idna-2.14-B {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587
+ }]] ""]
+} ihqwcrb4cv8a8dqg056pqjye
+test http-idna-2.14-C {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587
+ }]] ""]
+} ihqwctvzc91f659drss3x8bo0yb
+test http-idna-2.14-D {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074
+ u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D
+ u+0065 u+0073 u+006B u+0079
+ }]] ""]
+} Proprostnemluvesky-uyb24dma41a
+test http-idna-2.14-E {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8
+ u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2
+ u+05D1 u+05E8 u+05D9 u+05EA
+ }]] ""]
+} 4dbcagdahymbxekheh6e0a7fei0b
+test http-idna-2.14-F {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D
+ u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939
+ u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947
+ u+0939 u+0948 u+0902
+ }]] ""]
+} i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd
+test http-idna-2.14-G {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092
+ u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B
+ }]] ""]
+} n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa
+test http-idna-2.14-H {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774
+ u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74
+ u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C
+ }]] ""]
+} 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c
+test http-idna-2.14-I {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E
+ u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440
+ u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A
+ u+0438
+ }]] ""]
+} b1abfaaepdrnnbgefbadotcwatmq2g4l
+test http-idna-2.14-J {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070
+ u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070
+ u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061
+ u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070
+ u+0061 u+00F1 u+006F u+006C
+ }]] ""]
+} PorqunopuedensimplementehablarenEspaol-fmd56a
+test http-idna-2.14-K {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B
+ u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068
+ u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067
+ u+0056 u+0069 u+1EC7 u+0074
+ }]] ""]
+} TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g
+test http-idna-2.14-L {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F
+ }]] ""]
+} 3B-ww4c5e180e575a65lsy2b
+test http-idna-2.14-M {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074
+ u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D
+ u+004F u+004E u+004B u+0045 u+0059 u+0053
+ }]] ""]
+} -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n
+test http-idna-2.14-N {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F
+ u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D
+ u+305D u+308C u+305E u+308C u+306E u+5834 u+6240
+ }]] ""]
+} Hello-Another-Way--fc4qua05auwb3674vfr0b
+test http-idna-2.14-O {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032
+ }]] ""]
+} 2-u9tlzr9756bt3uc0v
+test http-idna-2.14-P {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059
+ u+308B u+0035 u+79D2 u+524D
+ }]] ""]
+} MajiKoi5-783gue6qz075azm5e
+test http-idna-2.14-Q {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0
+ }]] ""]
+} de-jg4avhby1noc0d
+test http-idna-2.14-R {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067
+ }]] ""]
+} d9juau41awczczp
+test http-idna-2.14-S {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode {-> $1.00 <-}
+} {-> $1.00 <--}
+
+test http-idna-3.1 {puny decode: functional test} {
+ ::tcl::idna puny decode abc-
+} abc
+test http-idna-3.2 {puny decode: functional test} {
+ ::tcl::idna puny decode abc-k50ab
+} a\u20acb\u20acc
+test http-idna-3.3 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-
+} ABC
+test http-idna-3.4 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-k50ab
+} A\u20ACB\u20ACC
+test http-idna-3.5 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-K50AB
+} A\u20ACB\u20ACC
+test http-idna-3.6 {puny decode: functional test} {
+ ::tcl::idna puny decode abc-K50AB
+} a\u20ACb\u20ACc
+test http-idna-3.7 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC- 0
+} abc
+test http-idna-3.8 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-K50AB 0
+} a\u20ACb\u20ACc
+test http-idna-3.9 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC- 1
+} ABC
+test http-idna-3.10 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-K50AB 1
+} A\u20ACB\u20ACC
+test http-idna-3.11 {puny decode: functional test} {
+ ::tcl::idna puny decode abc- 0
+} abc
+test http-idna-3.12 {puny decode: functional test} {
+ ::tcl::idna puny decode abc-k50ab 0
+} a\u20ACb\u20ACc
+test http-idna-3.13 {puny decode: functional test} {
+ ::tcl::idna puny decode abc- 1
+} ABC
+test http-idna-3.14 {puny decode: functional test} {
+ ::tcl::idna puny decode abc-k50ab 1
+} A\u20ACB\u20ACC
+test http-idna-3.15 {puny decode: edge cases and errors} {
+ # Is this case actually correct?
+ binary encode hex [encoding convertto utf-8 [::tcl::idna puny decode abc]]
+} c282c281c280
+test http-idna-3.16 {puny decode: edge cases and errors} -returnCodes error -body {
+ ::tcl::idna puny decode abc!
+} -result {bad decode character "!"}
+test http-idna-3.17 {puny decode: edge cases and errors} {
+ catch {::tcl::idna puny decode abc!} -> opt
+ dict get $opt -errorcode
+} {PUNYCODE BAD_INPUT CHAR}
+test http-idna-3.18 {puny decode: edge cases and errors} {
+ ::tcl::idna puny decode ""
+} {}
+# A helper so we don't get lots of crap in failures
+proc hexify s {lmap c [split $s ""] {format u+%04X [scan $c %c]}}
+test http-idna-3.19-A {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode egbpdaj6bu4bxfgehfvwxn]
+} [list {*}{
+ u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644
+ u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F
+}]
+test http-idna-3.19-B {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode ihqwcrb4cv8a8dqg056pqjye]
+} {u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587}
+test http-idna-3.19-C {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode ihqwctvzc91f659drss3x8bo0yb]
+} {u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587}
+test http-idna-3.19-D {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode Proprostnemluvesky-uyb24dma41a]
+} [list {*}{
+ u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074
+ u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D
+ u+0065 u+0073 u+006B u+0079
+}]
+test http-idna-3.19-E {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode 4dbcagdahymbxekheh6e0a7fei0b]
+} [list {*}{
+ u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8
+ u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2
+ u+05D1 u+05E8 u+05D9 u+05EA
+}]
+test http-idna-3.19-F {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode \
+ i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd]
+} [list {*}{
+ u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D
+ u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939
+ u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947
+ u+0939 u+0948 u+0902
+}]
+test http-idna-3.19-G {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa]
+} [list {*}{
+ u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092
+ u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B
+}]
+test http-idna-3.19-H {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode \
+ 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c]
+} [list {*}{
+ u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774
+ u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74
+ u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C
+}]
+test http-idna-3.19-I {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode b1abfaaepdrnnbgefbadotcwatmq2g4l]
+} [list {*}{
+ u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E
+ u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440
+ u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A
+ u+0438
+}]
+test http-idna-3.19-J {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode \
+ PorqunopuedensimplementehablarenEspaol-fmd56a]
+} [list {*}{
+ u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070
+ u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070
+ u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061
+ u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070
+ u+0061 u+00F1 u+006F u+006C
+}]
+test http-idna-3.19-K {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode \
+ TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g]
+} [list {*}{
+ u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B
+ u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068
+ u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067
+ u+0056 u+0069 u+1EC7 u+0074
+}]
+test http-idna-3.19-L {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode 3B-ww4c5e180e575a65lsy2b]
+} {u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F}
+test http-idna-3.19-M {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n]
+} [list {*}{
+ u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074
+ u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D
+ u+004F u+004E u+004B u+0045 u+0059 u+0053
+}]
+test http-idna-3.19-N {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode Hello-Another-Way--fc4qua05auwb3674vfr0b]
+} [list {*}{
+ u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F
+ u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D
+ u+305D u+308C u+305E u+308C u+306E u+5834 u+6240
+}]
+test http-idna-3.19-O {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode 2-u9tlzr9756bt3uc0v]
+} {u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032}
+test http-idna-3.19-P {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode MajiKoi5-783gue6qz075azm5e]
+} [list {*}{
+ u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059
+ u+308B u+0035 u+79D2 u+524D
+}]
+test http-idna-3.19-Q {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode de-jg4avhby1noc0d]
+} {u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0}
+test http-idna-3.19-R {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode d9juau41awczczp]
+} {u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067}
+test http-idna-3.19-S {puny decode: examples from RFC 3492} {
+ ::tcl::idna puny decode {-> $1.00 <--}
+} {-> $1.00 <-}
+rename hexify ""
+
+test http-idna-4.1 {IDNA encoding} {
+ ::tcl::idna encode abc.def
+} abc.def
+test http-idna-4.2 {IDNA encoding} {
+ ::tcl::idna encode a\u20acb\u20acc.def
+} xn--abc-k50ab.def
+test http-idna-4.3 {IDNA encoding} {
+ ::tcl::idna encode def.a\u20acb\u20acc
+} def.xn--abc-k50ab
+test http-idna-4.4 {IDNA encoding} {
+ ::tcl::idna encode ABC.DEF
+} ABC.DEF
+test http-idna-4.5 {IDNA encoding} {
+ ::tcl::idna encode A\u20acB\u20acC.def
+} xn--ABC-k50ab.def
+test http-idna-4.6 {IDNA encoding: invalid edge case} {
+ # Should this be an error?
+ ::tcl::idna encode abc..def
+} abc..def
+test http-idna-4.7 {IDNA encoding: invalid char} -returnCodes error -body {
+ ::tcl::idna encode abc.$.def
+} -result {bad character "$" in DNS name}
+test http-idna-4.7.1 {IDNA encoding: invalid char} {
+ catch {::tcl::idna encode abc.$.def} -> opt
+ dict get $opt -errorcode
+} {IDNA INVALID_NAME_CHARACTER {$}}
+test http-idna-4.8 {IDNA encoding: empty} {
+ ::tcl::idna encode ""
+} {}
+set overlong www.[join [subst [string map {u+ \\u} {
+ u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774
+ u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74
+ u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C
+}]] ""].com
+test http-idna-4.9 {IDNA encoding: max lengths from RFC 5890} -body {
+ ::tcl::idna encode $overlong
+} -returnCodes error -result "hostname part too long"
+test http-idna-4.9.1 {IDNA encoding: max lengths from RFC 5890} {
+ catch {::tcl::idna encode $overlong} -> opt
+ dict get $opt -errorcode
+} {IDNA OVERLONG_PART xn--989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c}
+unset overlong
+test http-idna-4.10 {IDNA encoding: edge cases} {
+ ::tcl::idna encode pass\u00e9.example.com
+} xn--pass-epa.example.com
+
+test http-idna-5.1 {IDNA decoding} {
+ ::tcl::idna decode abc.def
+} abc.def
+test http-idna-5.2 {IDNA decoding} {
+ # Invalid entry that's just a wrapper
+ ::tcl::idna decode xn--abc-.def
+} abc.def
+test http-idna-5.3 {IDNA decoding} {
+ # Invalid entry that's just a wrapper
+ ::tcl::idna decode xn--abc-.xn--def-
+} abc.def
+test http-idna-5.4 {IDNA decoding} {
+ # Invalid entry that's just a wrapper
+ ::tcl::idna decode XN--abc-.XN--def-
+} abc.def
+test http-idna-5.5 {IDNA decoding: error cases} -returnCodes error -body {
+ ::tcl::idna decode xn--$$$.example.com
+} -result {bad decode character "$"}
+test http-idna-5.5.1 {IDNA decoding: error cases} {
+ catch {::tcl::idna decode xn--$$$.example.com} -> opt
+ dict get $opt -errorcode
+} {PUNYCODE BAD_INPUT CHAR}
+test http-idna-5.6 {IDNA decoding: error cases} -returnCodes error -body {
+ ::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def
+} -result {exceeded input data}
+test http-idna-5.6.1 {IDNA decoding: error cases} {
+ catch {::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def} -> opt
+ dict get $opt -errorcode
+} {PUNYCODE BAD_INPUT LENGTH}
+
# cleanup
catch {unset url}
catch {unset badurl}
diff --git a/tests/httpcookie.test b/tests/httpcookie.test
new file mode 100644
index 0000000..8835791
--- /dev/null
+++ b/tests/httpcookie.test
@@ -0,0 +1,874 @@
+# Commands covered: http::cookiejar
+#
+# This file contains a collection of tests for the cookiejar package.
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2014 Donal K. Fellows.
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require tcltest 2
+namespace import -force ::tcltest::*
+
+testConstraint notOSXtravis [apply {{} {
+ upvar 1 env(TRAVIS_OSX_IMAGE) travis
+ return [expr {![info exists travis] || ![string match xcode* $travis]}]
+}}]
+testConstraint sqlite3 [expr {[testConstraint notOSXtravis] && ![catch {
+ package require sqlite3
+}]}]
+testConstraint cookiejar [expr {[testConstraint sqlite3] && ![catch {
+ package require cookiejar
+}]}]
+
+set COOKIEJAR_VERSION 0.1
+test http-cookiejar-1.1 "cookie storage: packaging" {notOSXtravis sqlite3 cookiejar} {
+ package require cookiejar
+} $COOKIEJAR_VERSION
+test http-cookiejar-1.2 "cookie storage: packaging" {notOSXtravis sqlite3 cookiejar} {
+ package require cookiejar
+ package require cookiejar
+} $COOKIEJAR_VERSION
+
+test http-cookiejar-2.1 "cookie storage: basics" -constraints {
+ notOSXtravis sqlite3 cookiejar
+} -returnCodes error -body {
+ http::cookiejar
+} -result {wrong # args: should be "http::cookiejar method ?arg ...?"}
+test http-cookiejar-2.2 "cookie storage: basics" -constraints {
+ notOSXtravis sqlite3 cookiejar
+} -returnCodes error -body {
+ http::cookiejar ?
+} -result {unknown method "?": must be configure, create, destroy or new}
+test http-cookiejar-2.3 "cookie storage: basics" -constraints {
+ notOSXtravis sqlite3 cookiejar
+} -body {
+ http::cookiejar configure
+} -result {-domainfile -domainlist -domainrefresh -loglevel -offline -purgeold -retain -vacuumtrigger}
+test http-cookiejar-2.4 "cookie storage: basics" -constraints {
+ notOSXtravis sqlite3 cookiejar
+} -returnCodes error -body {
+ http::cookiejar configure a b c d e
+} -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"}
+test http-cookiejar-2.5 "cookie storage: basics" -constraints {
+ notOSXtravis sqlite3 cookiejar
+} -returnCodes error -body {
+ http::cookiejar configure a
+} -result {bad option "a": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger}
+test http-cookiejar-2.6 "cookie storage: basics" -constraints {
+ notOSXtravis sqlite3 cookiejar
+} -returnCodes error -body {
+ http::cookiejar configure -d
+} -result {ambiguous option "-d": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger}
+test http-cookiejar-2.7 "cookie storage: basics" -setup {
+ set old [http::cookiejar configure -loglevel]
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ list [http::cookiejar configure -loglevel] \
+ [http::cookiejar configure -loglevel debug] \
+ [http::cookiejar configure -loglevel] \
+ [http::cookiejar configure -loglevel error] \
+ [http::cookiejar configure -loglevel]
+} -cleanup {
+ http::cookiejar configure -loglevel $old
+} -result {info debug debug error error}
+test http-cookiejar-2.8 "cookie storage: basics" -setup {
+ set old [http::cookiejar configure -loglevel]
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ list [http::cookiejar configure -loglevel] \
+ [http::cookiejar configure -loglevel d] \
+ [http::cookiejar configure -loglevel i] \
+ [http::cookiejar configure -loglevel w] \
+ [http::cookiejar configure -loglevel e]
+} -cleanup {
+ http::cookiejar configure -loglevel $old
+} -result {info debug info warn error}
+test http-cookiejar-2.9 "cookie storage: basics" -body {
+ http::cookiejar configure -off
+} -constraints {notOSXtravis sqlite3 cookiejar} -match glob -result *
+test http-cookiejar-2.10 "cookie storage: basics" -setup {
+ set oldval [http::cookiejar configure -offline]
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ http::cookiejar configure -offline true
+} -cleanup {
+ catch {http::cookiejar configure -offline $oldval}
+} -result 1
+test http-cookiejar-2.11 "cookie storage: basics" -setup {
+ set oldval [http::cookiejar configure -offline]
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ http::cookiejar configure -offline nonbool
+} -cleanup {
+ catch {http::cookiejar configure -offline $oldval}
+} -returnCodes error -result {expected boolean value but got "nonbool"}
+test http-cookiejar-2.12 "cookie storage: basics" -setup {
+ set oldval [http::cookiejar configure -purgeold]
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ http::cookiejar configure -purge nonint
+} -cleanup {
+ catch {http::cookiejar configure -purgeold $oldval}
+} -returnCodes error -result {expected positive integer but got "nonint"}
+test http-cookiejar-2.13 "cookie storage: basics" -setup {
+ set oldval [http::cookiejar configure -domainrefresh]
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ http::cookiejar configure -domainref nonint
+} -cleanup {
+ catch {http::cookiejar configure -domainrefresh $oldval}
+} -returnCodes error -result {expected positive integer but got "nonint"}
+test http-cookiejar-2.14 "cookie storage: basics" -setup {
+ set oldval [http::cookiejar configure -domainrefresh]
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ http::cookiejar configure -domainref -42
+} -cleanup {
+ catch {http::cookiejar configure -domainrefresh $oldval}
+} -returnCodes error -result {expected positive integer but got "-42"}
+test http-cookiejar-2.15 "cookie storage: basics" -setup {
+ set oldval [http::cookiejar configure -domainrefresh]
+ set result unset
+ set tracer [http::cookiejar create tracer]
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ oo::objdefine $tracer method PostponeRefresh {} {
+ set ::result set
+ next
+ }
+ http::cookiejar configure -domainref 12345
+ return $result
+} -cleanup {
+ $tracer destroy
+ catch {http::cookiejar configure -domainrefresh $oldval}
+} -result set
+
+test http-cookiejar-3.1 "cookie storage: class" {notOSXtravis sqlite3 cookiejar} {
+ info object isa object http::cookiejar
+} 1
+test http-cookiejar-3.2 "cookie storage: class" {notOSXtravis sqlite3 cookiejar} {
+ info object isa class http::cookiejar
+} 1
+test http-cookiejar-3.3 "cookie storage: class" {notOSXtravis sqlite3 cookiejar} {
+ lsort [info object methods http::cookiejar]
+} {configure}
+test http-cookiejar-3.4 "cookie storage: class" {notOSXtravis sqlite3 cookiejar} {
+ lsort [info object methods http::cookiejar -all]
+} {configure create destroy new}
+test http-cookiejar-3.5 "cookie storage: class" -setup {
+ catch {rename ::cookiejar ""}
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ namespace eval :: {http::cookiejar create cookiejar}
+} -cleanup {
+ catch {rename ::cookiejar ""}
+} -result ::cookiejar
+test http-cookiejar-3.6 "cookie storage: class" -setup {
+ catch {rename ::cookiejar ""}
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ list [http::cookiejar create ::cookiejar] [info commands ::cookiejar] \
+ [::cookiejar destroy] [info commands ::cookiejar]
+} -cleanup {
+ catch {rename ::cookiejar ""}
+} -result {::cookiejar ::cookiejar {} {}}
+test http-cookiejar-3.7 "cookie storage: class" -setup {
+ catch {rename ::cookiejar ""}
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ http::cookiejar create ::cookiejar foo bar
+} -returnCodes error -cleanup {
+ catch {rename ::cookiejar ""}
+} -result {wrong # args: should be "http::cookiejar create ::cookiejar ?path?"}
+test http-cookiejar-3.8 "cookie storage: class" -setup {
+ catch {rename ::cookiejar ""}
+ set f [makeFile "" cookiejar]
+ file delete $f
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ list [file exists $f] [http::cookiejar create ::cookiejar $f] \
+ [file exists $f]
+} -cleanup {
+ catch {rename ::cookiejar ""}
+ removeFile $f
+} -result {0 ::cookiejar 1}
+test http-cookiejar-3.9 "cookie storage: class" -setup {
+ catch {rename ::cookiejar ""}
+ set f [makeFile "bogus content for a database" cookiejar]
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ http::cookiejar create ::cookiejar $f
+} -returnCodes error -cleanup {
+ catch {rename ::cookiejar ""}
+ removeFile $f
+} -match glob -result *
+test http-cookiejar-3.10 "cookie storage: class" -setup {
+ catch {rename ::cookiejar ""}
+ set dir [makeDirectory cookiejar]
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ http::cookiejar create ::cookiejar $dir
+} -returnCodes error -cleanup {
+ catch {rename ::cookiejar ""}
+ removeDirectory $dir
+} -match glob -result *
+
+test http-cookiejar-4.1 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar
+} -returnCodes error -cleanup {
+ ::cookiejar destroy
+} -result {wrong # args: should be "cookiejar method ?arg ...?"}
+test http-cookiejar-4.2 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar ?
+} -returnCodes error -cleanup {
+ ::cookiejar destroy
+} -result {unknown method "?": must be destroy, forceLoadDomainData, getCookies, lookup, policyAllow or storeCookie}
+test http-cookiejar-4.3 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ lsort [info object methods cookiejar -all]
+} -cleanup {
+ ::cookiejar destroy
+} -result {destroy forceLoadDomainData getCookies lookup policyAllow storeCookie}
+test http-cookiejar-4.4 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar getCookies
+} -returnCodes error -cleanup {
+ ::cookiejar destroy
+} -result {wrong # args: should be "cookiejar getCookies proto host path"}
+test http-cookiejar-4.5 "cookie storage" -setup {
+ http::cookiejar create ::cookiejar
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar getCookies http www.example.com /
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-4.6 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar storeCookie
+} -returnCodes error -cleanup {
+ ::cookiejar destroy
+} -result {wrong # args: should be "cookiejar storeCookie options"}
+test http-cookiejar-4.7 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-4.8 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine ::cookiejar export Database
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ # Poke inside implementation!
+ cookiejar Database eval {SELECT count(*) FROM sessionCookies}
+} -cleanup {
+ ::cookiejar destroy
+} -result 1
+test http-cookiejar-4.9 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine ::cookiejar export Database
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ # Poke inside implementation!
+ cookiejar Database eval {SELECT count(*) FROM persistentCookies}
+} -cleanup {
+ ::cookiejar destroy
+} -result 0
+test http-cookiejar-4.10 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-4.11 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine ::cookiejar export Database
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+ # Poke inside implementation!
+ cookiejar Database eval {SELECT count(*) FROM sessionCookies}
+} -cleanup {
+ ::cookiejar destroy
+} -result 0
+test http-cookiejar-4.12 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine ::cookiejar export Database
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+ # Poke inside implementation!
+ cookiejar Database eval {SELECT count(*) FROM persistentCookies}
+} -cleanup {
+ ::cookiejar destroy
+} -result 1
+test http-cookiejar-4.13 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ lappend result [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ lappend result [cookiejar getCookies http www.example.com /]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{} {foo bar}}
+test http-cookiejar-4.14 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ lappend result [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+ lappend result [cookiejar getCookies http www.example.com /]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{} {foo bar}}
+test http-cookiejar-4.15 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ lappend result [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+ lappend result [cookiejar getCookies http www.example.com /]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{} {foo bar}}
+test http-cookiejar-4.16 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ lappend result [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo1
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie [dict replace {
+ key foo2
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+ lappend result [lsort -stride 2 [cookiejar getCookies http www.example.com /]]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{} {foo1 bar foo2 bar}}
+test http-cookiejar-4.17 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar lookup a b c d
+} -returnCodes error -cleanup {
+ ::cookiejar destroy
+} -result {wrong # args: should be "cookiejar lookup ?host? ?key?"}
+test http-cookiejar-4.18 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ lappend result [cookiejar lookup]
+ lappend result [cookiejar lookup www.example.com]
+ lappend result [catch {cookiejar lookup www.example.com foo} value] $value
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ lappend result [cookiejar lookup]
+ lappend result [cookiejar lookup www.example.com]
+ lappend result [cookiejar lookup www.example.com foo]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{} {} 1 {no such key for that host} www.example.com foo bar}
+test http-cookiejar-4.19 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key bar
+ value foo
+ secure 0
+ domain www.example.org
+ origin www.example.org
+ path /
+ hostonly 1
+ }
+ lappend result [lsort [cookiejar lookup]]
+ lappend result [cookiejar lookup www.example.com]
+ lappend result [cookiejar lookup www.example.com foo]
+ lappend result [cookiejar lookup www.example.org]
+ lappend result [cookiejar lookup www.example.org bar]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{www.example.com www.example.org} foo bar bar foo}
+test http-cookiejar-4.20 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar storeCookie {
+ key foo1
+ value bar1
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie [dict replace {
+ key foo2
+ value bar2
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+ lappend result [cookiejar lookup]
+ lappend result [lsort [cookiejar lookup www.example.com]]
+ lappend result [cookiejar lookup www.example.com foo1]
+ lappend result [cookiejar lookup www.example.com foo2]
+} -cleanup {
+ ::cookiejar destroy
+} -result {www.example.com {foo1 foo2} bar1 bar2}
+test http-cookiejar-4.21 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar storeCookie {
+ key foo1
+ value bar1
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo2
+ value bar2
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ lappend result [cookiejar lookup]
+ lappend result [lsort [cookiejar lookup www.example.com]]
+ lappend result [cookiejar lookup www.example.com foo1]
+ lappend result [cookiejar lookup www.example.com foo2]
+} -cleanup {
+ ::cookiejar destroy
+} -result {www.example.com {foo1 foo2} bar1 bar2}
+test http-cookiejar-4.22 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar forceLoadDomainData x y z
+} -returnCodes error -cleanup {
+ ::cookiejar destroy
+} -result {wrong # args: should be "cookiejar forceLoadDomainData"}
+test http-cookiejar-4.23 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar forceLoadDomainData
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-4.23.a {cookie storage: instance} -setup {
+ set off [http::cookiejar configure -offline]
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ http::cookiejar configure -offline 1
+ [http::cookiejar create ::cookiejar] destroy
+} -cleanup {
+ catch {::cookiejar destroy}
+ http::cookiejar configure -offline $off
+} -result {}
+test http-cookiejar-4.23.b {cookie storage: instance} -setup {
+ set off [http::cookiejar configure -offline]
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ http::cookiejar configure -offline 0
+ [http::cookiejar create ::cookiejar] destroy
+} -cleanup {
+ catch {::cookiejar destroy}
+ http::cookiejar configure -offline $off
+} -result {}
+
+test http-cookiejar-5.1 "cookie storage: constraints" -setup {
+ http::cookiejar create ::cookiejar
+ cookiejar forceLoadDomainData
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain com
+ origin com
+ path /
+ hostonly 1
+ }
+ cookiejar lookup
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-5.2 "cookie storage: constraints" -setup {
+ http::cookiejar create ::cookiejar
+ cookiejar forceLoadDomainData
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain foo.example.com
+ origin bar.example.org
+ path /
+ hostonly 1
+ }
+ cookiejar lookup
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-5.3 "cookie storage: constraints" -setup {
+ http::cookiejar create ::cookiejar
+ cookiejar forceLoadDomainData
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar storeCookie {
+ key foo1
+ value bar
+ secure 0
+ domain com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo2
+ value bar
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar lookup
+} -cleanup {
+ ::cookiejar destroy
+} -result {example.com}
+test http-cookiejar-5.4 "cookie storage: constraints" -setup {
+ http::cookiejar create ::cookiejar
+ cookiejar forceLoadDomainData
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar storeCookie {
+ key foo
+ value bar1
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo
+ value bar2
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ lsort [cookiejar lookup]
+} -cleanup {
+ ::cookiejar destroy
+} -result {example.com www.example.com}
+test http-cookiejar-5.5 "cookie storage: constraints" -setup {
+ http::cookiejar create ::cookiejar
+ cookiejar forceLoadDomainData
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ cookiejar storeCookie {
+ key foo1
+ value 1
+ secure 0
+ domain com
+ origin www.example.com
+ path /
+ hostonly 0
+ }
+ cookiejar storeCookie {
+ key foo2
+ value 2
+ secure 0
+ domain com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo3
+ value 3
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 0
+ }
+ cookiejar storeCookie {
+ key foo4
+ value 4
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo5
+ value 5
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 0
+ }
+ cookiejar storeCookie {
+ key foo6
+ value 6
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo7
+ value 7
+ secure 1
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 0
+ }
+ cookiejar storeCookie {
+ key foo8
+ value 8
+ secure 1
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo9
+ value 9
+ secure 0
+ domain sub.www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ list [cookiejar getCookies http www.example.com /] \
+ [cookiejar getCookies http www2.example.com /] \
+ [cookiejar getCookies https www.example.com /] \
+ [cookiejar getCookies http sub.www.example.com /]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{foo3 3 foo6 6} {foo3 3} {foo3 3 foo6 6 foo8 8} {foo3 3 foo5 5}}
+
+test http-cookiejar-6.1 "cookie storage: expiry and lookup" -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine cookiejar export PurgeCookies
+ set result {}
+ proc values cookies {
+ global result
+ lappend result [lsort [lmap {k v} $cookies {set v}]]
+ }
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ values [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo
+ value session
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ values [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie [dict replace {
+ key foo
+ value cookie
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+1}]]
+ values [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo
+ value session-global
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 0
+ }
+ values [cookiejar getCookies http www.example.com /]
+ after 2500
+ update
+ values [cookiejar getCookies http www.example.com /]
+ cookiejar PurgeCookies
+ values [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo
+ value go-away
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 0
+ expires 0
+ }
+ values [cookiejar getCookies http www.example.com /]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{} session cookie {cookie session-global} {cookie session-global} session-global {}}
+
+test http-cookiejar-7.1 "cookie storage: persistence of persistent cookies" -setup {
+ catch {rename ::cookiejar ""}
+ set f [makeFile "" cookiejar]
+ file delete $f
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ http::cookiejar create ::cookiejar $f
+ ::cookiejar destroy
+ http::cookiejar create ::cookiejar $f
+} -cleanup {
+ catch {rename ::cookiejar ""}
+ removeFile $f
+} -result ::cookiejar
+test http-cookiejar-7.2 "cookie storage: persistence of persistent cookies" -setup {
+ catch {rename ::cookiejar ""}
+ set f [makeFile "" cookiejar]
+ file delete $f
+ set result {}
+} -constraints {notOSXtravis sqlite3 cookiejar} -body {
+ http::cookiejar create ::cookiejar $f
+ cookiejar storeCookie [dict replace {
+ key foo
+ value cookie
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+1}]]
+ lappend result [::cookiejar getCookies http www.example.com /]
+ ::cookiejar destroy
+ http::cookiejar create ::cookiejar
+ lappend result [::cookiejar getCookies http www.example.com /]
+ ::cookiejar destroy
+ http::cookiejar create ::cookiejar $f
+ lappend result [::cookiejar getCookies http www.example.com /]
+} -cleanup {
+ catch {rename ::cookiejar ""}
+ removeFile $f
+} -result {{foo cookie} {} {foo cookie}}
+
+::tcltest::cleanupTests
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 948671e..68bc542 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -14,7 +14,7 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
+ package require tcltest 2.5
namespace import -force ::tcltest::*
}
@@ -154,10 +154,10 @@ test iocmd-4.11 {read command} {
test iocmd-4.12 {read command} -setup {
set f [open $path(test1)]
} -body {
- list [catch {read $f 12z} msg] $msg $::errorCode
+ read $f 12z
} -cleanup {
close $f
-} -result {1 {expected non-negative integer but got "12z"} {TCL VALUE NUMBER}}
+} -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER}
test iocmd-5.1 {seek command} -returnCodes error -body {
seek
diff --git a/tests/list.test b/tests/list.test
index dff5d50..2686bd7 100644
--- a/tests/list.test
+++ b/tests/list.test
@@ -128,6 +128,24 @@ test list-3.1 {SetListFromAny and lrange/concat results} {
test list-4.1 {Bug 3173086} {
string is list "{[list \\\\\}]}"
} 1
+test list-4.2 {Bug 35a8f1c04a, check correct str-rep} {
+ set result {}
+ foreach i {
+ {#"} {#"""} {#"""""""""""""""}
+ "#\"{" "#\"\"\"{" "#\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\{"
+ "#\"}" "#\"\"\"}" "#\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\}"
+ } {
+ set list [list $i]
+ set list [string trim " $list "]
+ if {[llength $list] > 1 || $i ne [lindex $list 0]} {
+ lappend result "wrong string-representation of list by '$i', length: [llength $list], list: '$list'"
+ }
+ }
+ set result [join $result \n]
+} {}
+test list-4.3 {Bug 35a8f1c04a, check correct string length} {
+ string length [list #""]
+} 5
# cleanup
::tcltest::cleanupTests
diff --git a/tests/lpop.test b/tests/lpop.test
new file mode 100644
index 0000000..089299b
--- /dev/null
+++ b/tests/lpop.test
@@ -0,0 +1,140 @@
+# Commands covered: lpop
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1991-1993 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import -force ::tcltest::*
+}
+
+test lpop-1.1 {error conditions} -returnCodes error -body {
+ lpop no
+} -result {can't read "no": no such variable}
+test lpop-1.2 {error conditions} -returnCodes error -body {
+ lpop no 0
+} -result {can't read "no": no such variable}
+test lpop-1.3 {error conditions} -returnCodes error -body {
+ set no "x {}x"
+ lpop no
+} -result {list element in braces followed by "x" instead of space}
+test lpop-1.4 {error conditions} -returnCodes error -body {
+ set no "x y"
+ lpop no -1
+} -result {list index out of range}
+test lpop-1.5 {error conditions} -returnCodes error -body {
+ set no "x y z"
+ lpop no 3
+} -result {list index out of range} ;#-errorCode {TCL OPERATION LPOP BADINDEX}
+test lpop-1.6 {error conditions} -returnCodes error -body {
+ set no "x y"
+ lpop no end+1
+} -result {list index out of range}
+test lpop-1.7 {error conditions} -returnCodes error -body {
+ set no "x y"
+ lpop no {}
+} -match glob -result {bad index *}
+test lpop-1.8 {error conditions} -returnCodes error -body {
+ set no "x y"
+ lpop no 0 0 0 0 1
+} -result {list index out of range}
+test lpop-1.9 {error conditions} -returnCodes error -body {
+ set no "x y"
+ lpop no {1 0}
+} -match glob -result {bad index *}
+
+test lpop-2.1 {basic functionality} -body {
+ set l "x y z"
+ list [lpop l 0] $l
+} -result {x {y z}}
+test lpop-2.2 {basic functionality} -body {
+ set l "x y z"
+ list [lpop l 1] $l
+} -result {y {x z}}
+test lpop-2.3 {basic functionality} -body {
+ set l "x y z"
+ list [lpop l] $l
+} -result {z {x y}}
+test lpop-2.4 {basic functionality} -body {
+ set l "x y z"
+ set l2 $l
+ list [lpop l] $l $l2
+} -result {z {x y} {x y z}}
+
+test lpop-3.1 {nested} -body {
+ set l "x y"
+ set l2 $l
+ list [lpop l 0 0 0 0] $l $l2
+} -result {x {{{{}}} y} {x y}}
+test lpop-3.2 {nested} -body {
+ set l "{x y} {a b}"
+ list [lpop l 0 1] $l
+} -result {y {x {a b}}}
+test lpop-3.3 {nested} -body {
+ set l "{x y} {a b}"
+ list [lpop l 1 0] $l
+} -result {a {{x y} b}}
+
+
+
+
+
+test lpop-99.1 {performance} -constraints perf -body {
+ set l [lrepeat 10000 x]
+ set l2 $l
+ set t1 [time {
+ while {[llength $l] >= 2} {
+ lpop l end
+ }
+ }]
+ set l [lrepeat 30000 x]
+ set l2 $l
+ set t2 [time {
+ while {[llength $l] >= 2} {
+ lpop l end
+ }
+ }]
+ regexp {\d+} $t1 ms1
+ regexp {\d+} $t2 ms2
+ set ratio [expr {double($ms2)/$ms1}]
+ # Deleting from end should have linear performance
+ expr {$ratio > 4 ? $ratio : 4}
+} -result {4}
+
+test lpop-99.2 {performance} -constraints perf -body {
+ set l [lrepeat 10000 x]
+ set l2 $l
+ set t1 [time {
+ while {[llength $l] >= 2} {
+ lpop l 1
+ }
+ }]
+ set l [lrepeat 30000 x]
+ set l2 $l
+ set t2 [time {
+ while {[llength $l] >= 2} {
+ lpop l 1
+ }
+ }]
+ regexp {\d+} $t1 ms1
+ regexp {\d+} $t2 ms2
+ set ratio [expr {double($ms2)/$ms1}]
+ expr {$ratio > 10 ? $ratio : 10}
+} -result {10}
+
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/msgcat.test b/tests/msgcat.test
index 3dde124..4ab3622 100644
--- a/tests/msgcat.test
+++ b/tests/msgcat.test
@@ -693,18 +693,18 @@ if {[package vsatisfies [package provide msgcat] 1.7]} {
set msgdir3 [makeDirectory msgdir3]
makeFile "::msgcat::mcflset k2 v2 ; ::msgcat::mcload [list $msgdir3]"\
l2.msg $msgdir2
- makeFile {::msgcat::mcflset k3 v3} l2.msg $msgdir3
+ makeFile {::msgcat::mcflset k3 v3 ; ::msgcat::mcflmset {k4 v4 k5 v5}} l2.msg $msgdir3
# chained mcload
- test msgcat-8.2 {mcflset} -setup {
+ test msgcat-8.2 {mcflset/mcflmset} -setup {
variable locale [mclocale]
mclocale l2
mcload $msgdir2
} -cleanup {
mclocale $locale
} -body {
- return [mc k2][mc k3]
- } -result v2v3
+ return [mc k2][mc k3]--[mc k4][mc k5]
+ } -result v2v3--v4v5
removeFile l2.msg $msgdir2
removeDirectory msgdir2
diff --git a/tests/obj.test b/tests/obj.test
index cd33eaa..87c8d08 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -540,7 +540,6 @@ test obj-30.1 {Ref counting and object deletion, simple types} testobj {
lappend result [testobj refcount 2]
} {{} 1024 1024 int 4 4 0 int 3 2}
-
test obj-32.1 {freeing very large object trees} {
set x {}
for {set i 0} {$i<100000} {incr i} {
diff --git a/tests/oo.test b/tests/oo.test
index 37c4495..0f8cd47 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -129,11 +129,11 @@ test oo-1.1 {basic test of OO functionality: no classes} {
} {::foo {} a b c 3 {} {}}
test oo-1.2 {basic test of OO functionality: no classes} -body {
oo::define oo::object method missingArgs
-} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name args body\""
+} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name ?option? args body\""
test oo-1.3 {basic test of OO functionality: no classes} {
catch {oo::define oo::object method missingArgs}
set errorInfo
-} "wrong # args: should be \"oo::define oo::object method name args body\"
+} "wrong # args: should be \"oo::define oo::object method name ?option? args body\"
while executing
\"oo::define oo::object method missingArgs\""
test oo-1.4 {basic test of OO functionality} -body {
@@ -329,16 +329,17 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup {
set fresh [interp create]
} -body {
lmap x [$fresh eval {
+ set initials {::oo::object ::oo::class ::oo::Slot}
foreach cmd {instances subclasses mixins superclass} {
- foreach initial {object class Slot} {
- lappend x [info class $cmd ::oo::$initial]
+ foreach initial $initials {
+ lappend x [info class $cmd $initial]
}
}
- foreach initial {object class Slot} {
- lappend x [info object class ::oo::$initial]
+ foreach initial $initials {
+ lappend x [info object class $initial]
}
return $x
- }] {lsort [lmap y $x {if {[string match *::delegate $y]} continue; set y}]}
+ }] {lsort [lsearch -all -not -inline $x *::delegate]}
} -cleanup {
interp delete $fresh
} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
@@ -778,6 +779,76 @@ test oo-4.6 {export creates proper method entries} -setup {
} -cleanup {
testClass destroy
} -result ok
+test oo-4.7 {basic test of OO functionality: method -export flag} -setup {
+ set o [oo::object new]
+ unset -nocomplain result
+} -body {
+ oo::objdefine $o {
+ method Foo {} {
+ lappend ::result Foo
+ return foo
+ }
+ method Bar -export {} {
+ lappend ::result Bar
+ return bar
+ }
+ }
+ lappend result [catch {$o Foo} msg] $msg
+ lappend result [$o Bar]
+} -cleanup {
+ $o destroy
+} -result {1 {unknown method "Foo": must be Bar or destroy} Bar bar}
+test oo-4.8 {basic test of OO functionality: method -unexport flag} -setup {
+ set o [oo::object new]
+ unset -nocomplain result
+} -body {
+ oo::objdefine $o {
+ method foo {} {
+ lappend ::result foo
+ return Foo
+ }
+ method bar -unexport {} {
+ lappend ::result bar
+ return Bar
+ }
+ }
+ lappend result [$o foo]
+ lappend result [catch {$o bar} msg] $msg
+} -cleanup {
+ $o destroy
+} -result {foo Foo 1 {unknown method "bar": must be destroy or foo}}
+test oo-4.9 {basic test of OO functionality: method -private flag} -setup {
+ set o [oo::object new]
+ unset -nocomplain result
+} -body {
+ oo::objdefine $o {
+ method foo {} {
+ lappend ::result foo
+ return Foo
+ }
+ method bar -private {} {
+ lappend ::result bar
+ return Bar
+ }
+ export eval
+ method gorp {} {
+ my bar
+ }
+ }
+ lappend result [$o foo]
+ lappend result [catch {$o bar} msg] $msg
+ lappend result [catch {$o eval my bar} msg] $msg
+ lappend result [$o gorp]
+} -cleanup {
+ $o destroy
+} -result {foo Foo 1 {unknown method "bar": must be destroy, eval, foo or gorp} 1 {unknown method "bar": must be <cloned>, destroy, eval, foo, gorp, unknown, variable or varname} bar Bar}
+test oo-4.10 {basic test of OO functionality: method flag parsing} -setup {
+ set o [oo::object new]
+} -body {
+ oo::objdefine $o method foo -gorp xyz {return Foo}
+} -returnCodes error -cleanup {
+ $o destroy
+} -result {bad export flag "-gorp": must be -export, -private, or -unexport}
test oo-5.1 {OO: manipulation of classes as objects} -setup {
set obj [oo::object new]
@@ -2519,7 +2590,7 @@ test oo-17.3 {OO: class introspection} -setup {
} -result {"foo" is not a class}
test oo-17.4 {OO: class introspection} -body {
info class gorp oo::object
-} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables}
+} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables}
test oo-17.5 {OO: class introspection} -setup {
oo::class create testClass
} -body {
@@ -5076,6 +5147,254 @@ test oo-41.3 {TIP 478: myclass command calls unexported methods, via forward} -s
} -cleanup {
parent destroy
} -result {1 {this is ::cls1}}
+
+test oo-42.1 {TIP 524: definition namespace control: introspection} {
+ info class definitionnamespace oo::object
+} {}
+test oo-42.2 {TIP 524: definition namespace control: introspection} {
+ info class definitionnamespace oo::object -class
+} {}
+test oo-42.3 {TIP 524: definition namespace control: introspection} {
+ info class definitionnamespace oo::object -instance
+} ::oo::objdefine
+test oo-42.4 {TIP 524: definition namespace control: introspection} -body {
+ info class definitionnamespace oo::object -gorp
+} -returnCodes error -result {bad kind "-gorp": must be -class or -instance}
+test oo-42.5 {TIP 524: definition namespace control: introspection} -body {
+ info class definitionnamespace oo::object -class x
+} -returnCodes error -result {wrong # args: should be "info class definitionnamespace className ?kind?"}
+test oo-42.6 {TIP 524: definition namespace control: introspection} {
+ info class definitionnamespace oo::class
+} ::oo::define
+test oo-42.7 {TIP 524: definition namespace control: introspection} {
+ info class definitionnamespace oo::class -class
+} ::oo::define
+test oo-42.8 {TIP 524: definition namespace control: introspection} {
+ info class definitionnamespace oo::class -instance
+} {}
+
+test oo-43.1 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {
+ proc sparkle {} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace foodef
+ }
+ oo::class create foo {
+ superclass parent
+ self class foocls
+ }
+ oo::define foo {
+ sparkle
+ }
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result ok
+test oo-43.2 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+ unset -nocomplain ::result
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::define
+ proc sparkle {} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace foodef
+ }
+ foocls create foo {
+ superclass parent
+ lappend ::result [sparkle]
+ }
+ return $result
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result ok
+test oo-43.3 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+ unset -nocomplain ::result
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::define
+ proc sparkle {} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace -class foodef
+ }
+ foocls create foo {
+ superclass parent
+ lappend ::result [sparkle]
+ }
+ return $result
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result ok
+test oo-43.4 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::objdefine
+ proc sparkle {} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace -instance foodef
+ }
+ foocls create foo {
+ sparkle
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result {invalid command name "sparkle"}
+test oo-43.5 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::objdefine
+ proc sparkle {} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace foodef
+ }
+ namespace delete foodef
+ foocls create foo {
+ sparkle
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+ catch {namespace delete foodef}
+} -result {invalid command name "sparkle"}
+test oo-43.6 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+ unset -nocomplain result
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::objdefine
+ proc sparkle {} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace foodef
+ }
+ foocls create foo
+ lappend result [catch {oo::define foo sparkle} msg] $msg
+ namespace delete foodef
+ lappend result [catch {oo::define foo sparkle} msg] $msg
+ namespace eval foodef {
+ namespace path ::oo::objdefine
+ proc sparkle {} {return ok}
+ }
+ lappend result [catch {oo::define foo sparkle} msg] $msg
+} -cleanup {
+ parent destroy
+ catch {namespace delete foodef}
+} -result {0 ok 1 {invalid command name "sparkle"} 0 ok}
+test oo-43.7 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::define
+ proc sparkle {x} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace foodef
+ }
+ foocls create foo {
+ superclass parent
+ }
+ oo::define foo spar gorp
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result ok
+test oo-43.8 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::objdefine
+ proc sparkle {} {return ok}
+ }
+ oo::class create foo {
+ superclass parent
+ definitionnamespace -instance foodef
+ }
+ oo::objdefine [foo new] {
+ method x y z
+ sparkle
+ }
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result ok
+test oo-43.9 {TIP 524: definition namespace control: syntax} -body {
+ oo::class create foo {
+ definitionnamespace -gorp foodef
+ }
+} -returnCodes error -result {bad kind "-gorp": must be -class or -instance}
+test oo-43.10 {TIP 524: definition namespace control: syntax} -body {
+ oo::class create foo {
+ definitionnamespace -class foodef x
+ }
+} -returnCodes error -result {wrong # args: should be "definitionnamespace ?kind? namespace"}
+test oo-43.11 {TIP 524: definition namespace control: syntax} -setup {
+ catch {namespace delete ::no_such_ns}
+} -body {
+ oo::class create foo {
+ definitionnamespace -class ::no_such_ns
+ }
+} -returnCodes error -result {namespace "::no_such_ns" not found}
+test oo-43.12 {TIP 524: definition namespace control: user-level introspection} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {}
+ oo::class create foo {
+ superclass oo::class parent
+ }
+ list [info class definitionnamespace foo] \
+ [oo::define foo definitionnamespace foodef] \
+ [info class definitionnamespace foo] \
+ [oo::define foo definitionnamespace {}] \
+ [info class definitionnamespace foo]
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result {{} {} ::foodef {} {}}
+test oo-43.13 {TIP 524: definition namespace control: user-level introspection} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {}
+ oo::class create foo {
+ superclass parent
+ }
+ list [info class definitionnamespace foo -instance] \
+ [oo::define foo definitionnamespace -instance foodef] \
+ [info class definitionnamespace foo -instance] \
+ [oo::define foo definitionnamespace -instance {}] \
+ [info class definitionnamespace foo -instance]
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result {{} {} ::foodef {} {}}
cleanupTests
return
diff --git a/tests/source.test b/tests/source.test
index 0235bd1..8b146d3 100644
--- a/tests/source.test
+++ b/tests/source.test
@@ -12,8 +12,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[catch {package require tcltest 2.1}]} {
- puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
+if {[catch {package require tcltest 2.5}]} {
+ puts stderr "Skipping tests in [info script]. tcltest 2.5 required."
return
}
@@ -103,10 +103,9 @@ test source-2.6 {source error conditions} -setup {
set sourcefile [makeFile {} _non_existent_]
removeFile _non_existent_
} -body {
- list [catch {source $sourcefile} msg] $msg $::errorCode
-} -match listGlob -result [list 1 \
- {couldn't read file "*_non_existent_": no such file or directory} \
- {POSIX ENOENT {no such file or directory}}]
+ source $sourcefile
+} -match glob -result {couldn't read file "*_non_existent_": no such file or directory} \
+ -errorCode {POSIX ENOENT {no such file or directory}}
test source-2.7 {utf-8 with BOM} -setup {
set sourcefile [makeFile {} source.file]
} -body {
diff --git a/tests/string.test b/tests/string.test
index a0eaac8..81fe130 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -515,10 +515,10 @@ test string-6.4.$noComp {string is, too many args} {
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
test string-6.5.$noComp {string is, class check} {
list [catch {run {string is bogus str}} msg] $msg
-} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
+} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
test string-6.6.$noComp {string is, ambiguous class} {
list [catch {run {string is al str}} msg] $msg
-} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
+} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
test string-6.7.$noComp {string is alpha, all ok} {
run {string is alpha -strict -failindex var abc}
} 1
@@ -2306,6 +2306,7 @@ test string-29.15.$noComp {string cat, efficiency} -setup {
tcl::unsupported::representation [run {string cat $e $f $e $f [list x]}]
} -match glob -result {*no string representation}
}
+
test string-30.1.1.$noComp {[Bug ba921a8d98]: string cat} {
run {string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data]}
} hellohello
@@ -2313,8 +2314,80 @@ test string-30.1.2.$noComp {[Bug ba921a8d98]: inplace cat by subst (compiled to
run {set x "[set data [binary format a* hello]][encoding convertto $data][unset data]"}
} hellohello
-}
+test string-31.1.$noComp {string is dict} {
+ string is dict {a b c d}
+} 1
+test string-31.1a.$noComp {string is dict} {
+ string is dict {a b c}
+} 0
+test string-31.2.$noComp {string is dict} {
+ string is dict "a \{b c"
+} 0
+test string-31.3.$noComp {string is dict} {
+ string is dict {a {b c}d e}
+} 0
+test string-31.4.$noComp {string is dict} {
+ string is dict {}
+} 1
+test string-31.5.$noComp {string is dict} {
+ string is dict -strict {a b c d}
+} 1
+test string-31.5a.$noComp {string is dict} {
+ string is dict -strict {a b c}
+} 0
+test string-31.6.$noComp {string is dict} {
+ string is dict -strict "a \{b c"
+} 0
+test string-31.7.$noComp {string is dict} {
+ string is dict -strict {a {b c}d e}
+} 0
+test string-31.8.$noComp {string is dict} {
+ string is dict -strict {}
+} 1
+test string-31.9.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x {a b c d}] $x
+} {1 {}}
+test string-31.9a.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x {a b c}] $x
+} {0 -1}
+test string-31.10.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x "a \{b c d"] $x
+} {0 2}
+test string-31.10a.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x "a \{b c"] $x
+} {0 2}
+test string-31.11.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x {a b {b c}d e}] $x
+} {0 4}
+test string-31.12.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x {}] $x
+} {1 {}}
+test string-31.13.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x { {b c}d e}] $x
+} {0 2}
+test string-31.14.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x "\uabcd {b c}d e"] $x
+} {0 2}
+test string-31.15.$noComp {string is dict, valid dict} {
+ string is dict {a b c d e f}
+} 1
+test string-31.16.$noComp {string is dict, invalid dict} {
+ string is dict a
+} 0
+test string-31.17.$noComp {string is dict, valid dict packed in invalid dict} {
+ string is dict {{a b c d e f g h}}
+} 0
+}; # foreach noComp {0 1}
+
# cleanup
rename MemStress {}
rename makeByteArray {}
diff --git a/tests/tcltest.test b/tests/tcltest.test
index 1487865..ca720ee 100644
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -1207,7 +1207,7 @@ test tcltest-21.2 {force a test command failure} {
} {1}
}
-returnCodes 1
- -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
+ -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
}
test tcltest-21.3 {test command with setup} {
@@ -1300,7 +1300,7 @@ test tcltest-21.7 {test command - bad flag} {
}
}
-returnCodes 1
- -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
+ -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
}
# alternate test command format (these are the same as 21.1-21.6, with the
@@ -1320,7 +1320,7 @@ test tcltest-21.8 {force a test command failure} \
} \
-returnCodes 1 \
-cleanup {set ::tcltest::currentFailure $fail} \
- -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
+ -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
test tcltest-21.9 {test command with setup} \
-setup {set foo 1} \
diff --git a/tests/timer.test b/tests/timer.test
index ab6efc9..740d05e 100644
--- a/tests/timer.test
+++ b/tests/timer.test
@@ -205,11 +205,11 @@ test timer-6.4 {Tcl_AfterCmd procedure, ms argument} {
} {before after}
test timer-6.5 {Tcl_AfterCmd procedure, ms argument} {
set x before
- after 300 set x after
+ after 400 set x after
after 200
update
set y $x
- after 200
+ after 400
update
list $y $x
} {before after}
diff --git a/tests/unixInit.test b/tests/unixInit.test
index 0469ee8..ab00b4e 100644
--- a/tests/unixInit.test
+++ b/tests/unixInit.test
@@ -338,11 +338,10 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints {
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
- return $enc
+ set enc
} -cleanup {
unset -nocomplain env(LANG)
-} -match regexp -result [expr {
- ($tcl_platform(os) eq "Darwin") ? "^utf-8$" : "^iso8859-15?$"}]
+} -match regexp -result {^(iso8859-15?|utf-8)$}
test unixInit-3.2 {TclpSetInitialEncodings} -setup {
catch {set oldlc_all $env(LC_ALL)}
} -constraints {unix stdio} -body {
diff --git a/tests/util.test b/tests/util.test
index 34113c0..5079a89 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -586,14 +586,14 @@ test util-9.2.1 {TclGetIntForIndex} -body {
test util-9.2.2 {TclGetIntForIndex} -body {
string index abcd {end }
} -returnCodes error -match glob -result *
-test util-9.3 {TclGetIntForIndex} {
+test util-9.3 {TclGetIntForIndex} -body {
# Deprecated
string index abcd en
-} d
-test util-9.4 {TclGetIntForIndex} {
+} -returnCodes error -match glob -result *
+test util-9.4 {TclGetIntForIndex} -body {
# Deprecated
string index abcd e
-} d
+} -returnCodes error -match glob -result *
test util-9.5.0 {TclGetIntForIndex} {
string index abcd end-1
} c
@@ -735,6 +735,43 @@ test util-9.45 {TclGetIntForIndex} {
test util-9.46 {TclGetIntForIndex} {
string index abcd end+4294967294
} {}
+# TIP 502
+test util-9.47 {TclGetIntForIndex} {
+ string index abcd 0x10000000000000000
+} {}
+test util-9.48 {TclGetIntForIndex} {
+ string index abcd -0x10000000000000000
+} {}
+test util-9.49 {TclGetIntForIndex} -body {
+ string index abcd end*1
+} -returnCodes error -match glob -result *
+test util-9.50 {TclGetIntForIndex} -body {
+ string index abcd {end- 1}
+} -returnCodes error -match glob -result *
+test util-9.51 {TclGetIntForIndex} -body {
+ string index abcd end-end
+} -returnCodes error -match glob -result *
+test util-9.52 {TclGetIntForIndex} -body {
+ string index abcd end-x
+} -returnCodes error -match glob -result *
+test util-9.53 {TclGetIntForIndex} -body {
+ string index abcd end-0.1
+} -returnCodes error -match glob -result *
+test util-9.54 {TclGetIntForIndex} {
+ string index abcd end-0x10000000000000000
+} {}
+test util-9.55 {TclGetIntForIndex} {
+ string index abcd end+0x10000000000000000
+} {}
+test util-9.56 {TclGetIntForIndex} {
+ string index abcd end--0x10000000000000000
+} {}
+test util-9.57 {TclGetIntForIndex} {
+ string index abcd end+-0x10000000000000000
+} {}
+test util-9.58 {TclGetIntForIndex} {
+ string index abcd end--0x8000000000000000
+} {}
test util-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
convertDouble 0x0000000000000000
diff --git a/tests/winDde.test b/tests/winDde.test
index f04fb45..1fa7e86 100644
--- a/tests/winDde.test
+++ b/tests/winDde.test
@@ -20,7 +20,7 @@ testConstraint dde 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
- set ::ddever [package require dde 1.4.0]
+ set ::ddever [package require dde 1.4.1]
set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} {
testConstraint dde 1
}
@@ -104,7 +104,7 @@ proc createChildProcess {ddeServerName args} {
# -------------------------------------------------------------------------
test winDde-1.0 {check if we are testing the right dll} {win dde} {
set ::ddever
-} {1.4.0}
+} {1.4.1}
test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
list [dde servername foobar] [dde servername] [dde servername self]
diff --git a/tests/winFile.test b/tests/winFile.test
index b2cdfa1..b288063 100644
--- a/tests/winFile.test
+++ b/tests/winFile.test
@@ -39,13 +39,14 @@ test winFile-1.4 {TclpGetUserHome} {win nonPortable} {
test winFile-2.1 {TclpMatchFiles: case sensitivity} -constraints {win} -body {
makeFile {} GlobCapS
- list [glob -nocomplain GlobC*] [glob -nocomplain globc*]
-} -cleanup {
+ set args [list -nocomplain -tails -directory [temporaryDirectory]]
+ list [glob {*}$args GlobC*] [glob {*}$args globc*]} -cleanup {
removeFile GlobCapS
} -result {GlobCapS GlobCapS}
test winFile-2.2 {TclpMatchFiles: case sensitivity} -constraints {win} -body {
makeFile {} globlower
- list [glob -nocomplain globl*] [glob -nocomplain gLOBl*]
+ set args [list -nocomplain -tails -directory [temporaryDirectory]]
+ list [glob {*}$args globl*] [glob {*}$args gLOBl*]
} -cleanup {
removeFile globlower
} -result {globlower globlower}
diff --git a/tests/winPipe.test b/tests/winPipe.test
index 361858a..7e01c5f 100644
--- a/tests/winPipe.test
+++ b/tests/winPipe.test
@@ -22,9 +22,13 @@ catch {
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
}
-set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
+set org_pwd [pwd]
+set bindir [file join $org_pwd [file dirname [info nameofexecutable]]]
set cat32 [file join $bindir cat32.exe]
+# several test-cases here expect current directory == [temporaryDirectory]:
+cd [temporaryDirectory]
+
testConstraint exec [llength [info commands exec]]
testConstraint cat32 [file exists $cat32]
testConstraint AllocConsole [catch {puts console1 ""}]
@@ -608,6 +612,8 @@ if {[info exists path(echoArgs.tcl)]} { removeFile echoArgs.tcl }
if {[info exists path(echoArgs.bat)]} { removeFile echoArgs.bat }
if {[info exists path(echoArgs2.bat)]} { removeDirectory test(Dir)Check }
::tcltest::cleanupTests
+# back to original directory:
+cd $org_pwd; unset org_pwd
return
# Local Variables:
diff --git a/tools/installVfs.tcl b/tools/installVfs.tcl
new file mode 100644
index 0000000..ad1f5c7
--- /dev/null
+++ b/tools/installVfs.tcl
@@ -0,0 +1,54 @@
+#!/bin/sh
+#\
+exec tclsh "$0" ${1+"$@"}
+
+#----------------------------------------------------------------------
+#
+# installVfs.tcl --
+#
+# This file wraps the /library file system around a binary
+#
+#----------------------------------------------------------------------
+#
+# Copyright (c) 2018 by Sean Woods. All rights reserved.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#----------------------------------------------------------------------
+
+proc mapDir {resultvar prefix filepath} {
+ upvar 1 $resultvar result
+ if {![info exists result]} {
+ set result {}
+ }
+ set queue [list $prefix $filepath]
+ while {[llength $queue]} {
+ set queue [lassign $queue qprefix qpath]
+ foreach ftail [glob -directory $qpath -nocomplain -tails *] {
+ set f [file join $qpath $ftail]
+ if {[file isdirectory $f]} {
+ if {$ftail eq "CVS"} continue
+ lappend queue [file join $qprefix $ftail] $f
+ } elseif {[file isfile $f]} {
+ if {$ftail eq "pkgIndex.tcl"} continue
+ if {$ftail eq "manifest.txt"} {
+ lappend result $f [file join $qprefix pkgIndex.tcl]
+ } else {
+ lappend result $f [file join $qprefix $ftail]
+ }
+ }
+ }
+ }
+}
+if {[llength $argv]<4} {
+ error "Usage: [file tail [info script]] IMG_OUTPUT IMG_INPUT PREFIX FILE_SYSTEM ?PREFIX FILE_SYSTEM?..."
+}
+
+set paths [lassign $argv DLL_OUTPUT DLL_INPUT]
+foreach {prefix fpath} $paths {
+ mapDir files $prefix [file normalize $fpath]
+}
+if {$DLL_INPUT != {}} {
+ zipfs lmkzip $DLL_OUTPUT $files
+} else {
+ zipfs lmkimg $DLL_OUTPUT $files {} $DLL_INPUT
+}
diff --git a/unix/Makefile.in b/unix/Makefile.in
index b2ea458..b9c347e 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -681,18 +681,24 @@ ${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS}
@rm -rf ${TCL_VFS_ROOT}
@mkdir -p ${TCL_VFS_PATH}
cp -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}
- -find ${TCL_VFS_ROOT} -type d -empty -delete
- ( cd ${TCL_VFS_ROOT} ; ${NATIVE_ZIP} ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH})
+ cp -a ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl
+ find ${TCL_VFS_ROOT} -type d -empty -delete
+ (zip=`(realpath '${NATIVE_ZIP}' || readlink -m '${NATIVE_ZIP}') 2>/dev/null || \
+ (echo '${NATIVE_ZIP}' | sed "s?^\./?$$(pwd)/?")`; \
+ cd ${TCL_VFS_ROOT} && \
+ $$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} && \
+ cd ..)
# The following target is configured by autoconf to generate either a shared
# library or non-shared library for Tcl.
${LIB_FILE}: ${STUB_LIB_FILE} ${OBJS} ${TCL_ZIP_FILE}
rm -f $@
@MAKE_LIB@
-ifeq (${ZIPFS_BUILD},1)
- cat ${TCL_ZIP_FILE} >> ${LIB_FILE}
- ${NATIVE_ZIP} -A ${LIB_FILE}
-endif
+ @if test "${ZIPFS_BUILD}" = "1" ; then \
+ cat ${TCL_ZIP_FILE} >> ${LIB_FILE}; \
+ ${NATIVE_ZIP} -A ${LIB_FILE} \
+ || echo 'ignore zip-error by adjust sfx process (not executable?)'; \
+ fi
${STUB_LIB_FILE}: ${STUB_LIB_OBJS}
@if [ "x${LIB_FILE}" = "xlibtcl${MAJOR_VERSION}.${MINOR_VERSION}.dll" ] ; then \
@@ -932,9 +938,9 @@ install-libraries: libraries
@echo "Installing package msgcat 1.7.0 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \
"$(MODULE_INSTALL_DIR)"/tcl8/8.7/msgcat-1.7.0.tm
- @echo "Installing package tcltest 2.4.1 as a Tcl Module"
+ @echo "Installing package tcltest 2.5.0 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \
- "$(MODULE_INSTALL_DIR)"/tcl8/8.5/tcltest-2.4.1.tm
+ "$(MODULE_INSTALL_DIR)"/tcl8/8.5/tcltest-2.5.0.tm
@echo "Installing package platform 1.0.14 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \
"$(MODULE_INSTALL_DIR)"/tcl8/8.4/platform-1.0.14.tm
@@ -1744,9 +1750,6 @@ tclXtTest.o: $(UNIX_DIR)/tclXtTest.c
# relocatable.
#--------------------------------------------------------------------------
-fixstrtod.o: $(COMPAT_DIR)/fixstrtod.c
- $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/fixstrtod.c
-
opendir.o: $(COMPAT_DIR)/opendir.c
$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/opendir.c
@@ -1762,9 +1765,6 @@ strncasecmp.o: $(COMPAT_DIR)/strncasecmp.c
strstr.o: $(COMPAT_DIR)/strstr.c
$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strstr.c
-strtod.o: $(COMPAT_DIR)/strtod.c
- $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtod.c
-
strtol.o: $(COMPAT_DIR)/strtol.c
$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtol.c
diff --git a/unix/configure b/unix/configure
index 013a8b3..31ea079 100755
--- a/unix/configure
+++ b/unix/configure
@@ -5731,7 +5731,7 @@ fi
CFLAGS="$CFLAGS -pthread"
LDFLAGS="$LDFLAGS -pthread"
;;
- FreeBSD-*)
+ DragonFly-*|FreeBSD-*)
# This configuration from FreeBSD Ports.
SHLIB_CFLAGS="-fPIC"
SHLIB_LD="${CC} -shared"
@@ -6472,7 +6472,7 @@ fi
BSD/OS*) ;;
CYGWIN_*) ;;
IRIX*) ;;
- NetBSD-*|FreeBSD-*|OpenBSD-*) ;;
+ NetBSD-*|DragonFly-*|FreeBSD-*|OpenBSD-*) ;;
Darwin-*) ;;
SCO_SV-3.2*) ;;
*) SHLIB_CFLAGS="-fPIC" ;;
@@ -8839,140 +8839,6 @@ esac
#--------------------------------------------------------------------
-# Check for the strtod function. This is tricky because in some
-# versions of Linux strtod mis-parses strings starting with "+".
-#--------------------------------------------------------------------
-
-
- ac_fn_c_check_func "$LINENO" "strtod" "ac_cv_func_strtod"
-if test "x$ac_cv_func_strtod" = xyes; then :
- tcl_ok=1
-else
- tcl_ok=0
-fi
-
- if test "$tcl_ok" = 1; then
- { $as_echo "$as_me:${as_lineno-$LINENO}: checking proper strtod implementation" >&5
-$as_echo_n "checking proper strtod implementation... " >&6; }
-if ${tcl_cv_strtod_unbroken+:} false; then :
- $as_echo_n "(cached) " >&6
-else
- if test "$cross_compiling" = yes; then :
- tcl_cv_strtod_unbroken=unknown
-else
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-int main() {
- extern double strtod();
- char *term, *string = " +69";
- exit(strtod(string,&term) != 69 || term != string+4);
-}
-_ACEOF
-if ac_fn_c_try_run "$LINENO"; then :
- tcl_cv_strtod_unbroken=ok
-else
- tcl_cv_strtod_unbroken=broken
-fi
-rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
- conftest.$ac_objext conftest.beam conftest.$ac_ext
-fi
-
-fi
-{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_strtod_unbroken" >&5
-$as_echo "$tcl_cv_strtod_unbroken" >&6; }
- if test "$tcl_cv_strtod_unbroken" = "ok"; then
- tcl_ok=1
- else
- tcl_ok=0
- fi
- fi
- if test "$tcl_ok" = 0; then
- case " $LIBOBJS " in
- *" strtod.$ac_objext "* ) ;;
- *) LIBOBJS="$LIBOBJS strtod.$ac_objext"
- ;;
-esac
-
- USE_COMPAT=1
- fi
-
-
-#--------------------------------------------------------------------
-# Under Solaris 2.4, strtod returns the wrong value for the
-# terminating character under some conditions. Check for this
-# and if the problem exists use a substitute procedure
-# "fixstrtod" that corrects the error.
-#--------------------------------------------------------------------
-
-
- ac_fn_c_check_func "$LINENO" "strtod" "ac_cv_func_strtod"
-if test "x$ac_cv_func_strtod" = xyes; then :
- tcl_strtod=1
-else
- tcl_strtod=0
-fi
-
- if test "$tcl_strtod" = 1; then
- { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Solaris2.4/Tru64 strtod bugs" >&5
-$as_echo_n "checking for Solaris2.4/Tru64 strtod bugs... " >&6; }
-if ${tcl_cv_strtod_buggy+:} false; then :
- $as_echo_n "(cached) " >&6
-else
-
- if test "$cross_compiling" = yes; then :
- tcl_cv_strtod_buggy=buggy
-else
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
- extern double strtod();
- int main() {
- char *infString="Inf", *nanString="NaN", *spaceString=" ";
- char *term;
- double value;
- value = strtod(infString, &term);
- if ((term != infString) && (term[-1] == 0)) {
- exit(1);
- }
- value = strtod(nanString, &term);
- if ((term != nanString) && (term[-1] == 0)) {
- exit(1);
- }
- value = strtod(spaceString, &term);
- if (term == (spaceString+1)) {
- exit(1);
- }
- exit(0);
- }
-_ACEOF
-if ac_fn_c_try_run "$LINENO"; then :
- tcl_cv_strtod_buggy=ok
-else
- tcl_cv_strtod_buggy=buggy
-fi
-rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
- conftest.$ac_objext conftest.beam conftest.$ac_ext
-fi
-
-fi
-{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_strtod_buggy" >&5
-$as_echo "$tcl_cv_strtod_buggy" >&6; }
- if test "$tcl_cv_strtod_buggy" = buggy; then
- case " $LIBOBJS " in
- *" fixstrtod.$ac_objext "* ) ;;
- *) LIBOBJS="$LIBOBJS fixstrtod.$ac_objext"
- ;;
-esac
-
- USE_COMPAT=1
-
-$as_echo "#define strtod fixstrtod" >>confdefs.h
-
- fi
- fi
-
-
-#--------------------------------------------------------------------
# Check for various typedefs and provide substitutes if
# they don't exist.
#--------------------------------------------------------------------
@@ -10232,7 +10098,7 @@ else
fi
if test -f "$ac_cv_path_zip" ; then
- ZIP_PROG="$ac_cv_path_zip "
+ ZIP_PROG="$ac_cv_path_zip"
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ZIP_PROG" >&5
$as_echo "$ZIP_PROG" >&6; }
ZIP_PROG_OPTIONS="-rq"
@@ -10243,7 +10109,7 @@ $as_echo "Found INFO Zip in environment" >&6; }
else
# It is not an error if an installed version of Zip can't be located.
# We can use the locally distributed minizip instead
- ZIP_PROG="../minizip${EXEEXT_FOR_BUILD}"
+ ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}"
ZIP_PROG_OPTIONS="-o -r"
ZIP_PROG_VFSSEARCH="."
ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}"
diff --git a/unix/configure.ac b/unix/configure.ac
index bd8ea97..f34091f 100644
--- a/unix/configure.ac
+++ b/unix/configure.ac
@@ -381,26 +381,6 @@ SC_TCL_CHECK_BROKEN_FUNC(strtoul, [
])
#--------------------------------------------------------------------
-# Check for the strtod function. This is tricky because in some
-# versions of Linux strtod mis-parses strings starting with "+".
-#--------------------------------------------------------------------
-
-SC_TCL_CHECK_BROKEN_FUNC(strtod, [
- extern double strtod();
- char *term, *string = " +69";
- exit(strtod(string,&term) != 69 || term != string+4);
-])
-
-#--------------------------------------------------------------------
-# Under Solaris 2.4, strtod returns the wrong value for the
-# terminating character under some conditions. Check for this
-# and if the problem exists use a substitute procedure
-# "fixstrtod" that corrects the error.
-#--------------------------------------------------------------------
-
-SC_BUGGY_STRTOD
-
-#--------------------------------------------------------------------
# Check for various typedefs and provide substitutes if
# they don't exist.
#--------------------------------------------------------------------
diff --git a/unix/tcl.m4 b/unix/tcl.m4
index e27cc2c..2f114d7 100644
--- a/unix/tcl.m4
+++ b/unix/tcl.m4
@@ -1374,7 +1374,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
CFLAGS="$CFLAGS -pthread"
LDFLAGS="$LDFLAGS -pthread"
;;
- FreeBSD-*)
+ DragonFly-*|FreeBSD-*)
# This configuration from FreeBSD Ports.
SHLIB_CFLAGS="-fPIC"
SHLIB_LD="${CC} -shared"
@@ -1803,7 +1803,7 @@ dnl # preprocessing tests use only CPPFLAGS.
BSD/OS*) ;;
CYGWIN_*) ;;
IRIX*) ;;
- NetBSD-*|FreeBSD-*|OpenBSD-*) ;;
+ NetBSD-*|DragonFly-*|FreeBSD-*|OpenBSD-*) ;;
Darwin-*) ;;
SCO_SV-3.2*) ;;
*) SHLIB_CFLAGS="-fPIC" ;;
@@ -2182,59 +2182,6 @@ AC_DEFUN([SC_TIME_HANDLER], [
])
#--------------------------------------------------------------------
-# SC_BUGGY_STRTOD
-#
-# Under Solaris 2.4, strtod returns the wrong value for the
-# terminating character under some conditions. Check for this
-# and if the problem exists use a substitute procedure
-# "fixstrtod" (provided by Tcl) that corrects the error.
-# Also, on Compaq's Tru64 Unix 5.0,
-# strtod(" ") returns 0.0 instead of a failure to convert.
-#
-# Arguments:
-# none
-#
-# Results:
-#
-# Might defines some of the following vars:
-# strtod (=fixstrtod)
-#
-#--------------------------------------------------------------------
-
-AC_DEFUN([SC_BUGGY_STRTOD], [
- AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0)
- if test "$tcl_strtod" = 1; then
- AC_CACHE_CHECK([for Solaris2.4/Tru64 strtod bugs], tcl_cv_strtod_buggy,[
- AC_TRY_RUN([
- extern double strtod();
- int main() {
- char *infString="Inf", *nanString="NaN", *spaceString=" ";
- char *term;
- double value;
- value = strtod(infString, &term);
- if ((term != infString) && (term[-1] == 0)) {
- exit(1);
- }
- value = strtod(nanString, &term);
- if ((term != nanString) && (term[-1] == 0)) {
- exit(1);
- }
- value = strtod(spaceString, &term);
- if (term == (spaceString+1)) {
- exit(1);
- }
- exit(0);
- }], tcl_cv_strtod_buggy=ok, tcl_cv_strtod_buggy=buggy,
- tcl_cv_strtod_buggy=buggy)])
- if test "$tcl_cv_strtod_buggy" = buggy; then
- AC_LIBOBJ([fixstrtod])
- USE_COMPAT=1
- AC_DEFINE(strtod, fixstrtod, [Do we want to use the strtod() in compat?])
- fi
- fi
-])
-
-#--------------------------------------------------------------------
# SC_TCL_LINK_LIBS
#
# Search for the libraries needed to link the Tcl shell.
@@ -3064,7 +3011,7 @@ AC_DEFUN([SC_ZIPFS_SUPPORT], [
done
])
if test -f "$ac_cv_path_zip" ; then
- ZIP_PROG="$ac_cv_path_zip "
+ ZIP_PROG="$ac_cv_path_zip"
AC_MSG_RESULT([$ZIP_PROG])
ZIP_PROG_OPTIONS="-rq"
ZIP_PROG_VFSSEARCH="."
@@ -3073,7 +3020,7 @@ AC_DEFUN([SC_ZIPFS_SUPPORT], [
else
# It is not an error if an installed version of Zip can't be located.
# We can use the locally distributed minizip instead
- ZIP_PROG="../minizip${EXEEXT_FOR_BUILD}"
+ ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}"
ZIP_PROG_OPTIONS="-o -r"
ZIP_PROG_VFSSEARCH="."
ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}"
diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in
index 21c3bef..e626049 100644
--- a/unix/tclConfig.h.in
+++ b/unix/tclConfig.h.in
@@ -31,6 +31,9 @@
/* Is the cpuid instruction usable? */
#undef HAVE_CPUID
+/* Is 'DIR64' in <sys/types.h>? */
+#undef HAVE_DIR64
+
/* Define to 1 if you have the `freeaddrinfo' function. */
#undef HAVE_FREEADDRINFO
@@ -196,9 +199,6 @@
/* Is 'struct dirent64' in <sys/types.h>? */
#undef HAVE_STRUCT_DIRENT64
-/* Is 'DIR64' in <sys/types.h>? */
-#undef HAVE_DIR64
-
/* Define to 1 if the system has the type `struct in6_addr'. */
#undef HAVE_STRUCT_IN6_ADDR
@@ -484,9 +484,6 @@
/* Define as int if socklen_t is not available */
#undef socklen_t
-/* Do we want to use the strtod() in compat? */
-#undef strtod
-
/* Define to `int' if <sys/types.h> doesn't define. */
#undef uid_t
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index 2793d3b..bd54a2e 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -253,9 +253,6 @@ InitializeHostName(
native = u.nodename;
}
}
- if (native == NULL) {
- native = &tclEmptyString;
- }
#else /* !NO_UNAME */
/*
* Uname doesn't exist; try gethostname instead.
@@ -284,9 +281,15 @@ InitializeHostName(
#endif /* NO_UNAME */
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
- *lengthPtr = strlen(native);
- *valuePtr = ckalloc(*lengthPtr + 1);
- memcpy(*valuePtr, native, *lengthPtr + 1);
+ if (native) {
+ *lengthPtr = strlen(native);
+ *valuePtr = ckalloc(*lengthPtr + 1);
+ memcpy(*valuePtr, native, *lengthPtr + 1);
+ } else {
+ *lengthPtr = 0;
+ *valuePtr = ckalloc(1);
+ *valuePtr[0] = '\0';
+ }
}
/*
diff --git a/win/Makefile.in b/win/Makefile.in
index 2148e3e..8ed5f60 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -487,9 +487,14 @@ ${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS} ${DDE_DLL_FILE} ${REG_DLL_FILE}
rm -rf ${TCL_VFS_ROOT}
mkdir -p ${TCL_VFS_PATH}
$(COPY) -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}
+ $(COPY) -a ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl
$(COPY) ${DDE_DLL_FILE} ${TCL_VFS_PATH}/dde
$(COPY) ${REG_DLL_FILE} ${TCL_VFS_PATH}/reg
- cd ${TCL_VFS_ROOT} ; ${NATIVE_ZIP} ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH}
+ (zip=`(realpath '${NATIVE_ZIP}' || readlink -m '${NATIVE_ZIP}') 2>/dev/null || \
+ (echo '${NATIVE_ZIP}' | sed "s?^\./?$$(pwd)/?")`; \
+ cd ${TCL_VFS_ROOT} && \
+ $$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} && \
+ cd ..)
$(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES)
$(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
@@ -514,10 +519,11 @@ ${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) @ZLIB_DLL_FILE@ ${TCL_ZIP_FILE}
@$(RM) ${TCL_DLL_FILE} $(TCL_LIB_FILE)
@MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS)
@VC_MANIFEST_EMBED_DLL@
-ifeq (${ZIPFS_BUILD},1)
- cat ${TCL_ZIP_FILE} >> ${TCL_DLL_FILE}
- ${NATIVE_ZIP} -A ${TCL_DLL_FILE}
-endif
+ @if test "${ZIPFS_BUILD}" = "1" ; then \
+ cat ${TCL_ZIP_FILE} >> ${TCL_DLL_FILE}; \
+ ${NATIVE_ZIP} -A ${TCL_DLL_FILE} \
+ || echo 'ignore zip-error by adjust sfx process (not executable?)'; \
+ fi
${TCL_LIB_FILE}: ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS}
@$(RM) ${TCL_LIB_FILE}
@@ -868,7 +874,7 @@ test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE)
$(WINE) ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \
-load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \
package ifneeded tcltests 0.1 \"[list source [file normalize $(ROOT_DIR_NATIVE)/tests/tcltests.tcl]];package provide tcltests 0.1\"; \
- package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
+ package ifneeded dde 1.4.1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" | $(WINE) ./$(CAT32)
# Useful target to launch a built tclsh with the proper path,...
@@ -876,7 +882,7 @@ runtest: binaries $(TCLSH) $(TEST_DLL_FILE)
@TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
$(WINE) ./$(TCLSH) $(TESTFLAGS) -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \
package ifneeded tcltests 0.1 \"[list source [file normalize $(ROOT_DIR_NATIVE)/tests/tcltests.tcl]];package provide tcltests 0.1\"; \
- package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
+ package ifneeded dde 1.4.1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT)
# This target can be used to run tclsh from the build directory via
diff --git a/win/configure b/win/configure
index 21c3cc7..f79ffda 100755
--- a/win/configure
+++ b/win/configure
@@ -4855,7 +4855,7 @@ else
fi
if test -f "$ac_cv_path_zip" ; then
- ZIP_PROG="$ac_cv_path_zip "
+ ZIP_PROG="$ac_cv_path_zip"
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ZIP_PROG" >&5
$as_echo "$ZIP_PROG" >&6; }
ZIP_PROG_OPTIONS="-rq"
@@ -4866,7 +4866,7 @@ $as_echo "Found INFO Zip in environment" >&6; }
else
# It is not an error if an installed version of Zip can't be located.
# We can use the locally distributed minizip instead
- ZIP_PROG="../minizip${EXEEXT_FOR_BUILD}"
+ ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}"
ZIP_PROG_OPTIONS="-o -r"
ZIP_PROG_VFSSEARCH="."
ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}"
diff --git a/win/makefile.vc b/win/makefile.vc
index 392e6b4..1278a41 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -392,7 +392,7 @@ test: test-core test-pkgs
test-core: setup $(TCLTEST) dlls
set TCL_LIBRARY=$(ROOT:\=/)/library
$(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile <<
- package ifneeded dde 1.4.0 [list load "$(TCLDDELIB:\=/)" dde]
+ package ifneeded dde 1.4.1 [list load "$(TCLDDELIB:\=/)" dde]
package ifneeded registry 1.3.3 [list load "$(TCLREGLIB:\=/)" registry]
<<
diff --git a/win/tcl.m4 b/win/tcl.m4
index bdcd8ea..a58dc2f 100644
--- a/win/tcl.m4
+++ b/win/tcl.m4
@@ -1267,7 +1267,7 @@ AC_DEFUN([SC_ZIPFS_SUPPORT], [
done
])
if test -f "$ac_cv_path_zip" ; then
- ZIP_PROG="$ac_cv_path_zip "
+ ZIP_PROG="$ac_cv_path_zip"
AC_MSG_RESULT([$ZIP_PROG])
ZIP_PROG_OPTIONS="-rq"
ZIP_PROG_VFSSEARCH="."
@@ -1276,7 +1276,7 @@ AC_DEFUN([SC_ZIPFS_SUPPORT], [
else
# It is not an error if an installed version of Zip can't be located.
# We can use the locally distributed minizip instead
- ZIP_PROG="../minizip${EXEEXT_FOR_BUILD}"
+ ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}"
ZIP_PROG_OPTIONS="-o -r"
ZIP_PROG_VFSSEARCH="."
ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}"
diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c
index dca6875..ddfa0d6 100644
--- a/win/tclWin32Dll.c
+++ b/win/tclWin32Dll.c
@@ -471,11 +471,68 @@ Tcl_WinUtfToTChar(
Tcl_DString *dsPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
+#if TCL_UTF_MAX > 4
+ Tcl_UniChar ch = 0;
+ TCHAR *w, *wString;
+ const char *p, *end;
+ int oldLength;
+#endif
+
Tcl_DStringInit(dsPtr);
if (!string) {
return NULL;
}
+#if TCL_UTF_MAX > 4
+
+ if (len < 0) {
+ len = strlen(string);
+ }
+
+ /*
+ * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in
+ * bytes.
+ */
+
+ oldLength = Tcl_DStringLength(dsPtr);
+
+ Tcl_DStringSetLength(dsPtr,
+ oldLength + (int) ((len + 1) * sizeof(TCHAR)));
+ wString = (TCHAR *) (Tcl_DStringValue(dsPtr) + oldLength);
+
+ w = wString;
+ p = string;
+ end = string + len - 4;
+ while (p < end) {
+ p += TclUtfToUniChar(p, &ch);
+ if (ch > 0xFFFF) {
+ *w++ = (wchar_t) (0xD800 + ((ch -= 0x10000) >> 10));
+ *w++ = (wchar_t) (0xDC00 | (ch & 0x3FF));
+ } else {
+ *w++ = ch;
+ }
+ }
+ end += 4;
+ while (p < end) {
+ if (Tcl_UtfCharComplete(p, end-p)) {
+ p += TclUtfToUniChar(p, &ch);
+ } else {
+ ch = UCHAR(*p++);
+ }
+ if (ch > 0xFFFF) {
+ *w++ = (wchar_t) (0xD800 + ((ch -= 0x10000) >> 10));
+ *w++ = (wchar_t) (0xDC00 | (ch & 0x3FF));
+ } else {
+ *w++ = ch;
+ }
+ }
+ *w = '\0';
+ Tcl_DStringSetLength(dsPtr,
+ oldLength + ((char *) w - (char *) wString));
+
+ return wString;
+#else
return Tcl_UtfToUniCharDString(string, len, dsPtr);
+#endif
}
char *
@@ -486,16 +543,47 @@ Tcl_WinTCharToUtf(
Tcl_DString *dsPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
+#if TCL_UTF_MAX > 4
+ const TCHAR *w, *wEnd;
+ char *p, *result;
+ int oldLength, blen = 1;
+#endif
+
Tcl_DStringInit(dsPtr);
if (!string) {
return NULL;
}
if (len < 0) {
- len = wcslen(string);
+ len = wcslen((TCHAR *)string);
} else {
len /= 2;
}
- return Tcl_UniCharToUtfDString(string, len, dsPtr);
+#if TCL_UTF_MAX > 4
+ oldLength = Tcl_DStringLength(dsPtr);
+ Tcl_DStringSetLength(dsPtr, oldLength + (len + 1) * 4);
+ result = Tcl_DStringValue(dsPtr) + oldLength;
+
+ p = result;
+ wEnd = (TCHAR *)string + len;
+ for (w = (TCHAR *)string; w < wEnd; ) {
+ if (!blen && ((*w & 0xFC00) != 0xDC00)) {
+ /* Special case for handling upper surrogates. */
+ p += Tcl_UniCharToUtf(-1, p);
+ }
+ blen = Tcl_UniCharToUtf(*w, p);
+ p += blen;
+ w++;
+ }
+ if (!blen) {
+ /* Special case for handling upper surrogates. */
+ p += Tcl_UniCharToUtf(-1, p);
+ }
+ Tcl_DStringSetLength(dsPtr, oldLength + (p - result));
+
+ return result;
+#else
+ return Tcl_UniCharToUtfDString((Tcl_UniChar *)string, len, dsPtr);
+#endif
}
/*
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
index 52bcd42..27ddfc8 100644
--- a/win/tclWinDde.c
+++ b/win/tclWinDde.c
@@ -17,6 +17,7 @@
#include "tclInt.h"
#include <dde.h>
#include <ddeml.h>
+#include <tchar.h>
#if !defined(NDEBUG)
/* test POKE server Implemented for debug mode only */
@@ -50,13 +51,13 @@ typedef struct Conversation {
Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */
} Conversation;
-struct DdeEnumServices {
+typedef struct {
Tcl_Interp *interp;
int result;
ATOM service;
ATOM topic;
HWND hwnd;
-};
+} DdeEnumServices;
typedef struct {
Conversation *currentConversations;
@@ -78,7 +79,7 @@ static DWORD ddeInstance; /* The application instance handle given to us
* by DdeInitialize. */
static int ddeIsServer = 0;
-#define TCL_DDE_VERSION "1.4.0"
+#define TCL_DDE_VERSION "1.4.1"
#define TCL_DDE_PACKAGE_NAME "dde"
#define TCL_DDE_SERVICE_NAME TEXT("TclEval")
#define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT")
@@ -95,7 +96,7 @@ TCL_DECLARE_MUTEX(ddeMutex)
static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg,
WPARAM wParam, LPARAM lParam);
-static int DdeCreateClient(struct DdeEnumServices *es);
+static int DdeCreateClient(DdeEnumServices *es);
static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget,
LPARAM lParam);
static void DdeExitProc(ClientData clientData);
@@ -116,8 +117,27 @@ static int DdeObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-DLLEXPORT int Dde_Init(Tcl_Interp *interp);
-DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp);
+static unsigned char *
+getByteArrayFromObj(
+ Tcl_Obj *objPtr,
+ size_t *lengthPtr
+) {
+ int length;
+
+ unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length);
+#if TCL_MAJOR_VERSION > 8
+ if (sizeof(TCL_HASH_TYPE) > sizeof(int)) {
+ /* 64-bit and TIP #494 situation: */
+ *lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1;
+ } else
+#endif
+ /* 32-bit or without TIP #494 */
+ *lengthPtr = (size_t) (unsigned) length;
+ return result;
+}
+
+DLLEXPORT int Dde_Init(Tcl_Interp *interp);
+DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp);
/*
*----------------------------------------------------------------------
@@ -388,9 +408,9 @@ DdeSetServerName(
* We have found a unique name. Now add it to the registry.
*/
- riPtr = ckalloc(sizeof(RegisteredInterp));
+ riPtr = (RegisteredInterp *) Tcl_Alloc(sizeof(RegisteredInterp));
riPtr->interp = interp;
- riPtr->name = ckalloc((_tcslen(actualName) + 1) * sizeof(TCHAR));
+ riPtr->name = (TCHAR *) Tcl_Alloc((_tcslen(actualName) + 1) * sizeof(TCHAR));
riPtr->nextPtr = tsdPtr->interpListPtr;
riPtr->handlerPtr = handlerPtr;
if (riPtr->handlerPtr != NULL) {
@@ -491,7 +511,7 @@ DeleteProc(
prevPtr->nextPtr = searchPtr->nextPtr;
}
}
- ckfree(riPtr->name);
+ Tcl_Free((char *) riPtr->name);
if (riPtr->handlerPtr) {
Tcl_DecrRefCount(riPtr->handlerPtr);
}
@@ -529,7 +549,7 @@ ExecuteRemoteObject(
Tcl_Obj *returnPackagePtr;
int result = TCL_OK;
- if (riPtr->handlerPtr == NULL && Tcl_IsSafe(riPtr->interp)) {
+ if ((riPtr->handlerPtr == NULL) && Tcl_IsSafe(riPtr->interp)) {
Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: "
"a handler procedure must be defined for use in a safe "
"interp", -1));
@@ -611,7 +631,7 @@ DdeServerProc(
/* Transaction-dependent data. */
{
Tcl_DString dString;
- int len;
+ size_t len;
DWORD dlen;
TCHAR *utilString;
Tcl_Obj *ddeObjectPtr;
@@ -661,7 +681,7 @@ DdeServerProc(
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
if (_tcsicmp(riPtr->name, utilString) == 0) {
- convPtr = ckalloc(sizeof(Conversation));
+ convPtr = (Conversation *) Tcl_Alloc(sizeof(Conversation));
convPtr->nextPtr = tsdPtr->currentConversations;
convPtr->returnPackagePtr = NULL;
convPtr->hConv = hConv;
@@ -691,7 +711,7 @@ DdeServerProc(
if (convPtr->returnPackagePtr != NULL) {
Tcl_DecrRefCount(convPtr->returnPackagePtr);
}
- ckfree(convPtr);
+ Tcl_Free((char *) convPtr);
break;
}
}
@@ -717,22 +737,24 @@ DdeServerProc(
}
if (convPtr != NULL) {
+ Tcl_DString dsBuf;
char *returnString;
len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
Tcl_DStringInit(&dString);
+ Tcl_DStringInit(&dsBuf);
Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
utilString = (TCHAR *) Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
CP_WINUNICODE);
if (_tcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) {
- if (uFmt == CF_TEXT) {
- returnString =
- Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len);
- } else {
- returnString = (char *)
- Tcl_GetUnicodeFromObj(convPtr->returnPackagePtr, &len);
- len = sizeof(TCHAR) * len + 1;
+ returnString =
+ Tcl_GetString(convPtr->returnPackagePtr);
+ len = convPtr->returnPackagePtr->length;
+ if (uFmt != CF_TEXT) {
+ Tcl_WinUtfToTChar(returnString, len, &dsBuf);
+ returnString = Tcl_DStringValue(&dsBuf);
+ len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1;
}
ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString,
(DWORD) len+1, 0, ddeItem, uFmt, 0);
@@ -742,18 +764,18 @@ DdeServerProc(
} else {
Tcl_DString ds;
Tcl_Obj *variableObjPtr;
+
Tcl_WinTCharToUtf(utilString, -1, &ds);
variableObjPtr = Tcl_GetVar2Ex(
convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
TCL_GLOBAL_ONLY);
if (variableObjPtr != NULL) {
- if (uFmt == CF_TEXT) {
- returnString = Tcl_GetStringFromObj(
- variableObjPtr, &len);
- } else {
- returnString = (char *) Tcl_GetUnicodeFromObj(
- variableObjPtr, &len);
- len = sizeof(TCHAR) * len + 1;
+ returnString = Tcl_GetString(variableObjPtr);
+ len = variableObjPtr->length;
+ if (uFmt != CF_TEXT) {
+ Tcl_WinUtfToTChar(returnString, len, &dsBuf);
+ returnString = Tcl_DStringValue(&dsBuf);
+ len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1;
}
ddeReturn = DdeCreateDataHandle(ddeInstance,
(BYTE *)returnString, (DWORD) len+1, 0, ddeItem,
@@ -764,6 +786,7 @@ DdeServerProc(
Tcl_DStringFree(&ds);
}
}
+ Tcl_DStringFree(&dsBuf);
Tcl_DStringFree(&dString);
}
return ddeReturn;
@@ -788,26 +811,30 @@ DdeServerProc(
}
if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) {
- Tcl_DString ds;
+ Tcl_DString ds, ds2;
Tcl_Obj *variableObjPtr;
+ DWORD len2;
- len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
Tcl_DStringInit(&dString);
+ Tcl_DStringInit(&ds2);
+ len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
utilString = (TCHAR *) Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
CP_WINUNICODE);
Tcl_WinTCharToUtf(utilString, -1, &ds);
- utilString = (TCHAR *) DdeAccessData(hData, &dlen);
- if (uFmt == CF_TEXT) {
- variableObjPtr = Tcl_NewStringObj((char *)utilString, -1);
- } else {
- variableObjPtr = Tcl_NewUnicodeObj(utilString, -1);
+ utilString = (TCHAR *) DdeAccessData(hData, &len2);
+ len = len2;
+ if (uFmt != CF_TEXT) {
+ Tcl_WinTCharToUtf(utilString, -1, &ds2);
+ utilString = (TCHAR *) Tcl_DStringValue(&ds2);
}
+ variableObjPtr = Tcl_NewStringObj((char *)utilString, -1);
Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
variableObjPtr, TCL_GLOBAL_ONLY);
+ Tcl_DStringFree(&ds2);
Tcl_DStringFree(&ds);
Tcl_DStringFree(&dString);
ddeReturn = (HDDEDATA) DDE_FACK;
@@ -848,8 +875,12 @@ DdeServerProc(
ddeObjectPtr = Tcl_NewStringObj(string, dlen);
} else {
/* unicode */
- dlen >>= 1;
- ddeObjectPtr = Tcl_NewUnicodeObj((Tcl_UniChar *)utilString, dlen - 1);
+ Tcl_DString dsBuf;
+
+ Tcl_WinTCharToUtf(utilString, dlen - sizeof(TCHAR), &dsBuf);
+ ddeObjectPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
+ Tcl_DStringLength(&dsBuf));
+ Tcl_DStringFree(&dsBuf);
}
Tcl_IncrRefCount(ddeObjectPtr);
DdeUnaccessData(hData);
@@ -1014,7 +1045,7 @@ MakeDdeConnection(
static int
DdeCreateClient(
- struct DdeEnumServices *es)
+ DdeEnumServices *es)
{
WNDCLASSEX wc;
static const TCHAR *szDdeClientClassName = TEXT("TclEval client class");
@@ -1024,7 +1055,7 @@ DdeCreateClient(
wc.cbSize = sizeof(wc);
wc.lpfnWndProc = DdeClientWindowProc;
wc.lpszClassName = szDdeClientClassName;
- wc.cbWndExtra = sizeof(struct DdeEnumServices *);
+ wc.cbWndExtra = sizeof(DdeEnumServices *);
/*
* Register and create the callback window.
@@ -1046,8 +1077,8 @@ DdeClientWindowProc(
switch (uMsg) {
case WM_CREATE: {
LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam;
- struct DdeEnumServices *es =
- (struct DdeEnumServices *) lpcs->lpCreateParams;
+ DdeEnumServices *es =
+ (DdeEnumServices *) lpcs->lpCreateParams;
#ifdef _WIN64
SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR) es);
@@ -1072,18 +1103,18 @@ DdeServicesOnAck(
HWND hwndRemote = (HWND)wParam;
ATOM service = (ATOM)LOWORD(lParam);
ATOM topic = (ATOM)HIWORD(lParam);
- struct DdeEnumServices *es;
+ DdeEnumServices *es;
TCHAR sz[255];
Tcl_DString dString;
#ifdef _WIN64
- es = (struct DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA);
+ es = (DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA);
#else
- es = (struct DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA);
+ es = (DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA);
#endif
- if ((es->service == (ATOM)0 || es->service == service)
- && (es->topic == (ATOM)0 || es->topic == topic)) {
+ if (((es->service == (ATOM)0) || (es->service == service))
+ && ((es->topic == (ATOM)0) || (es->topic == topic))) {
Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL);
Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp);
@@ -1130,7 +1161,7 @@ DdeEnumWindowsCallback(
LPARAM lParam)
{
DWORD_PTR dwResult = 0;
- struct DdeEnumServices *es = (struct DdeEnumServices *) lParam;
+ DdeEnumServices *es = (DdeEnumServices *) lParam;
SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd,
MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000,
@@ -1144,7 +1175,7 @@ DdeGetServicesList(
const TCHAR *serviceName,
const TCHAR *topicName)
{
- struct DdeEnumServices es;
+ DdeEnumServices es;
es.interp = interp;
es.result = TCL_OK;
@@ -1265,7 +1296,8 @@ DdeObjCmd(
"-binary", NULL
};
- int index, i, length, argIndex;
+ int index, i, argIndex;
+ size_t length;
int flags = 0, result = TCL_OK, firstArg = 0;
HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL;
HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn;
@@ -1274,6 +1306,7 @@ DdeObjCmd(
const char *string;
DWORD ddeResult;
Tcl_Obj *objPtr, *handlerPtr = NULL;
+ Tcl_DString serviceBuf, topicBuf, itemBuf;
/*
* Initialize DDE server/client
@@ -1289,6 +1322,9 @@ DdeObjCmd(
return TCL_ERROR;
}
+ Tcl_DStringInit(&serviceBuf);
+ Tcl_DStringInit(&topicBuf);
+ Tcl_DStringInit(&itemBuf);
switch ((enum DdeSubcommands) index) {
case DDE_SERVERNAME:
for (i = 2; i < objc; i++) {
@@ -1338,7 +1374,7 @@ DdeObjCmd(
if (objc == 5) {
firstArg = 2;
break;
- } else if (objc >= 6 && objc <= 7) {
+ } else if ((objc >= 6) && (objc <= 7)) {
firstArg = objc - 3;
for (i = 2; i < firstArg; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], ddeExecOptions,
@@ -1423,7 +1459,12 @@ DdeObjCmd(
Initialize();
if (firstArg != 1) {
- serviceName = Tcl_GetUnicodeFromObj(objv[firstArg], &length);
+ const char *src = Tcl_GetString(objv[firstArg]);
+
+ length = objv[firstArg]->length;
+ Tcl_WinUtfToTChar(src, length, &serviceBuf);
+ serviceName = (TCHAR *) Tcl_DStringValue(&serviceBuf);
+ length = Tcl_DStringLength(&serviceBuf) / sizeof(TCHAR);
} else {
length = 0;
}
@@ -1436,7 +1477,11 @@ DdeObjCmd(
}
if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
- topicName = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 1], &length);
+ const char *src = Tcl_GetString(objv[firstArg + 1]);
+
+ length = objv[firstArg + 1]->length;
+ topicName = Tcl_WinUtfToTChar(src, length, &topicBuf);
+ length = Tcl_DStringLength(&topicBuf) / sizeof(TCHAR);
if (length == 0) {
topicName = NULL;
} else {
@@ -1450,28 +1495,40 @@ DdeObjCmd(
serviceName = DdeSetServerName(interp, serviceName, flags,
handlerPtr);
if (serviceName != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewUnicodeObj((Tcl_UniChar *) serviceName, -1));
+ Tcl_DString dsBuf;
+
+ Tcl_WinTCharToUtf(serviceName, -1, &dsBuf);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
+ Tcl_DStringLength(&dsBuf)));
+ Tcl_DStringFree(&dsBuf);
} else {
Tcl_ResetResult(interp);
}
break;
case DDE_EXECUTE: {
- int dataLength;
- const Tcl_UniChar *dataString;
+ size_t dataLength;
+ const void *dataString;
+ Tcl_DString dsBuf;
+ Tcl_DStringInit(&dsBuf);
if (flags & DDE_FLAG_BINARY) {
- dataString = (const Tcl_UniChar *)
- Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength);
- } else {
dataString =
- Tcl_GetUnicodeFromObj(objv[firstArg + 2], &dataLength);
- dataLength = (dataLength + 1) * sizeof(Tcl_UniChar);
+ getByteArrayFromObj(objv[firstArg + 2], &dataLength);
+ } else {
+ const char *src;
+
+ src = Tcl_GetString(objv[firstArg + 2]);
+ dataLength = objv[firstArg + 2]->length;
+ dataString = (const TCHAR *)
+ Tcl_WinUtfToTChar(src, dataLength, &dsBuf);
+ dataLength = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR);
}
- if (dataLength <= 0) {
+ if (dataLength + 1 < 2) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot execute null data", -1));
+ Tcl_DStringFree(&dsBuf);
Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
break;
@@ -1481,6 +1538,7 @@ DdeObjCmd(
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
+ Tcl_DStringFree(&dsBuf);
SetDdeError(interp);
result = TCL_ERROR;
break;
@@ -1506,11 +1564,17 @@ DdeObjCmd(
SetDdeError(interp);
result = TCL_ERROR;
}
+ Tcl_DStringFree(&dsBuf);
break;
}
case DDE_REQUEST: {
- const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2],
- &length);
+ const TCHAR *itemString;
+ const char *src;
+
+ src = Tcl_GetString(objv[firstArg + 2]);
+ length = objv[firstArg + 2]->length;
+ itemString = Tcl_WinUtfToTChar(src, length, &itemBuf);
+ length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR);
if (length == 0) {
Tcl_SetObjResult(interp,
@@ -1538,18 +1602,23 @@ DdeObjCmd(
result = TCL_ERROR;
} else {
DWORD tmp;
- const Tcl_UniChar *dataString = (const Tcl_UniChar *) DdeAccessData(ddeData, &tmp);
+ TCHAR *dataString = (TCHAR *) DdeAccessData(ddeData, &tmp);
if (flags & DDE_FLAG_BINARY) {
returnObjPtr =
- Tcl_NewByteArrayObj((BYTE *) dataString, (int) tmp);
+ Tcl_NewByteArrayObj((BYTE *) dataString, tmp);
} else {
- tmp >>= 1;
- if (tmp && !dataString[(tmp-1)]) {
- --tmp;
+ Tcl_DString dsBuf;
+
+ if ((tmp >= sizeof(TCHAR))
+ && !dataString[tmp / sizeof(TCHAR) - 1]) {
+ tmp -= sizeof(TCHAR);
}
- returnObjPtr = Tcl_NewUnicodeObj(dataString,
- (int) tmp);
+ Tcl_WinTCharToUtf(dataString, tmp, &dsBuf);
+ returnObjPtr =
+ Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
+ Tcl_DStringLength(&dsBuf));
+ Tcl_DStringFree(&dsBuf);
}
DdeUnaccessData(ddeData);
DdeFreeDataHandle(ddeData);
@@ -1560,14 +1629,18 @@ DdeObjCmd(
result = TCL_ERROR;
}
}
-
break;
}
case DDE_POKE: {
- const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2],
- &length);
+ Tcl_DString dsBuf;
+ const TCHAR *itemString;
BYTE *dataString;
+ const char *src;
+ src = Tcl_GetString(objv[firstArg + 2]);
+ length = objv[firstArg + 2]->length;
+ itemString = Tcl_WinUtfToTChar(src, length, &itemBuf);
+ length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR);
if (length == 0) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot have a null item", -1));
@@ -1575,13 +1648,17 @@ DdeObjCmd(
result = TCL_ERROR;
goto cleanup;
}
+ Tcl_DStringInit(&dsBuf);
if (flags & DDE_FLAG_BINARY) {
dataString = (BYTE *)
- Tcl_GetByteArrayFromObj(objv[firstArg + 3], &length);
+ getByteArrayFromObj(objv[firstArg + 3], &length);
} else {
+ const char *data =
+ Tcl_GetString(objv[firstArg + 3]);
+ length = objv[firstArg + 3]->length;
dataString = (BYTE *)
- Tcl_GetUnicodeFromObj(objv[firstArg + 3], &length);
- length = 2 * length + 1;
+ Tcl_WinUtfToTChar(data, length, &dsBuf);
+ length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR);
}
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
@@ -1606,6 +1683,7 @@ DdeObjCmd(
result = TCL_ERROR;
}
}
+ Tcl_DStringFree(&dsBuf);
break;
}
@@ -1664,7 +1742,7 @@ DdeObjCmd(
* referring to deallocated objects.
*/
- if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) {
+ if (Tcl_IsSafe(riPtr->interp) && (riPtr->handlerPtr == NULL)) {
Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj(
"permission denied: a handler procedure must be"
" defined for use in a safe interp", -1));
@@ -1723,6 +1801,8 @@ DdeObjCmd(
Tcl_Release(riPtr);
Tcl_Release(sendInterp);
} else {
+ Tcl_DString dsBuf;
+
/*
* This is a non-local request. Send the script to the server and
* poll it for a result.
@@ -1738,9 +1818,14 @@ DdeObjCmd(
}
objPtr = Tcl_ConcatObj(objc, objv);
- string = (const char *) Tcl_GetUnicodeFromObj(objPtr, &length);
- ddeItemData = DdeCreateDataHandle(ddeInstance,
- (BYTE *) string, (DWORD) 2*length+2, 0, 0, CF_UNICODETEXT, 0);
+ string = Tcl_GetString(objPtr);
+ length = objPtr->length;
+ Tcl_WinUtfToTChar(string, length, &dsBuf);
+ string = Tcl_DStringValue(&dsBuf);
+ length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR);
+ ddeItemData = DdeCreateDataHandle(ddeInstance, (BYTE *) string,
+ (DWORD) length, 0, 0, CF_UNICODETEXT, 0);
+ Tcl_DStringFree(&dsBuf);
if (flags & DDE_FLAG_ASYNC) {
ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
@@ -1769,7 +1854,7 @@ DdeObjCmd(
if (!(flags & DDE_FLAG_ASYNC)) {
Tcl_Obj *resultPtr;
- Tcl_UniChar *ddeDataString;
+ TCHAR *ddeDataString;
/*
* The return handle has a two or four element list in it. The
@@ -1780,13 +1865,17 @@ DdeObjCmd(
* variable "errorInfo".
*/
- resultPtr = Tcl_NewObj();
length = DdeGetData(ddeData, NULL, 0, 0);
- ddeDataString = ckalloc(length);
+ ddeDataString = (TCHAR *) Tcl_Alloc(length);
DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0);
- length = (length >> 1) - 1;
- resultPtr = Tcl_NewUnicodeObj(ddeDataString, length);
- ckfree(ddeDataString);
+ if (length > sizeof(TCHAR)) {
+ length -= sizeof(TCHAR);
+ }
+ Tcl_WinTCharToUtf(ddeDataString, length, &dsBuf);
+ resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
+ Tcl_DStringLength(&dsBuf));
+ Tcl_DStringFree(&dsBuf);
+ Tcl_Free((char *) ddeDataString);
if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) {
Tcl_DecrRefCount(resultPtr);
@@ -1836,6 +1925,9 @@ DdeObjCmd(
if (hConv != NULL) {
DdeDisconnect(hConv);
}
+ Tcl_DStringFree(&itemBuf);
+ Tcl_DStringFree(&topicBuf);
+ Tcl_DStringFree(&serviceBuf);
return result;
}
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index 5a557fc..6582ee1 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -531,6 +531,11 @@ TclWinSymLinkDelete(
*--------------------------------------------------------------------
*/
+#if defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5))))
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Warray-bounds"
+#endif
+
static Tcl_Obj *
WinReadLinkDirectory(
const TCHAR *linkDirPath)
@@ -646,6 +651,10 @@ WinReadLinkDirectory(
Tcl_SetErrno(EINVAL);
return NULL;
}
+
+#if defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5))))
+#pragma GCC diagnostic pop
+#endif
/*
*--------------------------------------------------------------------
@@ -865,7 +874,8 @@ TclpFindExecutable(
*/
if (argv0 == NULL) {
- TclSetPanicProc(tclWinDebugPanic);
+# undef Tcl_SetPanicProc
+ Tcl_SetPanicProc(tclWinDebugPanic);
}
GetModuleFileNameW(NULL, wName, MAX_PATH);
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
index f3d7a07..f93a553 100644
--- a/win/tclWinReg.c
+++ b/win/tclWinReg.c
@@ -124,6 +124,25 @@ static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
Tcl_Obj *valueNameObj, Tcl_Obj *dataObj,
Tcl_Obj *typeObj, REGSAM mode);
+static unsigned char *
+getByteArrayFromObj(
+ Tcl_Obj *objPtr,
+ size_t *lengthPtr
+) {
+ int length;
+
+ unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length);
+#if TCL_MAJOR_VERSION > 8
+ if (sizeof(TCL_HASH_TYPE) > sizeof(int)) {
+ /* 64-bit and TIP #494 situation: */
+ *lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1;
+ } else
+#endif
+ /* 32-bit or without TIP #494 */
+ *lengthPtr = (size_t) (unsigned) length;
+ return result;
+}
+
DLLEXPORT int Registry_Init(Tcl_Interp *interp);
DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags);
@@ -492,7 +511,6 @@ DeleteValue(
{
HKEY key;
char *valueName;
- size_t length;
DWORD result;
Tcl_DString ds;
@@ -506,8 +524,7 @@ DeleteValue(
}
valueName = Tcl_GetString(valueNameObj);
- length = valueNameObj->length;
- Tcl_WinUtfToTChar(valueName, length, &ds);
+ Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds);
result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
if (result != ERROR_SUCCESS) {
@@ -647,7 +664,6 @@ GetType(
Tcl_DString ds;
const char *valueName;
const TCHAR *nativeValue;
- size_t length;
/*
* Attempt to open the key for reading.
@@ -663,8 +679,7 @@ GetType(
*/
valueName = Tcl_GetString(valueNameObj);
- length = valueNameObj->length;
- nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds);
+ nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds);
result = RegQueryValueEx(key, nativeValue, NULL, &type,
NULL, NULL);
Tcl_DStringFree(&ds);
@@ -720,7 +735,6 @@ GetValue(
const TCHAR *nativeValue;
DWORD result, length, type;
Tcl_DString data, buf;
- size_t nameLen;
/*
* Attempt to open the key for reading.
@@ -746,8 +760,7 @@ GetValue(
length = TCL_DSTRING_STATIC_SIZE/sizeof(TCHAR) - 1;
valueName = Tcl_GetString(valueNameObj);
- nameLen = valueNameObj->length;
- nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf);
+ nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &buf);
result = RegQueryValueEx(key, nativeValue, NULL, &type,
(BYTE *) Tcl_DStringValue(&data), &length);
@@ -936,13 +949,11 @@ OpenKey(
HKEY *keyPtr) /* Returned HKEY. */
{
char *keyName, *buffer, *hostName;
- size_t length;
HKEY rootKey;
DWORD result;
keyName = Tcl_GetString(keyNameObj);
- length = keyNameObj->length;
- buffer = Tcl_Alloc(length + 1);
+ buffer = Tcl_Alloc(keyNameObj->length + 1);
strcpy(buffer, keyName);
result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName);
@@ -1244,7 +1255,6 @@ SetValue(
REGSAM mode) /* Mode flags to pass. */
{
int type;
- size_t length;
DWORD result;
HKEY key;
const char *valueName;
@@ -1265,8 +1275,7 @@ SetValue(
}
valueName = Tcl_GetString(valueNameObj);
- length = valueNameObj->length;
- valueName = (char *) Tcl_WinUtfToTChar(valueName, length, &nameBuf);
+ valueName = (char *) Tcl_WinUtfToTChar(valueName, valueNameObj->length, &nameBuf);
if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
int value;
@@ -1301,8 +1310,7 @@ SetValue(
for (i = 0; i < objc; i++) {
const char *bytes = Tcl_GetString(objv[i]);
- length = objv[i]->length;
- Tcl_DStringAppend(&data, bytes, length);
+ Tcl_DStringAppend(&data, bytes, objv[i]->length);
/*
* Add a null character to separate this value from the next.
@@ -1322,28 +1330,26 @@ SetValue(
Tcl_DString buf;
const char *data = Tcl_GetString(dataObj);
- length = dataObj->length;
- data = (char *) Tcl_WinUtfToTChar(data, length, &buf);
+ data = (char *) Tcl_WinUtfToTChar(data, dataObj->length, &buf);
/*
* Include the null in the length, padding if needed for WCHAR.
*/
Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
- length = Tcl_DStringLength(&buf) + 1;
result = RegSetValueEx(key, (TCHAR *) valueName, 0,
- (DWORD) type, (BYTE *) data, (DWORD) length);
+ (DWORD) type, (BYTE *) data, (DWORD) Tcl_DStringLength(&buf) + 1);
Tcl_DStringFree(&buf);
} else {
BYTE *data;
- int bytelength;
+ size_t bytelength;
/*
* Store binary data in the registry.
*/
- data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &bytelength);
+ data = (BYTE *) getByteArrayFromObj(dataObj, &bytelength);
result = RegSetValueEx(key, (TCHAR *) valueName, 0,
(DWORD) type, data, (DWORD) bytelength);
}
@@ -1404,8 +1410,7 @@ BroadcastValue(
}
str = Tcl_GetString(objv[0]);
- len = objv[0]->length;
- wstr = (WCHAR *) Tcl_WinUtfToTChar(str, len, &ds);
+ wstr = (WCHAR *) Tcl_WinUtfToTChar(str, objv[0]->length, &ds);
if (Tcl_DStringLength(&ds) == 0) {
wstr = NULL;
}
diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c
index d77a609..8ee426b 100644
--- a/win/tclWinSerial.c
+++ b/win/tclWinSerial.c
@@ -1024,7 +1024,7 @@ SerialOutputProc(
infoPtr->writeBufLen = toWrite;
infoPtr->writeBuf = ckalloc(toWrite);
}
- memcpy(infoPtr->writeBuf, buf, (size_t) toWrite);
+ memcpy(infoPtr->writeBuf, buf, toWrite);
infoPtr->toWrite = toWrite;
ResetEvent(infoPtr->evWritable);
TclPipeThreadSignal(&infoPtr->writeTI);
@@ -1849,7 +1849,7 @@ SerialSetOptionProc(
* -sysbuffer 4096 or -sysbuffer {64536 4096}
*/
- size_t inSize = (size_t) -1, outSize = (size_t) -1;
+ int inSize = -1, outSize = -1;
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
diff --git a/win/tclWinTest.c b/win/tclWinTest.c
index b3ad626..b2fe6c0 100644
--- a/win/tclWinTest.c
+++ b/win/tclWinTest.c
@@ -399,9 +399,11 @@ TestplatformChmod(
{
static const SECURITY_INFORMATION infoBits = OWNER_SECURITY_INFORMATION
| GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION;
+ /* don't deny DELETE mask (reset writable only, allow test-cases cleanup) */
static const DWORD readOnlyMask = FILE_DELETE_CHILD | FILE_ADD_FILE
| FILE_ADD_SUBDIRECTORY | FILE_WRITE_EA | FILE_APPEND_DATA
- | FILE_WRITE_DATA | DELETE;
+ | FILE_WRITE_DATA
+ /* | DELETE */;
/*
* References to security functions (only available on NT and later).
@@ -565,11 +567,13 @@ TestplatformChmod(
}
/*
- * Apply the new ACL.
+ * Apply the new ACL. Note PROTECTED_DACL_SECURITY_INFORMATION can be used
+ * to remove inherited ACL (we need to overwrite the default ACL's in this case)
*/
if (set_readOnly == acl_readOnly_found || SetNamedSecurityInfoA(
- (LPSTR) nativePath, SE_FILE_OBJECT, DACL_SECURITY_INFORMATION,
+ (LPSTR) nativePath, SE_FILE_OBJECT,
+ DACL_SECURITY_INFORMATION /*| PROTECTED_DACL_SECURITY_INFORMATION*/,
NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) {
res = 0;
}