Tcl Source Code

Check-in [ee3df4e647]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Correct spelling errors in comments and documentation, but also non-comment corrections in history.tcl and tcltest.test.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-6-branch
Files: files | file ages | folders
SHA3-256: ee3df4e647593609530c50114d170a75cf017d6e37a264a7d574808bc20fd2d8
User & Date: pooryorick 2023-04-12 09:35:08
Original Comment: Correct spelling errors in comments and documentation, but also a non-comment corections in history.tcl and tcltest.test.
Context
2023-04-12
13:30
Correct spelling errors in comments and documentation, but also a non-comment corrections in histor... check-in: aca8de0aeb user: pooryorick tags: core-8-branch
12:48
2 more spelling fixes, but undo fixes in compat/zlib: Please report them upstream, otherwise they wi... check-in: 9244b0b09d user: jan.nijtmans tags: core-8-6-branch
09:35
Correct spelling errors in comments and documentation, but also non-comment corrections in history.... check-in: ee3df4e647 user: pooryorick tags: core-8-6-branch
2023-03-31
07:57
Update to tzdata 2023c (which is identical to 2023a, due to the summertime situation in Libanon) check-in: 8823d963d4 user: jan.nijtmans tags: core-8-6-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.

1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
2012-04-28  Alexandre Ferrieux  <[email protected]>

	* generic/tclIO.c: Properly close nonblocking channels even when
	not flushing them.

2012-05-03  Jan Nijtmans  <[email protected]>

	* compat/zlib/*: Upgrade to zlib 1.2.7 (pre-built dll is still 1.2.5,
	will be upgraded as soon as the official build is available)

2012-05-03  Don Porter  <[email protected]>

	* tests/socket.test:	[Bug 3428754]: Test socket-14.2 tolerate
	[socket -async] connection that connects synchronously.








|







1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
2012-04-28  Alexandre Ferrieux  <[email protected]>

	* generic/tclIO.c: Properly close nonblocking channels even when
	not flushing them.

2012-05-03  Jan Nijtmans  <[email protected]>

	* compat/zlib/*: Upgrade to zlib 1.2.7 (prebuilt dll is still 1.2.5,
	will be upgraded as soon as the official build is available)

2012-05-03  Don Porter  <[email protected]>

	* tests/socket.test:	[Bug 3428754]: Test socket-14.2 tolerate
	[socket -async] connection that connects synchronously.

5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
	                      checking for the exact error message.

2010-03-30  Andreas Kupries  <[email protected]>

	* generic/tclIORChan.c (ReflectClose, ReflectInput, ReflectOutput,
	(ReflectSeekWide, ReflectWatch, ReflectBlock, ReflectSetOption,
	(ReflectGetOption, ForwardProc): [Bug 2978773]: Preserve
	ReflectedChannel* structures across handler invokations, to avoid
	crashes when the handler implementation induces nested callbacks and
	destruction of the channel deep inside such a nesting.

2010-03-30  Don Porter  <[email protected]>

	* generic/tclObj.c (Tcl_GetCommandFromObj):     [Bug 2979402]: Reorder
	the validity tests on internal rep of a "cmdName" value to avoid







|







5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
	                      checking for the exact error message.

2010-03-30  Andreas Kupries  <[email protected]>

	* generic/tclIORChan.c (ReflectClose, ReflectInput, ReflectOutput,
	(ReflectSeekWide, ReflectWatch, ReflectBlock, ReflectSetOption,
	(ReflectGetOption, ForwardProc): [Bug 2978773]: Preserve
	ReflectedChannel* structures across handler invocations, to avoid
	crashes when the handler implementation induces nested callbacks and
	destruction of the channel deep inside such a nesting.

2010-03-30  Don Porter  <[email protected]>

	* generic/tclObj.c (Tcl_GetCommandFromObj):     [Bug 2979402]: Reorder
	the validity tests on internal rep of a "cmdName" value to avoid
6359
6360
6361
6362
6363
6364
6365
6366
6367
6368
6369
6370
6371
6372
6373

	* generic/tclBinary.c:	[Bug 2922555]: Handle completely invalid input
	* tests/binary.test:	to the decode methods.

2009-12-28  Donal K. Fellows  <[email protected]>

	* unix/Makefile.in (trace-shell, trace-test): [FRQ 1083288]: Added
	targets to allow easier tracing of shell and test invokations.

	* unix/configure.in: [Bug 942170]:	Detect the st_blocks field of
	* generic/tclCmdAH.c (StoreStatData):	'struct stat' correctly.
	* generic/tclFileName.c (Tcl_GetBlocksFromStat):
	* generic/tclIOUtil.c (Tcl_Stat):

	* generic/tclInterp.c (TimeLimitCallback): [Bug 2891362]: Ensure that







|







6359
6360
6361
6362
6363
6364
6365
6366
6367
6368
6369
6370
6371
6372
6373

	* generic/tclBinary.c:	[Bug 2922555]: Handle completely invalid input
	* tests/binary.test:	to the decode methods.

2009-12-28  Donal K. Fellows  <[email protected]>

	* unix/Makefile.in (trace-shell, trace-test): [FRQ 1083288]: Added
	targets to allow easier tracing of shell and test invocations.

	* unix/configure.in: [Bug 942170]:	Detect the st_blocks field of
	* generic/tclCmdAH.c (StoreStatData):	'struct stat' correctly.
	* generic/tclFileName.c (Tcl_GetBlocksFromStat):
	* generic/tclIOUtil.c (Tcl_Stat):

	* generic/tclInterp.c (TimeLimitCallback): [Bug 2891362]: Ensure that
6843
6844
6845
6846
6847
6848
6849
6850
6851
6852
6853
6854
6855
6856
6857
	* tools/tclZIC.tcl
	* tools/tsdPerf.c

2009-11-17  Andreas Kupries  <[email protected]>

	* unix/tclUnixChan.c (TtyParseMode): Partial undo of Donal's tidy-up
	from a few days ago (2009-11-9, not in ChangeLog). It seems that
	strchr is apparently a macro on AIX and reacts badly to pre-processor
	directives in its arguments.

2009-11-16  Alexandre Ferrieux  <[email protected]>

	* generic/tclEncoding.c:  [Bug 2891556]: Fix and improve test to
	* generic/tclTest.c:	  detect similar manifestations in the future.
	* tests/encoding.test:    Add tcltest support for finalization.







|







6843
6844
6845
6846
6847
6848
6849
6850
6851
6852
6853
6854
6855
6856
6857
	* tools/tclZIC.tcl
	* tools/tsdPerf.c

2009-11-17  Andreas Kupries  <[email protected]>

	* unix/tclUnixChan.c (TtyParseMode): Partial undo of Donal's tidy-up
	from a few days ago (2009-11-9, not in ChangeLog). It seems that
	strchr is apparently a macro on AIX and reacts badly to preprocessor
	directives in its arguments.

2009-11-16  Alexandre Ferrieux  <[email protected]>

	* generic/tclEncoding.c:  [Bug 2891556]: Fix and improve test to
	* generic/tclTest.c:	  detect similar manifestations in the future.
	* tests/encoding.test:    Add tcltest support for finalization.
7137
7138
7139
7140
7141
7142
7143
7144
7145
7146
7147
7148
7149
7150
7151

2009-10-20  Don Porter  <[email protected]>

	* unix/Makefile.in:	Removed the long outdated and broken targets
	package-* that were for building Solaris packages.  Appears that the
	pieces needed for these targets to function have never been present in
	the current era of Tcl development and belong completely to Tcl
	pre-history.

2009-10-19  Don Porter  <[email protected]>

	* generic/tclIO.c:      [Patch 2107634]: Revised ReadChars and
	FilterInputBytes routines to permit reads to continue up to the string
	limits of Tcl values.  Before revisions, large read attempts could
	panic when as little as half the limiting value length was reached.







|







7137
7138
7139
7140
7141
7142
7143
7144
7145
7146
7147
7148
7149
7150
7151

2009-10-20  Don Porter  <[email protected]>

	* unix/Makefile.in:	Removed the long outdated and broken targets
	package-* that were for building Solaris packages.  Appears that the
	pieces needed for these targets to function have never been present in
	the current era of Tcl development and belong completely to Tcl
	prehistory.

2009-10-19  Don Porter  <[email protected]>

	* generic/tclIO.c:      [Patch 2107634]: Revised ReadChars and
	FilterInputBytes routines to permit reads to continue up to the string
	limits of Tcl values.  Before revisions, large read attempts could
	panic when as little as half the limiting value length was reached.
8705
8706
8707
8708
8709
8710
8711
8712
8713
8714
8715
8716
8717
8718
8719
	customize SHLIB_VERSION on BSD-derived systems. Thanks to Stuart
	Cassoff for his help.
	* unix/configure: Autoconf 2.59

2009-01-19  David Gravereaux  <[email protected]>

	* win/build.vc.bat: Improved tools detection and error message
	* win/makefile.vc: Reorganized the $(TCLOBJ) file list into seperate
	parts for easier maintenance. Matched all sources built using -GL to
	both $(lib) and $(link) to use -LTCG and avoid a warning message.
	Addressed the over-building nature of the htmlhelp target by moving
	from a pseudo target to a real target dependent on the entire docs/
	directory contents.
	* win/nmakehlp.c: Removed -g option and GrepForDefine() func as it
	isn't being used anymore. The -V option method is much better.







|







8705
8706
8707
8708
8709
8710
8711
8712
8713
8714
8715
8716
8717
8718
8719
	customize SHLIB_VERSION on BSD-derived systems. Thanks to Stuart
	Cassoff for his help.
	* unix/configure: Autoconf 2.59

2009-01-19  David Gravereaux  <[email protected]>

	* win/build.vc.bat: Improved tools detection and error message
	* win/makefile.vc: Reorganized the $(TCLOBJ) file list into separate
	parts for easier maintenance. Matched all sources built using -GL to
	both $(lib) and $(link) to use -LTCG and avoid a warning message.
	Addressed the over-building nature of the htmlhelp target by moving
	from a pseudo target to a real target dependent on the entire docs/
	directory contents.
	* win/nmakehlp.c: Removed -g option and GrepForDefine() func as it
	isn't being used anymore. The -V option method is much better.

Changes to ChangeLog.1999.

384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
	of the variable.

	* tests/autoMkindex.test:
	* tests/pkgMkIndex.test: Explicitly cd to ::tcltest::testsDirectory at
	the beginning of the test run

	* tests/basic.test: Use version information defined in tcltest instead
	of hardcoded version number

	* tests/socket.test: package require tcltest before attempting to use
	variable defined in tcltest namespace

	* tests/unixInit.test:
	* tests/unixNotfy.test: Added explicit exits needed to avoid problems
	when the tests area run in wish.







|







384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
	of the variable.

	* tests/autoMkindex.test:
	* tests/pkgMkIndex.test: Explicitly cd to ::tcltest::testsDirectory at
	the beginning of the test run

	* tests/basic.test: Use version information defined in tcltest instead
	of hard-coded version number

	* tests/socket.test: package require tcltest before attempting to use
	variable defined in tcltest namespace

	* tests/unixInit.test:
	* tests/unixNotfy.test: Added explicit exits needed to avoid problems
	when the tests area run in wish.

Changes to ChangeLog.2000.

99
100
101
102
103
104
105
106
107
108
109
110
111
112
113

2000-11-23  Donal K. Fellows  <[email protected]>

	* generic/tclCmdIL.c (Tcl_LsortObjCmd): Fixed memory leak from [Bug
	119398]

	* library/init.tcl (unknown): Added specific level parameters to
	all uplevel invokations to boost performance; didn't dare touch
	the "namespace inscope" stuff though, since it looks sensitive
	to me!  Should fix [Bug 123217], though testing is tricky...

2000-11-21  Andreas Kupries  <[email protected]>

	All of the changes below are described in TIP #7 ~ Specification and
	result from the application of the patch contained therein. Creator of







|







99
100
101
102
103
104
105
106
107
108
109
110
111
112
113

2000-11-23  Donal K. Fellows  <[email protected]>

	* generic/tclCmdIL.c (Tcl_LsortObjCmd): Fixed memory leak from [Bug
	119398]

	* library/init.tcl (unknown): Added specific level parameters to
	all uplevel invocation to boost performance; didn't dare touch
	the "namespace inscope" stuff though, since it looks sensitive
	to me!  Should fix [Bug 123217], though testing is tricky...

2000-11-21  Andreas Kupries  <[email protected]>

	All of the changes below are described in TIP #7 ~ Specification and
	result from the application of the patch contained therein. Creator of
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
	* doc/tcltest2.n: Code and documentation cleanup. Modified -verbose to
	take list of keywords as well as string of letters. Removed Tcl
	version information from tcltest. Removed tcltest::grep from tcltest
	package. Added optional 3rd directory argument to
	makeFile/makeDirectory and removeFile/removeDirectory.

	* tests/basic.test: Changed references to tcltest::tclVersion to
	hardcoded numbers.
	* generic/tcl.h: Changed reference to tcltest2.tcl and tcltest.tcl in
	comments to tests/basic.test.

2000-10-06  David Gravereaux  <[email protected]>

	* win/tclWinChan.c: moved Win2K bug case test with GetStdHandle() from
	TclpGetDefaultStdChannel into Tcl_MakeFileChannel to enable a more







|







344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
	* doc/tcltest2.n: Code and documentation cleanup. Modified -verbose to
	take list of keywords as well as string of letters. Removed Tcl
	version information from tcltest. Removed tcltest::grep from tcltest
	package. Added optional 3rd directory argument to
	makeFile/makeDirectory and removeFile/removeDirectory.

	* tests/basic.test: Changed references to tcltest::tclVersion to
	hard-coded numbers.
	* generic/tcl.h: Changed reference to tcltest2.tcl and tcltest.tcl in
	comments to tests/basic.test.

2000-10-06  David Gravereaux  <[email protected]>

	* win/tclWinChan.c: moved Win2K bug case test with GetStdHandle() from
	TclpGetDefaultStdChannel into Tcl_MakeFileChannel to enable a more
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131

	* library/msgcat1.0/msgcat.tcl: Applied patches from Laurent Duperval,
	to add mcmax function, which computes the length of the longest of
	several translated strings. Bumped version number to 1.1.

2000-06-27  Eric Melski  <[email protected]>

	* tests/stringObj.test: Tweaked tests to avoid hardcoded high-ASCII
	characters (which will fail in multibyte locales); instead used \uXXXX
	syntax. [Bug: 3842].

2000-06-26  Eric Melski  <[email protected]>

	* doc/package.n: Corrected information about [package forget]
	arguments [Bug: 5418].







|







1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131

	* library/msgcat1.0/msgcat.tcl: Applied patches from Laurent Duperval,
	to add mcmax function, which computes the length of the longest of
	several translated strings. Bumped version number to 1.1.

2000-06-27  Eric Melski  <[email protected]>

	* tests/stringObj.test: Tweaked tests to avoid hard-coded high-ASCII
	characters (which will fail in multibyte locales); instead used \uXXXX
	syntax. [Bug: 3842].

2000-06-26  Eric Melski  <[email protected]>

	* doc/package.n: Corrected information about [package forget]
	arguments [Bug: 5418].
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
	Tcl_InitMemory, and Tcl_ValidateAllMemory [Bug: 1816, 1835].

	* generic/tclCkalloc.c: Fixed some function headers.

	* unix/mkLinks: Regen'd with new mkLinks.tcl.

	* unix/mkLinks.tcl: Fixed indentation, made link setup more
	intelligent (only do one existance test per man page, instead of one
	per function).

	* doc/library.n: Fixed .SH NAME macro to include each function
	documented on the page, so that mkLinks will know about the functions
	listed there, and so that the Windows help file index will get set up
	correctly [Bug: 1898, 5273].








|







1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
	Tcl_InitMemory, and Tcl_ValidateAllMemory [Bug: 1816, 1835].

	* generic/tclCkalloc.c: Fixed some function headers.

	* unix/mkLinks: Regen'd with new mkLinks.tcl.

	* unix/mkLinks.tcl: Fixed indentation, made link setup more
	intelligent (only do one existence test per man page, instead of one
	per function).

	* doc/library.n: Fixed .SH NAME macro to include each function
	documented on the page, so that mkLinks will know about the functions
	listed there, and so that the Windows help file index will get set up
	correctly [Bug: 1898, 5273].

1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
	fixed http::ncode so that it actually gives you back the http return
	code (i.e. 200, 404, etc.) instead of the first digit of the version
	of HTTP being used (i.e. 1).

2000-04-21  Brent Welch <[email protected]>

	* library/http2.1/http.tcl: More thrashing with the "server closes
	without reading post data" scenario. Reverted to the previous filevent
	configuratiuon, which seems to work better with small amounts of post
	data.

2000-04-20  Jeff Hobbs  <[email protected]>

	* generic/tclAlloc.c: wrapped caddr_t define to not be done on Unix
	* unix/tclUnixPort.h: added Tclp*Alloc defines to allow the use of







|







1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
	fixed http::ncode so that it actually gives you back the http return
	code (i.e. 200, 404, etc.) instead of the first digit of the version
	of HTTP being used (i.e. 1).

2000-04-21  Brent Welch <[email protected]>

	* library/http2.1/http.tcl: More thrashing with the "server closes
	without reading post data" scenario. Reverted to the previous fileevent
	configuratiuon, which seems to work better with small amounts of post
	data.

2000-04-20  Jeff Hobbs  <[email protected]>

	* generic/tclAlloc.c: wrapped caddr_t define to not be done on Unix
	* unix/tclUnixPort.h: added Tclp*Alloc defines to allow the use of
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277

	* tests/pkg/magicchar.tcl:
	* tests/autoMkindex.test: Test for fix for bug #2611.

	* library/auto.tcl: Fixed the regular expression that performs $
	escaping before sourcing a file to index. It was erroneously adding \
	escapes even to $'s that were already escaped, effectively
	"un-escaping" those $'s. (bug #2611).

2000-01-27  Eric Melski  <[email protected]>

	* tests/autoMkindex.test:
	* library/auto.tcl: Applied patch (with slight modification) from bug
	#2701: auto_mkIndex uses platform dependent file paths. Added test for
	fix.







|







2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277

	* tests/pkg/magicchar.tcl:
	* tests/autoMkindex.test: Test for fix for bug #2611.

	* library/auto.tcl: Fixed the regular expression that performs $
	escaping before sourcing a file to index. It was erroneously adding \
	escapes even to $'s that were already escaped, effectively
	"unescaping" those $'s. (bug #2611).

2000-01-27  Eric Melski  <[email protected]>

	* tests/autoMkindex.test:
	* library/auto.tcl: Applied patch (with slight modification) from bug
	#2701: auto_mkIndex uses platform dependent file paths. Added test for
	fix.
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
	#981).

	* doc/upvar.n: Expanded explanation of upvar behavior with respect to
	variable traces. (bugs 3917 1433 2110).

	* generic/tclVar.c: Changed behavior of variable command when name
	refers to an element in an array (ie, "variable foo(x)") to always
	return an error, regardless of existance of that element in the array
	(now behavior is consistant with docs too) (bug #981).

2000-01-20  Jeff Hobbs  <[email protected]>

	* generic/tclCmdIL.c (InfoBodyCmd): made [info body] return a string
	if the body has been bytecompiled.
	* generic/tclBasic.c (Tcl_EvalObjEx): added pedantic check for







|







2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
	#981).

	* doc/upvar.n: Expanded explanation of upvar behavior with respect to
	variable traces. (bugs 3917 1433 2110).

	* generic/tclVar.c: Changed behavior of variable command when name
	refers to an element in an array (ie, "variable foo(x)") to always
	return an error, regardless of existence of that element in the array
	(now behavior is consistant with docs too) (bug #981).

2000-01-20  Jeff Hobbs  <[email protected]>

	* generic/tclCmdIL.c (InfoBodyCmd): made [info body] return a string
	if the body has been bytecompiled.
	* generic/tclBasic.c (Tcl_EvalObjEx): added pedantic check for

Changes to ChangeLog.2002.

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

2002-12-16  David Gravereaux  <[email protected]>

	* generic/tclPipe.c (TclCleanupChildren):
	* tests/winPipe.test:
	* win/tclWinPipe.c (Tcl_WaitPid):
	* win/tclWinTest.c:  Gave Tcl_WaitPid the ability to return a Win32
	exception code translated into a posix style SIG*. This allows [close]
	to report "CHILDKILLED" without the meaning getting lost in a
	truncated exit code. In TclCleanupChildren(), TclpGetPid() had to get
	moved to before Tcl_WaitPid() as the the handle is removed from the
	list taking away the ability to get the process id after the wait is
	done. This shouldn't effect the unix implimentaion unless waitpid is
	called with a pid of zero, meaning "any". I don't think it is..








|







11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

2002-12-16  David Gravereaux  <[email protected]>

	* generic/tclPipe.c (TclCleanupChildren):
	* tests/winPipe.test:
	* win/tclWinPipe.c (Tcl_WaitPid):
	* win/tclWinTest.c:  Gave Tcl_WaitPid the ability to return a Win32
	exception code translated into a Posix-style SIG*. This allows [close]
	to report "CHILDKILLED" without the meaning getting lost in a
	truncated exit code. In TclCleanupChildren(), TclpGetPid() had to get
	moved to before Tcl_WaitPid() as the the handle is removed from the
	list taking away the ability to get the process id after the wait is
	done. This shouldn't effect the unix implimentaion unless waitpid is
	called with a pid of zero, meaning "any". I don't think it is..

1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971

	* library/tcltest/tcltest.tcl: Change [configure -match] to stop
	treating an empty list as a list of the single pattern "*". Changed
	the default value to [list *] so default operation remains the same.

	* tests/pkg/samename.tcl: restored. needed by pkgMkIndex.test.

	* library/tcltest/tcltest.tcl: restored writeability testing of
	-tmpdir, augmented by a special exception for the deafault value.

2002-07-01  Donal K. Fellows  <[email protected]>

	* doc/concat.n: Documented the *real* behaviour of [concat]!

2002-06-30  Don Porter  <[email protected]>

	* doc/tcltest.n: more work in progress updating tcltest docs.

	* tests/README:		Updated the instructions on running and
	* tests/cmdMZ.test:	adding to the test suite. Also updated
	* tests/encoding.test:	several tests, mostly to correctly create
	* tests/fCmd.test:	and destroy any temporary files in the
	* tests/info.test:	[temporaryDirectory] of tcltest.
	* tests/interp.test:

	* library/tcltest/tcltest.tcl:	Stopped checking for writeability of
	-tmpdir value because no default directory can be guaranteed to be
	writeable.

	* tests/autoMkindex.tcl: removed.
	* tests/pkg/samename.tcl: removed.
	* tests/pkg/magicchar.tcl: removed.
	* tests/pkg/magicchar2.tcl: removed.
	* tests/autoMkindex.test: Updated auto_mkIndex tests to use [makeFile]
	and [removeFile] so tests are done in [temporaryDirecotry] where write







|

















|

|







1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971

	* library/tcltest/tcltest.tcl: Change [configure -match] to stop
	treating an empty list as a list of the single pattern "*". Changed
	the default value to [list *] so default operation remains the same.

	* tests/pkg/samename.tcl: restored. needed by pkgMkIndex.test.

	* library/tcltest/tcltest.tcl: restored writability testing of
	-tmpdir, augmented by a special exception for the deafault value.

2002-07-01  Donal K. Fellows  <[email protected]>

	* doc/concat.n: Documented the *real* behaviour of [concat]!

2002-06-30  Don Porter  <[email protected]>

	* doc/tcltest.n: more work in progress updating tcltest docs.

	* tests/README:		Updated the instructions on running and
	* tests/cmdMZ.test:	adding to the test suite. Also updated
	* tests/encoding.test:	several tests, mostly to correctly create
	* tests/fCmd.test:	and destroy any temporary files in the
	* tests/info.test:	[temporaryDirectory] of tcltest.
	* tests/interp.test:

	* library/tcltest/tcltest.tcl:	Stopped checking for writability of
	-tmpdir value because no default directory can be guaranteed to be
	writable.

	* tests/autoMkindex.tcl: removed.
	* tests/pkg/samename.tcl: removed.
	* tests/pkg/magicchar.tcl: removed.
	* tests/pkg/magicchar2.tcl: removed.
	* tests/autoMkindex.test: Updated auto_mkIndex tests to use [makeFile]
	and [removeFile] so tests are done in [temporaryDirecotry] where write
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2002-06-06  Daniel Steffen  <[email protected]>

	* unix/tclUnixThrd.c (TclpReaddir, TclpLocaltime, TclpGmtime): added
	mutex wrapped calls to readdir, localtime & gmtime in case their
	thread-safe *_r counterparts are not available.
	* unix/tcl.m4: added configure check for readdir_r
	* unix/tcl.m4 (Darwin): set TCL_DEFAULT_ENCODING to utf-8 on MacOSX
	(where posix file apis expect utf-8, not iso8859-1).
	* unix/configure: regen
	* unix/Makefile.in: set DYLD_LIBRARY_PATH in parallel to
	LD_LIBRARY_PATH for MacOSX dynamic linker.
	* generic/tclEnv.c (TclSetEnv): fix env var setting on MacOSX (adapted
	from [Patch 524352] by jkbonfield).

2002-06-05  Don Porter  <[email protected]>







|







2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2002-06-06  Daniel Steffen  <[email protected]>

	* unix/tclUnixThrd.c (TclpReaddir, TclpLocaltime, TclpGmtime): added
	mutex wrapped calls to readdir, localtime & gmtime in case their
	thread-safe *_r counterparts are not available.
	* unix/tcl.m4: added configure check for readdir_r
	* unix/tcl.m4 (Darwin): set TCL_DEFAULT_ENCODING to utf-8 on MacOSX
	(where Posix file apis expect utf-8, not iso8859-1).
	* unix/configure: regen
	* unix/Makefile.in: set DYLD_LIBRARY_PATH in parallel to
	LD_LIBRARY_PATH for MacOSX dynamic linker.
	* generic/tclEnv.c (TclSetEnv): fix env var setting on MacOSX (adapted
	from [Patch 524352] by jkbonfield).

2002-06-05  Don Porter  <[email protected]>
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
	* win/makefile.vc:
	* win/rules.vc:  Added a new "loimpact" option that sets the
	-ws:aggressive linker option. Off by default. It's said to keep the
	heap use low at the expense of alloc speed.

	* win/tclAppInit.c: Changed #include "tcl.h" to be tclPort.h to remove
	the raw windows.h include. tclPort.h brings in windows.h already and
	lessens the pre-compiled-header mush and the randomly useless #pragma
	comment (lib,...) references throughout the big windows.h tree (as
	observed at high linker warning levels).

2002-02-21  Donal K. Fellows  <[email protected]>

	* generic/tcl.h: Better guessing of LP64/ILP32 architecture, but now
	sensitive to presence of (suitable) <limits.h>







|







3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
	* win/makefile.vc:
	* win/rules.vc:  Added a new "loimpact" option that sets the
	-ws:aggressive linker option. Off by default. It's said to keep the
	heap use low at the expense of alloc speed.

	* win/tclAppInit.c: Changed #include "tcl.h" to be tclPort.h to remove
	the raw windows.h include. tclPort.h brings in windows.h already and
	lessens the precompiled-header mush and the randomly useless #pragma
	comment (lib,...) references throughout the big windows.h tree (as
	observed at high linker warning levels).

2002-02-21  Donal K. Fellows  <[email protected]>

	* generic/tcl.h: Better guessing of LP64/ILP32 architecture, but now
	sensitive to presence of (suitable) <limits.h>
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
	* generic/tclCmdAH.c: 64-bit handling in [file] and [format]
	commands.
	* generic/tclBasic.c: New "wordSize" entry in ::tcl_platform.
	* generic/tclFCmd.c: Large-file support (with many consequences.)
	* generic/tclIO.c: Large-file support (with many consequences.)
	* compat/strtoll.c, compat/strtoull.c: New support functions.
	* unix/tcl.m4, unix/configure: 64-bit support and greatly enhanced
	cacheing.

	Most other changes, including all those in doc/* and test/* as well as
	the majority in the platform directories, follow on from these.

	Also coming out of the woodwork:
	* generic/tclIndex.c: Better support for Cray PVP.
	* win/tclWinMtherr.c: Better Borland support.







|







3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
	* generic/tclCmdAH.c: 64-bit handling in [file] and [format]
	commands.
	* generic/tclBasic.c: New "wordSize" entry in ::tcl_platform.
	* generic/tclFCmd.c: Large-file support (with many consequences.)
	* generic/tclIO.c: Large-file support (with many consequences.)
	* compat/strtoll.c, compat/strtoull.c: New support functions.
	* unix/tcl.m4, unix/configure: 64-bit support and greatly enhanced
	caching.

	Most other changes, including all those in doc/* and test/* as well as
	the majority in the platform directories, follow on from these.

	Also coming out of the woodwork:
	* generic/tclIndex.c: Better support for Cray PVP.
	* win/tclWinMtherr.c: Better Borland support.

Changes to ChangeLog.2003.

264
265
266
267
268
269
270
271
272
273
274
275
276
277
278

2003-11-17  Don Porter	<[email protected]>

	* tests/reg.test: Added tests for [Bugs 230589, 504785, 505048, 840258]
	recently fixed by 2003-11-15 commit to regcomp.c by Pavel Goran. His
	notes on the fix: This bug results from an error in code that splits
	states into "progress" and "no-progress" ones. This error causes an
	interesting situation with the pre-collected single-linked list of
	states to be splitted: many items were added to the list, but only
	several of them are accessible from the list beginning, since the
	"tmp" member of struct state (which is used here to hold a pointer to
	the next list item) gets overwritten, which results in a "looped"
	chain. As a result, not all of states are splitted, and one state is
	splitted two times, causing incorrect "no-progress" flag values.








|







264
265
266
267
268
269
270
271
272
273
274
275
276
277
278

2003-11-17  Don Porter	<[email protected]>

	* tests/reg.test: Added tests for [Bugs 230589, 504785, 505048, 840258]
	recently fixed by 2003-11-15 commit to regcomp.c by Pavel Goran. His
	notes on the fix: This bug results from an error in code that splits
	states into "progress" and "no-progress" ones. This error causes an
	interesting situation with the precollected single-linked list of
	states to be splitted: many items were added to the list, but only
	several of them are accessible from the list beginning, since the
	"tmp" member of struct state (which is used here to hold a pointer to
	the next list item) gets overwritten, which results in a "looped"
	chain. As a result, not all of states are splitted, and one state is
	splitted two times, causing incorrect "no-progress" flag values.

Changes to ChangeLog.2004.

373
374
375
376
377
378
379
380
381
382
383
384
385
386
387

2004-11-26  Donal K. Fellows  <[email protected]>

	* unix/configure.in: Simplify the code to check for correctness of
	strstr, strtoul and strtod.
	* unix/tcl.m4 (SC_TCL_CHECK_BROKEN_FUNC): Split a complex stanza out
	of configure.in into its own function. Also force it to do the right
	thing with cacheing of results of AC_TRY_RUN to deal with issue raised
	in [Patch 1073524]

	* doc/foreach.n: Added simple example. [FRQ 1073334]

2004-11-25  Donal K. Fellows  <[email protected]>

	* generic/tclProc.c (TclObjInterpProc):	    Make it so that only







|







373
374
375
376
377
378
379
380
381
382
383
384
385
386
387

2004-11-26  Donal K. Fellows  <[email protected]>

	* unix/configure.in: Simplify the code to check for correctness of
	strstr, strtoul and strtod.
	* unix/tcl.m4 (SC_TCL_CHECK_BROKEN_FUNC): Split a complex stanza out
	of configure.in into its own function. Also force it to do the right
	thing with caching of results of AC_TRY_RUN to deal with issue raised
	in [Patch 1073524]

	* doc/foreach.n: Added simple example. [FRQ 1073334]

2004-11-25  Donal K. Fellows  <[email protected]>

	* generic/tclProc.c (TclObjInterpProc):	    Make it so that only
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
	Mikhail Kolesnitchenko. [Patch 1018486]

2004-08-31  Vince Darley  <[email protected]>

	* doc/FileSystem.3:
	* generic/tclIOUtil.c: Clarified documentation regarding ability of a
	filesystem to say that it doesn't support a given operation using the
	EXDEV posix error code (copyFileProc, renameFileProc, etc), and
	updated one piece of code to ensure correct behaviour when an
	operation is not supported [Bug 1017072]

	* tests/fCmd.test: fix to test suite problem [Bug 1002884]

2004-08-31  Daniel Steffen  <[email protected]>








|







1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
	Mikhail Kolesnitchenko. [Patch 1018486]

2004-08-31  Vince Darley  <[email protected]>

	* doc/FileSystem.3:
	* generic/tclIOUtil.c: Clarified documentation regarding ability of a
	filesystem to say that it doesn't support a given operation using the
	EXDEV Posix error code (copyFileProc, renameFileProc, etc), and
	updated one piece of code to ensure correct behaviour when an
	operation is not supported [Bug 1017072]

	* tests/fCmd.test: fix to test suite problem [Bug 1002884]

2004-08-31  Daniel Steffen  <[email protected]>

2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287

2004-07-17  Vince Darley  <[email protected]>

	* generic/tclIOUtil.c: fix to rare 'cd' infinite loop in normalization
	with vfs [Bug 991420].
	* tests/fileSystem.test: added test for above bug.

	* doc/FileSystem.3: clarified documentation of posix error codes in
	'remove directory' FS proc - 'EEXIST' is used to signify a non-empty
	directory error (bug reported against tclvfs).

2004-07-16  Jeff Hobbs	<[email protected]>

	* unix/Makefile.in, unix/tcl.m4:     move (C|LD)FLAGS after their
	* unix/configure.in, unix/configure: _DEFAULT to allow for env setting







|







2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287

2004-07-17  Vince Darley  <[email protected]>

	* generic/tclIOUtil.c: fix to rare 'cd' infinite loop in normalization
	with vfs [Bug 991420].
	* tests/fileSystem.test: added test for above bug.

	* doc/FileSystem.3: clarified documentation of Posix error codes in
	'remove directory' FS proc - 'EEXIST' is used to signify a non-empty
	directory error (bug reported against tclvfs).

2004-07-16  Jeff Hobbs	<[email protected]>

	* unix/Makefile.in, unix/tcl.m4:     move (C|LD)FLAGS after their
	* unix/configure.in, unix/configure: _DEFAULT to allow for env setting
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
	* tests/winPipe.test: more pass-thru commandline verifications.
	* win/tclWinPipe.c (BuildCommandLine): Special case quoting for '{'
	not required by the c-runtimes's parse_cmdline().
	* win/tclAppInit.c: Removed our custom setargv() in favor of the work
	provided by the c-runtime. [Bug 672938]

	* win/nmakehlp.c: defensive techniques to avoid static buffer
	overflows and a couple envars upsetting invokations of cl.exe and
	link.exe. [Bug 885537]

	* tests/winPipe.test: Added proof that BuildCommandLine() is not doing
	the "N backslashes followed a quote -> insert N * 2 + 1 backslashes
	then a quote" rule needed for the crt's parse_cmdline().
	* win/tclWinPipe.c: Fixed BuildCommandLine() to pass the new cases.








|







4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
	* tests/winPipe.test: more pass-thru commandline verifications.
	* win/tclWinPipe.c (BuildCommandLine): Special case quoting for '{'
	not required by the c-runtimes's parse_cmdline().
	* win/tclAppInit.c: Removed our custom setargv() in favor of the work
	provided by the c-runtime. [Bug 672938]

	* win/nmakehlp.c: defensive techniques to avoid static buffer
	overflows and a couple envars upsetting invocations of cl.exe and
	link.exe. [Bug 885537]

	* tests/winPipe.test: Added proof that BuildCommandLine() is not doing
	the "N backslashes followed a quote -> insert N * 2 + 1 backslashes
	then a quote" rule needed for the crt's parse_cmdline().
	* win/tclWinPipe.c: Fixed BuildCommandLine() to pass the new cases.

4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
	operation.

	* generic/tclCompCmds.c: Rewrote TclCompileReturnCmd() to call
	TclMergeReturnOptions() at compile time so the return options
	dictionary is computed at compile time (when it is fully known). The
	dictionary is pushed on the stack along with the result, and the code
	and level values are included in the bytecode as operands. Also
	supports optimized compilation of un-[catch]ed [return]s from procs
	with default options into the INST_DONE instruction.

	* generic/tclExecute.c: Rewrote INST_RETURN instruction to retrieve
	the code and level operands, pop the return options from the stack,
	and call TclProcessReturn() to perform the [return] operation.

	* generic/tclCompile.h:	New utilities include TclEmitInt4 macro







|







4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
	operation.

	* generic/tclCompCmds.c: Rewrote TclCompileReturnCmd() to call
	TclMergeReturnOptions() at compile time so the return options
	dictionary is computed at compile time (when it is fully known). The
	dictionary is pushed on the stack along with the result, and the code
	and level values are included in the bytecode as operands. Also
	supports optimized compilation of un[catch]ed [return]s from procs
	with default options into the INST_DONE instruction.

	* generic/tclExecute.c: Rewrote INST_RETURN instruction to retrieve
	the code and level operands, pop the return options from the stack,
	and call TclProcessReturn() to perform the [return] operation.

	* generic/tclCompile.h:	New utilities include TclEmitInt4 macro

Changes to ChangeLog.2005.

225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
	since when the list of opcodes changes it is usually useful to rebuild
	everything that depends on it (but which is nonetheless a small
	fraction of the total set of Tcl source files).

	***POTENTIAL INCOMPATIBILITY*** for bytecode savers/loaders. See below

	* generic/tclCompCmds.c (TclCompileSwitchCmd): Arrange for very simple
	[switch] invokations to be compiled into hash lookups into jump tables;
	only a very specific kind of [switch] can be safely compiled this way,
	but that happens to be the most common kind. This makes around 5-10%
	difference to the speed of execution of clock.test.
	* generic/tclExecute.c (TEBC:INST_JUMP_TABLE): New instruction to allow
	for jumps to locations looked up in a hashtable. Requires a new AuxData
	type, tclJumptableInfoType (supported by the functions DupJumptableInfo
	and FreeJumptableInfo in tclCompCmds.c) so anything that saves bytecode







|







225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
	since when the list of opcodes changes it is usually useful to rebuild
	everything that depends on it (but which is nonetheless a small
	fraction of the total set of Tcl source files).

	***POTENTIAL INCOMPATIBILITY*** for bytecode savers/loaders. See below

	* generic/tclCompCmds.c (TclCompileSwitchCmd): Arrange for very simple
	[switch] invocations to be compiled into hash lookups into jump tables;
	only a very specific kind of [switch] can be safely compiled this way,
	but that happens to be the most common kind. This makes around 5-10%
	difference to the speed of execution of clock.test.
	* generic/tclExecute.c (TEBC:INST_JUMP_TABLE): New instruction to allow
	for jumps to locations looked up in a hashtable. Requires a new AuxData
	type, tclJumptableInfoType (supported by the functions DupJumptableInfo
	and FreeJumptableInfo in tclCompCmds.c) so anything that saves bytecode

Changes to ChangeLog.2007.

1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
	an expr syntax error (masked by a [catch]).

	* generic/tclCompCmds.c (TclCompileReturnCmd):	Added crash protection
	to handle callers other than TclCompileScript() failing to meet the
	initialization assumptions of the TIP 280 code in CompileWord().

	* generic/tclCompExpr.c:	Suppress the attempt to convert to
	numeric when pre-compiling a constant expresion indicates an error.

2007-08-22  Miguel Sofer  <[email protected]>

	* generic/tclExecute.c (TEBC): disable the new shortcut to frequent
	INSTs for debug builds. REVERTED (collision with alternative fix)

2007-08-21  Don Porter	<[email protected]>







|







1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
	an expr syntax error (masked by a [catch]).

	* generic/tclCompCmds.c (TclCompileReturnCmd):	Added crash protection
	to handle callers other than TclCompileScript() failing to meet the
	initialization assumptions of the TIP 280 code in CompileWord().

	* generic/tclCompExpr.c:	Suppress the attempt to convert to
	numeric when precompiling a constant expresion indicates an error.

2007-08-22  Miguel Sofer  <[email protected]>

	* generic/tclExecute.c (TEBC): disable the new shortcut to frequent
	INSTs for debug builds. REVERTED (collision with alternative fix)

2007-08-21  Don Porter	<[email protected]>
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838

	* generic/tclCmdMZ.c (STR_MAP): Replace ckalloc calls with
	TclStackAlloc calls.

2007-03-24  Zoran Vasiljevic <[email protected]>

	* win/tclWinThrd.c: Thread exit handler marks the current thread as
	un-initialized. This allows exit handlers that are registered later to
	re-initialize this subsystem in case they need to use some sync
	primitives (cond variables) from this file again.

2007-03-23  Miguel Sofer  <[email protected]>

	* generic/tclBasic.c (DeleteInterpProc): pop the root frame pointer
	before deleting the global namespace [Bug 1658572]








|
|







2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838

	* generic/tclCmdMZ.c (STR_MAP): Replace ckalloc calls with
	TclStackAlloc calls.

2007-03-24  Zoran Vasiljevic <[email protected]>

	* win/tclWinThrd.c: Thread exit handler marks the current thread as
	uninitialized. This allows exit handlers that are registered later to
	reinitialize this subsystem in case they need to use some sync
	primitives (cond variables) from this file again.

2007-03-23  Miguel Sofer  <[email protected]>

	* generic/tclBasic.c (DeleteInterpProc): pop the root frame pointer
	before deleting the global namespace [Bug 1658572]

4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
	namespace creation faster. Plus selected other minor improvements to
	code quality. [Patch 1352382]

2006-08-10  Donal K. Fellows  <[email protected]>

	Misc patches to make code more efficient. [Bug 1530474] (afredd)
	* generic/*.c, macosx/tclMacOSXNotify.c, unix/tclUnixNotfy.c,
	* win/tclWinThrd.c: Tidy up invokations of Tcl_Panic() to promote
	string constant sharing and consistent style.
	* generic/tclBasic.c (Tcl_CreateInterp): More efficient handling of
	* generic/tclClock.c (TclClockInit):	 registration of commands not
						 in global namespace.
	* generic/tclVar.c (Tcl_UnsetObjCmd): Remove unreachable clause.

2006-08-09  Don Porter	<[email protected]>







|







4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
	namespace creation faster. Plus selected other minor improvements to
	code quality. [Patch 1352382]

2006-08-10  Donal K. Fellows  <[email protected]>

	Misc patches to make code more efficient. [Bug 1530474] (afredd)
	* generic/*.c, macosx/tclMacOSXNotify.c, unix/tclUnixNotfy.c,
	* win/tclWinThrd.c: Tidy up invocations of Tcl_Panic() to promote
	string constant sharing and consistent style.
	* generic/tclBasic.c (Tcl_CreateInterp): More efficient handling of
	* generic/tclClock.c (TclClockInit):	 registration of commands not
						 in global namespace.
	* generic/tclVar.c (Tcl_UnsetObjCmd): Remove unreachable clause.

2006-08-09  Don Porter	<[email protected]>
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026

	* generic/tclExecute.c: Corrected flawed overflow detection in
	* tests/expr.test:	INST_EXPON that caused [expr 2**64] to return
	0 instead of the same value as [expr 1<<64].

2006-07-24  Don Porter	<[email protected]>

	* win/tclWinSock.c:	Correct un-initialized Tcl_DString. Thanks to
	afredd. [Bug 1518166]

2006-07-21  Miguel Sofer  <[email protected]>

	* generic/tclExecute.c:
	* tests/execute.test (execute-9.1): dgp's fix for [Bug 1522803].








|







5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026

	* generic/tclExecute.c: Corrected flawed overflow detection in
	* tests/expr.test:	INST_EXPON that caused [expr 2**64] to return
	0 instead of the same value as [expr 1<<64].

2006-07-24  Don Porter	<[email protected]>

	* win/tclWinSock.c:	Correct uninitialized Tcl_DString. Thanks to
	afredd. [Bug 1518166]

2006-07-21  Miguel Sofer  <[email protected]>

	* generic/tclExecute.c:
	* tests/execute.test (execute-9.1): dgp's fix for [Bug 1522803].

Changes to ChangeLog.2008.

1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
	* generic/tclCompCmds.c (TclCompileEnsemble)
	* generic/tclNamesp.c (NamespaceEnsembleCmd)
	(Tcl_SetEnsembleParameterList, Tcl_GetEnsembleParameterList)
	(NsEnsembleImplementationCmdNR):
	* generic/tcl.decls, doc/Ensemble.3, doc/namespace.n
	* tests/namespace.test: Allow the handling of a (fixed) number of
	formal parameters between an ensemble's command and subcommand at
	invokation time. [Patch 1901783]

2008-09-28  Miguel Sofer  <[email protected]>

	* generic/tclBasic.c:	   Fix the numLevels computations on
	* generic/tclInt.h:	   coroutine yield/resume
	* tests/unsupported.test:








|







1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
	* generic/tclCompCmds.c (TclCompileEnsemble)
	* generic/tclNamesp.c (NamespaceEnsembleCmd)
	(Tcl_SetEnsembleParameterList, Tcl_GetEnsembleParameterList)
	(NsEnsembleImplementationCmdNR):
	* generic/tcl.decls, doc/Ensemble.3, doc/namespace.n
	* tests/namespace.test: Allow the handling of a (fixed) number of
	formal parameters between an ensemble's command and subcommand at
	invocation time. [Patch 1901783]

2008-09-28  Miguel Sofer  <[email protected]>

	* generic/tclBasic.c:	   Fix the numLevels computations on
	* generic/tclInt.h:	   coroutine yield/resume
	* tests/unsupported.test:

3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262

	* generic/tclBinary.c: [Bug 1923966] - crash in binary format
	* tests/binary.test:   Added tests for the above crash condition.

2008-03-21  Donal K. Fellows  <[email protected]>

	* doc/switch.n: Clarified documentation in respect of two-argument
	invokation. [Bug 1899962]

	* tests/switch.test: Added more tests of regexp-mode compilation of
	the [switch] command. [Bug 1854435]

2008-03-20  Donal K. Fellows  <[email protected]>

	* generic/tcl.h, generic/tclThreadAlloc.c: Tidied up the declarations







|







3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262

	* generic/tclBinary.c: [Bug 1923966] - crash in binary format
	* tests/binary.test:   Added tests for the above crash condition.

2008-03-21  Donal K. Fellows  <[email protected]>

	* doc/switch.n: Clarified documentation in respect of two-argument
	invocation. [Bug 1899962]

	* tests/switch.test: Added more tests of regexp-mode compilation of
	the [switch] command. [Bug 1854435]

2008-03-20  Donal K. Fellows  <[email protected]>

	* generic/tcl.h, generic/tclThreadAlloc.c: Tidied up the declarations

Changes to changes.

3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038

6/19/97 (bug fix) Fixed a panic due to the following four line script:
	interp create x
	x alias foo bar
	x eval rename foo blotz
	x alias foo {}
The problem was that the interp code was not using the actual current name
of the command to be deleted as a result of un-aliasing foo. (JL)

6/19/97 (feature change) Pass interp down to the ChannelOption and
driver specific calls so system errors can be differentiated from syntax
ones. Changed Tcl_DriverGetOptionProc type. Affects Tcl_GetChannelOption,
TcpGetOptionProc,  TtyGetOptionProc, etc. (DL)
*** POTENTIAL INCOMPATIBILITY ***








|







3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038

6/19/97 (bug fix) Fixed a panic due to the following four line script:
	interp create x
	x alias foo bar
	x eval rename foo blotz
	x alias foo {}
The problem was that the interp code was not using the actual current name
of the command to be deleted as a result of unaliasing foo. (JL)

6/19/97 (feature change) Pass interp down to the ChannelOption and
driver specific calls so system errors can be differentiated from syntax
ones. Changed Tcl_DriverGetOptionProc type. Affects Tcl_GetChannelOption,
TcpGetOptionProc,  TtyGetOptionProc, etc. (DL)
*** POTENTIAL INCOMPATIBILITY ***

4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
    - Modifying the TclpInitLibraryPath routines.
(surles)

3/14/99 (feature change) Added hooks for TclPro Wrapper to initialize
the location of the encoding files and libraries.  This fix included:
    - Adding the TclSetPerInitScript routine.
    - Modifying the Tcl_Init routines to evaluate the non-NULL
      pre-init script.
    - Adding the Tcl_SetdefaultEncodingDir and Tcl_GetDefaultEncodingDir
      routines.
    - Modifying the TclpInitLibrary routines to append the default
      encoding dir.
(surles)

3/14/99 (feature change) Test suite now uses "test" namespace to







|







4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
    - Modifying the TclpInitLibraryPath routines.
(surles)

3/14/99 (feature change) Added hooks for TclPro Wrapper to initialize
the location of the encoding files and libraries.  This fix included:
    - Adding the TclSetPerInitScript routine.
    - Modifying the Tcl_Init routines to evaluate the non-NULL
      preinit script.
    - Adding the Tcl_SetdefaultEncodingDir and Tcl_GetDefaultEncodingDir
      routines.
    - Modifying the TclpInitLibrary routines to append the default
      encoding dir.
(surles)

3/14/99 (feature change) Test suite now uses "test" namespace to
6973
6974
6975
6976
6977
6978
6979
6980
6981
6982
6983
6984
6985
6986
6987

2007-08-14 (platform support) Darwin [load] from VFS on intel & 64bit (steffen)

2007-08-15 (bug fix)[1773127] corrected open mode "a+" (rottman,fellows)

2007-08-16 (bug fix)[1773040] ::errorInfo trace crash (janssen,porter)

2007-08-16 (performance)[1564517] pre-compile constant expressions (porter)

2007-08-21 (bug fix)[1775878] 'puts \' in interactive tclsh failed to move to
prompt for continuation line (porter)

2007-08-25 (bug fix)[1781282] [clock scan] case senstivity (kenny)

2007-08-25 (performance)[1767293] ** on native integer types (kenny)







|







6973
6974
6975
6976
6977
6978
6979
6980
6981
6982
6983
6984
6985
6986
6987

2007-08-14 (platform support) Darwin [load] from VFS on intel & 64bit (steffen)

2007-08-15 (bug fix)[1773127] corrected open mode "a+" (rottman,fellows)

2007-08-16 (bug fix)[1773040] ::errorInfo trace crash (janssen,porter)

2007-08-16 (performance)[1564517] precompile constant expressions (porter)

2007-08-21 (bug fix)[1775878] 'puts \' in interactive tclsh failed to move to
prompt for continuation line (porter)

2007-08-25 (bug fix)[1781282] [clock scan] case senstivity (kenny)

2007-08-25 (performance)[1767293] ** on native integer types (kenny)
8681
8682
8683
8684
8685
8686
8687
8688
8689
8690
8691
8692
8693
8694
8695
2016-07-02 (enhancement)[09fabc] Sort order of -relateddir (lanam)

2016-07-07 (bug)[5d7ca0] Win: [file executable] for .cmd and .ps1 (nadkarni)
        *** POTENTIAL INCOMPATIBILITY ***

2016-07-08 (bug)[a47641] [file normalize] & Windows junctions (nadkarni)

2016-07-09 [ae61a6] [file] handling of Win hardcoded names (CON) (nadkarni)
        *** POTENTIAL INCOMPATIBILITY ***

2016-07-09 [3613671] [file owned] (more) useful on Win (nadkarni)

2016-07-09 (bug)[1493a4] [namespace upvar] use of resolvers (beric,fellows)
        *** POTENTIAL INCOMPATIBILITY ***








|







8681
8682
8683
8684
8685
8686
8687
8688
8689
8690
8691
8692
8693
8694
8695
2016-07-02 (enhancement)[09fabc] Sort order of -relateddir (lanam)

2016-07-07 (bug)[5d7ca0] Win: [file executable] for .cmd and .ps1 (nadkarni)
        *** POTENTIAL INCOMPATIBILITY ***

2016-07-08 (bug)[a47641] [file normalize] & Windows junctions (nadkarni)

2016-07-09 [ae61a6] [file] handling of Win hard-coded names (CON) (nadkarni)
        *** POTENTIAL INCOMPATIBILITY ***

2016-07-09 [3613671] [file owned] (more) useful on Win (nadkarni)

2016-07-09 (bug)[1493a4] [namespace upvar] use of resolvers (beric,fellows)
        *** POTENTIAL INCOMPATIBILITY ***

Changes to compat/zlib/ChangeLog.

843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
- Add "volatile" to crc table flag declaration (for DYNAMIC_CRC_TABLE)
- Add limited multitasking protection to DYNAMIC_CRC_TABLE
- Add NO_vsnprintf for VMS in zutil.h [Mozilla]
- Don't declare strerror() under VMS [Mozilla]
- Add comment to DYNAMIC_CRC_TABLE to use get_crc_table() to initialize
- Update contrib/ada [Anisimkov]
- Update contrib/minizip [Vollant]
- Fix configure to not hardcode directories for Darwin [Peterson]
- Fix gzio.c to not return error on empty files [Brown]
- Fix indentation; update version in contrib/delphi/ZLib.pas and
  contrib/pascal/zlibpas.pas [Truta]
- Update mkasm.bat in contrib/masmx86 [Truta]
- Update contrib/untgz [Truta]
- Add projects/README.projects [Truta]
- Add project for MS Visual C++ 6.0 in projects/visualc6 [Cadieux, Truta]







|







843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
- Add "volatile" to crc table flag declaration (for DYNAMIC_CRC_TABLE)
- Add limited multitasking protection to DYNAMIC_CRC_TABLE
- Add NO_vsnprintf for VMS in zutil.h [Mozilla]
- Don't declare strerror() under VMS [Mozilla]
- Add comment to DYNAMIC_CRC_TABLE to use get_crc_table() to initialize
- Update contrib/ada [Anisimkov]
- Update contrib/minizip [Vollant]
- Fix configure to not hard-code directories for Darwin [Peterson]
- Fix gzio.c to not return error on empty files [Brown]
- Fix indentation; update version in contrib/delphi/ZLib.pas and
  contrib/pascal/zlibpas.pas [Truta]
- Update mkasm.bat in contrib/masmx86 [Truta]
- Update contrib/untgz [Truta]
- Add projects/README.projects [Truta]
- Add project for MS Visual C++ 6.0 in projects/visualc6 [Cadieux, Truta]

Changes to compat/zlib/contrib/iostream3/zfstream.cc.

134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
  bool testb = mode & std::ios_base::binary;
  bool testi = mode & std::ios_base::in;
  bool testo = mode & std::ios_base::out;
  bool testt = mode & std::ios_base::trunc;
  bool testa = mode & std::ios_base::app;

  // Check for valid flag combinations - see [27.8.1.3.2] (Table 92)
  // Original zfstream hardcoded the compression level to maximum here...
  // Double the time for less than 1% size improvement seems
  // excessive though - keeping it at the default level
  // To change back, just append "9" to the next three mode strings
  if (!testi && testo && !testt && !testa)
    strcpy(c_mode, "w");
  if (!testi && testo && !testt && testa)
    strcpy(c_mode, "a");







|







134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
  bool testb = mode & std::ios_base::binary;
  bool testi = mode & std::ios_base::in;
  bool testo = mode & std::ios_base::out;
  bool testt = mode & std::ios_base::trunc;
  bool testa = mode & std::ios_base::app;

  // Check for valid flag combinations - see [27.8.1.3.2] (Table 92)
  // Original zfstream hard-coded the compression level to maximum here...
  // Double the time for less than 1% size improvement seems
  // excessive though - keeping it at the default level
  // To change back, just append "9" to the next three mode strings
  if (!testi && testo && !testt && !testa)
    strcpy(c_mode, "w");
  if (!testi && testo && !testt && testa)
    strcpy(c_mode, "a");

Changes to doc/Cancel.3.

22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
.AP Tcl_Interp *interp in
Interpreter in which to cancel the script.
.AP Tcl_Obj *resultObjPtr in
Error message to use in the cancellation, or NULL to use a default message. If
not NULL, this object will have its reference count decremented before
\fBTcl_CancelEval\fR returns.
.AP int flags in
ORed combination of flag bits that specify additional options.
For \fBTcl_CancelEval\fR, only \fBTCL_CANCEL_UNWIND\fR is currently
supported.  For \fBTcl_Canceled\fR, only \fBTCL_LEAVE_ERR_MSG\fR and
\fBTCL_CANCEL_UNWIND\fR are currently supported.
.AP ClientData clientData in
Currently reserved for future use.
It should be set to NULL.
.BE
.SH DESCRIPTION
.PP
\fBTcl_CancelEval\fR cancels or unwinds the script in progress soon after
the next invocation of asynchronous handlers, causing \fBTCL_ERROR\fR to be
the return code for that script.  This function is thread-safe and may be
called from any thread in the process.
.PP
\fBTcl_Canceled\fR checks if the script in progress has been canceled and
returns \fBTCL_ERROR\fR if it has.  Otherwise, \fBTCL_OK\fR is returned.
Extensions can use this function to check to see if they should abort a long
running command.  This function is thread sensitive and may only be called
from the thread the interpreter was created in.
.SS "FLAG BITS"
Any ORed combination of the following values may be used for the
\fIflags\fR argument to procedures such as \fBTcl_CancelEval\fR:
.TP 20
\fBTCL_CANCEL_UNWIND\fR
.
This flag is used by \fBTcl_CancelEval\fR and \fBTcl_Canceled\fR.
For \fBTcl_CancelEval\fR, if this flag is set, the script in progress
is canceled and the evaluation stack for the interpreter is unwound.







|




















|







22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
.AP Tcl_Interp *interp in
Interpreter in which to cancel the script.
.AP Tcl_Obj *resultObjPtr in
Error message to use in the cancellation, or NULL to use a default message. If
not NULL, this object will have its reference count decremented before
\fBTcl_CancelEval\fR returns.
.AP int flags in
OR'ed combination of flag bits that specify additional options.
For \fBTcl_CancelEval\fR, only \fBTCL_CANCEL_UNWIND\fR is currently
supported.  For \fBTcl_Canceled\fR, only \fBTCL_LEAVE_ERR_MSG\fR and
\fBTCL_CANCEL_UNWIND\fR are currently supported.
.AP ClientData clientData in
Currently reserved for future use.
It should be set to NULL.
.BE
.SH DESCRIPTION
.PP
\fBTcl_CancelEval\fR cancels or unwinds the script in progress soon after
the next invocation of asynchronous handlers, causing \fBTCL_ERROR\fR to be
the return code for that script.  This function is thread-safe and may be
called from any thread in the process.
.PP
\fBTcl_Canceled\fR checks if the script in progress has been canceled and
returns \fBTCL_ERROR\fR if it has.  Otherwise, \fBTCL_OK\fR is returned.
Extensions can use this function to check to see if they should abort a long
running command.  This function is thread sensitive and may only be called
from the thread the interpreter was created in.
.SS "FLAG BITS"
Any OR'ed combination of the following values may be used for the
\fIflags\fR argument to procedures such as \fBTcl_CancelEval\fR:
.TP 20
\fBTCL_CANCEL_UNWIND\fR
.
This flag is used by \fBTcl_CancelEval\fR and \fBTcl_Canceled\fR.
For \fBTcl_CancelEval\fR, if this flag is set, the script in progress
is canceled and the evaluation stack for the interpreter is unwound.

Changes to doc/Ensemble.3.

67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
but all other functions must not.
.AP "const char" *name in
The name of the ensemble command to be created.
.AP Tcl_Namespace *namespacePtr in
The namespace to which the ensemble command is to be bound, or NULL
for the current namespace.
.AP int ensFlags in
An ORed set of flag bits describing the basic configuration of the
ensemble. Currently only one bit has meaning, \fBTCL_ENSEMBLE_PREFIX\fR,
which is present when the ensemble command should also match
unambiguous prefixes of subcommands.
.AP Tcl_Obj *cmdNameObj in
A value holding the name of the ensemble command to look up.
.AP int flags in
An ORed set of flag bits controlling the behavior of
\fBTcl_FindEnsemble\fR. Currently only \fBTCL_LEAVE_ERR_MSG\fR is supported.
.AP Tcl_Command token in
A normal command token that refers to an ensemble command, or which
you wish to use for testing as an ensemble command in \fBTcl_IsEnsemble\fR.
.AP int *ensFlagsPtr out
Pointer to a variable into which to write the current ensemble flag
bits; currently only the bit \fBTCL_ENSEMBLE_PREFIX\fR is defined.







|






|







67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
but all other functions must not.
.AP "const char" *name in
The name of the ensemble command to be created.
.AP Tcl_Namespace *namespacePtr in
The namespace to which the ensemble command is to be bound, or NULL
for the current namespace.
.AP int ensFlags in
An OR'ed set of flag bits describing the basic configuration of the
ensemble. Currently only one bit has meaning, \fBTCL_ENSEMBLE_PREFIX\fR,
which is present when the ensemble command should also match
unambiguous prefixes of subcommands.
.AP Tcl_Obj *cmdNameObj in
A value holding the name of the ensemble command to look up.
.AP int flags in
An OR'ed set of flag bits controlling the behavior of
\fBTcl_FindEnsemble\fR. Currently only \fBTCL_LEAVE_ERR_MSG\fR is supported.
.AP Tcl_Command token in
A normal command token that refers to an ensemble command, or which
you wish to use for testing as an ensemble command in \fBTcl_IsEnsemble\fR.
.AP int *ensFlagsPtr out
Pointer to a variable into which to write the current ensemble flag
bits; currently only the bit \fBTCL_ENSEMBLE_PREFIX\fR is defined.

Changes to doc/Eval.3.

45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
.AS Tcl_Interp **termPtr
.AP Tcl_Interp *interp in
Interpreter in which to execute the script.  The interpreter's result is
modified to hold the result or error message from the script.
.AP Tcl_Obj *objPtr in
A Tcl value containing the script to execute.
.AP int flags in
ORed combination of flag bits that specify additional options.
\fBTCL_EVAL_GLOBAL\fR and \fBTCL_EVAL_DIRECT\fR are currently supported.
.AP "const char" *fileName in
Name of a file containing a Tcl script.
.AP int objc in
The number of values in the array pointed to by \fIobjv\fR;
this is also the number of words in the command.
.AP Tcl_Obj **objv in







|







45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
.AS Tcl_Interp **termPtr
.AP Tcl_Interp *interp in
Interpreter in which to execute the script.  The interpreter's result is
modified to hold the result or error message from the script.
.AP Tcl_Obj *objPtr in
A Tcl value containing the script to execute.
.AP int flags in
OR'ed combination of flag bits that specify additional options.
\fBTCL_EVAL_GLOBAL\fR and \fBTCL_EVAL_DIRECT\fR are currently supported.
.AP "const char" *fileName in
Name of a file containing a Tcl script.
.AP int objc in
The number of values in the array pointed to by \fIobjv\fR;
this is also the number of words in the command.
.AP Tcl_Obj **objv in
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
in code for string comparison, you can use
.QW \e032
or
.QW \eu001a ,
which will be safely substituted by the Tcl interpreter into
.QW ^Z .
.PP
\fBTcl_EvalObjv\fR executes a single pre-parsed command instead of a
script.  The \fIobjc\fR and \fIobjv\fR arguments contain the values
of the words for the Tcl command, one word in each value in
\fIobjv\fR.  \fBTcl_EvalObjv\fR evaluates the command and returns
a completion code and result just like \fBTcl_EvalObjEx\fR.
The caller of \fBTcl_EvalObjv\fR has to manage the reference count of the
elements of \fIobjv\fR, insuring that the values are valid until
\fBTcl_EvalObjv\fR returns.







|







105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
in code for string comparison, you can use
.QW \e032
or
.QW \eu001a ,
which will be safely substituted by the Tcl interpreter into
.QW ^Z .
.PP
\fBTcl_EvalObjv\fR executes a single preparsed command instead of a
script.  The \fIobjc\fR and \fIobjv\fR arguments contain the values
of the words for the Tcl command, one word in each value in
\fIobjv\fR.  \fBTcl_EvalObjv\fR evaluates the command and returns
a completion code and result just like \fBTcl_EvalObjEx\fR.
The caller of \fBTcl_EvalObjv\fR has to manage the reference count of the
elements of \fIobjv\fR, insuring that the values are valid until
\fBTcl_EvalObjv\fR returns.
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
.PP
\fBTcl_VarEvalVA\fR is the same as \fBTcl_VarEval\fR except that
instead of taking a variable number of arguments it takes an argument
list. Like \fBTcl_VarEval\fR, \fBTcl_VarEvalVA\fR is deprecated.

.SH "FLAG BITS"
.PP
Any ORed combination of the following values may be used for the
\fIflags\fR argument to procedures such as \fBTcl_EvalObjEx\fR:
.TP 23
\fBTCL_EVAL_DIRECT\fR
.
This flag is only used by \fBTcl_EvalObjEx\fR; it is ignored by
other procedures.  If this flag bit is set, the script is not
compiled to bytecodes; instead it is executed directly







|







156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
.PP
\fBTcl_VarEvalVA\fR is the same as \fBTcl_VarEval\fR except that
instead of taking a variable number of arguments it takes an argument
list. Like \fBTcl_VarEval\fR, \fBTcl_VarEvalVA\fR is deprecated.

.SH "FLAG BITS"
.PP
Any OR'ed combination of the following values may be used for the
\fIflags\fR argument to procedures such as \fBTcl_EvalObjEx\fR:
.TP 23
\fBTCL_EVAL_DIRECT\fR
.
This flag is only used by \fBTcl_EvalObjEx\fR; it is ignored by
other procedures.  If this flag bit is set, the script is not
compiled to bytecodes; instead it is executed directly

Changes to doc/FileSystem.3.

227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
be joined together. If negative, then all elements are joined.
.AP Tcl_Obj **errorPtr out
In the case of an error, filled with a value containing the name of
the file which caused an error in the various copy/rename operations.
.AP Tcl_Obj **objPtrRef out
Filled with a value containing the result of the operation.
.AP Tcl_Obj *resultPtr out
Pre-allocated value in which to store (using
\fBTcl_ListObjAppendElement\fR) the list of
files or directories which are successfully matched.
.AP int mode in
Mask consisting of one or more of R_OK, W_OK, X_OK and F_OK. R_OK,
W_OK and X_OK request checking whether the file exists and  has  read,
write and  execute  permissions, respectively. F_OK just requests
checking for the existence of the file.







|







227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
be joined together. If negative, then all elements are joined.
.AP Tcl_Obj **errorPtr out
In the case of an error, filled with a value containing the name of
the file which caused an error in the various copy/rename operations.
.AP Tcl_Obj **objPtrRef out
Filled with a value containing the result of the operation.
.AP Tcl_Obj *resultPtr out
Preallocated value in which to store (using
\fBTcl_ListObjAppendElement\fR) the list of
files or directories which are successfully matched.
.AP int mode in
Mask consisting of one or more of R_OK, W_OK, X_OK and F_OK. R_OK,
W_OK and X_OK request checking whether the file exists and  has  read,
write and  execute  permissions, respectively. F_OK just requests
checking for the existence of the file.
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
.QW "read link"
action is performed. The result
is a Tcl_Obj specifying the contents of the symbolic link given by
\fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned
by the caller, which should call \fBTcl_DecrRefCount\fR when the result is no
longer needed. If the \fItoPtr\fR is not NULL, Tcl should create a link
of one of the types passed in in the \fIlinkAction\fR flag. This flag is
an ORed combination of \fBTCL_CREATE_SYMBOLIC_LINK\fR and \fBTCL_CREATE_HARD_LINK\fR.
Where a choice exists (i.e.\ more than one flag is passed in), the Tcl
convention is to prefer symbolic links. When a link is successfully
created, the return value should be \fItoPtr\fR (which is therefore
already owned by the caller). If unsuccessful, NULL is returned.
.PP
\fBTcl_FSLstat\fR fills the \fITcl_StatBuf\fR structure \fIstatPtr\fR with
information about the specified file. You do not need any access rights to the







|







483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
.QW "read link"
action is performed. The result
is a Tcl_Obj specifying the contents of the symbolic link given by
\fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned
by the caller, which should call \fBTcl_DecrRefCount\fR when the result is no
longer needed. If the \fItoPtr\fR is not NULL, Tcl should create a link
of one of the types passed in in the \fIlinkAction\fR flag. This flag is
an OR'ed combination of \fBTCL_CREATE_SYMBOLIC_LINK\fR and \fBTCL_CREATE_HARD_LINK\fR.
Where a choice exists (i.e.\ more than one flag is passed in), the Tcl
convention is to prefer symbolic links. When a link is successfully
created, the return value should be \fItoPtr\fR (which is therefore
already owned by the caller). If unsuccessful, NULL is returned.
.PP
\fBTcl_FSLstat\fR fills the \fITcl_StatBuf\fR structure \fIstatPtr\fR with
information about the specified file. You do not need any access rights to the

Changes to doc/OpenFileChnl.3.

595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
\fIoptionName\fR is NULL, the function stores an alternating list of option
names and their values in \fIoptionValue\fR, using a series of calls to
\fBTcl_DStringAppendElement\fR. The various preexisting options and
their possible values are described in the manual entry for the Tcl
\fBfconfigure\fR command. Other options can be added by each channel type.
These channel type specific options are described in the manual entry for
the Tcl command that creates a channel of that type; for example, the
additional options for TCP based channels are described in the manual entry
for the Tcl \fBsocket\fR command.
The procedure normally returns \fBTCL_OK\fR. If an error occurs, it returns
\fBTCL_ERROR\fR and calls \fBTcl_SetErrno\fR to store an appropriate POSIX
error code.
.SH TCL_SETCHANNELOPTION
.PP
\fBTcl_SetChannelOption\fR sets a new value \fInewValue\fR







|







595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
\fIoptionName\fR is NULL, the function stores an alternating list of option
names and their values in \fIoptionValue\fR, using a series of calls to
\fBTcl_DStringAppendElement\fR. The various preexisting options and
their possible values are described in the manual entry for the Tcl
\fBfconfigure\fR command. Other options can be added by each channel type.
These channel type specific options are described in the manual entry for
the Tcl command that creates a channel of that type; for example, the
additional options for TCP-based channels are described in the manual entry
for the Tcl \fBsocket\fR command.
The procedure normally returns \fBTCL_OK\fR. If an error occurs, it returns
\fBTCL_ERROR\fR and calls \fBTcl_SetErrno\fR to store an appropriate POSIX
error code.
.SH TCL_SETCHANNELOPTION
.PP
\fBTcl_SetChannelOption\fR sets a new value \fInewValue\fR

Changes to doc/SubstObj.3.

20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
.AP Tcl_Interp *interp in
Interpreter in which to execute Tcl scripts and lookup variables.  If
an error occurs, the interpreter's result is modified to hold an error
message.
.AP Tcl_Obj *objPtr in
A Tcl value containing the string to perform substitutions on.
.AP int flags in
ORed combination of flag bits that specify which substitutions to
perform.  The flags \fBTCL_SUBST_COMMANDS\fR,
\fBTCL_SUBST_VARIABLES\fR and \fBTCL_SUBST_BACKSLASHES\fR are
currently supported, and \fBTCL_SUBST_ALL\fR is provided as a
convenience for the common case where all substitutions are desired.
.BE
.SH DESCRIPTION
.PP







|







20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
.AP Tcl_Interp *interp in
Interpreter in which to execute Tcl scripts and lookup variables.  If
an error occurs, the interpreter's result is modified to hold an error
message.
.AP Tcl_Obj *objPtr in
A Tcl value containing the string to perform substitutions on.
.AP int flags in
OR'ed combination of flag bits that specify which substitutions to
perform.  The flags \fBTCL_SUBST_COMMANDS\fR,
\fBTCL_SUBST_VARIABLES\fR and \fBTCL_SUBST_BACKSLASHES\fR are
currently supported, and \fBTCL_SUBST_ALL\fR is provided as a
convenience for the common case where all substitutions are desired.
.BE
.SH DESCRIPTION
.PP

Changes to doc/Tcl.n.

178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
\e\fBv\fR
Vertical tab (Unicode U+00000B).
.TP 7
\e\fB<newline>\fIwhiteSpace\fR
.
A single space character replaces the backslash, newline, and all spaces
and tabs after the newline.  This backslash sequence is unique in that it
is replaced in a separate pre-pass before the command is actually parsed.
This means that it will be replaced even when it occurs between braces,
and the resulting space will be treated as a word separator if it is not
in braces or quotes.
.TP 7
\e\e
Backslash
.PQ \e "" .







|







178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
\e\fBv\fR
Vertical tab (Unicode U+00000B).
.TP 7
\e\fB<newline>\fIwhiteSpace\fR
.
A single space character replaces the backslash, newline, and all spaces
and tabs after the newline.  This backslash sequence is unique in that it
is replaced in a separate prepass before the command is actually parsed.
This means that it will be replaced even when it occurs between braces,
and the resulting space will be treated as a word separator if it is not
in braces or quotes.
.TP 7
\e\e
Backslash
.PQ \e "" .

Changes to doc/info.n.

176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
.TP
\fBeval\fR\0\0\0\0\0\0\0\0
.
means that the command is executed by \fBeval\fR or \fBuplevel\fR.
.TP
\fBprecompiled\fR\0\0\0\0\0\0\0\0
.
means that the command is found in a pre-compiled script (loadable by
the package \fBtbcload\fR), and no further information will be
available.
.RE
.TP
\fBline\fR
.
This entry provides the number of the line the command is at inside of







|







176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
.TP
\fBeval\fR\0\0\0\0\0\0\0\0
.
means that the command is executed by \fBeval\fR or \fBuplevel\fR.
.TP
\fBprecompiled\fR\0\0\0\0\0\0\0\0
.
means that the command is found in a precompiled script (loadable by
the package \fBtbcload\fR), and no further information will be
available.
.RE
.TP
\fBline\fR
.
This entry provides the number of the line the command is at inside of

Changes to doc/memory.n.

37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Tcl began, the current packets allocated (the current
number of calls to \fBckalloc\fR not met by a corresponding call
to \fBckfree\fR), the current bytes allocated, and the maximum number
of packets and bytes allocated.
.TP
\fBmemory init \fR[\fBon\fR|\fBoff\fR]
.
Turn on or off the pre-initialization of all allocated memory
with bogus bytes.  Useful for detecting the use of uninitialized
values.
.TP
\fBmemory objs \fIfile\fR
.
Causes a list of all allocated Tcl_Obj values to be written to the specified
\fIfile\fR immediately, together with where they were allocated.  Useful for







|







37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Tcl began, the current packets allocated (the current
number of calls to \fBckalloc\fR not met by a corresponding call
to \fBckfree\fR), the current bytes allocated, and the maximum number
of packets and bytes allocated.
.TP
\fBmemory init \fR[\fBon\fR|\fBoff\fR]
.
Turn on or off the preinitialization of all allocated memory
with bogus bytes.  Useful for detecting the use of uninitialized
values.
.TP
\fBmemory objs \fIfile\fR
.
Causes a list of all allocated Tcl_Obj values to be written to the specified
\fIfile\fR immediately, together with where they were allocated.  Useful for

Changes to doc/namespace.n.

157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
current namespace that were imported from a different namespace.
For
.QW "qualified patterns" ,
this command first finds the matching exported commands.
It then checks whether any of those commands
were previously imported by the current namespace.
If so, this command deletes the corresponding imported commands.
In effect, this un-does the action of a \fBnamespace import\fR command.
.TP
\fBnamespace import \fR?\fB\-force\fR? ?\fIpattern\fR \fIpattern ...\fR?
.
Imports commands into a namespace, or queries the set of imported
commands in a namespace.  When no arguments are present,
\fBnamespace import\fR returns the list of commands in
the current namespace that have been imported from other







|







157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
current namespace that were imported from a different namespace.
For
.QW "qualified patterns" ,
this command first finds the matching exported commands.
It then checks whether any of those commands
were previously imported by the current namespace.
If so, this command deletes the corresponding imported commands.
In effect, this undoes the action of a \fBnamespace import\fR command.
.TP
\fBnamespace import \fR?\fB\-force\fR? ?\fIpattern\fR \fIpattern ...\fR?
.
Imports commands into a namespace, or queries the set of imported
commands in a namespace.  When no arguments are present,
\fBnamespace import\fR returns the list of commands in
the current namespace that have been imported from other

Changes to doc/next.n.

92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
a filter and once as a normal method.
.PP
Each filter should decide for itself whether to permit the execution to go
forward to the proper implementation of the method (which it does by invoking
the \fBnext\fR command as filters are inserted into the front of the method
call chain) and is responsible for returning the result of \fBnext\fR.
.PP
Filters are invoked when processing an invokation of the \fBunknown\fR
method because of a failure to locate a method implementation, but \fInot\fR
when invoking either constructors or destructors. (Note however that the
\fBdestroy\fR method is a conventional method, and filters are invoked as
normal when it is called.)
.SH EXAMPLES
.PP
This example demonstrates how to use the \fBnext\fR command to call the







|







92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
a filter and once as a normal method.
.PP
Each filter should decide for itself whether to permit the execution to go
forward to the proper implementation of the method (which it does by invoking
the \fBnext\fR command as filters are inserted into the front of the method
call chain) and is responsible for returning the result of \fBnext\fR.
.PP
Filters are invoked when processing an invocation of the \fBunknown\fR
method because of a failure to locate a method implementation, but \fInot\fR
when invoking either constructors or destructors. (Note however that the
\fBdestroy\fR method is a conventional method, and filters are invoked as
normal when it is called.)
.SH EXAMPLES
.PP
This example demonstrates how to use the \fBnext\fR command to call the

Changes to doc/pkgMkIndex.n.

104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
\fB\-lazy\fR
The generated index will manage to delay loading the package until the
use of one of the commands provided by the package, instead of loading
it immediately upon \fBpackage require\fR.  This is not compatible with
the use of \fIauto_reset\fR, and therefore its use is discouraged.
.TP 15
\fB\-load \fIpkgPat\fR
The index process will pre-load any packages that exist in the
current interpreter and match \fIpkgPat\fR into the child interpreter used to
generate the index.  The pattern match uses string match rules, but without
making case distinctions.
See \fBCOMPLEX CASES\fR below.
.TP 15
\fB\-verbose\fR
Generate output during the indexing process.  Output is via







|







104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
\fB\-lazy\fR
The generated index will manage to delay loading the package until the
use of one of the commands provided by the package, instead of loading
it immediately upon \fBpackage require\fR.  This is not compatible with
the use of \fIauto_reset\fR, and therefore its use is discouraged.
.TP 15
\fB\-load \fIpkgPat\fR
The index process will preload any packages that exist in the
current interpreter and match \fIpkgPat\fR into the child interpreter used to
generate the index.  The pattern match uses string match rules, but without
making case distinctions.
See \fBCOMPLEX CASES\fR below.
.TP 15
\fB\-verbose\fR
Generate output during the indexing process.  Output is via

Changes to doc/tcltest.n.

621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
way to define any conditions required for the test to be possible or
meaningful.  For example, a \fBtest\fR with \fB\-constraints unix\fR
will only be run if the constraint \fBunix\fR is true, which indicates
the test suite is being run on a Unix platform.
.PP
Each \fBtest\fR should include whatever \fB\-constraints\fR are
required to constrain it to run only where appropriate.  Several
constraints are pre-defined in the \fBtcltest\fR package, listed
below.  The registration of user-defined constraints is performed
by the \fBtestConstraint\fR command.  User-defined constraints
may appear within a test file, or within the script specified
by the \fBconfigure \-load\fR or \fBconfigure \-loadfile\fR
options.
.PP
The following is a list of constraints pre-defined by the
\fBtcltest\fR package itself:
.TP
\fIsingleTestInterp\fR
.
This test can only be run if all test files are sourced into a single
interpreter.
.TP







|






|







621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
way to define any conditions required for the test to be possible or
meaningful.  For example, a \fBtest\fR with \fB\-constraints unix\fR
will only be run if the constraint \fBunix\fR is true, which indicates
the test suite is being run on a Unix platform.
.PP
Each \fBtest\fR should include whatever \fB\-constraints\fR are
required to constrain it to run only where appropriate.  Several
constraints are predefined in the \fBtcltest\fR package, listed
below.  The registration of user-defined constraints is performed
by the \fBtestConstraint\fR command.  User-defined constraints
may appear within a test file, or within the script specified
by the \fBconfigure \-load\fR or \fBconfigure \-loadfile\fR
options.
.PP
The following is a list of constraints predefined by the
\fBtcltest\fR package itself:
.TP
\fIsingleTestInterp\fR
.
This test can only be run if all test files are sourced into a single
interpreter.
.TP

Changes to generic/regc_nfa.c.

483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
    victim->freechain = from->free;
    from->free = victim;
}

/*
 * changearctarget - flip an arc to have a different to state
 *
 * Caller must have verified that there is no pre-existing duplicate arc.
 *
 * Note that because we store arcs in their from state, we can't easily have
 * a similar changearcsource function.
 */
static void
changearctarget(struct arc * a, struct state * newto)
{







|







483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
    victim->freechain = from->free;
    from->free = victim;
}

/*
 * changearctarget - flip an arc to have a different to state
 *
 * Caller must have verified that there is no preexisting duplicate arc.
 *
 * Note that because we store arcs in their from state, we can't easily have
 * a similar changearcsource function.
 */
static void
changearctarget(struct arc * a, struct state * newto)
{
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525

/*
 - pull - pull a back constraint backward past its source state
 *
 * Returns 1 if successful (which it always is unless the source is the
 * start state or we have an internal error), 0 if nothing happened.
 *
 * A significant property of this function is that it deletes no pre-existing
 * states, and no outarcs of the constraint's from state other than the given
 * constraint arc.  This makes the loops in pullback() safe, at the cost that
 * we may leave useless states behind.  Therefore, we leave it to pullback()
 * to delete such states.
 *
 * If the from state has multiple back-constraint outarcs, and/or multiple
 * compatible constraint inarcs, we only need to create one new intermediate







|







1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525

/*
 - pull - pull a back constraint backward past its source state
 *
 * Returns 1 if successful (which it always is unless the source is the
 * start state or we have an internal error), 0 if nothing happened.
 *
 * A significant property of this function is that it deletes no preexisting
 * states, and no outarcs of the constraint's from state other than the given
 * constraint arc.  This makes the loops in pullback() safe, at the cost that
 * we may leave useless states behind.  Therefore, we leave it to pullback()
 * to delete such states.
 *
 * If the from state has multiple back-constraint outarcs, and/or multiple
 * compatible constraint inarcs, we only need to create one new intermediate
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704

/*
 - push - push a forward constraint forward past its destination state
 *
 * Returns 1 if successful (which it always is unless the destination is the
 * post state or we have an internal error), 0 if nothing happened.
 *
 * A significant property of this function is that it deletes no pre-existing
 * states, and no inarcs of the constraint's to state other than the given
 * constraint arc.  This makes the loops in pushfwd() safe, at the cost that
 * we may leave useless states behind.  Therefore, we leave it to pushfwd()
 * to delete such states.
 *
 * If the to state has multiple forward-constraint inarcs, and/or multiple
 * compatible constraint outarcs, we only need to create one new intermediate







|







1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704

/*
 - push - push a forward constraint forward past its destination state
 *
 * Returns 1 if successful (which it always is unless the destination is the
 * post state or we have an internal error), 0 if nothing happened.
 *
 * A significant property of this function is that it deletes no preexisting
 * states, and no inarcs of the constraint's to state other than the given
 * constraint arc.  This makes the loops in pushfwd() safe, at the cost that
 * we may leave useless states behind.  Therefore, we leave it to pushfwd()
 * to delete such states.
 *
 * If the to state has multiple forward-constraint inarcs, and/or multiple
 * compatible constraint outarcs, we only need to create one new intermediate
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
 * For each cloned successor state, we transiently create a "donemap" that is
 * a boolean array showing which source states we've already visited for this
 * clone state.  This prevents infinite recursion as well as useless repeat
 * visits to the same state subtree (which can add up fast, since typical NFAs
 * have multiple redundant arc pathways).  Each donemap is a char array
 * indexed by state number.  The donemaps are all of the same size "nstates",
 * which is nfa->nstates as of the start of the recursion.  This is enough to
 * have entries for all pre-existing states, but *not* entries for clone
 * states created during the recursion.  That's okay since we have no need to
 * mark those.
 *
 * curdonemap is NULL when recursing to a new sclone state, or sclone's
 * donemap when we are recursing without having created a new state (which we
 * do when we decide we can merge a successor state into the current clone
 * state).  outerdonemap is NULL at the top level and otherwise the parent







|







2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
 * For each cloned successor state, we transiently create a "donemap" that is
 * a boolean array showing which source states we've already visited for this
 * clone state.  This prevents infinite recursion as well as useless repeat
 * visits to the same state subtree (which can add up fast, since typical NFAs
 * have multiple redundant arc pathways).  Each donemap is a char array
 * indexed by state number.  The donemaps are all of the same size "nstates",
 * which is nfa->nstates as of the start of the recursion.  This is enough to
 * have entries for all preexisting states, but *not* entries for clone
 * states created during the recursion.  That's okay since we have no need to
 * mark those.
 *
 * curdonemap is NULL when recursing to a new sclone state, or sclone's
 * donemap when we are recursing without having created a new state (which we
 * do when we decide we can merge a successor state into the current clone
 * state).  outerdonemap is NULL at the top level and otherwise the parent
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
    }
}

/*
 - analyze - ascertain potentially-useful facts about an optimized NFA
 ^ static long analyze(struct nfa *);
 */
static long			/* re_info bits to be ORed in */
analyze(
    struct nfa *nfa)
{
    struct arc *a;
    struct arc *aa;

    if (nfa->pre->outs == NULL) {







|







2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
    }
}

/*
 - analyze - ascertain potentially-useful facts about an optimized NFA
 ^ static long analyze(struct nfa *);
 */
static long			/* re_info bits to be OR'ed in */
analyze(
    struct nfa *nfa)
{
    struct arc *a;
    struct arc *aa;

    if (nfa->pre->outs == NULL) {

Changes to generic/regguts.h.

281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
    struct state *next;		/* chain for traversing all */
    struct state *prev;		/* back chain */
    struct arcbatch oas;	/* first arcbatch, avoid malloc in easy case */
    int noas;			/* number of arcs used in first arcbatch */
};

struct nfa {
    struct state *pre;		/* pre-initial state */
    struct state *init;		/* initial state */
    struct state *final;	/* final state */
    struct state *post;		/* post-final state */
    int nstates;		/* for numbering states */
    struct state *states;	/* state-chain header */
    struct state *slast;	/* tail of the chain */
    struct state *free;		/* free list */
    struct colormap *cm;	/* the color map */
    color bos[2];		/* colors, if any, assigned to BOS and BOL */
    color eos[2];		/* colors, if any, assigned to EOS and EOL */







|


|







281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
    struct state *next;		/* chain for traversing all */
    struct state *prev;		/* back chain */
    struct arcbatch oas;	/* first arcbatch, avoid malloc in easy case */
    int noas;			/* number of arcs used in first arcbatch */
};

struct nfa {
    struct state *pre;		/* preinitial state */
    struct state *init;		/* initial state */
    struct state *final;	/* final state */
    struct state *post;		/* postfinal state */
    int nstates;		/* for numbering states */
    struct state *states;	/* state-chain header */
    struct state *slast;	/* tail of the chain */
    struct state *free;		/* free list */
    struct colormap *cm;	/* the color map */
    color bos[2];		/* colors, if any, assigned to BOS and BOL */
    color eos[2];		/* colors, if any, assigned to EOS and EOL */

Changes to generic/tcl.decls.

55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
    void Tcl_DbCkfree(char *ptr, const char *file, int line)
}
declare 8 {
    char *Tcl_DbCkrealloc(char *ptr, unsigned int size,
	    const char *file, int line)
}

# Tcl_CreateFileHandler and Tcl_DeleteFileHandler are only available on unix,
# but they are part of the old generic interface, so we include them here for
# compatibility reasons.

declare 9 unix {
    void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc,
	    ClientData clientData)
}







|







55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
    void Tcl_DbCkfree(char *ptr, const char *file, int line)
}
declare 8 {
    char *Tcl_DbCkrealloc(char *ptr, unsigned int size,
	    const char *file, int line)
}

# Tcl_CreateFileHandler and Tcl_DeleteFileHandler are only available on Unix,
# but they are part of the old generic interface, so we include them here for
# compatibility reasons.

declare 9 unix {
    void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc,
	    ClientData clientData)
}

Changes to generic/tclAlloc.c.

112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
static struct block *blockList;	/* Tracks the suballocated blocks. */
static struct block bigBlocks={	/* Big blocks aren't suballocated. */
    &bigBlocks, &bigBlocks
};

/*
 * The allocator is protected by a special mutex that must be explicitly
 * initialized. Futhermore, because Tcl_Alloc may be used before anything else
 * in Tcl, we make this module self-initializing after all with the allocInit
 * variable.
 */

#ifdef TCL_THREADS
static Tcl_Mutex *allocMutexPtr;
#endif







|







112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
static struct block *blockList;	/* Tracks the suballocated blocks. */
static struct block bigBlocks={	/* Big blocks aren't suballocated. */
    &bigBlocks, &bigBlocks
};

/*
 * The allocator is protected by a special mutex that must be explicitly
 * initialized. Furthermore, because Tcl_Alloc may be used before anything else
 * in Tcl, we make this module self-initializing after all with the allocInit
 * variable.
 */

#ifdef TCL_THREADS
static Tcl_Mutex *allocMutexPtr;
#endif
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
 *	Attempts to get more memory from the system.
 *
 *----------------------------------------------------------------------
 */

static void
MoreCore(
    int bucket)			/* What bucket to allocat to. */
{
    union overhead *overPtr;
    long size;		/* size of desired block */
    long amount;		/* amount to allocate */
    int numBlocks;		/* how many blocks we get */
    struct block *blockPtr;

    /*
     * sbrk_size <= 0 only for big, FLUFFY, requests (about 2^30 bytes on a
     * VAX, I think) or for a negative arg.







|


|







381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
 *	Attempts to get more memory from the system.
 *
 *----------------------------------------------------------------------
 */

static void
MoreCore(
    int bucket)			/* Bucket to allocate to. */
{
    union overhead *overPtr;
    long size;			/* size of desired block */
    long amount;		/* amount to allocate */
    int numBlocks;		/* how many blocks we get */
    struct block *blockPtr;

    /*
     * sbrk_size <= 0 only for big, FLUFFY, requests (about 2^30 bytes on a
     * VAX, I think) or for a negative arg.
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
 *	None.
 *
 *----------------------------------------------------------------------
 */

char *
TclpRealloc(
    char *oldPtr,		/* Pointer to alloced block. */
    unsigned int numBytes)	/* New size of memory. */
{
    int i;
    union overhead *overPtr;
    struct block *bigBlockPtr;
    int expensive;
    unsigned long maxSize;







|







507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
 *	None.
 *
 *----------------------------------------------------------------------
 */

char *
TclpRealloc(
    char *oldPtr,		/* Pointer to alloc'ed block. */
    unsigned int numBytes)	/* New size of memory. */
{
    int i;
    union overhead *overPtr;
    struct block *bigBlockPtr;
    int expensive;
    unsigned long maxSize;
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
	}
	memcpy(newPtr, oldPtr, numBytes);
	TclpFree(oldPtr);
	return newPtr;
    }

    /*
     * Ok, we don't have to copy, it fits as-is
     */

#ifndef NDEBUG
    overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
    BLOCK_END(overPtr) = RMAGIC;
#endif








|







606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
	}
	memcpy(newPtr, oldPtr, numBytes);
	TclpFree(oldPtr);
	return newPtr;
    }

    /*
     * No need to copy. It fits as-is.
     */

#ifndef NDEBUG
    overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
    BLOCK_END(overPtr) = RMAGIC;
#endif

Changes to generic/tclBasic.c.

750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
    iPtr->pendingObjDataPtr = NULL;
    iPtr->asyncReadyPtr = TclGetAsyncReadyPtr();
    iPtr->deferredCallbacks = NULL;

    /*
     * Create the core commands. Do it here, rather than calling
     * Tcl_CreateCommand, because it's faster (there's no need to check for a
     * pre-existing command by the same name). If a command has a Tcl_CmdProc
     * but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to
     * TclInvokeStringCommand. This is an object-based wrapper function that
     * extracts strings, calls the string function, and creates an object for
     * the result. Similarly, if a command has a Tcl_ObjCmdProc but no
     * Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand.
     */








|







750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
    iPtr->pendingObjDataPtr = NULL;
    iPtr->asyncReadyPtr = TclGetAsyncReadyPtr();
    iPtr->deferredCallbacks = NULL;

    /*
     * Create the core commands. Do it here, rather than calling
     * Tcl_CreateCommand, because it's faster (there's no need to check for a
     * preexisting command by the same name). If a command has a Tcl_CmdProc
     * but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to
     * TclInvokeStringCommand. This is an object-based wrapper function that
     * extracts strings, calls the string function, and creates an object for
     * the result. Similarly, if a command has a Tcl_ObjCmdProc but no
     * Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand.
     */

1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
                "hidden command named \"%s\" already exists",
                hiddenCmdToken));
        Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", NULL);
	return TCL_ERROR;
    }

    /*
     * NB: This code is currently 'like' a rename to a specialy set apart name
     * table. Changes here and in TclRenameCommand must be kept in synch until
     * the common parts are actually factorized out.
     */

    /*
     * Remove the hash entry for the command from the interpreter command
     * table. This is like deleting the command, so bump its command epoch;
     * this invalidates any cached references that point to the command.
     */

    if (cmdPtr->hPtr != NULL) {
	Tcl_DeleteHashEntry(cmdPtr->hPtr);
	cmdPtr->hPtr = NULL;
	cmdPtr->cmdEpoch++;
    }







|






|
|







1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
                "hidden command named \"%s\" already exists",
                hiddenCmdToken));
        Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", NULL);
	return TCL_ERROR;
    }

    /*
     * NB: This code is currently 'like' a rename to a special separate name
     * table. Changes here and in TclRenameCommand must be kept in synch until
     * the common parts are actually factorized out.
     */

    /*
     * Remove the hash entry for the command from the interpreter command
     * table. This is like deleting the command, so bump its command epoch
     * to invalidate any cached references that point to the command.
     */

    if (cmdPtr->hPtr != NULL) {
	Tcl_DeleteHashEntry(cmdPtr->hPtr);
	cmdPtr->hPtr = NULL;
	cmdPtr->cmdEpoch++;
    }
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
     * Check that we have a true global namespace command (enforced by
     * Tcl_HideCommand but let's double check. (If it was not, we would not
     * really know how to handle it).
     */

    if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
	/*
	 * This case is theoritically impossible, we might rather Tcl_Panic
	 * than 'nicely' erroring out ?
	 */

	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"trying to expose a non-global command namespace command",
		-1));
	return TCL_ERROR;







|







1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
     * Check that we have a true global namespace command (enforced by
     * Tcl_HideCommand but let's double check. (If it was not, we would not
     * really know how to handle it).
     */

    if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
	/*
	 * This case is theoretically impossible, we might rather Tcl_Panic
	 * than 'nicely' erroring out ?
	 */

	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"trying to expose a non-global command namespace command",
		-1));
	return TCL_ERROR;
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
 *	future calls to Tcl_GetCommandName.
 *
 * Side effects:
 *	If a command named cmdName already exists for interp, it is deleted.
 *	In the future, when cmdName is seen as the name of a command by
 *	Tcl_Eval, proc will be called. To support the bytecode interpreter,
 *	the command is created with a wrapper Tcl_ObjCmdProc
 *	(TclInvokeStringCommand) that eventially calls proc. When the command
 *	is deleted from the table, deleteProc will be called. See the manual
 *	entry for details on the calling sequence.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command







|







2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
 *	future calls to Tcl_GetCommandName.
 *
 * Side effects:
 *	If a command named cmdName already exists for interp, it is deleted.
 *	In the future, when cmdName is seen as the name of a command by
 *	Tcl_Eval, proc will be called. To support the bytecode interpreter,
 *	the command is created with a wrapper Tcl_ObjCmdProc
 *	(TclInvokeStringCommand) that eventually calls proc. When the command
 *	is deleted from the table, deleteProc will be called. See the manual
 *	entry for details on the calling sequence.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
 *	interpreter is still able to execute further commands after the
 *	cancelation is cleared (unlike if it is deleted).
 *
 * Results:
 *	The value given for the code argument.
 *
 * Side effects:
 *	Transfers a message from the cancelation message to the interpreter.
 *
 *----------------------------------------------------------------------
 */

static int
CancelEvalProc(
    ClientData clientData,	/* Interp to cancel the script in progress. */







|







3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
 *	interpreter is still able to execute further commands after the
 *	cancelation is cleared (unlike if it is deleted).
 *
 * Results:
 *	The value given for the code argument.
 *
 * Side effects:
 *	Transfers a message from the cancellation message to the interpreter.
 *
 *----------------------------------------------------------------------
 */

static int
CancelEvalProc(
    ClientData clientData,	/* Interp to cancel the script in progress. */
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
    if (currNsPtr->unknownHandlerPtr == NULL) {
	TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown");
	Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr);
    }

    /*
     * Get the list of words for the unknown handler and allocate enough space
     * to hold both the handler prefix and all words of the command invokation
     * itself.
     */

    TclListObjGetElements(NULL, currNsPtr->unknownHandlerPtr,
	    &handlerObjc, &handlerObjv);
    newObjc = objc + handlerObjc;
    newObjv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc);







|







4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
    if (currNsPtr->unknownHandlerPtr == NULL) {
	TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown");
	Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr);
    }

    /*
     * Get the list of words for the unknown handler and allocate enough space
     * to hold both the handler prefix and all words of the command invocation
     * itself.
     */

    TclListObjGetElements(NULL, currNsPtr->unknownHandlerPtr,
	    &handlerObjc, &handlerObjv);
    newObjc = objc + handlerObjc;
    newObjv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc);
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
				 * TCL_EVAL_GLOBAL is currently supported. */
    int line,			/* The line the script starts on. */
    int *clNextOuter,		/* Information about an outer context for */
    const char *outerScript)	/* continuation line data. This is set only in
				 * TclSubstTokens(), to properly handle
				 * [...]-nested commands. The 'outerScript'
				 * refers to the most-outer script containing
				 * the embedded command, which is refered to
				 * by 'script'. The 'clNextOuter' refers to
				 * the current entry in the table of
				 * continuation lines in this "main script",
				 * and the character offsets are relative to
				 * the 'outerScript' as well.
				 *
				 * If outerScript == script, then this call is







|







5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
				 * TCL_EVAL_GLOBAL is currently supported. */
    int line,			/* The line the script starts on. */
    int *clNextOuter,		/* Information about an outer context for */
    const char *outerScript)	/* continuation line data. This is set only in
				 * TclSubstTokens(), to properly handle
				 * [...]-nested commands. The 'outerScript'
				 * refers to the most-outer script containing
				 * the embedded command, which is referred to
				 * by 'script'. The 'clNextOuter' refers to
				 * the current entry in the table of
				 * continuation lines in this "main script",
				 * and the character offsets are relative to
				 * the 'outerScript' as well.
				 *
				 * If outerScript == script, then this call is
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
    Tcl_HashEntry *hPtr;
    CFWord *cfwPtr;

    for (i = 1; i < objc; i++) {
	/*
	 * Ignore argument words without line information (= dynamic). If they
	 * are variables they may have location information associated with
	 * that, either through globally recorded 'set' invokations, or
	 * literals in bytecode. Eitehr way there is no need to record
	 * something here.
	 */

	if (cfPtr->line[i] < 0) {
	    continue;
	}
	hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &isNew);







|
|







5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
    Tcl_HashEntry *hPtr;
    CFWord *cfwPtr;

    for (i = 1; i < objc; i++) {
	/*
	 * Ignore argument words without line information (= dynamic). If they
	 * are variables they may have location information associated with
	 * that, either through globally recorded 'set' invocations, or
	 * literals in bytecode. Either way there is no need to record
	 * something here.
	 */

	if (cfPtr->line[i] < 0) {
	    continue;
	}
	hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &isNew);
7053
7054
7055
7056
7057
7058
7059
7060
7061
7062
7063
7064
7065
7066
7067
 *----------------------------------------------------------------------
 */

int
Tcl_SetRecursionLimit(
    Tcl_Interp *interp,		/* Interpreter whose nesting limit is to be
				 * set. */
    int depth)			/* New value for maximimum depth. */
{
    Interp *iPtr = (Interp *) interp;
    int old;

    old = iPtr->maxNestingDepth;
    if (depth > 0) {
	iPtr->maxNestingDepth = depth;







|







7053
7054
7055
7056
7057
7058
7059
7060
7061
7062
7063
7064
7065
7066
7067
 *----------------------------------------------------------------------
 */

int
Tcl_SetRecursionLimit(
    Tcl_Interp *interp,		/* Interpreter whose nesting limit is to be
				 * set. */
    int depth)			/* New value for maximum depth. */
{
    Interp *iPtr = (Interp *) interp;
    int old;

    old = iPtr->maxNestingDepth;
    if (depth > 0) {
	iPtr->maxNestingDepth = depth;

Changes to generic/tclBinary.c.

21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
 * special conditions in the parsing of a format specifier.
 */

#define BINARY_ALL -1		/* Use all elements in the argument. */
#define BINARY_NOCOUNT -2	/* No count was specified in format. */

/*
 * The following flags may be ORed together and returned by GetFormatSpec
 */

#define BINARY_SIGNED 0		/* Field to be read as signed data */
#define BINARY_UNSIGNED 1	/* Field to be read as unsigned data */

/*
 * The following defines the maximum number of different (integer) numbers
 * placed in the object cache by 'binary scan' before it bails out and
 * switches back to Plan A (creating a new object for each value.)
 * Theoretically, it would be possible to keep the cache about for the values
 * that are already in it, but that makes the code slower in practise when
 * overflow happens, and makes little odds the rest of the time (as measured
 * on my machine.) It is also slower (on the sample I tried at least) to grow
 * the cache to hold all items we might want to put in it; presumably the
 * extra cost of managing the memory for the enlarged table outweighs the
 * benefit from allocating fewer objects. This is probably because as the
 * number of objects increases, the likelihood of reuse of any particular one
 * drops, and there is very little gain from larger maximum cache sizes (the







|










|







21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
 * special conditions in the parsing of a format specifier.
 */

#define BINARY_ALL -1		/* Use all elements in the argument. */
#define BINARY_NOCOUNT -2	/* No count was specified in format. */

/*
 * The following flags may be OR'ed together and returned by GetFormatSpec
 */

#define BINARY_SIGNED 0		/* Field to be read as signed data */
#define BINARY_UNSIGNED 1	/* Field to be read as unsigned data */

/*
 * The following defines the maximum number of different (integer) numbers
 * placed in the object cache by 'binary scan' before it bails out and
 * switches back to Plan A (creating a new object for each value.)
 * Theoretically, it would be possible to keep the cache about for the values
 * that are already in it, but that makes the code slower in practice when
 * overflow happens, and makes little odds the rest of the time (as measured
 * on my machine.) It is also slower (on the sample I tried at least) to grow
 * the cache to hold all items we might want to put in it; presumably the
 * extra cost of managing the memory for the enlarged table outweighs the
 * benefit from allocating fewer objects. This is probably because as the
 * number of objects increases, the likelihood of reuse of any particular one
 * drops, and there is very little gain from larger maximum cache sizes (the
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
	length = offset;
    }
    if (length == 0) {
	return TCL_OK;
    }

    /*
     * Prepare the result object by preallocating the caclulated number of
     * bytes and filling with nulls.
     */

    TclNewObj(resultPtr);
    buffer = Tcl_SetByteArrayLength(resultPtr, length);
    memset(buffer, 0, length);








|







922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
	length = offset;
    }
    if (length == 0) {
	return TCL_OK;
    }

    /*
     * Prepare the result object by preallocating the calculated number of
     * bytes and filling with nulls.
     */

    TclNewObj(resultPtr);
    buffer = Tcl_SetByteArrayLength(resultPtr, length);
    memset(buffer, 0, length);

1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
/*
 *----------------------------------------------------------------------
 *
 * NeedReversing --
 *
 *	This routine determines, if bytes of a number need to be re-ordered,
 *	and returns a numeric code indicating the re-ordering to be done.
 *	This depends on the endiannes of the machine and the desired format.
 *	It is in effect a table (whose contents depend on the endianness of
 *	the system) describing whether a value needs reversing or not. Anyone
 *	porting the code to a big-endian platform should take care to make
 *	sure that they define WORDS_BIGENDIAN though this is already done by
 *	configure for the Unix build; little-endian platforms (including
 *	Windows) don't need to do anything.
 *







|







1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
/*
 *----------------------------------------------------------------------
 *
 * NeedReversing --
 *
 *	This routine determines, if bytes of a number need to be re-ordered,
 *	and returns a numeric code indicating the re-ordering to be done.
 *	This depends on the endianness of the machine and the desired format.
 *	It is in effect a table (whose contents depend on the endianness of
 *	the system) describing whether a value needs reversing or not. Anyone
 *	porting the code to a big-endian platform should take care to make
 *	sure that they define WORDS_BIGENDIAN though this is already done by
 *	configure for the Unix build; little-endian platforms (including
 *	Windows) don't need to do anything.
 *

Changes to generic/tclCkalloc.c.

376
377
378
379
380
381
382
383
384
385
386
387
388
389
390

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbCkalloc - debugging ckalloc
 *
 *	Allocate the requested amount of space plus some extra for guard bands
 *	at both ends of the request, plus a size, panicing if there isn't
 *	enough space, then write in the guard bands and return the address of
 *	the space in the middle that the user asked for.
 *
 *	The second and third arguments are file and line, these contain the
 *	filename and line number corresponding to the caller. These are sent
 *	by the ckalloc macro; it uses the preprocessor autodefines __FILE__
 *	and __LINE__.







|







376
377
378
379
380
381
382
383
384
385
386
387
388
389
390

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbCkalloc - debugging ckalloc
 *
 *	Allocate the requested amount of space plus some extra for guard bands
 *	at both ends of the request, plus a size, panicking if there isn't
 *	enough space, then write in the guard bands and return the address of
 *	the space in the middle that the user asked for.
 *
 *	The second and third arguments are file and line, these contain the
 *	filename and line number corresponding to the caller. These are sent
 *	by the ckalloc macro; it uses the preprocessor autodefines __FILE__
 *	and __LINE__.

Changes to generic/tclCmdIL.c.

57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
 */

typedef struct SortInfo {
    int isIncreasing;		/* Nonzero means sort in increasing order. */
    int sortMode;		/* The sort mode. One of SORTMODE_* values
				 * defined below. */
    Tcl_Obj *compareCmdPtr;	/* The Tcl comparison command when sortMode is
				 * SORTMODE_COMMAND. Pre-initialized to hold
				 * base of command. */
    int *indexv;		/* If the -index option was specified, this
				 * holds an encoding of the indexes contained
				 * in the list supplied as an argument to
				 * that option.
				 * NULL if no indexes supplied, and points to
				 * singleIndex field when only one







|







57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
 */

typedef struct SortInfo {
    int isIncreasing;		/* Nonzero means sort in increasing order. */
    int sortMode;		/* The sort mode. One of SORTMODE_* values
				 * defined below. */
    Tcl_Obj *compareCmdPtr;	/* The Tcl comparison command when sortMode is
				 * SORTMODE_COMMAND. Preinitialized to hold
				 * base of command. */
    int *indexv;		/* If the -index option was specified, this
				 * holds an encoding of the indexes contained
				 * in the list supplied as an argument to
				 * that option.
				 * NULL if no indexes supplied, and points to
				 * singleIndex field when only one
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
	    if (match == 0) {
		/*
		 * Normally, binary search is written to stop when it finds a
		 * match. If there are duplicates of an element in the list,
		 * our first match might not be the first occurrence.
		 * Consider: 0 0 0 1 1 1 2 2 2
		 *
		 * To maintain consistancy with standard lsearch semantics, we
		 * must find the leftmost occurrence of the pattern in the
		 * list. Thus we don't just stop searching here. This
		 * variation means that a search always makes log n
		 * comparisons (normal binary search might "get lucky" with an
		 * early comparison).
		 *
		 * In bisect mode though, we want the last of equals.







|







3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
	    if (match == 0) {
		/*
		 * Normally, binary search is written to stop when it finds a
		 * match. If there are duplicates of an element in the list,
		 * our first match might not be the first occurrence.
		 * Consider: 0 0 0 1 1 1 2 2 2
		 *
		 * To maintain consistency with standard lsearch semantics, we
		 * must find the leftmost occurrence of the pattern in the
		 * list. Thus we don't just stop searching here. This
		 * variation means that a search always makes log n
		 * comparisons (normal binary search might "get lucky" with an
		 * early comparison).
		 *
		 * In bisect mode though, we want the last of equals.
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
	if (indices || group) {
	    elementArray[i].payload.index = idx;
	} else {
	    elementArray[i].payload.objPtr = listObjPtrs[idx];
	}

	/*
	 * Merge this element in the pre-existing sublists (and merge together
	 * sublists when we have two of the same size).
	 */

	elementArray[i].nextPtr = NULL;
	elementPtr = &elementArray[i];
	for (j=0 ; subList[j] ; j++) {
	    elementPtr = MergeLists(subList[j], elementPtr, &sortInfo);







|







4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
	if (indices || group) {
	    elementArray[i].payload.index = idx;
	} else {
	    elementArray[i].payload.objPtr = listObjPtrs[idx];
	}

	/*
	 * Merge this element in the preexisting sublists (and merge together
	 * sublists when we have two of the same size).
	 */

	elementArray[i].nextPtr = NULL;
	elementPtr = &elementArray[i];
	for (j=0 ; subList[j] ; j++) {
	    elementPtr = MergeLists(subList[j], elementPtr, &sortInfo);
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
 *
 * SortCompare --
 *
 *	This procedure is invoked by MergeLists to determine the proper
 *	ordering between two elements.
 *
 * Results:
 *	A negative results means the the first element comes before the
 *	second, and a positive results means that the second element should
 *	come first. A result of zero means the two elements are equal and it
 *	doesn't matter which comes first.
 *
 * Side effects:
 *	None, unless a user-defined comparison command does something weird.
 *







|







4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
 *
 * SortCompare --
 *
 *	This procedure is invoked by MergeLists to determine the proper
 *	ordering between two elements.
 *
 * Results:
 *	A negative results means the first element comes before the
 *	second, and a positive results means that the second element should
 *	come first. A result of zero means the two elements are equal and it
 *	doesn't matter which comes first.
 *
 * Side effects:
 *	None, unless a user-defined comparison command does something weird.
 *
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455

	if ((*left != '\0') && (*right != '\0')) {
	    left += TclUtfToUCS4(left, &uniLeft);
	    right += TclUtfToUCS4(right, &uniRight);

	    /*
	     * Convert both chars to lower for the comparison, because
	     * dictionary sorts are case insensitve. Covert to lower, not
	     * upper, so chars between Z and a will sort before A (where most
	     * other interesting punctuations occur).
	     */

	    uniLeftLower = TclUCS4ToLower(uniLeft);
	    uniRightLower = TclUCS4ToLower(uniRight);
	} else {







|







4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455

	if ((*left != '\0') && (*right != '\0')) {
	    left += TclUtfToUCS4(left, &uniLeft);
	    right += TclUtfToUCS4(right, &uniRight);

	    /*
	     * Convert both chars to lower for the comparison, because
	     * dictionary sorts are case-insensitive. Covert to lower, not
	     * upper, so chars between Z and a will sort before A (where most
	     * other interesting punctuations occur).
	     */

	    uniLeftLower = TclUCS4ToLower(uniLeft);
	    uniRightLower = TclUCS4ToLower(uniRight);
	} else {

Changes to generic/tclCmdMZ.c.

320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
		numMatchesSaved, eflags);
	if (match < 0) {
	    return TCL_ERROR;
	}

	if (match == 0) {
	    /*
	     * We want to set the value of the intepreter result only when
	     * this is the first time through the loop.
	     */

	    if (all <= 1) {
		/*
		 * If inlining, the interpreter's object result remains an
		 * empty list, otherwise set it to an integer object w/ value







|







320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
		numMatchesSaved, eflags);
	if (match < 0) {
	    return TCL_ERROR;
	}

	if (match == 0) {
	    /*
	     * We want to set the value of the interpreter result only when
	     * this is the first time through the loop.
	     */

	    if (all <= 1) {
		/*
		 * If inlining, the interpreter's object result remains an
		 * empty list, otherwise set it to an integer object w/ value
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437

	/*
	 * Adjust the offset to the character just after the last one in the
	 * matchVar and increment all to count how many times we are making a
	 * match. We always increment the offset by at least one to prevent
	 * endless looping (as in the case: regexp -all {a*} a). Otherwise,
	 * when we match the NULL string at the end of the input string, we
	 * will loop indefinately (because the length of the match is 0, so
	 * offset never changes).
	 */

	matchLength = (info.matches[0].end - info.matches[0].start);

	offset += info.matches[0].end;








|







423
424
425
426
427
428
429
430
431
432
433
434
435
436
437

	/*
	 * Adjust the offset to the character just after the last one in the
	 * matchVar and increment all to count how many times we are making a
	 * match. We always increment the offset by at least one to prevent
	 * endless looping (as in the case: regexp -all {a*} a). Otherwise,
	 * when we match the NULL string at the end of the input string, we
	 * will loop indefinitely (because the length of the match is 0, so
	 * offset never changes).
	 */

	matchLength = (info.matches[0].end - info.matches[0].start);

	offset += info.matches[0].end;

1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
	Tcl_DeleteHashTable(&charReuseTable);

    } else if (splitCharLen == 1) {
	char *p;

	/*
	 * Handle the special case of splitting on a single character. This is
	 * only true for the one-char ASCII case, as one unicode char is > 1
	 * byte in length.
	 */

	while (*stringPtr && (p=strchr(stringPtr,(int)*splitChars)) != NULL) {
	    objPtr = Tcl_NewStringObj(stringPtr, p - stringPtr);
	    Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
	    stringPtr = p + 1;







|







1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
	Tcl_DeleteHashTable(&charReuseTable);

    } else if (splitCharLen == 1) {
	char *p;

	/*
	 * Handle the special case of splitting on a single character. This is
	 * only true for the one-char ASCII case, as one Unicode char is > 1
	 * byte in length.
	 */

	while (*stringPtr && (p=strchr(stringPtr,(int)*splitChars)) != NULL) {
	    objPtr = Tcl_NewStringObj(stringPtr, p - stringPtr);
	    Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
	    stringPtr = p + 1;
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "string charIndex");
	return TCL_ERROR;
    }

    /*
     * Get the char length to calulate what 'end' means.
     */

    length = Tcl_GetCharLength(objv[1]);
    if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) {
	return TCL_ERROR;
    }








|







1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "string charIndex");
	return TCL_ERROR;
    }

    /*
     * Get the char length to calculate what 'end' means.
     */

    length = Tcl_GetCharLength(objv[1]);
    if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) {
	return TCL_ERROR;
    }

1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
	    }
	}
    }

    /*
     * We get the objPtr so that we can short-cut for some classes by checking
     * the object type (int and double), but we need the string otherwise,
     * because we don't want any conversion of type occuring (as, for example,
     * Tcl_Get*FromObj would do).
     */

    objPtr = objv[objc-1];

    /*
     * When entering here, result == 1 and failat == 0.







|







1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
	    }
	}
    }

    /*
     * We get the objPtr so that we can short-cut for some classes by checking
     * the object type (int and double), but we need the string otherwise,
     * because we don't want any conversion of type occurring (as, for example,
     * Tcl_Get*FromObj would do).
     */

    objPtr = objv[objc-1];

    /*
     * When entering here, result == 1 and failat == 0.
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
	    }
	}
    } else {
	Tcl_UniChar **mapStrings, *u2lc = NULL;
	int *mapLens;

	/*
	 * Precompute pointers to the unicode string and length. This saves us
	 * repeated function calls later, significantly speeding up the
	 * algorithm. We only need the lowercase first char in the nocase
	 * case.
	 */

	mapStrings = TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *));
	mapLens = TclStackAlloc(interp, mapElemc * 2 * sizeof(int));







|







2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
	    }
	}
    } else {
	Tcl_UniChar **mapStrings, *u2lc = NULL;
	int *mapLens;

	/*
	 * Precompute pointers to the Unicode string and length. This saves us
	 * repeated function calls later, significantly speeding up the
	 * algorithm. We only need the lowercase first char in the nocase
	 * case.
	 */

	mapStrings = TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *));
	mapLens = TclStackAlloc(interp, mapElemc * 2 * sizeof(int));
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
		    /*
		     * Adjust len to be full length of matched string.
		     */

		    ustring1 = p - 1;

		    /*
		     * Append the map value to the unicode string.
		     */

		    Tcl_AppendUnicodeToObj(resultPtr,
			    mapStrings[index+1], mapLens[index+1]);
		    break;
		}
	    }







|







2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
		    /*
		     * Adjust len to be full length of matched string.
		     */

		    ustring1 = p - 1;

		    /*
		     * Append the map value to the Unicode string.
		     */

		    Tcl_AppendUnicodeToObj(resultPtr,
			    mapStrings[index+1], mapLens[index+1]);
		    break;
		}
	    }

Changes to generic/tclCompCmds.c.

238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileArray*Cmd --
 *
 *	Functions called to compile "array" sucommands.
 *
 * Results:
 *	All return TCL_OK for a successful compile, and TCL_ERROR to defer
 *	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "array" subcommand at







|







238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileArray*Cmd --
 *
 *	Functions called to compile "array" subcommands.
 *
 * Results:
 *	All return TCL_OK for a successful compile, and TCL_ERROR to defer
 *	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "array" subcommand at
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
     * Otherwise, compile instructions to substitute the body text before
     * starting the catch, then BEGIN_CATCH, and then EVAL_STK to evaluate the
     * substituted body.
     * Care has to be taken to make sure that substitution happens outside the
     * catch range so that errors in the substitution are not caught.
     * [Bug 219184]
     * The reason for duplicating the script is that EVAL_STK would otherwise
     * begin by undeflowing the stack below the mark set by BEGIN_CATCH4.
     */

    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
    if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
	ExceptionRangeStarts(envPtr, range);
	BODY(cmdTokenPtr, 1);







|







643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
     * Otherwise, compile instructions to substitute the body text before
     * starting the catch, then BEGIN_CATCH, and then EVAL_STK to evaluate the
     * substituted body.
     * Care has to be taken to make sure that substitution happens outside the
     * catch range so that errors in the substitution are not caught.
     * [Bug 219184]
     * The reason for duplicating the script is that EVAL_STK would otherwise
     * begin by underflowing the stack below the mark set by BEGIN_CATCH4.
     */

    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
    if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
	ExceptionRangeStarts(envPtr, range);
	BODY(cmdTokenPtr, 1);
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileDict*Cmd --
 *
 *	Functions called to compile "dict" sucommands.
 *
 * Results:
 *	All return TCL_OK for a successful compile, and TCL_ERROR to defer
 *	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "dict" subcommand at







|







994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileDict*Cmd --
 *
 *	Functions called to compile "dict" subcommands.
 *
 * Results:
 *	All return TCL_OK for a successful compile, and TCL_ERROR to defer
 *	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "dict" subcommand at
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
    jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr);
    TclEmitInstInt4(	INST_JUMP_FALSE4, jumpDisplacement,	envPtr);
    endTargetOffset = CurrentOffset(envPtr);
    TclEmitInstInt1(	INST_JUMP1, 0,				envPtr);

    /*
     * Error handler "finally" clause, which force-terminates the iteration
     * and rethrows the error.
     */

    TclAdjustStackDepth(-1, envPtr);
    ExceptionRangeTarget(envPtr, catchRange, catchOffset);
    TclEmitOpcode(	INST_PUSH_RETURN_OPTIONS,		envPtr);
    TclEmitOpcode(	INST_PUSH_RESULT,			envPtr);
    TclEmitOpcode(	INST_END_CATCH,				envPtr);







|







1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
    jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr);
    TclEmitInstInt4(	INST_JUMP_FALSE4, jumpDisplacement,	envPtr);
    endTargetOffset = CurrentOffset(envPtr);
    TclEmitInstInt1(	INST_JUMP1, 0,				envPtr);

    /*
     * Error handler "finally" clause, which force-terminates the iteration
     * and re-throws the error.
     */

    TclAdjustStackDepth(-1, envPtr);
    ExceptionRangeTarget(envPtr, catchRange, catchOffset);
    TclEmitOpcode(	INST_PUSH_RETURN_OPTIONS,		envPtr);
    TclEmitOpcode(	INST_PUSH_RESULT,			envPtr);
    TclEmitOpcode(	INST_END_CATCH,				envPtr);
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
     */

    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);

    /*
     * Termination code for non-ok returns: stash the result and return
     * options in the stack, bring up the key list, finish the update code,
     * and finally return with the catched return data
     */

    ExceptionRangeTarget(envPtr, range, catchOffset);
    TclEmitOpcode(	INST_PUSH_RESULT,			envPtr);
    TclEmitOpcode(	INST_PUSH_RETURN_OPTIONS,		envPtr);
    TclEmitOpcode(	INST_END_CATCH,				envPtr);
    TclEmitInstInt4(	INST_REVERSE, 3,			envPtr);







|







1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
     */

    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);

    /*
     * Termination code for non-ok returns: stash the result and return
     * options in the stack, bring up the key list, finish the update code,
     * and finally return with the caught return data
     */

    ExceptionRangeTarget(envPtr, range, catchOffset);
    TclEmitOpcode(	INST_PUSH_RESULT,			envPtr);
    TclEmitOpcode(	INST_PUSH_RETURN_OPTIONS,		envPtr);
    TclEmitOpcode(	INST_END_CATCH,				envPtr);
    TclEmitInstInt4(	INST_REVERSE, 3,			envPtr);
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *tokenPtr;
    int i, dictVarIndex;

    /*
     * There must be at least two argument after the command. And we impose an
     * (arbirary) safe limit; anyone exceeding it should stop worrying about
     * speed quite so much. ;-)
     */

    /* TODO: Consider support for compiling expanded args. */
    if (parsePtr->numWords<4 || parsePtr->numWords>100) {
	return TCL_ERROR;
    }







|







1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *tokenPtr;
    int i, dictVarIndex;

    /*
     * There must be at least two argument after the command. And we impose an
     * (arbitrary) safe limit; anyone exceeding it should stop worrying about
     * speed quite so much. ;-)
     */

    /* TODO: Consider support for compiling expanded args. */
    if (parsePtr->numWords<4 || parsePtr->numWords>100) {
	return TCL_ERROR;
    }

Changes to generic/tclCompCmdsGR.c.

411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
     */

    for (j = jumpEndFixupArray.next;  j > 0;  j--) {
	jumpIndex = (j - 1);	/* i.e. process the closest jump first. */
	if (TclFixupForwardJumpToHere(envPtr,
		jumpEndFixupArray.fixup+jumpIndex, 127)) {
	    /*
	     * Adjust the immediately preceeding "ifFalse" jump. We moved it's
	     * target (just after this jump) down three bytes.
	     */

	    unsigned char *ifFalsePc = envPtr->codeStart
		    + jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
	    unsigned char opCode = *ifFalsePc;








|







411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
     */

    for (j = jumpEndFixupArray.next;  j > 0;  j--) {
	jumpIndex = (j - 1);	/* i.e. process the closest jump first. */
	if (TclFixupForwardJumpToHere(envPtr,
		jumpEndFixupArray.fixup+jumpIndex, 127)) {
	    /*
	     * Adjust the immediately preceding "ifFalse" jump. We moved it's
	     * target (just after this jump) down three bytes.
	     */

	    unsigned char *ifFalsePc = envPtr->codeStart
		    + jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
	    unsigned char opCode = *ifFalsePc;

615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630

    if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) {
	goto notCompilable;
    }
    Tcl_DecrRefCount(objPtr);

    /*
     * Confirmed as a literal that will not frighten the horses. Compile. Note
     * that the result needs to be list-ified.
     */

    /* TODO: Just push the known value */
    CompileWord(envPtr, tokenPtr,		interp, 1);
    TclEmitOpcode(	INST_RESOLVE_COMMAND,	envPtr);
    TclEmitOpcode(	INST_DUP,		envPtr);
    TclEmitOpcode(	INST_STR_LEN,		envPtr);







|
|







615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630

    if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) {
	goto notCompilable;
    }
    Tcl_DecrRefCount(objPtr);

    /*
     * Confirmed as a literal that will not frighten the horses. Compile.
     * The result must be made into a list.
     */

    /* TODO: Just push the known value */
    CompileWord(envPtr, tokenPtr,		interp, 1);
    TclEmitOpcode(	INST_RESOLVE_COMMAND,	envPtr);
    TclEmitOpcode(	INST_DUP,		envPtr);
    TclEmitOpcode(	INST_STR_LEN,		envPtr);
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
	/*
	 * Here we handle two ranges for idx. First when idx > 0, we
	 * want the first half of the split to end at index idx-1 and
	 * the second half to start at index idx.
	 * Second when idx < TCL_INDEX_END, indicating "end-N" indexing,
	 * we want the first half of the split to end at index end-N and
	 * the second half to start at index end-N+1. We accomplish this
	 * with a pre-adjustment of the end-N value.
	 * The root of this is that the commands [lrange] and [linsert]
	 * differ in their interpretation of the "end" index.
	 */

	if (idx < TCL_INDEX_END) {
	    idx++;
	}







|







1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
	/*
	 * Here we handle two ranges for idx. First when idx > 0, we
	 * want the first half of the split to end at index idx-1 and
	 * the second half to start at index idx.
	 * Second when idx < TCL_INDEX_END, indicating "end-N" indexing,
	 * we want the first half of the split to end at index end-N and
	 * the second half to start at index end-N+1. We accomplish this
	 * with a preadjustment of the end-N value.
	 * The root of this is that the commands [lrange] and [linsert]
	 * differ in their interpretation of the "end" index.
	 */

	if (idx < TCL_INDEX_END) {
	    idx++;
	}

Changes to generic/tclCompCmdsSZ.c.

2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
    Tcl_DString buffer;
    Tcl_HashEntry *hPtr;

    /*
     * Compile the switch by using a jump table, which is basically a
     * hashtable that maps from literal values to match against to the offset
     * (relative to the INST_JUMP_TABLE instruction) to jump to. The jump
     * table itself is independent of any invokation of the bytecode, and as
     * such is stored in an auxData block.
     *
     * Start by allocating the jump table itself, plus some workspace.
     */

    jtPtr = ckalloc(sizeof(JumptableInfo));
    Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);







|







2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
    Tcl_DString buffer;
    Tcl_HashEntry *hPtr;

    /*
     * Compile the switch by using a jump table, which is basically a
     * hashtable that maps from literal values to match against to the offset
     * (relative to the INST_JUMP_TABLE instruction) to jump to. The jump
     * table itself is independent of any invocation of the bytecode, and as
     * such is stored in an auxData block.
     *
     * Start by allocating the jump table itself, plus some workspace.
     */

    jtPtr = ckalloc(sizeof(JumptableInfo));
    Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);

Changes to generic/tclCompExpr.c.

92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
 *
 * While the parse tree is being constructed, the same memory space is used to
 * hold the p.prev field which chains together a stack of incomplete trees
 * awaiting their right operands.
 *
 * The lexeme field is filled in with the lexeme of the operator that is
 * returned by the ParseLexeme() routine. Only lexemes for unary and binary
 * operators get stored in an OpNode. Other lexmes get different treatement.
 *
 * The precedence field provides a place to store the precedence of the
 * operator, so it need not be looked up again and again.
 *
 * The mark field is use to control the traversal of the tree, so that it can
 * be done non-recursively. The mark values are:
 */







|







92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
 *
 * While the parse tree is being constructed, the same memory space is used to
 * hold the p.prev field which chains together a stack of incomplete trees
 * awaiting their right operands.
 *
 * The lexeme field is filled in with the lexeme of the operator that is
 * returned by the ParseLexeme() routine. Only lexemes for unary and binary
 * operators get stored in an OpNode. Other lexmes get different treatment.
 *
 * The precedence field provides a place to store the precedence of the
 * operator, so it need not be looked up again and again.
 *
 * The mark field is use to control the traversal of the tree, so that it can
 * be done non-recursively. The mark values are:
 */
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167

/* Uncategorized lexemes */

#define PLUS		1	/* Ambiguous. Resolves to UNARY_PLUS or
				 * BINARY_PLUS according to context. */
#define MINUS		2	/* Ambiguous. Resolves to UNARY_MINUS or
				 * BINARY_MINUS according to context. */
#define BAREWORD	3	/* Ambigous. Resolves to BOOLEAN or to
				 * FUNCTION or a parse error according to
				 * context and value. */
#define INCOMPLETE	4	/* A parse error. Used only when the single
				 * "=" is encountered.  */
#define INVALID		5	/* A parse error. Used when any punctuation
				 * appears that's not a supported operator. */








|







153
154
155
156
157
158
159
160
161
162
163
164
165
166
167

/* Uncategorized lexemes */

#define PLUS		1	/* Ambiguous. Resolves to UNARY_PLUS or
				 * BINARY_PLUS according to context. */
#define MINUS		2	/* Ambiguous. Resolves to UNARY_MINUS or
				 * BINARY_MINUS according to context. */
#define BAREWORD	3	/* Ambiguous. Resolves to BOOLEAN or to
				 * FUNCTION or a parse error according to
				 * context and value. */
#define INCOMPLETE	4	/* A parse error. Used only when the single
				 * "=" is encountered.  */
#define INVALID		5	/* A parse error. Used when any punctuation
				 * appears that's not a supported operator. */

562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
				 * optimizations are appropriate for the two
				 * scenarios. */
{
    OpNode *nodes = NULL;	/* Pointer to the OpNode storage array where
				 * we build the parse tree. */
    unsigned int nodesAvailable = 64; /* Initial size of the storage array. This
				 * value establishes a minimum tree memory
				 * cost of only about 1 kibyte, and is large
				 * enough for most expressions to parse with
				 * no need for array growth and
				 * reallocation. */
    unsigned int nodesUsed = 0;	/* Number of OpNodes filled. */
    int scanned = 0;		/* Capture number of byte scanned by parsing
				 * routines. */
    int lastParsed;		/* Stores info about what the lexeme parsed







|







562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
				 * optimizations are appropriate for the two
				 * scenarios. */
{
    OpNode *nodes = NULL;	/* Pointer to the OpNode storage array where
				 * we build the parse tree. */
    unsigned int nodesAvailable = 64; /* Initial size of the storage array. This
				 * value establishes a minimum tree memory
				 * cost of only about 1 kilobyte, and is large
				 * enough for most expressions to parse with
				 * no need for array growth and
				 * reallocation. */
    unsigned int nodesUsed = 0;	/* Number of OpNodes filled. */
    int scanned = 0;		/* Capture number of byte scanned by parsing
				 * routines. */
    int lastParsed;		/* Stores info about what the lexeme parsed
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
 *	Parse a single lexeme from the start of a string, scanning no more
 *	than numBytes bytes.
 *
 * Results:
 *	Returns the number of bytes scanned to produce the lexeme.
 *
 * Side effects:
 *	Code identifying lexeme parsed is writen to *lexemePtr.
 *
 *----------------------------------------------------------------------
 */

static int
ParseLexeme(
    const char *start,		/* Start of lexeme to parse. */







|







1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
 *	Parse a single lexeme from the start of a string, scanning no more
 *	than numBytes bytes.
 *
 * Results:
 *	Returns the number of bytes scanned to produce the lexeme.
 *
 * Side effects:
 *	Code identifying lexeme parsed is written to *lexemePtr.
 *
 *----------------------------------------------------------------------
 */

static int
ParseLexeme(
    const char *start,		/* Start of lexeme to parse. */

Changes to generic/tclCompile.c.

2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
    int cmdIdx = envPtr->numCommands;
    int startCodeOffset = envPtr->codeNext - envPtr->codeStart;
    int depth = TclGetStackDepth(envPtr);

    TclNewObj(cmdObj);
    assert (parsePtr->numWords > 0);

    /* Pre-Compile */

    envPtr->numCommands++;
    EnterCmdStartData(envPtr, cmdIdx,
	    parsePtr->commandStart - envPtr->source, startCodeOffset);

    /*
     * TIP #280. Scan the words and compute the extended location information.







|







2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
    int cmdIdx = envPtr->numCommands;
    int startCodeOffset = envPtr->codeNext - envPtr->codeStart;
    int depth = TclGetStackDepth(envPtr);

    TclNewObj(cmdObj);
    assert (parsePtr->numWords > 0);

    /* Precompile */

    envPtr->numCommands++;
    EnterCmdStartData(envPtr, cmdIdx,
	    parsePtr->commandStart - envPtr->source, startCodeOffset);

    /*
     * TIP #280. Scan the words and compute the extended location information.
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
    unsigned char *entryCodeNext = envPtr->codeNext;
#define NUM_STATIC_POS 20
    int isLiteral, maxNumCL, numCL;
    int *clPosition = NULL;
    int depth = TclGetStackDepth(envPtr);

    /*
     * For the handling of continuation lines in literals we first check if
     * this is actually a literal. For if not we can forego the additional
     * processing. Otherwise we pre-allocate a small table to store the
     * locations of all continuation lines we find in this literal, if any.
     * The table is extended if needed.
     *
     * Note: Different to the equivalent code in function 'TclSubstTokens()'
     * (see file "tclParse.c") we do not seem to need the 'adjust' variable.
     * We also do not seem to need code which merges continuation line
     * information of multiple words which concat'd at runtime. Either that or
     * I have not managed to find a test case for these two possibilities yet.
     * It might be a difference between compile- versus run-time processing.
     */

    numCL = 0;
    maxNumCL = 0;







|

|
|



|
|







2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
    unsigned char *entryCodeNext = envPtr->codeNext;
#define NUM_STATIC_POS 20
    int isLiteral, maxNumCL, numCL;
    int *clPosition = NULL;
    int depth = TclGetStackDepth(envPtr);

    /*
     * For the handling of continuation lines in literals, first check if
     * this is actually a literal. For if not we can forego the additional
     * processing. Otherwise preallocate a small table to store the
     * locations of all continuation lines found in this literal, if any.
     * The table is extended if needed.
     *
     * Note: Different to the equivalent code in function 'TclSubstTokens()'
     * (see file "tclParse.c") there seem to be no need the 'adjust' variable.
     * There also seems to be no need for code which merges continuation line
     * information of multiple words which concat'd at runtime. Either that or
     * I have not managed to find a test case for these two possibilities yet.
     * It might be a difference between compile- versus run-time processing.
     */

    numCL = 0;
    maxNumCL = 0;

Changes to generic/tclCompile.h.

430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
				 * code when new namespace resolution rules
				 * are put into effect. */
    int refCount;		/* Reference count: set 1 when created plus 1
				 * for each execution of the code currently
				 * active. This structure can be freed when
				 * refCount becomes zero. */
    unsigned int flags;		/* flags describing state for the codebyte.
				 * this variable holds ORed values from the
				 * TCL_BYTECODE_ masks defined above */
    const char *source;		/* The source string from which this ByteCode
				 * was compiled. Note that this pointer is not
				 * owned by the ByteCode and must not be freed
				 * or modified by it. */
    Proc *procPtr;		/* If the ByteCode was compiled from a
				 * procedure body, this is a pointer to its







|







430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
				 * code when new namespace resolution rules
				 * are put into effect. */
    int refCount;		/* Reference count: set 1 when created plus 1
				 * for each execution of the code currently
				 * active. This structure can be freed when
				 * refCount becomes zero. */
    unsigned int flags;		/* flags describing state for the codebyte.
				 * this variable holds OR'ed values from the
				 * TCL_BYTECODE_ masks defined above */
    const char *source;		/* The source string from which this ByteCode
				 * was compiled. Note that this pointer is not
				 * owned by the ByteCode and must not be freed
				 * or modified by it. */
    Proc *procPtr;		/* If the ByteCode was compiled from a
				 * procedure body, this is a pointer to its

Changes to generic/tclConfig.c.

178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
 *
 * QueryConfigObjCmd --
 *
 *	Implementation of "::<package>::pkgconfig", the command to query
 *	configuration information embedded into a binary library.
 *
 * Results:
 *	A standard tcl result.
 *
 * Side effects:
 *	See the manual for what this command does.
 *
 *----------------------------------------------------------------------
 */








|







178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
 *
 * QueryConfigObjCmd --
 *
 *	Implementation of "::<package>::pkgconfig", the command to query
 *	configuration information embedded into a binary library.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the manual for what this command does.
 *
 *----------------------------------------------------------------------
 */

Changes to generic/tclDate.c.

2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
    { "bt",	tZONE,	  -HOUR( 3) },	    /* Baghdad, USSR Zone 2 */
    { "it",	tZONE,	  -HOUR( 7/2) },    /* Iran */
    { "zp4",	tZONE,	  -HOUR( 4) },	    /* USSR Zone 3 */
    { "zp5",	tZONE,	  -HOUR( 5) },	    /* USSR Zone 4 */
    { "ist",	tZONE,	  -HOUR(11/2) },    /* Indian Standard */
    { "zp6",	tZONE,	  -HOUR( 6) },	    /* USSR Zone 5 */
#if	0
    /* For completeness.  NST is also Newfoundland Stanard, nad SST is
     * also Swedish Summer. */
    { "nst",	tZONE,	  -HOUR(13/2) },    /* North Sumatra */
    { "sst",	tZONE,	  -HOUR( 7) },	    /* South Sumatra, USSR Zone 6 */
#endif	/* 0 */
    { "wast",	tZONE,	  -HOUR( 7) },	    /* West Australian Standard */
    { "wadt",	tDAYZONE, -HOUR( 7) },	    /* West Australian Daylight */
    { "jt",	tZONE,	  -HOUR(15/2) },    /* Java (3pm in Cronusland!) */







|







2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
    { "bt",	tZONE,	  -HOUR( 3) },	    /* Baghdad, USSR Zone 2 */
    { "it",	tZONE,	  -HOUR( 7/2) },    /* Iran */
    { "zp4",	tZONE,	  -HOUR( 4) },	    /* USSR Zone 3 */
    { "zp5",	tZONE,	  -HOUR( 5) },	    /* USSR Zone 4 */
    { "ist",	tZONE,	  -HOUR(11/2) },    /* Indian Standard */
    { "zp6",	tZONE,	  -HOUR( 6) },	    /* USSR Zone 5 */
#if	0
    /* For completeness.  NST is also Newfoundland Standard, and SST is
     * also Swedish Summer. */
    { "nst",	tZONE,	  -HOUR(13/2) },    /* North Sumatra */
    { "sst",	tZONE,	  -HOUR( 7) },	    /* South Sumatra, USSR Zone 6 */
#endif	/* 0 */
    { "wast",	tZONE,	  -HOUR( 7) },	    /* West Australian Standard */
    { "wadt",	tDAYZONE, -HOUR( 7) },	    /* West Australian Daylight */
    { "jt",	tZONE,	  -HOUR(15/2) },    /* Java (3pm in Cronusland!) */

Changes to generic/tclDictObj.c.

750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
 *	effects (other than potential conversion of objects to dictionaries.)
 *	If the flags argument is DICT_PATH_UPDATE, the following additional
 *	side effects occur. Shared dictionaries along the path are converted
 *	into unshared objects, and a backward-pointing chain is built using
 *	the chain fields of the dictionaries (for easy invalidation of string
 *	representations using InvalidateDictChain). If the flags argument has
 *	the DICT_PATH_CREATE bits set (and not the DICT_PATH_EXISTS bit),
 *	non-existant keys will be inserted with a value of an empty
 *	dictionary, resulting in the path being built.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclTraceDictPath(







|







750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
 *	effects (other than potential conversion of objects to dictionaries.)
 *	If the flags argument is DICT_PATH_UPDATE, the following additional
 *	side effects occur. Shared dictionaries along the path are converted
 *	into unshared objects, and a backward-pointing chain is built using
 *	the chain fields of the dictionaries (for easy invalidation of string
 *	representations using InvalidateDictChain). If the flags argument has
 *	the DICT_PATH_CREATE bits set (and not the DICT_PATH_EXISTS bit),
 *	non-extant keys will be inserted with a value of an empty
 *	dictionary, resulting in the path being built.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclTraceDictPath(
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
}

/*
 *----------------------------------------------------------------------
 *
 * InvalidateDictChain --
 *
 *	Go through a dictionary chain (built by an updating invokation of
 *	TclTraceDictPath) and invalidate the string representations of all the
 *	dictionaries on the chain.
 *
 * Results:
 *	None
 *
 * Side effects:







|







837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
}

/*
 *----------------------------------------------------------------------
 *
 * InvalidateDictChain --
 *
 *	Go through a dictionary chain (built by an updating invocation of
 *	TclTraceDictPath) and invalidate the string representations of all the
 *	dictionaries on the chain.
 *
 * Results:
 *	None
 *
 * Side effects:
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
				 * written into when there are no further
				 * values in the dictionary, or a 0
				 * otherwise. */
{
    ChainEntry *cPtr;

    /*
     * If the searh is done; we do no work.
     */

    if (searchPtr->epoch == -1) {
	*donePtr = 1;
	return;
    }








|







1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
				 * written into when there are no further
				 * values in the dictionary, or a 0
				 * otherwise. */
{
    ChainEntry *cPtr;

    /*
     * If the search is done; we do no work.
     */

    if (searchPtr->epoch == -1) {
	*donePtr = 1;
	return;
    }

3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
    } else {
	allocdict = 0;
    }

    if (pathc > 0) {
	/*
	 * Want to get to the dictionary which we will update; need to do
	 * prepare-for-update de-sharing along the path *but* avoid generating
	 * an error on a non-existant path (we'll treat that the same as a
	 * non-existant variable. Luckily, the de-sharing operation isn't
	 * deeply damaging if we don't go on to update; it's just less than
	 * perfectly efficient (but no memory should be leaked).
	 */

	leafPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv,
		DICT_PATH_EXISTS | DICT_PATH_UPDATE);
	if (leafPtr == NULL) {







|
|
|







3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
    } else {
	allocdict = 0;
    }

    if (pathc > 0) {
	/*
	 * Want to get to the dictionary which we will update; need to do
	 * prepare-for-update unsharing along the path *but* avoid generating
	 * an error on a non-extant path (we'll treat that the same as a
	 * non-extant variable. Luckily, the unsharing operation isn't
	 * deeply damaging if we don't go on to update; it's just less than
	 * perfectly efficient (but no memory should be leaked).
	 */

	leafPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv,
		DICT_PATH_EXISTS | DICT_PATH_UPDATE);
	if (leafPtr == NULL) {

Changes to generic/tclEncoding.c.

852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_GetEncodingName --
 *
 *	Given an encoding, return the name that was used to constuct the
 *	encoding.
 *
 * Results:
 *	The name of the encoding.
 *
 * Side effects:
 *	None.







|







852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_GetEncodingName --
 *
 *	Given an encoding, return the name that was used to construct the
 *	encoding.
 *
 * Results:
 *	The name of the encoding.
 *
 * Side effects:
 *	None.
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
	    if (prefixBytes[byte]) {
		src--;
	    }
	    ch = (Tcl_UniChar) byte;
	}

	/*
	 * Special case for 1-byte utf chars for speed.
	 */

	if (ch && ch < 0x80) {
	    *dst++ = (char) ch;
	} else {
	    dst += Tcl_UniCharToUtf(ch, dst);
	}







|







2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
	    if (prefixBytes[byte]) {
		src--;
	    }
	    ch = (Tcl_UniChar) byte;
	}

	/*
	 * Special case for 1-byte Utf chars for speed.
	 */

	if (ch && ch < 0x80) {
	    *dst++ = (char) ch;
	} else {
	    dst += Tcl_UniCharToUtf(ch, dst);
	}

Changes to generic/tclEnsemble.c.

1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
     * number of arguments to this ensemble command), populating it and then
     * feeding it back through the main command-lookup engine. In theory, we
     * could look up the command in the namespace ourselves, as we already
     * have the namespace in which it is guaranteed to exist,
     *
     *   ((Q: That's not true if the -map option is used, is it?))
     *
     * but we don't do that (the cacheing of the command object used should
     * help with that.)
     */

    {
	Tcl_Obj *copyPtr;	/* The actual list of words to dispatch to.
				 * Will be freed by the dispatch engine. */
	Tcl_Obj **copyObjv;







|







1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
     * number of arguments to this ensemble command), populating it and then
     * feeding it back through the main command-lookup engine. In theory, we
     * could look up the command in the namespace ourselves, as we already
     * have the namespace in which it is guaranteed to exist,
     *
     *   ((Q: That's not true if the -map option is used, is it?))
     *
     * but we don't do that (the caching of the command object used should
     * help with that.)
     */

    {
	Tcl_Obj *copyPtr;	/* The actual list of words to dispatch to.
				 * Will be freed by the dispatch engine. */
	Tcl_Obj **copyObjv;
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
}

/*
 * ----------------------------------------------------------------------
 *
 * EnsmebleUnknownCallback --
 *
 *	Helper for the ensemble engine that handles the procesing of unknown
 *	callbacks. See the user documentation of the ensemble unknown handler
 *	for details; this function is only ever called when such a function is
 *	defined, and is only ever called once per ensemble dispatch (i.e. if a
 *	reparse still fails, this isn't called again).
 *
 * Results:
 *	TCL_OK -	*prefixObjPtr contains the command words to dispatch







|







2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
}

/*
 * ----------------------------------------------------------------------
 *
 * EnsmebleUnknownCallback --
 *
 *	Helper for the ensemble engine that handles the processing of unknown
 *	callbacks. See the user documentation of the ensemble unknown handler
 *	for details; this function is only ever called when such a function is
 *	defined, and is only ever called once per ensemble dispatch (i.e. if a
 *	reparse still fails, this isn't called again).
 *
 * Results:
 *	TCL_OK -	*prefixObjPtr contains the command words to dispatch

Changes to generic/tclEnv.c.

407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
    char *value;

    if (assignment == NULL) {
	return 0;
    }

    /*
     * First convert the native string to UTF. Then separate the string into
     * name and value parts, and call TclSetEnv to do all of the real work.
     */

    name = Tcl_ExternalToUtfDString(NULL, assignment, -1, &nameString);
    value = (char *)strchr(name, '=');

    if ((value != NULL) && (value != name)) {







|







407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
    char *value;

    if (assignment == NULL) {
	return 0;
    }

    /*
     * First convert the native string to Utf. Then separate the string into
     * name and value parts, and call TclSetEnv to do all of the real work.
     */

    name = Tcl_ExternalToUtfDString(NULL, assignment, -1, &nameString);
    value = (char *)strchr(name, '=');

    if ((value != NULL) && (value != name)) {

Changes to generic/tclEvent.c.

575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
/*
 *----------------------------------------------------------------------
 *
 * BgErrorDeleteProc --
 *
 *	This function is associated with the "tclBgError" assoc data for an
 *	interpreter; it is invoked when the interpreter is deleted in order to
 *	free the information assoicated with any pending error reports.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Background error information is freed: if there were any pending error
 *	reports, they are canceled.







|







575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
/*
 *----------------------------------------------------------------------
 *
 * BgErrorDeleteProc --
 *
 *	This function is associated with the "tclBgError" assoc data for an
 *	interpreter; it is invoked when the interpreter is deleted in order to
 *	free the information associated with any pending error reports.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Background error information is freed: if there were any pending error
 *	reports, they are canceled.
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
{
    if (inExit != 0) {
	Tcl_Panic("TclInitSubsystems called while exiting");
    }

    if (subsystemsInitialized == 0) {
	/*
	 * Double check inside the mutex. There are definitly calls back into
	 * this routine from some of the functions below.
	 */

	TclpInitLock();
	if (subsystemsInitialized == 0) {

		/*







|







1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
{
    if (inExit != 0) {
	Tcl_Panic("TclInitSubsystems called while exiting");
    }

    if (subsystemsInitialized == 0) {
	/*
	 * Double check inside the mutex. There are definitely calls back into
	 * this routine from some of the functions below.
	 */

	TclpInitLock();
	if (subsystemsInitialized == 0) {

		/*

Changes to generic/tclExecute.c.

1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
	 * has to be recompiled to get the correct locations. Not doing this
	 * will execute the saved bytecode with data for a different location,
	 * causing 'info frame' to point to the wrong place in the sources.
	 *
	 * Future optimizations ...
	 * (1) Save the location data (ExtCmdLoc) keyed by start line. In that
	 *     case we recompile once per location of the literal, but not
	 *     continously, because the moment we have all locations we do not
	 *     need to recompile any longer.
	 *
	 * (2) Alternative: Do not recompile, tell the execution engine the
	 *     offset between saved starting line and actual one. Then modify
	 *     the users to adjust the locations they have by this offset.
	 *
	 * (3) Alternative 2: Do not fully recompile, adjust just the location







|







1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
	 * has to be recompiled to get the correct locations. Not doing this
	 * will execute the saved bytecode with data for a different location,
	 * causing 'info frame' to point to the wrong place in the sources.
	 *
	 * Future optimizations ...
	 * (1) Save the location data (ExtCmdLoc) keyed by start line. In that
	 *     case we recompile once per location of the literal, but not
	 *     continuously, because the moment we have all locations we do not
	 *     need to recompile any longer.
	 *
	 * (2) Alternative: Do not recompile, tell the execution engine the
	 *     offset between saved starting line and actual one. Then modify
	 *     the users to adjust the locations they have by this offset.
	 *
	 * (3) Alternative 2: Do not fully recompile, adjust just the location
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
}

/*
 *----------------------------------------------------------------------
 *
 * TclIncrObj --
 *
 *	Increment an integeral value in a Tcl_Obj by an integeral value held
 *	in another Tcl_Obj. Caller is responsible for making sure we can
 *	update the first object.
 *
 * Results:
 *	TCL_ERROR if either object is non-integer, and TCL_OK otherwise. On
 *	error, an error message is left in the interpreter (if it is not NULL,
 *	of course).







|







1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
}

/*
 *----------------------------------------------------------------------
 *
 * TclIncrObj --
 *
 *	Increment an integral value in a Tcl_Obj by an integral value held
 *	in another Tcl_Obj. Caller is responsible for making sure we can
 *	update the first object.
 *
 * Results:
 *	TCL_ERROR if either object is non-integer, and TCL_OK otherwise. On
 *	error, an error message is left in the interpreter (if it is not NULL,
 *	of course).
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828

    /*
     *	   End of INST_STORE and related instructions.
     * -----------------------------------------------------------------
     *	   Start of INST_INCR instructions.
     *
     * WARNING: more 'goto' here than your doctor recommended! The different
     * instructions set the value of some variables and then jump to somme
     * common execution code.
     */

/*TODO: Consider more untangling here; merge with LOAD and STORE ? */

    {
	Tcl_Obj *incrPtr;







|







3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828

    /*
     *	   End of INST_STORE and related instructions.
     * -----------------------------------------------------------------
     *	   Start of INST_INCR instructions.
     *
     * WARNING: more 'goto' here than your doctor recommended! The different
     * instructions set the value of some variables and then jump to some
     * common execution code.
     */

/*TODO: Consider more untangling here; merge with LOAD and STORE ? */

    {
	Tcl_Obj *incrPtr;
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364

	fromIdx = TclIndexDecode(fromIdx, objc - 1);
	if (fromIdx < 0) {
	    fromIdx = 0;
	}

	if (fromIdx <= toIdx) {
	    /* Construct the subsquence list */
	    /* unshared optimization */
	    if (Tcl_IsShared(valuePtr)) {
		objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx);
	    } else {
		if (toIdx != objc - 1) {
		    Tcl_ListObjReplace(NULL, valuePtr, toIdx + 1, LIST_MAX,
			    0, NULL);







|







5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364

	fromIdx = TclIndexDecode(fromIdx, objc - 1);
	if (fromIdx < 0) {
	    fromIdx = 0;
	}

	if (fromIdx <= toIdx) {
	    /* Construct the subsequence list */
	    /* unshared optimization */
	    if (Tcl_IsShared(valuePtr)) {
		objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx);
	    } else {
		if (toIdx != objc - 1) {
		    Tcl_ListObjReplace(NULL, valuePtr, toIdx + 1, LIST_MAX,
			    0, NULL);
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579

    case INST_STR_INDEX:
	value2Ptr = OBJ_AT_TOS;
	valuePtr = OBJ_UNDER_TOS;
	TRACE(("\"%.20s\" %.20s => ", O2S(valuePtr), O2S(value2Ptr)));

	/*
	 * Get char length to calulate what 'end' means.
	 */

	length = Tcl_GetCharLength(valuePtr);
	if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
	    TRACE_ERROR(interp);
	    goto gotError;
	}







|







5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579

    case INST_STR_INDEX:
	value2Ptr = OBJ_AT_TOS;
	valuePtr = OBJ_UNDER_TOS;
	TRACE(("\"%.20s\" %.20s => ", O2S(valuePtr), O2S(value2Ptr)));

	/*
	 * Get char length to calculate what 'end' means.
	 */

	length = Tcl_GetCharLength(valuePtr);
	if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
	    TRACE_ERROR(interp);
	    goto gotError;
	}
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
		NEXT_INST_F(1, 0, 0);
	    } else {
		NEXT_INST_F(1, 1, 1);
	    }
	}

	/*
	 * Get the unicode representation; this is where we guarantee to lose
	 * bytearrays.
	 */

	ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
	length--;

	/*







|







5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
		NEXT_INST_F(1, 0, 0);
	    } else {
		NEXT_INST_F(1, 1, 1);
	    }
	}

	/*
	 * Get the Unicode representation; this is where we guarantee to lose
	 * bytearrays.
	 */

	ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
	length--;

	/*
7650
7651
7652
7653
7654
7655
7656
7657
7658
7659
7660
7661
7662
7663
7664
	    PUSH_OBJECT(valuePtr);
	    PUSH_OBJECT(keyPtr);
	}
	TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n",
		O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done));

	/*
	 * The INST_DICT_FIRST and INST_DICT_NEXT instructsions are always
	 * followed by a conditional jump, so we can take advantage of this to
	 * do some peephole optimization (note that we're careful to not close
	 * out someone doing something else).
	 */

	JUMP_PEEPHOLE_F(done, 5, 0);








|







7650
7651
7652
7653
7654
7655
7656
7657
7658
7659
7660
7661
7662
7663
7664
	    PUSH_OBJECT(valuePtr);
	    PUSH_OBJECT(keyPtr);
	}
	TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n",
		O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done));

	/*
	 * The INST_DICT_FIRST and INST_DICT_NEXT instructions are always
	 * followed by a conditional jump, so we can take advantage of this to
	 * do some peephole optimization (note that we're careful to not close
	 * out someone doing something else).
	 */

	JUMP_PEEPHOLE_F(done, 5, 0);

Changes to generic/tclFCmd.c.

1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
	 * Create link from source to target.
	 */

	contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
	if (contents == NULL) {
	    /*
	     * We handle three common error cases specially, and for all other
	     * errors, we use the standard posix error message.
	     */

	    if (errno == EEXIST) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"could not create new link \"%s\": that path already"
			" exists", TclGetString(objv[index])));
		Tcl_PosixError(interp);







|







1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
	 * Create link from source to target.
	 */

	contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
	if (contents == NULL) {
	    /*
	     * We handle three common error cases specially, and for all other
	     * errors, we use the standard Posix error message.
	     */

	    if (errno == EEXIST) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"could not create new link \"%s\": that path already"
			" exists", TclGetString(objv[index])));
		Tcl_PosixError(interp);

Changes to generic/tclFileName.c.

85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
 *
 *	Matches the root portion of a Windows path and appends it to the
 *	specified Tcl_DString.
 *
 * Results:
 *	Returns the position in the path immediately after the root including
 *	any trailing slashes. Appends a cleaned up version of the root to the
 *	Tcl_DString at the specified offest.
 *
 * Side effects:
 *	Modifies the specified Tcl_DString.
 *
 *----------------------------------------------------------------------
 */








|







85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
 *
 *	Matches the root portion of a Windows path and appends it to the
 *	specified Tcl_DString.
 *
 * Results:
 *	Returns the position in the path immediately after the root including
 *	any trailing slashes. Appends a cleaned up version of the root to the
 *	Tcl_DString at the specified offset.
 *
 * Side effects:
 *	Modifies the specified Tcl_DString.
 *
 *----------------------------------------------------------------------
 */

1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
	}
    }

    /*
     * To process a [glob] invocation, this function may be called multiple
     * times. Each time, the previously discovered filenames are in the
     * interpreter result. We stash that away here so the result is free for
     * error messsages.
     */

    savedResultObj = Tcl_GetObjResult(interp);
    Tcl_IncrRefCount(savedResultObj);
    Tcl_ResetResult(interp);
    TclNewObj(filenamesObj);
    Tcl_IncrRefCount(filenamesObj);







|







1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
	}
    }

    /*
     * To process a [glob] invocation, this function may be called multiple
     * times. Each time, the previously discovered filenames are in the
     * interpreter result. We stash that away here so the result is free for
     * error messages.
     */

    savedResultObj = Tcl_GetObjResult(interp);
    Tcl_IncrRefCount(savedResultObj);
    Tcl_ResetResult(interp);
    TclNewObj(filenamesObj);
    Tcl_IncrRefCount(filenamesObj);

Changes to generic/tclIO.c.

951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
 *	an interpreter is deleted, via the AssocData cleanup mechanism.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deletes the hash table of channels. May close channels. May flush
 *	output on closed channels. Removes any channeEvent handlers that were
 *	registered in this interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteChannelTable(







|







951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
 *	an interpreter is deleted, via the AssocData cleanup mechanism.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deletes the hash table of channels. May close channels. May flush
 *	output on closed channels. Removes any channelEvent handlers that were
 *	registered in this interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteChannelTable(
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
    hTblPtr = (Tcl_HashTable *)clientData;
    for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL;
	    hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) {
	chanPtr = (Channel *)Tcl_GetHashValue(hPtr);
	statePtr = chanPtr->state;

	/*
	 * Remove any fileevents registered in this interpreter.
	 */

	for (sPtr = statePtr->scriptRecordPtr, prevPtr = NULL;
		sPtr != NULL; sPtr = nextPtr) {
	    nextPtr = sPtr->nextPtr;
	    if (sPtr->interp == interp) {
		if (prevPtr == NULL) {







|







984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
    hTblPtr = (Tcl_HashTable *)clientData;
    for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL;
	    hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) {
	chanPtr = (Channel *)Tcl_GetHashValue(hPtr);
	statePtr = chanPtr->state;

	/*
	 * Remove any file events registered in this interpreter.
	 */

	for (sPtr = statePtr->scriptRecordPtr, prevPtr = NULL;
		sPtr != NULL; sPtr = nextPtr) {
	    nextPtr = sPtr->nextPtr;
	    if (sPtr->interp == interp) {
		if (prevPtr == NULL) {
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417

Tcl_Channel
Tcl_GetChannel(
    Tcl_Interp *interp,		/* Interpreter in which to find or create the
				 * channel. */
    const char *chanName,	/* The name of the channel. */
    int *modePtr)		/* Where to store the mode in which the
				 * channel was opened? Will contain an ORed
				 * combination of TCL_READABLE and
				 * TCL_WRITABLE, if non-NULL. */
{
    Channel *chanPtr;		/* The actual channel. */
    Tcl_HashTable *hTblPtr;	/* Hash table of channels. */
    Tcl_HashEntry *hPtr;	/* Search variable. */
    const char *name;		/* Translated name. */







|







1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417

Tcl_Channel
Tcl_GetChannel(
    Tcl_Interp *interp,		/* Interpreter in which to find or create the
				 * channel. */
    const char *chanName,	/* The name of the channel. */
    int *modePtr)		/* Where to store the mode in which the
				 * channel was opened? Will contain an OR'ed
				 * combination of TCL_READABLE and
				 * TCL_WRITABLE, if non-NULL. */
{
    Channel *chanPtr;		/* The actual channel. */
    Tcl_HashTable *hTblPtr;	/* Hash table of channels. */
    Tcl_HashEntry *hPtr;	/* Search variable. */
    const char *name;		/* Translated name. */
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
int
TclGetChannelFromObj(
    Tcl_Interp *interp,		/* Interpreter in which to find or create the
				 * channel. */
    Tcl_Obj *objPtr,
    Tcl_Channel *channelPtr,
    int *modePtr,		/* Where to store the mode in which the
				 * channel was opened? Will contain an ORed
				 * combination of TCL_READABLE and
				 * TCL_WRITABLE, if non-NULL. */
    int flags)
{
    ChannelState *statePtr;
    ResolvedChanName *resPtr = NULL;
    Tcl_Channel chan;







|







1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
int
TclGetChannelFromObj(
    Tcl_Interp *interp,		/* Interpreter in which to find or create the
				 * channel. */
    Tcl_Obj *objPtr,
    Tcl_Channel *channelPtr,
    int *modePtr,		/* Where to store the mode in which the
				 * channel was opened? Will contain an OR'ed
				 * combination of TCL_READABLE and
				 * TCL_WRITABLE, if non-NULL. */
    int flags)
{
    ChannelState *statePtr;
    ResolvedChanName *resPtr = NULL;
    Tcl_Channel chan;
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
     * are not only useless but actually distorts our view of the system.
     *
     * To preserve the information without having to read them again and to
     * avoid problems with the location in the channel (seeking might be
     * impossible) we move the buffers from the common state structure into
     * the channel itself. We use the buffers in the channel below the new
     * transformation to hold the data. In the future this allows us to write
     * transformations which pre-read data and push the unused part back when
     * they are going away.
     */

    if (((mask & TCL_READABLE) != 0) && (statePtr->inQueueHead != NULL)) {
	/*
	 * When statePtr->inQueueHead is not NULL, we know
	 * prevChanPtr->inQueueHead must be NULL.







|







1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
     * are not only useless but actually distorts our view of the system.
     *
     * To preserve the information without having to read them again and to
     * avoid problems with the location in the channel (seeking might be
     * impossible) we move the buffers from the common state structure into
     * the channel itself. We use the buffers in the channel below the new
     * transformation to hold the data. In the future this allows us to write
     * transformations which preread data and push the unused part back when
     * they are going away.
     */

    if (((mask & TCL_READABLE) != 0) && (statePtr->inQueueHead != NULL)) {
	/*
	 * When statePtr->inQueueHead is not NULL, we know
	 * prevChanPtr->inQueueHead must be NULL.
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
 *	Unstacks an entry in the hash table for a Tcl_Channel record. This is
 *	the reverse to 'Tcl_StackChannel'.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	If TCL_ERROR is returned, the posix error code will be set with
 *	Tcl_SetErrno. May leave a message in interp result as well.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UnstackChannel(







|







2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
 *	Unstacks an entry in the hash table for a Tcl_Channel record. This is
 *	the reverse to 'Tcl_StackChannel'.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	If TCL_ERROR is returned, the Posix error code will be set with
 *	Tcl_SetErrno. May leave a message in interp result as well.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UnstackChannel(
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
     * This operation should occur at the top of a channel stack.
     */

    chanPtr = statePtr->topChanPtr;

    if (chanPtr->downChanPtr != NULL) {
	/*
	 * Instead of manipulating the per-thread / per-interp list/hashtable
	 * of registered channels we wind down the state of the
	 * transformation, and then restore the state of underlying channel
	 * into the old structure.
	 *
	 * TODO: Figure out how to handle the situation where the chan
	 * operations called below by this unstacking operation cause
	 * another unstacking recursively.  In that case the downChanPtr







|







2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
     * This operation should occur at the top of a channel stack.
     */

    chanPtr = statePtr->topChanPtr;

    if (chanPtr->downChanPtr != NULL) {
	/*
	 * Instead of manipulating the per-thread / per-interp list/hash table
	 * of registered channels we wind down the state of the
	 * transformation, and then restore the state of underlying channel
	 * into the old structure.
	 *
	 * TODO: Figure out how to handle the situation where the chan
	 * operations called below by this unstacking operation cause
	 * another unstacking recursively.  In that case the downChanPtr
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536

    if (mustDiscard) {
	ReleaseChannelBuffer(bufPtr);
	return;
    }

    /*
     * Only save buffers which have the requested buffersize for the channel.
     * This is to honor dynamic changes of the buffersize made by the user.
     */

    if ((bufPtr->bufLength - BUFFER_PADDING) != statePtr->bufSize) {
	ReleaseChannelBuffer(bufPtr);
	return;
    }








|
|







2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536

    if (mustDiscard) {
	ReleaseChannelBuffer(bufPtr);
	return;
    }

    /*
     * Only save buffers which have the requested buffer size for the channel.
     * This is to honor dynamic changes of the buffe rsize made by the user.
     */

    if ((bufPtr->bufLength - BUFFER_PADDING) != statePtr->bufSize) {
	ReleaseChannelBuffer(bufPtr);
	return;
    }

2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
				 * driver operations. */
    int wroteSome = 0;		/* Set to one if any data was written to the
				 * driver. */

    /*
     * Prevent writing on a dead channel -- a channel that has been closed but
     * not yet deallocated. This can occur if the exit handler for the channel
     * deallocation runs before all channels are deregistered in all
     * interpreters.
     */

    if (CheckForDeadChannel(interp, statePtr)) {
	return -1;
    }








|







2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
				 * driver operations. */
    int wroteSome = 0;		/* Set to one if any data was written to the
				 * driver. */

    /*
     * Prevent writing on a dead channel -- a channel that has been closed but
     * not yet deallocated. This can occur if the exit handler for the channel
     * deallocation runs before all channels are unregistered in all
     * interpreters.
     */

    if (CheckForDeadChannel(interp, statePtr)) {
	return -1;
    }

2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
	    /*
	     * Decide whether to report the error upwards or defer it.
	     */

	    if (calledFromAsyncFlush) {
		/*
		 * TIP #219, Tcl Channel Reflection API.
		 * When defering the error copy a message from the bypass into
		 * the unreported area. Or discard it if the new error is to
		 * be ignored in favor of an earlier defered error.
		 */

		Tcl_Obj *msg = statePtr->chanMsg;

		if (statePtr->unreportedError == 0) {
		    statePtr->unreportedError = errorCode;
		    statePtr->unreportedMsg = msg;







|

|







2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
	    /*
	     * Decide whether to report the error upwards or defer it.
	     */

	    if (calledFromAsyncFlush) {
		/*
		 * TIP #219, Tcl Channel Reflection API.
		 * When deferring the error copy a message from the bypass into
		 * the unreported area. Or discard it if the new error is to
		 * be ignored in favor of an earlier deferred error.
		 */

		Tcl_Obj *msg = statePtr->chanMsg;

		if (statePtr->unreportedError == 0) {
		    statePtr->unreportedError = errorCode;
		    statePtr->unreportedMsg = msg;
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
 * Side effects:
 *	Resets the field 'nextCSPtr' of the specified channel state to NULL.
 *
 * NOTE:
 *	The channel to cut out of the list must not be referenced in any
 *	interpreter. This is something this procedure cannot check (despite
 *	the refcount) because the caller usually wants fiddle with the channel
 *	(like transfering it to a different thread) and thus keeps the
 *	refcount artifically high to prevent its destruction.
 *
 *----------------------------------------------------------------------
 */

static void
CutChannel(
    Tcl_Channel chan)		/* The channel being removed. Must not be







|
|







3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
 * Side effects:
 *	Resets the field 'nextCSPtr' of the specified channel state to NULL.
 *
 * NOTE:
 *	The channel to cut out of the list must not be referenced in any
 *	interpreter. This is something this procedure cannot check (despite
 *	the refcount) because the caller usually wants fiddle with the channel
 *	(like transferring it to a different thread) and thus keeps the
 *	refcount artificially high to prevent its destruction.
 *
 *----------------------------------------------------------------------
 */

static void
CutChannel(
    Tcl_Channel chan)		/* The channel being removed. Must not be
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
 *
 * Side effects:
 *	Nothing.
 *
 * NOTE:
 *	The channel to splice into the list must not be referenced in any
 *	interpreter. This is something this procedure cannot check (despite
 *	the refcount) because the caller usually wants figgle with the channel
 *	(like transfering it to a different thread) and thus keeps the
 *	refcount artifically high to prevent its destruction.
 *
 *----------------------------------------------------------------------
 */

static void
SpliceChannel(
    Tcl_Channel chan)		/* The channel being added. Must not be







|
|
|







3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
 *
 * Side effects:
 *	Nothing.
 *
 * NOTE:
 *	The channel to splice into the list must not be referenced in any
 *	interpreter. This is something this procedure cannot check (despite
 *	the refcount) because the caller usually wants fiddle with the channel
 *	(like transferring it to a different thread) and thus keeps the
 *	refcount artificially high to prevent its destruction.
 *
 *----------------------------------------------------------------------
 */

static void
SpliceChannel(
    Tcl_Channel chan)		/* The channel being added. Must not be
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
 *	A standard Tcl result.
 *
 * Side effects:
 *	Closes the write side of the channel.
 *
 * NOTE:
 *	CloseWrite removes the channel as far as the user is concerned.
 *	However, the ooutput data structures may continue to exist for a while
 *	longer if it has a background flush scheduled. The device itself is
 *	eventually closed and the channel structures modified, in
 *	CloseChannelPart, below.
 *
 *----------------------------------------------------------------------
 */








|







3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
 *	A standard Tcl result.
 *
 * Side effects:
 *	Closes the write side of the channel.
 *
 * NOTE:
 *	CloseWrite removes the channel as far as the user is concerned.
 *	However, the output data structures may continue to exist for a while
 *	longer if it has a background flush scheduled. The device itself is
 *	eventually closed and the channel structures modified, in
 *	CloseChannelPart, below.
 *
 *----------------------------------------------------------------------
 */

4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
    if (statePtr->encoding) {
	return WriteChars(chanPtr, src, len);
    }

    /*
     * Inefficient way to convert UTF-8 to byte-array, but the code
     * parallels the way it is done for objects.  Special case for 1-byte
     * (used by eg [puts] for the \n) could be extended to more efficient
     * translation of the src string.
     */

    if ((len == 1) && (UCHAR(*src) < 0xC0)) {
	return WriteBytes(chanPtr, src, len);
    }








|







4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
    if (statePtr->encoding) {
	return WriteChars(chanPtr, src, len);
    }

    /*
     * Inefficient way to convert UTF-8 to byte-array, but the code
     * parallels the way it is done for objects.  Special case for 1-byte
     * (used by e.g. [puts] for the \n) could be extended to more efficient
     * translation of the src string.
     */

    if ((len == 1) && (UCHAR(*src) < 0xC0)) {
	return WriteBytes(chanPtr, src, len);
    }

4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
		ReleaseChannelBuffer(bufPtr);
		return -1;
	    }
	    flushed += statePtr->bufSize;

	    /*
 	     * We just flushed.  So if we have needNlFlush set to record that
 	     * we need to flush because theres a (translated) newline in the
 	     * buffer, that's likely not true any more.  But there is a tricky
 	     * exception.  If we have saved bytes that did not really get
 	     * flushed and those bytes came from a translation of a newline as
 	     * the last thing taken from the src array, then needNlFlush needs
 	     * to remain set to flag that the next buffer still needs a
 	     * newline flush.
 	     */







|







4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
		ReleaseChannelBuffer(bufPtr);
		return -1;
	    }
	    flushed += statePtr->bufSize;

	    /*
 	     * We just flushed.  So if we have needNlFlush set to record that
 	     * we need to flush because there is a (translated) newline in the
 	     * buffer, that's likely not true any more.  But there is a tricky
 	     * exception.  If we have saved bytes that did not really get
 	     * flushed and those bytes came from a translation of a newline as
 	     * the last thing taken from the src array, then needNlFlush needs
 	     * to remain set to flag that the next buffer still needs a
 	     * newline flush.
 	     */
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
	case TCL_TRANSLATE_CRLF:
	    for (eol = dst; eol < dstEnd; eol++) {
		if (*eol == '\r') {
		    eol++;

		    /*
		     * If a CR is at the end of the buffer, then check for a
		     * LF at the begining of the next buffer, unless EOF char
		     * was found already.
		     */

		    if (eol >= dstEnd) {
			int offset;

			if (eol != eof) {







|







4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
	case TCL_TRANSLATE_CRLF:
	    for (eol = dst; eol < dstEnd; eol++) {
		if (*eol == '\r') {
		    eol++;

		    /*
		     * If a CR is at the end of the buffer, then check for a
		     * LF at the beginning of the next buffer, unless EOF char
		     * was found already.
		     */

		    if (eol >= dstEnd) {
			int offset;

			if (eol != eof) {
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
	    }
	    RecycleBuffer(chanPtr->state, bufPtr, 0);
	}
    }

    /*
     * Go to the driver only if we got nothing from pushback.  Have to do it
     * this way to avoid EOF mis-timings when we consider the ability that EOF
     * may not be a permanent condition in the driver, and in that case we
     * have to synchronize.
     */

    if (copied) {
	return copied;
    }







|







5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
	    }
	    RecycleBuffer(chanPtr->state, bufPtr, 0);
	}
    }

    /*
     * Go to the driver only if we got nothing from pushback.  Have to do it
     * this way to avoid EOF mistimings when we consider the ability that EOF
     * may not be a permanent condition in the driver, and in that case we
     * have to synchronize.
     */

    if (copied) {
	return copied;
    }
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
    int charsToRead,		/* Maximum number of characters to store, or
				 * -1 to get all available characters.
				 * Characters are obtained from the first
				 * buffer in the queue -- even if this number
				 * is larger than the number of characters
				 * available in the first buffer, only the
				 * characters from the first buffer are
				 * returned. The execption is when there is
				 * not any complete character in the first
				 * buffer.  In that case, a recursive call
				 * effectively obtains chars from the
				 * second buffer. */
    int *factorPtr)		/* On input, contains a guess of how many
				 * bytes need to be allocated to hold the
				 * result of converting N source bytes to







|







6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
    int charsToRead,		/* Maximum number of characters to store, or
				 * -1 to get all available characters.
				 * Characters are obtained from the first
				 * buffer in the queue -- even if this number
				 * is larger than the number of characters
				 * available in the first buffer, only the
				 * characters from the first buffer are
				 * returned. The exception is when there is
				 * not any complete character in the first
				 * buffer.  In that case, a recursive call
				 * effectively obtains chars from the
				 * second buffer. */
    int *factorPtr)		/* On input, contains a guess of how many
				 * bytes need to be allocated to hold the
				 * result of converting N source bytes to
7281
7282
7283
7284
7285
7286
7287
7288
7289
7290
7291
7292
7293
7294
7295

	Tcl_SetErrno(EINVAL);
	return TCL_ERROR;
    }

    /*
     * Seek first to force a total flush of all pending buffers and ditch any
     * pre-read input data.
     */

    WillWrite(chanPtr);

    if (WillRead(chanPtr) < 0) {
        return TCL_ERROR;
    }







|







7281
7282
7283
7284
7285
7286
7287
7288
7289
7290
7291
7292
7293
7294
7295

	Tcl_SetErrno(EINVAL);
	return TCL_ERROR;
    }

    /*
     * Seek first to force a total flush of all pending buffers and ditch any
     * preread input data.
     */

    WillWrite(chanPtr);

    if (WillRead(chanPtr) < 0) {
        return TCL_ERROR;
    }
7341
7342
7343
7344
7345
7346
7347
7348
7349
7350
7351
7352
7353
7354
7355

    if (statePtr->unreportedError != 0) {
	Tcl_SetErrno(statePtr->unreportedError);
	statePtr->unreportedError = 0;

	/*
	 * TIP #219, Tcl Channel Reflection API.
	 * Move a defered error message back into the channel bypass.
	 */

	if (statePtr->chanMsg != NULL) {
	    TclDecrRefCount(statePtr->chanMsg);
	}
	statePtr->chanMsg = statePtr->unreportedMsg;
	statePtr->unreportedMsg = NULL;







|







7341
7342
7343
7344
7345
7346
7347
7348
7349
7350
7351
7352
7353
7354
7355

    if (statePtr->unreportedError != 0) {
	Tcl_SetErrno(statePtr->unreportedError);
	statePtr->unreportedError = 0;

	/*
	 * TIP #219, Tcl Channel Reflection API.
	 * Move a deferred error message back into the channel bypass.
	 */

	if (statePtr->chanMsg != NULL) {
	    TclDecrRefCount(statePtr->chanMsg);
	}
	statePtr->chanMsg = statePtr->unreportedMsg;
	statePtr->unreportedMsg = NULL;
7666
7667
7668
7669
7670
7671
7672
7673
7674
7675
7676
7677
7678
7679
7680
 *
 * Results:
 *	TCL_ERROR.
 *
 * Side effects:

 *	An error message is generated in interp's result object to indicate
 *	that a command was invoked with the a bad option. The message has the
 *	form:
 *		bad option "blah": should be one of
 *		<...generic options...>+<...specific options...>
 *	"blah" is the optionName argument and "<specific options>" is a space
 *	separated list of specific option words. The function takes good care
 *	of inserting minus signs before each option, commas after, and an "or"
 *	before the last option.







|







7666
7667
7668
7669
7670
7671
7672
7673
7674
7675
7676
7677
7678
7679
7680
 *
 * Results:
 *	TCL_ERROR.
 *
 * Side effects:

 *	An error message is generated in interp's result object to indicate
 *	that a command was invoked with a bad option. The message has the
 *	form:
 *		bad option "blah": should be one of
 *		<...generic options...>+<...specific options...>
 *	"blah" is the optionName argument and "<specific options>" is a space
 *	separated list of specific option words. The function takes good care
 *	of inserting minus signs before each option, commas after, and an "or"
 *	before the last option.
11020
11021
11022
11023
11024
11025
11026
11027
11028
11029
11030
11031
11032
11033
11034

    /*
     * Process the caught message.
     *
     * Syntax = (option value)... ?message?
     *
     * Bad message syntax causes a panic, because the other side uses
     * Tcl_GetReturnOptions and list construction functions to marshall the
     * information. Hence an error means that we've got serious breakage.
     */

    res = TclListObjGetElements(NULL, msg, &lc, &lv);
    if (res != TCL_OK) {
	Tcl_Panic("Tcl_SetChannelError: bad syntax of message");
    }







|







11020
11021
11022
11023
11024
11025
11026
11027
11028
11029
11030
11031
11032
11033
11034

    /*
     * Process the caught message.
     *
     * Syntax = (option value)... ?message?
     *
     * Bad message syntax causes a panic, because the other side uses
     * Tcl_GetReturnOptions and list construction functions to marshal the
     * information. Hence an error means that we've got serious breakage.
     */

    res = TclListObjGetElements(NULL, msg, &lc, &lv);
    if (res != TCL_OK) {
	Tcl_Panic("Tcl_SetChannelError: bad syntax of message");
    }
11089
11090
11091
11092
11093
11094
11095
11096
11097
11098
11099
11100
11101
11102
11103
11104
    if (newcode >= 0) {
	lcn += 2;
    }

    lvn = (Tcl_Obj **)ckalloc(lcn * sizeof(Tcl_Obj *));

    /*
     * New level/code information is spliced into the first occurence of
     * -level, -code, further occurences are ignored. The options cannot be
     * not present, we would not come here. Options which are ok are simply
     * copied over.
     */

    lignore = cignore = 0;
    for (i=0, j=0; i<numOptions; i+=2) {
	if (0 == strcmp(TclGetString(lv[i]), "-level")) {







|
|







11089
11090
11091
11092
11093
11094
11095
11096
11097
11098
11099
11100
11101
11102
11103
11104
    if (newcode >= 0) {
	lcn += 2;
    }

    lvn = (Tcl_Obj **)ckalloc(lcn * sizeof(Tcl_Obj *));

    /*
     * New level/code information is spliced into the first occurrence of
     * -level, -code, further occurrences are ignored. The options cannot be
     * not present, we would not come here. Options which are ok are simply
     * copied over.
     */

    lignore = cignore = 0;
    for (i=0, j=0; i<numOptions; i+=2) {
	if (0 == strcmp(TclGetString(lv[i]), "-level")) {

Changes to generic/tclIO.h.

41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
				 * will be put in the buffer. */
    int nextRemoved;		/* Position of next byte to be removed from
				 * the buffer. */
    int bufLength;		/* How big is the buffer? */
    struct ChannelBuffer *nextPtr;
    				/* Next buffer in chain. */
    char buf[TCLFLEXARRAY];		/* Placeholder for real buffer. The real
				 * buffer occuppies this space + bufSize-1
				 * bytes. This must be the last field in the
				 * structure. */
} ChannelBuffer;

#define CHANNELBUFFER_HEADER_SIZE	TclOffset(ChannelBuffer, buf)

/*







|







41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
				 * will be put in the buffer. */
    int nextRemoved;		/* Position of next byte to be removed from
				 * the buffer. */
    int bufLength;		/* How big is the buffer? */
    struct ChannelBuffer *nextPtr;
    				/* Next buffer in chain. */
    char buf[TCLFLEXARRAY];		/* Placeholder for real buffer. The real
				 * buffer occupies this space + bufSize-1
				 * bytes. This must be the last field in the
				 * structure. */
} ChannelBuffer;

#define CHANNELBUFFER_HEADER_SIZE	TclOffset(ChannelBuffer, buf)

/*
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
 * specific) instance data, and at a channel type structure.
 */

typedef struct ChannelState {
    char *channelName;		/* The name of the channel instance in Tcl
				 * commands. Storage is owned by the generic
				 * IO code, is dynamically allocated. */
    int	flags;			/* ORed combination of the flags defined
				 * below. */
    Tcl_Encoding encoding;	/* Encoding to apply when reading or writing
				 * data on this channel. NULL means no
				 * encoding is applied to data. */
    Tcl_EncodingState inputEncodingState;
				/* Current encoding state, used when
				 * converting input data bytes to UTF-8. */







|







125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
 * specific) instance data, and at a channel type structure.
 */

typedef struct ChannelState {
    char *channelName;		/* The name of the channel instance in Tcl
				 * commands. Storage is owned by the generic
				 * IO code, is dynamically allocated. */
    int	flags;			/* OR'ed combination of the flags defined
				 * below. */
    Tcl_Encoding encoding;	/* Encoding to apply when reading or writing
				 * data on this channel. NULL means no
				 * encoding is applied to data. */
    Tcl_EncodingState inputEncodingState;
				/* Current encoding state, used when
				 * converting input data bytes to UTF-8. */
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
    Tcl_ThreadId managingThread;/* TIP #10: Id of the thread managing this
				 * stack of channels. */

    /*
     * TIP #219 ... Info for the I/O system ...
     * Error message set by channel drivers, for the propagation of arbitrary
     * Tcl errors. This information, if present (chanMsg not NULL), takes
     * precedence over a posix error code returned by a channel operation.
     */

    Tcl_Obj* chanMsg;
    Tcl_Obj* unreportedMsg;     /* Non-NULL if an error report was deferred
				 * because it happened in the background. The
				 * value is the chanMg, if any. #219's
				 * companion to 'unreportedError'. */
    int epoch;			/* Used to test validity of stored channelname
				 * lookup results. */
} ChannelState;

/*
 * Values for the flags field in Channel. Any ORed combination of the
 * following flags can be stored in the field. These flags record various
 * options and state bits about the channel. In addition to the flags below,
 * the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set.
 */

#define CHANNEL_NONBLOCKING	(1<<3)	/* Channel is currently in nonblocking
					 * mode. */







|












|







205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
    Tcl_ThreadId managingThread;/* TIP #10: Id of the thread managing this
				 * stack of channels. */

    /*
     * TIP #219 ... Info for the I/O system ...
     * Error message set by channel drivers, for the propagation of arbitrary
     * Tcl errors. This information, if present (chanMsg not NULL), takes
     * precedence over a Posix error code returned by a channel operation.
     */

    Tcl_Obj* chanMsg;
    Tcl_Obj* unreportedMsg;     /* Non-NULL if an error report was deferred
				 * because it happened in the background. The
				 * value is the chanMg, if any. #219's
				 * companion to 'unreportedError'. */
    int epoch;			/* Used to test validity of stored channelname
				 * lookup results. */
} ChannelState;

/*
 * Values for the flags field in Channel. Any OR'ed combination of the
 * following flags can be stored in the field. These flags record various
 * options and state bits about the channel. In addition to the flags below,
 * the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set.
 */

#define CHANNEL_NONBLOCKING	(1<<3)	/* Channel is currently in nonblocking
					 * mode. */

Changes to generic/tclIOCmd.c.

1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
 *	the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Sets interp's result to boolean true or false depending on whether the
 *	preceeding input operation on the channel would have blocked.
 *
 *---------------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_FblockedObjCmd(







|







1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
 *	the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Sets interp's result to boolean true or false depending on whether the
 *	preceding input operation on the channel would have blocked.
 *
 *---------------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_FblockedObjCmd(

Changes to generic/tclIOGT.c.

402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
    }

    Tcl_IncrRefCount(command);
    Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, -1));

    /*
     * Use a byte-array to prevent the misinterpretation of binary data coming
     * through as UTF while at the tcl level.
     */

    Tcl_ListObjAppendElement(NULL, command, Tcl_NewByteArrayObj(buf, bufLen));

    /*
     * Step 2, execute the command at the global level of the interpreter used
     * to create the transformation. Destroy the command afterward. If an
     * error occured and the current interpreter is defined and not equal to
     * the interpreter for the callback, then copy the error message into
     * current interpreter. Don't copy if in preservation mode.
     */

    res = Tcl_EvalObjEx(eval, command, TCL_EVAL_GLOBAL);
    Tcl_DecrRefCount(command);
    command = NULL;







|







|







402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
    }

    Tcl_IncrRefCount(command);
    Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, -1));

    /*
     * Use a byte-array to prevent the misinterpretation of binary data coming
     * through as Utf while at the tcl level.
     */

    Tcl_ListObjAppendElement(NULL, command, Tcl_NewByteArrayObj(buf, bufLen));

    /*
     * Step 2, execute the command at the global level of the interpreter used
     * to create the transformation. Destroy the command afterward. If an
     * error occurred and the current interpreter is defined and not equal to
     * the interpreter for the callback, then copy the error message into
     * current interpreter. Don't copy if in preservation mode.
     */

    res = Tcl_EvalObjEx(eval, command, TCL_EVAL_GLOBAL);
    Tcl_DecrRefCount(command);
    command = NULL;
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
	dataPtr->timer = NULL;
    }

    /*
     * Now flush data waiting in internal buffers to output and input. The
     * input must be done despite the fact that there is no real receiver for
     * it anymore. But the scripts might have sideeffects other parts of the
     * system rely on (f.e. signaling the close to interested parties).
     */

    PreserveData(dataPtr);
    if (dataPtr->mode & TCL_WRITABLE) {
	ExecuteCallback(dataPtr, interp, A_FLUSH_WRITE, NULL, 0,
		TRANSMIT_DOWN, P_PRESERVE);
    }







|







556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
	dataPtr->timer = NULL;
    }

    /*
     * Now flush data waiting in internal buffers to output and input. The
     * input must be done despite the fact that there is no real receiver for
     * it anymore. But the scripts might have sideeffects other parts of the
     * system rely on (f.e. signalling the close to interested parties).
     */

    PreserveData(dataPtr);
    if (dataPtr->mode & TCL_WRITABLE) {
	ExecuteCallback(dataPtr, interp, A_FLUSH_WRITE, NULL, 0,
		TRANSMIT_DOWN, P_PRESERVE);
    }
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
    ClientData instanceData,	/* Channel to watch. */
    int mask)			/* Events of interest. */
{
    TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
    Tcl_Channel downChan;

    /*
     * The caller expressed interest in events occuring for this channel. We
     * are forwarding the call to the underlying channel now.
     */

    dataPtr->watchMask = mask;

    /*
     * No channel handlers any more. We will be notified automatically about







|







1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
    ClientData instanceData,	/* Channel to watch. */
    int mask)			/* Events of interest. */
{
    TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
    Tcl_Channel downChan;

    /*
     * The caller expressed interest in events occurring for this channel. We
     * are forwarding the call to the underlying channel now.
     */

    dataPtr->watchMask = mask;

    /*
     * No channel handlers any more. We will be notified automatically about
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
 *----------------------------------------------------------------------
 */

static int
TransformNotifyProc(
    ClientData clientData,	/* The state of the notified
				 * transformation. */
    int mask)			/* The mask of occuring events. */
{
    TransformChannelData *dataPtr = (TransformChannelData *)clientData;

    /*
     * An event occured in the underlying channel. This transformation doesn't
     * process such events thus returns the incoming mask unchanged.
     */

    if (dataPtr->timer != NULL) {
	/*
	 * Delete an existing timer. It was not fired, yet we are here, so the
	 * channel below generated such an event and we don't have to. The







|




|







1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
 *----------------------------------------------------------------------
 */

static int
TransformNotifyProc(
    ClientData clientData,	/* The state of the notified
				 * transformation. */
    int mask)			/* The mask of occurring events. */
{
    TransformChannelData *dataPtr = (TransformChannelData *)clientData;

    /*
     * An event occurred in the underlying channel. This transformation doesn't
     * process such events thus returns the incoming mask unchanged.
     */

    if (dataPtr->timer != NULL) {
	/*
	 * Delete an existing timer. It was not fired, yet we are here, so the
	 * channel below generated such an event and we don't have to. The
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309

/*
 *----------------------------------------------------------------------
 *
 * ResultInit --
 *
 *	Initializes the specified buffer structure. The structure will contain
 *	valid information for an emtpy buffer.
 *
 * Side effects:
 *	See above.
 *
 * Result:
 *	None.
 *







|







1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309

/*
 *----------------------------------------------------------------------
 *
 * ResultInit --
 *
 *	Initializes the specified buffer structure. The structure will contain
 *	valid information for an empty buffer.
 *
 * Side effects:
 *	See above.
 *
 * Result:
 *	None.
 *

Changes to generic/tclIORChan.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/*
 * tclIORChan.c --
 *
 *	This file contains the implementation of Tcl's generic channel
 *	reflection code, which allows the implementation of Tcl channels in
 *	Tcl code.
 *
 *	Parts of this file are based on code contributed by Jean-Claude
 *	Wippler.
 *
 *	See TIP #219 for the specification of this functionality.
 *
 * Copyright (c) 2004-2005 ActiveState, a divison of Sophos
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include "tclIO.h"












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/*
 * tclIORChan.c --
 *
 *	This file contains the implementation of Tcl's generic channel
 *	reflection code, which allows the implementation of Tcl channels in
 *	Tcl code.
 *
 *	Parts of this file are based on code contributed by Jean-Claude
 *	Wippler.
 *
 *	See TIP #219 for the specification of this functionality.
 *
 * Copyright (c) 2004-2005 ActiveState, a division of Sophos
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include "tclIO.h"
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
    /*
     * Note regarding the usage of timers.
     *
     * Most channel implementations need a timer in the C level to ensure that
     * data in buffers is flushed out through the generation of fake file
     * events.
     *
     * See 'rechan', 'memchan', etc.
     *
     * Here this is _not_ required. Interest in events is posted to the Tcl
     * level via 'watch'. And posting of events is possible from the Tcl level
     * as well, via 'chan postevent'. This means that the generation of all
     * events, fake or not, timer based or not, is completely in the hands of
     * the Tcl level. Therefore no timer here.
     */
} ReflectedChannel;

/*
 * Structure of the table maping from channel handles to reflected
 * channels. Each interpreter which has the handler command for one or more
 * reflected channels records them in such a table, so that 'chan postevent'
 * is able to find them even if the actual channel was moved to a different
 * interpreter and/or thread.
 *
 * The table is reachable via the standard interpreter AssocData, the key is
 * defined below.







|










|







116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
    /*
     * Note regarding the usage of timers.
     *
     * Most channel implementations need a timer in the C level to ensure that
     * data in buffers is flushed out through the generation of fake file
     * events.
     *
     * See 'refchan', 'memchan', etc.
     *
     * Here this is _not_ required. Interest in events is posted to the Tcl
     * level via 'watch'. And posting of events is possible from the Tcl level
     * as well, via 'chan postevent'. This means that the generation of all
     * events, fake or not, timer based or not, is completely in the hands of
     * the Tcl level. Therefore no timer here.
     */
} ReflectedChannel;

/*
 * Structure of the table mapping from channel handles to reflected
 * channels. Each interpreter which has the handler command for one or more
 * reflected channels records them in such a table, so that 'chan postevent'
 * is able to find them even if the actual channel was moved to a different
 * interpreter and/or thread.
 *
 * The table is reachable via the standard interpreter AssocData, the key is
 * defined below.
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
     * (2) Is the post event issued from the interpreter holding the handler
     *     of the reflected channel?
     *
     * A successful search answers yes to both. Because the map holds only
     * handles of reflected channels, and only of such whose handler is
     * defined in this interpreter.
     *
     * We keep the old checks for both, for paranioa, but abort now instead of
     * throwing errors, as failure now means that our internal datastructures
     * have gone seriously haywire.
     */

    chan = (Tcl_Channel)Tcl_GetHashValue(hPtr);
    chanTypePtr = Tcl_GetChannelType(chan);

    /*







|
|







866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
     * (2) Is the post event issued from the interpreter holding the handler
     *     of the reflected channel?
     *
     * A successful search answers yes to both. Because the map holds only
     * handles of reflected channels, and only of such whose handler is
     * defined in this interpreter.
     *
     * We keep the old checks for both, for paranoia, but abort now instead of
     * throwing errors, as failure now means that our internal data structures
     * have gone seriously haywire.
     */

    chan = (Tcl_Channel)Tcl_GetHashValue(hPtr);
    chanTypePtr = Tcl_GetChannelType(chan);

    /*
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027

    /*
     * Process the caught message.
     *
     * Syntax = (option value)... ?message?
     *
     * Bad syntax causes a panic. This is OK because the other side uses
     * Tcl_GetReturnOptions and list construction functions to marshall the
     * information; if we panic here, something has gone badly wrong already.
     */

    if (TclListObjGetElements(interp, msgObj, &lc, &lv) != TCL_OK) {
	Tcl_Panic("TclChanCaughtErrorBypass: Bad syntax of caught result");
    }
    if (interp == NULL) {







|







1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027

    /*
     * Process the caught message.
     *
     * Syntax = (option value)... ?message?
     *
     * Bad syntax causes a panic. This is OK because the other side uses
     * Tcl_GetReturnOptions and list construction functions to marshal the
     * information; if we panic here, something has gone badly wrong already.
     */

    if (TclListObjGetElements(interp, msgObj, &lc, &lv) != TCL_OK) {
	Tcl_Panic("TclChanCaughtErrorBypass: Bad syntax of caught result");
    }
    if (interp == NULL) {
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
 *
 * ReflectClose/ReflectClose2 --
 *
 *	This function is invoked when the channel is closed, to delete the
 *	driver specific instance data.
 *
 * Results:
 *	A posix error.
 *
 * Side effects:
 *	Releases memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */








|







1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
 *
 * ReflectClose/ReflectClose2 --
 *
 *	This function is invoked when the channel is closed, to delete the
 *	driver specific instance data.
 *
 * Results:
 *	A Posix error.
 *
 * Side effects:
 *	Releases memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
 *
 * ReflectBlock --
 *
 *	This function is invoked to tell the channel which blocking behaviour
 *	is required of it.
 *
 * Results:
 *	A posix error number.
 *
 * Side effects:
 *	Allocates memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */








|







1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
 *
 * ReflectBlock --
 *
 *	This function is invoked to tell the channel which blocking behaviour
 *	is required of it.
 *
 * Results:
 *	A Posix error number.
 *
 * Side effects:
 *	Allocates memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
 *	reflected channel.
 *
 * Results:
 *	A Tcl_Obj containing the string of the new channel handle. The
 *	refcount of the returned object is -- zero --.
 *
 * Side effects:
 *	May allocate memory. Mutex protected critical section locks out other
 *	threads for a short time.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
NextHandle(void)







|







2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
 *	reflected channel.
 *
 * Results:
 *	A Tcl_Obj containing the string of the new channel handle. The
 *	refcount of the returned object is -- zero --.
 *
 * Side effects:
 *	May allocate memory. Mutex-protected critical section locks out other
 *	threads for a short time.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
NextHandle(void)
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243

/*
 *----------------------------------------------------------------------
 *
 * InvokeTclMethod --
 *
 *	This function is used to invoke the Tcl level of a reflected channel.
 *	It handles all the command assembly, invokation, and generic state and
 *	result mgmt. It does *not* handle thread redirection; that is the
 *	responsibility of clients of this function.
 *
 * Results:
 *	Result code and data as returned by the method.
 *
 * Side effects:







|







2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243

/*
 *----------------------------------------------------------------------
 *
 * InvokeTclMethod --
 *
 *	This function is used to invoke the Tcl level of a reflected channel.
 *	It handles all the command assembly, invocation, and generic state and
 *	result mgmt. It does *not* handle thread redirection; that is the
 *	responsibility of clients of this function.
 *
 * Results:
 *	Result code and data as returned by the method.
 *
 * Side effects:
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
    MethodName method,
    Tcl_Obj *argOneObj,		/* NULL'able */
    Tcl_Obj *argTwoObj,		/* NULL'able */
    Tcl_Obj **resultObjPtr)	/* NULL'able */
{
    Tcl_Obj *methObj = NULL;	/* Method name in object form */
    Tcl_InterpState sr;		/* State of handler interp */
    int result;			/* Result code of method invokation */
    Tcl_Obj *resObj = NULL;	/* Result of method invokation. */
    Tcl_Obj *cmd;

    if (rcPtr->dead) {
	/*
	 * The channel is marked as dead. Bail out immediately, with an
	 * appropriate error.
	 */







|
|







2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
    MethodName method,
    Tcl_Obj *argOneObj,		/* NULL'able */
    Tcl_Obj *argTwoObj,		/* NULL'able */
    Tcl_Obj **resultObjPtr)	/* NULL'able */
{
    Tcl_Obj *methObj = NULL;	/* Method name in object form */
    Tcl_InterpState sr;		/* State of handler interp */
    int result;			/* Result code of method invocation */
    Tcl_Obj *resObj = NULL;	/* Result of method invocation. */
    Tcl_Obj *cmd;

    if (rcPtr->dead) {
	/*
	 * The channel is marked as dead. Bail out immediately, with an
	 * appropriate error.
	 */
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
 *	an interpreter is deleted, via the AssocData cleanup mechanism.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deletes the hash table of channels. May close channels. May flush
 *	output on closed channels. Removes any channeEvent handlers that were
 *	registered in this interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
MarkDead(







|







2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
 *	an interpreter is deleted, via the AssocData cleanup mechanism.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deletes the hash table of channels. May close channels. May flush
 *	output on closed channels. Removes any channelEvent handlers that were
 *	registered in this interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
MarkDead(

Changes to generic/tclIORTrans.c.

635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
                Tcl_GetString(cmdObj)));
	goto error;
    }

    /*
     * Mode tell us what the parent channel supports. The methods tell us what
     * the handler supports. We remove the non-supported bits from the mode
     * and check that the channel is not completely inacessible. Afterward the
     * mode tells us which methods are still required, and these methods will
     * also be supported by the handler, by design of the check.
     */

    if (!HAS(methods, METH_READ)) {
	mode &= ~TCL_READABLE;
    }







|







635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
                Tcl_GetString(cmdObj)));
	goto error;
    }

    /*
     * Mode tell us what the parent channel supports. The methods tell us what
     * the handler supports. We remove the non-supported bits from the mode
     * and check that the channel is not completely inaccessible. Afterward the
     * mode tells us which methods are still required, and these methods will
     * also be supported by the handler, by design of the check.
     */

    if (!HAS(methods, METH_READ)) {
	mode &= ~TCL_READABLE;
    }
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
 *
 * ReflectClose --
 *
 *	This function is invoked when the channel is closed, to delete the
 *	driver specific instance data.
 *
 * Results:
 *	A posix error.
 *
 * Side effects:
 *	Releases memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */








|







868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
 *
 * ReflectClose --
 *
 *	This function is invoked when the channel is closed, to delete the
 *	driver specific instance data.
 *
 * Results:
 *	A Posix error.
 *
 * Side effects:
 *	Releases memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
	    return EINVAL;
	}
	return EOK;
    }
#endif /* TCL_THREADS */

    /*
     * Do the actual invokation of "finalize" now; we're in the right thread.
     */

    result = InvokeTclMethod(rtPtr, "finalize", NULL, NULL, &resObj);
    if ((result != TCL_OK) && (interp != NULL)) {
	Tcl_SetChannelErrorInterp(interp, resObj);
    }








|







982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
	    return EINVAL;
	}
	return EOK;
    }
#endif /* TCL_THREADS */

    /*
     * Do the actual invocation of "finalize" now; we're in the right thread.
     */

    result = InvokeTclMethod(rtPtr, "finalize", NULL, NULL, &resObj);
    if ((result != TCL_OK) && (interp != NULL)) {
	Tcl_SetChannelErrorInterp(interp, resObj);
    }

1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
 *
 * ReflectBlock --
 *
 *	This function is invoked to tell the channel which blocking behaviour
 *	is required of it.
 *
 * Results:
 *	A posix error number.
 *
 * Side effects:
 *	Allocates memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */








|







1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
 *
 * ReflectBlock --
 *
 *	This function is invoked to tell the channel which blocking behaviour
 *	is required of it.
 *
 * Results:
 *	A Posix error number.
 *
 * Side effects:
 *	Allocates memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
 *----------------------------------------------------------------------
 */

static int
ReflectGetOption(
    ClientData clientData,	/* Channel to query */
    Tcl_Interp *interp,		/* Interpreter to leave error messages in */
    const char *optionName,	/* Name of reuqested option */
    Tcl_DString *dsPtr)		/* String to place the result into */
{
    ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;

    /*
     * Transformations have no options. Thus the call is passed down unchanged
     * to the parent channel for processing. Its results are passed back







|







1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
 *----------------------------------------------------------------------
 */

static int
ReflectGetOption(
    ClientData clientData,	/* Channel to query */
    Tcl_Interp *interp,		/* Interpreter to leave error messages in */
    const char *optionName,	/* Name of requested option */
    Tcl_DString *dsPtr)		/* String to place the result into */
{
    ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;

    /*
     * Transformations have no options. Thus the call is passed down unchanged
     * to the parent channel for processing. Its results are passed back
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
    int direction,
    ClientData *handlePtr)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;

    /*
     * Transformations have no handle of their own. As such we simply query
     * the parent channel for it. This way the qery will ripple down through
     * all transformations until reaches the base channel. Which then returns
     * its handle, or fails. The former will then ripple up the stack.
     *
     * This all happens in the thread we are in. As the Tcl level is not
     * involved no forwarding is required.
     */








|







1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
    int direction,
    ClientData *handlePtr)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;

    /*
     * Transformations have no handle of their own. As such we simply query
     * the parent channel for it. This way the query will ripple down through
     * all transformations until reaches the base channel. Which then returns
     * its handle, or fails. The former will then ripple up the stack.
     *
     * This all happens in the thread we are in. As the Tcl level is not
     * involved no forwarding is required.
     */

1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
ReflectNotify(
    ClientData clientData,
    int mask)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;

    /*
     * An event occured in the underlying channel.
     *
     * We delete our timer. It was not fired, yet we are here, so the channel
     * below generated such an event and we don't have to. The renewal of the
     * interest after the execution of channel handlers will eventually cause
     * us to recreate the timer (in ReflectWatch).
     */








|







1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
ReflectNotify(
    ClientData clientData,
    int mask)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;

    /*
     * An event occurred in the underlying channel.
     *
     * We delete our timer. It was not fired, yet we are here, so the channel
     * below generated such an event and we don't have to. The renewal of the
     * interest after the execution of channel handlers will eventually cause
     * us to recreate the timer (in ReflectWatch).
     */

1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947

/*
 *----------------------------------------------------------------------
 *
 * InvokeTclMethod --
 *
 *	This function is used to invoke the Tcl level of a reflected channel.
 *	It handles all the command assembly, invokation, and generic state and
 *	result mgmt. It does *not* handle thread redirection; that is the
 *	responsibility of clients of this function.
 *
 * Results:
 *	Result code and data as returned by the method.
 *
 * Side effects:







|







1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947

/*
 *----------------------------------------------------------------------
 *
 * InvokeTclMethod --
 *
 *	This function is used to invoke the Tcl level of a reflected channel.
 *	It handles all the command assembly, invocation, and generic state and
 *	result mgmt. It does *not* handle thread redirection; that is the
 *	responsibility of clients of this function.
 *
 * Results:
 *	Result code and data as returned by the method.
 *
 * Side effects:
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
    Tcl_Obj *argOneObj,		/* NULL'able */
    Tcl_Obj *argTwoObj,		/* NULL'able */
    Tcl_Obj **resultObjPtr)	/* NULL'able */
{
    int cmdc;			/* #words in constructed command */
    Tcl_Obj *methObj = NULL;	/* Method name in object form */
    Tcl_InterpState sr;		/* State of handler interp */
    int result;			/* Result code of method invokation */
    Tcl_Obj *resObj = NULL;	/* Result of method invokation. */

    if (rtPtr->dead) {
	/*
	 * The transform is marked as dead. Bail out immediately, with an
	 * appropriate error.
	 */








|
|







1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
    Tcl_Obj *argOneObj,		/* NULL'able */
    Tcl_Obj *argTwoObj,		/* NULL'able */
    Tcl_Obj **resultObjPtr)	/* NULL'able */
{
    int cmdc;			/* #words in constructed command */
    Tcl_Obj *methObj = NULL;	/* Method name in object form */
    Tcl_InterpState sr;		/* State of handler interp */
    int result;			/* Result code of method invocation */
    Tcl_Obj *resObj = NULL;	/* Result of method invocation. */

    if (rtPtr->dead) {
	/*
	 * The transform is marked as dead. Bail out immediately, with an
	 * appropriate error.
	 */

1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
     * NOTE (5): Decide impl. issue: Cache objects with method names?
     * Requires TSD data as reflections can be created in many different
     * threads.
     * NO: Caching of command resolutions means storage per channel.
     */

    /*
     * Insert method into the pre-allocated area, after the command prefix,
     * before the channel id.
     */

    methObj = Tcl_NewStringObj(method, -1);
    Tcl_IncrRefCount(methObj);
    rtPtr->argv[rtPtr->argc - 2] = methObj;








|







1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
     * NOTE (5): Decide impl. issue: Cache objects with method names?
     * Requires TSD data as reflections can be created in many different
     * threads.
     * NO: Caching of command resolutions means storage per channel.
     */

    /*
     * Insert method into the preallocated area, after the command prefix,
     * before the channel id.
     */

    methObj = Tcl_NewStringObj(method, -1);
    Tcl_IncrRefCount(methObj);
    rtPtr->argv[rtPtr->argc - 2] = methObj;

2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
	if (argTwoObj) {
	    rtPtr->argv[cmdc] = argTwoObj;
	    cmdc++;
	}
    }

    /*
     * And run the handler... This is done in auch a manner which leaves any
     * existing state intact.
     */

    sr = Tcl_SaveInterpState(rtPtr->interp, 0 /* Dummy */);
    Tcl_Preserve(rtPtr);
    Tcl_Preserve(rtPtr->interp);
    result = Tcl_EvalObjv(rtPtr->interp, cmdc, rtPtr->argv, TCL_EVAL_GLOBAL);







|







2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
	if (argTwoObj) {
	    rtPtr->argv[cmdc] = argTwoObj;
	    cmdc++;
	}
    }

    /*
     * And run the handler... This is done in a manner which leaves any
     * existing state intact.
     */

    sr = Tcl_SaveInterpState(rtPtr->interp, 0 /* Dummy */);
    Tcl_Preserve(rtPtr);
    Tcl_Preserve(rtPtr->interp);
    result = Tcl_EvalObjv(rtPtr->interp, cmdc, rtPtr->argv, TCL_EVAL_GLOBAL);
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933

/*
 *----------------------------------------------------------------------
 *
 * ResultInit --
 *
 *	Initializes the specified buffer structure. The structure will contain
 *	valid information for an emtpy buffer.
 *
 * Side effects:
 *	See above.
 *
 * Result:
 *	None.
 *







|







2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933

/*
 *----------------------------------------------------------------------
 *
 * ResultInit --
 *
 *	Initializes the specified buffer structure. The structure will contain
 *	valid information for an empty buffer.
 *
 * Side effects:
 *	See above.
 *
 * Result:
 *	None.
 *

Changes to generic/tclIOUtil.c.

308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
	}

#   undef OUT_OF_RANGE
#   undef OUT_OF_URANGE
#endif /* !TCL_WIDE_INT_IS_LONG */

	/*
	 * Copy across all supported fields, with possible type coercions on
	 * those fields that change between the normal and lf64 versions of
	 * the stat structure (on Solaris at least). This is slow when the
	 * structure sizes coincide, but that's what you get for using an
	 * obsolete interface.
	 */

	oldStyleBuf->st_mode	= buf.st_mode;







|







308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
	}

#   undef OUT_OF_RANGE
#   undef OUT_OF_URANGE
#endif /* !TCL_WIDE_INT_IS_LONG */

	/*
	 * Copy across all supported fields, with possible type coercion on
	 * those fields that change between the normal and lf64 versions of
	 * the stat structure (on Solaris at least). This is slow when the
	 * structure sizes coincide, but that's what you get for using an
	 * obsolete interface.
	 */

	oldStyleBuf->st_mode	= buf.st_mode;
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
 *
 * TclFSCwdPointerEquals --
 *
 *	Check whether the current working directory is equal to the path
 *	given.
 *
 * Results:
 *	1 (equal) or 0 (un-equal) as appropriate.
 *
 * Side effects:
 *	If the paths are equal, but are not the same object, this method will
 *	modify the given pathPtrPtr to refer to the same object. In this case
 *	the object pointed to by pathPtrPtr will have its refCount
 *	decremented, and it will be adjusted to point to the cwd (with a new
 *	refCount).







|







481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
 *
 * TclFSCwdPointerEquals --
 *
 *	Check whether the current working directory is equal to the path
 *	given.
 *
 * Results:
 *	1 (equal) or 0 (unequal) as appropriate.
 *
 * Side effects:
 *	If the paths are equal, but are not the same object, this method will
 *	modify the given pathPtrPtr to refer to the same object. In this case
 *	the object pointed to by pathPtrPtr will have its refCount
 *	decremented, and it will be adjusted to point to the cwd (with a new
 *	refCount).
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
 *
 * Side effects:
 *	None (beyond the memory allocation for the result).
 *
 * Special notes:
 *	If the filesystem-specific normalizePathProcs can re-introduce ../, ./
 *	sequences into the path, then this function will not return the
 *	correct result. This may be possible with symbolic links on unix.
 *
 *	Important assumption: if startAt is non-zero, it must point to a
 *	directory separator that we know exists and is already normalized (so
 *	it is important not to point to the char just after the separator).
 *
 *---------------------------------------------------------------------------
 */

int
TclFSNormalizeToUniquePath(
    Tcl_Interp *interp,		/* Used for error messages. */
    Tcl_Obj *pathPtr,		/* The path to normalize in place. */
    int startAt)		/* Start at this char-offset. */
{
    FilesystemRecord *fsRecPtr, *firstFsRecPtr;

    /*
     * Call each of the "normalise path" functions in succession. This is a
     * special case, in which if we have a native filesystem handler, we call
     * it first. This is because the root of Tcl's filesystem is always a
     * native filesystem (i.e. '/' on unix is native).
     */

    firstFsRecPtr = FsGetFirstFilesystem();

    Claim();
    for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
	if (fsRecPtr->fsPtr != &tclNativeFilesystem) {







|




















|







1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
 *
 * Side effects:
 *	None (beyond the memory allocation for the result).
 *
 * Special notes:
 *	If the filesystem-specific normalizePathProcs can re-introduce ../, ./
 *	sequences into the path, then this function will not return the
 *	correct result. This may be possible with symbolic links on Unix.
 *
 *	Important assumption: if startAt is non-zero, it must point to a
 *	directory separator that we know exists and is already normalized (so
 *	it is important not to point to the char just after the separator).
 *
 *---------------------------------------------------------------------------
 */

int
TclFSNormalizeToUniquePath(
    Tcl_Interp *interp,		/* Used for error messages. */
    Tcl_Obj *pathPtr,		/* The path to normalize in place. */
    int startAt)		/* Start at this char-offset. */
{
    FilesystemRecord *fsRecPtr, *firstFsRecPtr;

    /*
     * Call each of the "normalise path" functions in succession. This is a
     * special case, in which if we have a native filesystem handler, we call
     * it first. This is because the root of Tcl's filesystem is always a
     * native filesystem (i.e. '/' on Unix is native).
     */

    firstFsRecPtr = FsGetFirstFilesystem();

    Claim();
    for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
	if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSStat --
 *
 *	This function replaces the library version of stat and lsat.
 *
 *	The appropriate function for the filesystem to which pathPtr belongs
 *	will be called.
 *
 * Results:
 *	See stat documentation.
 *







|







2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSStat --
 *
 *	This function replaces the library version of stat and lstat.
 *
 *	The appropriate function for the filesystem to which pathPtr belongs
 *	will be called.
 *
 * Results:
 *	See stat documentation.
 *
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780

	/*
	 * If the filesystem couldn't be found, or if no cwd function exists
	 * for this filesystem, then we simply assume the cached cwd is ok.
	 * If we do call a cwd, we must watch for errors (if the cwd returns
	 * NULL). This ensures that, say, on Unix if the permissions of the
	 * cwd change, 'pwd' does actually throw the correct error in Tcl.
	 * (This is tested for in the test suite on unix).
	 */

	if (fsPtr == NULL || fsPtr->getCwdProc == NULL) {
	    goto cdDidNotChange;
	}

	if (fsPtr->version == TCL_FILESYSTEM_VERSION_1) {







|







2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780

	/*
	 * If the filesystem couldn't be found, or if no cwd function exists
	 * for this filesystem, then we simply assume the cached cwd is ok.
	 * If we do call a cwd, we must watch for errors (if the cwd returns
	 * NULL). This ensures that, say, on Unix if the permissions of the
	 * cwd change, 'pwd' does actually throw the correct error in Tcl.
	 * (This is tested for in the test suite on Unix).
	 */

	if (fsPtr == NULL || fsPtr->getCwdProc == NULL) {
	    goto cdDidNotChange;
	}

	if (fsPtr->version == TCL_FILESYSTEM_VERSION_1) {
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
 * Tcl_FSSplitPath --
 *
 *	This function takes the given Tcl_Obj, which should be a valid path,
 *	and returns a Tcl List object containing each segment of that path as
 *	an element.
 *
 * Results:
 *	Returns list object with refCount of zero. If the passed in lenPtr is
 *	non-NULL, we use it to return the number of elements in the returned
 *	list.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------







|







3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
 * Tcl_FSSplitPath --
 *
 *	This function takes the given Tcl_Obj, which should be a valid path,
 *	and returns a Tcl List object containing each segment of that path as
 *	an element.
 *
 * Results:
 *	Returns list object with refCount of zero. If the passed-in lenPtr is
 *	non-NULL, we use it to return the number of elements in the returned
 *	list.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
    fsRecPtr = FsGetFirstFilesystem();
    Claim();
    while (fsRecPtr != NULL) {
	/*
	 * We want to skip the native filesystem in this loop because
	 * otherwise we won't necessarily pass all the Tcl testsuite - this is
	 * because some of the tests artificially change the current platform
	 * (between win, unix) but the list of volumes we get by calling
	 * fsRecPtr->fsPtr->listVolumesProc will reflect the current (real)
	 * platform only and this may cause some tests to fail. In particular,
	 * on Unix '/' will match the beginning of certain absolute Windows
	 * paths starting '//' and those tests will go wrong.
	 *
	 * Besides these test-suite issues, there is one other reason to skip
	 * the native filesystem - since the tclFilename.c code has nice fast







|







4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
    fsRecPtr = FsGetFirstFilesystem();
    Claim();
    while (fsRecPtr != NULL) {
	/*
	 * We want to skip the native filesystem in this loop because
	 * otherwise we won't necessarily pass all the Tcl testsuite - this is
	 * because some of the tests artificially change the current platform
	 * (between Win, Unix) but the list of volumes we get by calling
	 * fsRecPtr->fsPtr->listVolumesProc will reflect the current (real)
	 * platform only and this may cause some tests to fail. In particular,
	 * on Unix '/' will match the beginning of certain absolute Windows
	 * paths starting '//' and those tests will go wrong.
	 *
	 * Besides these test-suite issues, there is one other reason to skip
	 * the native filesystem - since the tclFilename.c code has nice fast

Changes to generic/tclIndexObj.c.

177
178
179
180
181
182
183
184
185
186
187
188
189
190
191

    int objc, result, t;
    Tcl_Obj **objv;
    const char **tablePtr;

    /*
     * Use Tcl_GetIndexFromObjStruct to do the work to avoid duplicating most
     * of the code there. This is a bit ineffiecient but simpler.
     */

    result = TclListObjGetElements(interp, tableObjPtr, &objc, &objv);
    if (result != TCL_OK) {
	return result;
    }








|







177
178
179
180
181
182
183
184
185
186
187
188
189
190
191

    int objc, result, t;
    Tcl_Obj **objv;
    const char **tablePtr;

    /*
     * Use Tcl_GetIndexFromObjStruct to do the work to avoid duplicating most
     * of the code there. This is a bit inefficient but simpler.
     */

    result = TclListObjGetElements(interp, tableObjPtr, &objc, &objv);
    if (result != TCL_OK) {
	return result;
    }

Changes to generic/tclInt.h.

191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
 *----------------------------------------------------------------
 */

typedef struct Tcl_Ensemble Tcl_Ensemble;
typedef struct NamespacePathEntry NamespacePathEntry;

/*
 * Special hashtable for variables: this is just a Tcl_HashTable with an nsPtr
 * field added at the end: in this way variables can find their namespace
 * without having to copy a pointer in their struct: they can access it via
 * their hPtr->tablePtr.
 */

typedef struct TclVarHashTable {
    Tcl_HashTable table;







|







191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
 *----------------------------------------------------------------
 */

typedef struct Tcl_Ensemble Tcl_Ensemble;
typedef struct NamespacePathEntry NamespacePathEntry;

/*
 * Special hash table for variables: this is just a Tcl_HashTable with an nsPtr
 * field added at the end: in this way variables can find their namespace
 * without having to copy a pointer in their struct: they can access it via
 * their hPtr->tablePtr.
 */

typedef struct TclVarHashTable {
    Tcl_HashTable table;
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
				 * pattern may include "string match" style
				 * wildcard characters to specify multiple
				 * commands; however, no namespace qualifiers
				 * are allowed. NULL if no export patterns are
				 * registered. */
    int numExportPatterns;	/* Number of export patterns currently
				 * registered using "namespace export". */
    int maxExportPatterns;	/* Mumber of export patterns for which space
				 * is currently allocated. */
    int cmdRefEpoch;		/* Incremented if a newly added command
				 * shadows a command for which this namespace
				 * has already cached a Command* pointer; this
				 * causes all its cached Command* pointers to
				 * be invalidated. */
    int resolverEpoch;		/* Incremented whenever (a) the name







|







281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
				 * pattern may include "string match" style
				 * wildcard characters to specify multiple
				 * commands; however, no namespace qualifiers
				 * are allowed. NULL if no export patterns are
				 * registered. */
    int numExportPatterns;	/* Number of export patterns currently
				 * registered using "namespace export". */
    int maxExportPatterns;	/* Number of export patterns for which space
				 * is currently allocated. */
    int cmdRefEpoch;		/* Incremented if a newly added command
				 * shadows a command for which this namespace
				 * has already cached a Command* pointer; this
				 * causes all its cached Command* pointers to
				 * be invalidated. */
    int resolverEpoch;		/* Incremented whenever (a) the name
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
    struct EnsembleConfig *next;/* The next ensemble in the linked list of
				 * ensembles associated with a namespace. If
				 * this field points to this ensemble, the
				 * structure has already been unlinked from
				 * all lists, and cannot be found by scanning
				 * the list from the namespace's ensemble
				 * field. */
    int flags;			/* ORed combo of TCL_ENSEMBLE_PREFIX,
				 * ENSEMBLE_DEAD and ENSEMBLE_COMPILE. */

    /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */

    Tcl_Obj *subcommandDict;	/* Dictionary providing mapping from
				 * subcommands to their implementing command
				 * prefixes, or NULL if we are to build the







|







442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
    struct EnsembleConfig *next;/* The next ensemble in the linked list of
				 * ensembles associated with a namespace. If
				 * this field points to this ensemble, the
				 * structure has already been unlinked from
				 * all lists, and cannot be found by scanning
				 * the list from the namespace's ensemble
				 * field. */
    int flags;			/* OR'ed combo of TCL_ENSEMBLE_PREFIX,
				 * ENSEMBLE_DEAD and ENSEMBLE_COMPILE. */

    /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */

    Tcl_Obj *subcommandDict;	/* Dictionary providing mapping from
				 * subcommands to their implementing command
				 * prefixes, or NULL if we are to build the
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
				 * NULL to use the default error-generating
				 * behaviour. The script execution gets all
				 * the arguments to the ensemble command
				 * (including objv[0]) and will have the
				 * results passed directly back to the caller
				 * (including the error code) unless the code
				 * is TCL_CONTINUE in which case the
				 * subcommand will be reparsed by the ensemble
				 * core, presumably because the ensemble
				 * itself has been updated. */
    Tcl_Obj *parameterList;	/* List of ensemble parameter names. */
    int numParameters;		/* Cached number of parameters. This is either
				 * 0 (if the parameterList field is NULL) or
				 * the length of the list in the parameterList
				 * field. */







|







469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
				 * NULL to use the default error-generating
				 * behaviour. The script execution gets all
				 * the arguments to the ensemble command
				 * (including objv[0]) and will have the
				 * results passed directly back to the caller
				 * (including the error code) unless the code
				 * is TCL_CONTINUE in which case the
				 * subcommand will be re-parsed by the ensemble
				 * core, presumably because the ensemble
				 * itself has been updated. */
    Tcl_Obj *parameterList;	/* List of ensemble parameter names. */
    int numParameters;		/* Cached number of parameters. This is either
				 * 0 (if the parameterList field is NULL) or
				 * the length of the list in the parameterList
				 * field. */
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
				 * trace active on variable, and 1 if the
				 * variable is a namespace variable. This
				 * record can't be deleted until refCount
				 * becomes 0. */
    Tcl_HashEntry entry;	/* The hash table entry that refers to this
				 * variable. This is used to find the name of
				 * the variable and to delete it from its
				 * hashtable if it is no longer needed. It
				 * also holds the variable's name. */
} VarInHash;

/*
 * Flag bits for variables. The first two (VAR_ARRAY and VAR_LINK) are
 * mutually exclusive and give the "type" of the variable. If none is set,
 * this is a scalar variable.
 *
 * VAR_ARRAY -			1 means this is an array variable rather than
 *				a scalar variable or link. The "tablePtr"
 *				field points to the array's hashtable for its
 *				elements.
 * VAR_LINK -			1 means this Var structure contains a pointer
 *				to another Var structure that either has the
 *				real value or is itself another VAR_LINK
 *				pointer. Variables like this come about
 *				through "upvar" and "global" commands, or
 *				through references to variables in enclosing
 *				namespaces.
 *
 * Flags that indicate the type and status of storage; none is set for
 * compiled local variables (Var structs).
 *
 * VAR_IN_HASHTABLE -		1 means this variable is in a hashtable and
 *				the Var structure is malloced. 0 if it is a
 *				local variable that was assigned a slot in a
 *				procedure frame by the compiler so the Var
 *				storage is part of the call frame.
 * VAR_DEAD_HASH		1 means that this var's entry in the hashtable
 *				has already been deleted.
 * VAR_ARRAY_ELEMENT -		1 means that this variable is an array
 *				element, so it is not legal for it to be an
 *				array itself (the VAR_ARRAY flag had better
 *				not be set).
 * VAR_NAMESPACE_VAR -		1 means that this variable was declared as a
 *				namespace variable. This flag ensures it







|










|












|
|



|







613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
				 * trace active on variable, and 1 if the
				 * variable is a namespace variable. This
				 * record can't be deleted until refCount
				 * becomes 0. */
    Tcl_HashEntry entry;	/* The hash table entry that refers to this
				 * variable. This is used to find the name of
				 * the variable and to delete it from its
				 * hash table if it is no longer needed. It
				 * also holds the variable's name. */
} VarInHash;

/*
 * Flag bits for variables. The first two (VAR_ARRAY and VAR_LINK) are
 * mutually exclusive and give the "type" of the variable. If none is set,
 * this is a scalar variable.
 *
 * VAR_ARRAY -			1 means this is an array variable rather than
 *				a scalar variable or link. The "tablePtr"
 *				field points to the array's hash table for its
 *				elements.
 * VAR_LINK -			1 means this Var structure contains a pointer
 *				to another Var structure that either has the
 *				real value or is itself another VAR_LINK
 *				pointer. Variables like this come about
 *				through "upvar" and "global" commands, or
 *				through references to variables in enclosing
 *				namespaces.
 *
 * Flags that indicate the type and status of storage; none is set for
 * compiled local variables (Var structs).
 *
 * VAR_IN_HASHTABLE -		1 means this variable is in a hash table and
 *				the Var structure is malloc'ed. 0 if it is a
 *				local variable that was assigned a slot in a
 *				procedure frame by the compiler so the Var
 *				storage is part of the call frame.
 * VAR_DEAD_HASH		1 means that this var's entry in the hash table
 *				has already been deleted.
 * VAR_ARRAY_ELEMENT -		1 means that this variable is an array
 *				element, so it is not legal for it to be an
 *				array itself (the VAR_ARRAY flag had better
 *				not be set).
 * VAR_NAMESPACE_VAR -		1 means that this variable was declared as a
 *				namespace variable. This flag ensures it
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
    int pc;			/* Instruction pointer of a command in
				 * ExtCmdLoc.loc[.] */
    int word;			/* Index of word in
				 * ExtCmdLoc.loc[cmd]->line[.] */
    struct CFWordBC *prevPtr;	/* Previous entry in stack for same Tcl_Obj. */
    struct CFWordBC *nextPtr;	/* Next entry for same command call. See
				 * CmdFrame litarg field for the list start. */
    Tcl_Obj *obj;		/* Back reference to hashtable key */
} CFWordBC;

/*
 * Structure to record the locations of invisible continuation lines in
 * literal scripts, as character offset from the beginning of the script. Both
 * compiler and direct evaluator use this information to adjust their line
 * counters when tracking through the script, because when it is invoked the
 * continuation line marker as a whole has been removed already, meaning that
 * the \n which was part of it is gone as well, breaking regular line
 * tracking.
 *
 * These structures are allocated and filled by both the function
 * TclSubstTokens() in the file "tclParse.c" and its caller TclEvalEx() in the
 * file "tclBasic.c", and stored in the thread-global hashtable "lineCLPtr" in
 * file "tclObj.c". They are used by the functions TclSetByteCodeFromAny() and
 * TclCompileScript(), both found in the file "tclCompile.c". Their memory is
 * released by the function TclFreeObj(), in the file "tclObj.c", and also by
 * the function TclThreadFinalizeObjects(), in the same file.
 */

#define CLL_END		(-1)







|













|







1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
    int pc;			/* Instruction pointer of a command in
				 * ExtCmdLoc.loc[.] */
    int word;			/* Index of word in
				 * ExtCmdLoc.loc[cmd]->line[.] */
    struct CFWordBC *prevPtr;	/* Previous entry in stack for same Tcl_Obj. */
    struct CFWordBC *nextPtr;	/* Next entry for same command call. See
				 * CmdFrame litarg field for the list start. */
    Tcl_Obj *obj;		/* Back reference to hash table key */
} CFWordBC;

/*
 * Structure to record the locations of invisible continuation lines in
 * literal scripts, as character offset from the beginning of the script. Both
 * compiler and direct evaluator use this information to adjust their line
 * counters when tracking through the script, because when it is invoked the
 * continuation line marker as a whole has been removed already, meaning that
 * the \n which was part of it is gone as well, breaking regular line
 * tracking.
 *
 * These structures are allocated and filled by both the function
 * TclSubstTokens() in the file "tclParse.c" and its caller TclEvalEx() in the
 * file "tclBasic.c", and stored in the thread-global hash table "lineCLPtr" in
 * file "tclObj.c". They are used by the functions TclSetByteCodeFromAny() and
 * TclCompileScript(), both found in the file "tclCompile.c". Their memory is
 * released by the function TclFreeObj(), in the file "tclObj.c", and also by
 * the function TclThreadFinalizeObjects(), in the same file.
 */

#define CLL_END		(-1)
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
				 * from its Tcl_Command handle. NULL means
				 * that the hash table entry has been removed
				 * already (this can happen if deleteProc
				 * causes the command to be deleted or
				 * recreated). */
    Namespace *nsPtr;		/* Points to the namespace containing this
				 * command. */
    int refCount;		/* 1 if in command hashtable plus 1 for each
				 * reference from a CmdName Tcl object
				 * representing a command's name in a ByteCode
				 * instruction sequence. This structure can be
				 * freed when refCount becomes zero. */
    int cmdEpoch;		/* Incremented to invalidate any references
				 * that point to this command when it is
				 * renamed, deleted, hidden, or exposed. */







|







1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
				 * from its Tcl_Command handle. NULL means
				 * that the hash table entry has been removed
				 * already (this can happen if deleteProc
				 * causes the command to be deleted or
				 * recreated). */
    Namespace *nsPtr;		/* Points to the namespace containing this
				 * command. */
    int refCount;		/* 1 if in command hash table plus 1 for each
				 * reference from a CmdName Tcl object
				 * representing a command's name in a ByteCode
				 * instruction sequence. This structure can be
				 * freed when refCount becomes zero. */
    int cmdEpoch;		/* Incremented to invalidate any references
				 * that point to this command when it is
				 * renamed, deleted, hidden, or exposed. */
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
 * Other externals.
 */

MODULE_SCOPE size_t TclEnvEpoch; /* Epoch of the tcl environment
                                         * (if changed with tcl-env). */

#endif /* _TCLINT */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







|







4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
 * Other externals.
 */

MODULE_SCOPE size_t TclEnvEpoch; /* Epoch of the tcl environment
                                         * (if changed with tcl-env). */

#endif /* _TCLINT */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclIntPlatDecls.h.

571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
#undef TclWinConvertWSAError
#define TclWinConvertWSAError TclWinConvertError
#undef TclpInetNtoa
#define TclpInetNtoa inet_ntoa

#undef TclpCreateTempFile_
#undef TclUnixWaitForFile_
#ifndef MAC_OSX_TCL /* not accessable on Win32/UNIX */
#undef TclMacOSXGetFileAttribute /* 15 */
#undef TclMacOSXSetFileAttribute /* 16 */
#undef TclMacOSXCopyFileAttributes /* 17 */
#undef TclMacOSXMatchType /* 18 */
#undef TclMacOSXNotifierAddRunLoopMode /* 19 */
#endif








|







571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
#undef TclWinConvertWSAError
#define TclWinConvertWSAError TclWinConvertError
#undef TclpInetNtoa
#define TclpInetNtoa inet_ntoa

#undef TclpCreateTempFile_
#undef TclUnixWaitForFile_
#ifndef MAC_OSX_TCL /* not accessible on Win32/UNIX */
#undef TclMacOSXGetFileAttribute /* 15 */
#undef TclMacOSXSetFileAttribute /* 16 */
#undef TclMacOSXCopyFileAttributes /* 17 */
#undef TclMacOSXMatchType /* 18 */
#undef TclMacOSXNotifierAddRunLoopMode /* 19 */
#endif

Changes to generic/tclInterp.c.

193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
				 * handlers. */
    LimitHandler *nextPtr;	/* Next item in linked list of handlers. */
};

/*
 * Values for the LimitHandler flags field.
 *      LIMIT_HANDLER_ACTIVE - Whether the handler is currently being
 *              processed; handlers are never to be entered reentrantly.
 *      LIMIT_HANDLER_DELETED - Whether the handler has been deleted. This
 *              should not normally be observed because when a handler is
 *              deleted it is also spliced out of the list of handlers, but
 *              even so we will be careful.
 */

#define LIMIT_HANDLER_ACTIVE    0x01







|







193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
				 * handlers. */
    LimitHandler *nextPtr;	/* Next item in linked list of handlers. */
};

/*
 * Values for the LimitHandler flags field.
 *      LIMIT_HANDLER_ACTIVE - Whether the handler is currently being
 *              processed; handlers are never to be reentered.
 *      LIMIT_HANDLER_DELETED - Whether the handler has been deleted. This
 *              should not normally be observed because when a handler is
 *              deleted it is also spliced out of the list of handlers, but
 *              even so we will be careful.
 */

#define LIMIT_HANDLER_ACTIVE    0x01
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231

    Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY);

    /*
     * Unset path informations variables (the only one remaining is [info
     * nameofexecutable])
     */

    Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);








|







3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231

    Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY);

    /*
     * Unset path information variables (the only one remaining is [info
     * nameofexecutable])
     */

    Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);

4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
 *	interpreter through this mechanism (though as many interpreters may be
 *	limited as the programmer chooses overall).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	A limit callback implemented as an invokation of a Tcl script in
 *	another interpreter is either installed or removed.
 *
 *----------------------------------------------------------------------
 */

static void
SetScriptLimitCallback(







|







4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
 *	interpreter through this mechanism (though as many interpreters may be
 *	limited as the programmer chooses overall).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	A limit callback implemented as an invocation of a Tcl script in
 *	another interpreter is either installed or removed.
 *
 *----------------------------------------------------------------------
 */

static void
SetScriptLimitCallback(

Changes to generic/tclLink.c.

372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
	}
	return NULL;
    }

    /*
     * For writes, first make sure that the variable is writable. Then convert
     * the Tcl value to C if possible. If the variable isn't writable or can't
     * be converted, then restore the varaible's old value and return an
     * error. Another tricky thing: we have to save and restore the interp's
     * result, since the variable access could occur when the result has been
     * partially set.
     */

    if (linkPtr->flags & LINK_READ_ONLY) {
	Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),







|







372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
	}
	return NULL;
    }

    /*
     * For writes, first make sure that the variable is writable. Then convert
     * the Tcl value to C if possible. If the variable isn't writable or can't
     * be converted, then restore the variable's old value and return an
     * error. Another tricky thing: we have to save and restore the interp's
     * result, since the variable access could occur when the result has been
     * partially set.
     */

    if (linkPtr->flags & LINK_READ_ONLY) {
	Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),

Changes to generic/tclListObj.c.

535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
 *	    converted to one. An error message will be left in the
 *	    interpreter's result if interp is not NULL.
 *
 * Effect
 *
 *	If 'listPtr' is not already of type 'tclListType', it is converted.
 *	The 'refCount' of 'objPtr' is incremented as it is added to 'listPtr'.
 *	Appending the new element may cause the the array of element pointers
 *	in 'listObj' to grow.  Any preexisting string representation of
 *	'listPtr' is invalidated.
 *
 *----------------------------------------------------------------------
 */

int







|







535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
 *	    converted to one. An error message will be left in the
 *	    interpreter's result if interp is not NULL.
 *
 * Effect
 *
 *	If 'listPtr' is not already of type 'tclListType', it is converted.
 *	The 'refCount' of 'objPtr' is incremented as it is added to 'listPtr'.
 *	Appending the new element may cause the array of element pointers
 *	in 'listObj' to grow.  Any preexisting string representation of
 *	'listPtr' is invalidated.
 *
 *----------------------------------------------------------------------
 */

int
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
 *	    'index' is out of range, NULL is stored in 'objPtrPtr'.  This
 *	    object should be treated as readonly and its 'refCount' is _not_
 *	    incremented. The caller must do that if it holds on to the
 *	    reference.
 *
 * 	TCL_ERROR
 *
 * 	    'listPtr' is not a valid list. An an error message is left in the
 * 	    interpreter's result if 'interp' is not NULL.
 *
 *  Effect
 *
 * 	If 'listPtr' is not already of type 'tclListType', it is converted.
 *
 *----------------------------------------------------------------------







|







703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
 *	    'index' is out of range, NULL is stored in 'objPtrPtr'.  This
 *	    object should be treated as readonly and its 'refCount' is _not_
 *	    incremented. The caller must do that if it holds on to the
 *	    reference.
 *
 * 	TCL_ERROR
 *
 * 	    'listPtr' is not a valid list. An error message is left in the
 * 	    interpreter's result if 'interp' is not NULL.
 *
 *  Effect
 *
 * 	If 'listPtr' is not already of type 'tclListType', it is converted.
 *
 *----------------------------------------------------------------------
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
	}
    }

    /*
     * Note that when count == 0 and objc == 0, this routine is logically a
     * no-op, removing and adding no elements to the list. However, by flowing
     * through this routine anyway, we get the important side effect that the
     * resulting listPtr is a list in canoncial form. This is important.
     * Resist any temptation to optimize this case.
     */

    listRepPtr = ListRepPtr(listPtr);
    elemPtrs = &listRepPtr->elements;
    numElems = listRepPtr->elemCount;








|







869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
	}
    }

    /*
     * Note that when count == 0 and objc == 0, this routine is logically a
     * no-op, removing and adding no elements to the list. However, by flowing
     * through this routine anyway, we get the important side effect that the
     * resulting listPtr is a list in canonical form. This is important.
     * Resist any temptation to optimize this case.
     */

    listRepPtr = ListRepPtr(listPtr);
    elemPtrs = &listRepPtr->elements;
    numElems = listRepPtr->elemCount;

1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
	 */

	return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);
    }
    TclListObjGetElements(NULL, indexArgPtr, &indexCount, &indices);

    /*
     * Let TclLsetFlat handle the actual lset'ting.
     */

    retValuePtr = TclLsetFlat(interp, listPtr, indexCount, indices, valuePtr);

    Tcl_DecrRefCount(indexListCopy);
    return retValuePtr;
}







|







1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
	 */

	return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);
    }
    TclListObjGetElements(NULL, indexArgPtr, &indexCount, &indices);

    /*
     * Let TclLsetFlat perform the actual lset operation.
     */

    retValuePtr = TclLsetFlat(interp, listPtr, indexCount, indices, valuePtr);

    Tcl_DecrRefCount(indexListCopy);
    return retValuePtr;
}
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfList --
 *
 *	Update the string representation for a list object.
 *
 *	Any previously-exising string representation is not invalidated, so
 *	storage is lost if this has not been taken care of.
 *
 * Effect
 *
 *	The string representation of 'listPtr' is set to the resulting string.
 *	This string will be empty if the list has no elements. It is assumed
 *	that the list internal representation is not NULL.







|







1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfList --
 *
 *	Update the string representation for a list object.
 *
 *	Any previously-existing string representation is not invalidated, so
 *	storage is lost if this has not been taken care of.
 *
 * Effect
 *
 *	The string representation of 'listPtr' is set to the resulting string.
 *	This string will be empty if the list has no elements. It is assumed
 *	that the list internal representation is not NULL.

Changes to generic/tclLiteral.c.

386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
				 * array. */
    int length,			/* Number of bytes in the string. If < 0, the
				 * string consists of all bytes up to the
				 * first null character. */
    int flags)			/* If LITERAL_ON_HEAP then the caller already
				 * malloc'd bytes and ownership is passed to
				 * this function. If LITERAL_CMD_NAME then
				 * the literal should not be shared accross
				 * namespaces. */
{
    CompileEnv *envPtr = ePtr;
    Interp *iPtr = envPtr->iPtr;
    LiteralTable *localTablePtr = &envPtr->localLitTable;
    LiteralEntry *globalPtr, *localPtr;
    Tcl_Obj *objPtr;







|







386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
				 * array. */
    int length,			/* Number of bytes in the string. If < 0, the
				 * string consists of all bytes up to the
				 * first null character. */
    int flags)			/* If LITERAL_ON_HEAP then the caller already
				 * malloc'd bytes and ownership is passed to
				 * this function. If LITERAL_CMD_NAME then
				 * the literal should not be shared across
				 * namespaces. */
{
    CompileEnv *envPtr = ePtr;
    Interp *iPtr = envPtr->iPtr;
    LiteralTable *localTablePtr = &envPtr->localLitTable;
    LiteralEntry *globalPtr, *localPtr;
    Tcl_Obj *objPtr;
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443

	    return objIndex;
	}
    }

    /*
     * The literal is new to this CompileEnv. If it is a command name, avoid
     * sharing it accross namespaces, and try not to share it with non-cmd
     * literals. Note that FQ command names can be shared, so that we register
     * the namespace as the interp's global NS.
     */

    if ((flags & LITERAL_CMD_NAME)) {
	if ((length >= 2) && (bytes[0] == ':') && (bytes[1] == ':')) {
	    nsPtr = iPtr->globalNsPtr;







|







429
430
431
432
433
434
435
436
437
438
439
440
441
442
443

	    return objIndex;
	}
    }

    /*
     * The literal is new to this CompileEnv. If it is a command name, avoid
     * sharing it across namespaces, and try not to share it with non-cmd
     * literals. Note that FQ command names can be shared, so that we register
     * the namespace as the interp's global NS.
     */

    if ((flags & LITERAL_CMD_NAME)) {
	if ((length >= 2) && (bytes[0] == ':') && (bytes[1] == ':')) {
	    nsPtr = iPtr->globalNsPtr;

Changes to generic/tclLoad.c.

1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025

/*
 *----------------------------------------------------------------------
 *
 * TclGetLoadedPackages --
 *
 *	This function returns information about all of the files that are
 *	loaded (either in a particular intepreter, or for all interpreters).
 *
 * Results:
 *	The return value is a standard Tcl completion code. If successful, a
 *	list of lists is placed in the interp's result. Each sublist
 *	corresponds to one loaded file; its first element is the name of the
 *	file (or an empty string for something that's statically loaded) and
 *	the second element is the name of the package in that file.







|







1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025

/*
 *----------------------------------------------------------------------
 *
 * TclGetLoadedPackages --
 *
 *	This function returns information about all of the files that are
 *	loaded (either in a particular interpreter, or for all interpreters).
 *
 * Results:
 *	The return value is a standard Tcl completion code. If successful, a
 *	list of lists is placed in the interp's result. Each sublist
 *	corresponds to one loaded file; its first element is the name of the
 *	file (or an empty string for something that's statically loaded) and
 *	the second element is the name of the package in that file.

Changes to generic/tclNamesp.c.

4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
 *
 * Results:
 *	nothing
 *
 * Side effects:
 *	Increments the command reference epoch in each namespace whose path
 *	includes the given namespace. This causes any cached resolved names
 *	whose root cacheing context starts at that namespace to be recomputed
 *	the next time they are used.
 *
 *----------------------------------------------------------------------
 */

void
TclInvalidateNsPath(







|







4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
 *
 * Results:
 *	nothing
 *
 * Side effects:
 *	Increments the command reference epoch in each namespace whose path
 *	includes the given namespace. This causes any cached resolved names
 *	whose root caching context starts at that namespace to be recomputed
 *	the next time they are used.
 *
 *----------------------------------------------------------------------
 */

void
TclInvalidateNsPath(
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
    for (p = name;  *p != '\0';  p++) {
	/* empty body */
    }
    while (--p >= name) {
	if ((*p == ':') && (p > name) && (*(p-1) == ':')) {
	    p -= 2;			/* Back up over the :: */
	    while ((p >= name) && (*p == ':')) {
		p--;			/* Back up over the preceeding : */
	    }
	    break;
	}
    }

    if (p >= name) {
	length = p-name+1;







|







4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
    for (p = name;  *p != '\0';  p++) {
	/* empty body */
    }
    while (--p >= name) {
	if ((*p == ':') && (p > name) && (*(p-1) == ':')) {
	    p -= 2;			/* Back up over the :: */
	    while ((p >= name) && (*p == ':')) {
		p--;			/* Back up over the preceding : */
	    }
	    break;
	}
    }

    if (p >= name) {
	length = p-name+1;
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
 *	    namespace upvar ns otherVar myVar ?otherVar myVar ...?
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Creates new variables in the current scope, linked to the
 *	corresponding variables in the stipulated nmamespace. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceUpvarCmd(







|







4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
 *	    namespace upvar ns otherVar myVar ?otherVar myVar ...?
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Creates new variables in the current scope, linked to the
 *	corresponding variables in the stipulated namespace. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceUpvarCmd(

Changes to generic/tclNotify.c.

983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
	    }
	}
	if (flags & TCL_DONT_WAIT) {
	    break;
	}

	/*
	 * If Tcl_WaitForEvent has returned 1, indicating that one system
	 * event has been dispatched (and thus that some Tcl code might have
	 * been indirectly executed), we break out of the loop. We do this to
	 * give VwaitCmd for instance a chance to check if that system event
	 * had the side effect of changing the variable (so the vwait can
	 * return and unwind properly).
	 *
	 * NB: We will process idle events if any first, because otherwise we
	 *     might never do the idle events if the notifier always gets
	 *     system events.
	 */

	if (result) {







|
|
|
|
|
|







983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
	    }
	}
	if (flags & TCL_DONT_WAIT) {
	    break;
	}

	/*
	 * If Tcl_WaitForEvent has returned 1, indicating that one system event
	 * has been dispatched (and thus that some Tcl code might have been
	 * indirectly executed), we break out of the loop in order, e.g.  to
	 * give vwait a chance to determine whether that system event had the
	 * side effect of changing the variable (so the vwait can return and
	 * unwind properly).
	 *
	 * NB: We will process idle events if any first, because otherwise we
	 *     might never do the idle events if the notifier always gets
	 *     system events.
	 */

	if (result) {

Changes to generic/tclOO.c.

1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
	 * this guard could be removed.
	 */
	return;
    }

    /*
     * One rule for the teardown routines is that if an object is in the
     * process of being deleted, nothing else may modify its bookeeping
     * records.  This is the flag that
     */
    oPtr->flags |= OBJECT_DESTRUCTING;

    /*
     * Let the dominoes fall!
     */







|







1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
	 * this guard could be removed.
	 */
	return;
    }

    /*
     * One rule for the teardown routines is that if an object is in the
     * process of being deleted, nothing else may modify its bookkeeping
     * records.  This is the flag that
     */
    oPtr->flags |= OBJECT_DESTRUCTING;

    /*
     * Let the dominoes fall!
     */
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
     * still exists) because otherwise its pointer to the object points into
     * freed memory.
     */

    if (((Command *) oPtr->command)->flags && CMD_IS_DELETED) {
	/*
	 * Something has already started the command deletion process. We can
	 * go ahead and clean up the the namespace,
	 */
    } else {
	/*
	 * The namespace must have been deleted directly.  Delete the command
	 * as well.
	 */








|







1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
     * still exists) because otherwise its pointer to the object points into
     * freed memory.
     */

    if (((Command *) oPtr->command)->flags && CMD_IS_DELETED) {
	/*
	 * Something has already started the command deletion process. We can
	 * go ahead and clean up the namespace,
	 */
    } else {
	/*
	 * The namespace must have been deleted directly.  Delete the command
	 * as well.
	 */

Changes to generic/tclOOCall.c.

1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
    AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL,
	    flags|BUILDING_MIXINS, NULL);
    AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL);

    /*
     * Check to see if the method has no implementation. If so, we probably
     * need to add in a call to the unknown method. Otherwise, set up the
     * cacheing of the method implementation (if relevant).
     */

    if (count == callPtr->numChain) {
	AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb,
		NULL, BUILDING_MIXINS, NULL);
	AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb,
		NULL, 0, NULL);







|







1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
    AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL,
	    flags|BUILDING_MIXINS, NULL);
    AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL);

    /*
     * Check to see if the method has no implementation. If so, we probably
     * need to add in a call to the unknown method. Otherwise, set up the
     * caching of the method implementation (if relevant).
     */

    if (count == callPtr->numChain) {
	AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb,
		NULL, BUILDING_MIXINS, NULL);
	AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb,
		NULL, 0, NULL);

Changes to generic/tclOOMethod.c.

14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
#endif
#include "tclInt.h"
#include "tclOOInt.h"
#include "tclCompile.h"

/*
 * Structure used to help delay computing names of objects or classes for
 * [info frame] until needed, making invokation faster in the normal case.
 */

struct PNI {
    Tcl_Interp *interp;		/* Interpreter in which to compute the name of
				 * a method. */
    Tcl_Method method;		/* Method to compute the name of. */
};







|







14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
#endif
#include "tclInt.h"
#include "tclOOInt.h"
#include "tclCompile.h"

/*
 * Structure used to help delay computing names of objects or classes for
 * [info frame] until needed, making invocation faster in the normal case.
 */

struct PNI {
    Tcl_Interp *interp;		/* Interpreter in which to compute the name of
				 * a method. */
    Tcl_Method method;		/* Method to compute the name of. */
};

Changes to generic/tclObj.c.

76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
 * The structure defined below is used in this file only.
 */

typedef struct ThreadSpecificData {
    Tcl_HashTable *lineCLPtr;   /* This table remembers for each Tcl_Obj
                                 * generated by a call to the function
                                 * TclSubstTokens() from a literal text
                                 * where bs+nl sequences occured in it, if
                                 * any. I.e. this table keeps track of
                                 * invisible and stripped continuation lines.
                                 * Its keys are Tcl_Obj pointers, the values
                                 * are ContLineLoc pointers. See the file
                                 * tclCompile.h for the definition of this
                                 * structure, and for references to all
                                 * related places in the core. */







|







76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
 * The structure defined below is used in this file only.
 */

typedef struct ThreadSpecificData {
    Tcl_HashTable *lineCLPtr;   /* This table remembers for each Tcl_Obj
                                 * generated by a call to the function
                                 * TclSubstTokens() from a literal text
                                 * where bs+nl sequences occurred in it, if
                                 * any. I.e. this table keeps track of
                                 * invisible and stripped continuation lines.
                                 * Its keys are Tcl_Obj pointers, the values
                                 * are ContLineLoc pointers. See the file
                                 * tclCompile.h for the definition of this
                                 * structure, and for references to all
                                 * related places in the core. */
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
 * structure; every thread will have its own structure instance. The purpose
 * of this structure is to allow deeply nested collections of Tcl_Objs to be
 * freed without taking a vast depth of C stack (which could cause all sorts
 * of breakage.)
 */

typedef struct PendingObjData {
    int deletionCount;		/* Count of the number of invokations of
				 * TclFreeObj() are on the stack (at least
				 * conceptually; many are actually expanded
				 * macros). */
    Tcl_Obj *deletionStack;	/* Stack of objects that have had TclFreeObj()
				 * invoked upon them but which can't be
				 * deleted yet because they are in a nested
				 * invokation of TclFreeObj(). By postponing
				 * this way, we limit the maximum overall C
				 * stack depth when deleting a complex object.
				 * The down-side is that we alter the overall
				 * behaviour by altering the order in which
				 * objects are deleted, and we change the
				 * order in which the string rep and the
				 * internal rep of an object are deleted. Note







|






|







107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
 * structure; every thread will have its own structure instance. The purpose
 * of this structure is to allow deeply nested collections of Tcl_Objs to be
 * freed without taking a vast depth of C stack (which could cause all sorts
 * of breakage.)
 */

typedef struct PendingObjData {
    int deletionCount;		/* Count of the number of invocations of
				 * TclFreeObj() are on the stack (at least
				 * conceptually; many are actually expanded
				 * macros). */
    Tcl_Obj *deletionStack;	/* Stack of objects that have had TclFreeObj()
				 * invoked upon them but which can't be
				 * deleted yet because they are in a nested
				 * invocation of TclFreeObj(). By postponing
				 * this way, we limit the maximum overall C
				 * stack depth when deleting a complex object.
				 * The down-side is that we alter the overall
				 * behaviour by altering the order in which
				 * objects are deleted, and we change the
				 * order in which the string rep and the
				 * internal rep of an object are deleted. Note
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
	 * time. Taking care not to leak the old entry.
	 *
	 * This can happen when literals in a proc body are shared. See for
	 * example test info-30.19 where the action (code) for all branches of
	 * the switch command is identical, mapping them all to the same
	 * literal. An interesting result of this is that the number and
	 * locations (offset) of invisible continuation lines in the literal
	 * are the same for all occurences.
	 *
	 * Note that while reusing the existing entry is possible it requires
	 * the same actions as for a new entry because we have to copy the
	 * incoming num/loc data even so. Because we are called from
	 * TclContinuationsEnterDerived for this case, which modified the
	 * stored locations (Rebased to the proper relative offset). Just
	 * returning the stored entry would rebase them a second time, or







|







584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
	 * time. Taking care not to leak the old entry.
	 *
	 * This can happen when literals in a proc body are shared. See for
	 * example test info-30.19 where the action (code) for all branches of
	 * the switch command is identical, mapping them all to the same
	 * literal. An interesting result of this is that the number and
	 * locations (offset) of invisible continuation lines in the literal
	 * are the same for all occurrences.
	 *
	 * Note that while reusing the existing entry is possible it requires
	 * the same actions as for a new entry because we have to copy the
	 * incoming num/loc data even so. Because we are called from
	 * TclContinuationsEnterDerived for this case, which modified the
	 * stored locations (Rebased to the proper relative offset). Just
	 * returning the stored entry would rebase them a second time, or
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405

    /*
     * We cannot use TclGetContinuationTable() here, because that may
     * re-initialize the thread-data for calls coming after the finalization.
     * We have to access it using the low-level call and then check for
     * validity. This function can be called after TclFinalizeThreadData() has
     * already killed the thread-global data structures. Performing
     * TCL_TSD_INIT will leave us with an un-initialized memory block upon
     * which we crash (if we where to access the uninitialized hashtable).
     */

    {
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
        Tcl_HashEntry *hPtr;








|







1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405

    /*
     * We cannot use TclGetContinuationTable() here, because that may
     * re-initialize the thread-data for calls coming after the finalization.
     * We have to access it using the low-level call and then check for
     * validity. This function can be called after TclFinalizeThreadData() has
     * already killed the thread-global data structures. Performing
     * TCL_TSD_INIT will leave us with an uninitialized memory block upon
     * which we crash (if we where to access the uninitialized hashtable).
     */

    {
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
        Tcl_HashEntry *hPtr;

1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496

    /*
     * We cannot use TclGetContinuationTable() here, because that may
     * re-initialize the thread-data for calls coming after the finalization.
     * We have to access it using the low-level call and then check for
     * validity. This function can be called after TclFinalizeThreadData() has
     * already killed the thread-global data structures. Performing
     * TCL_TSD_INIT will leave us with an un-initialized memory block upon
     * which we crash (if we where to access the uninitialized hashtable).
     */

    {
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
        Tcl_HashEntry *hPtr;








|







1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496

    /*
     * We cannot use TclGetContinuationTable() here, because that may
     * re-initialize the thread-data for calls coming after the finalization.
     * We have to access it using the low-level call and then check for
     * validity. This function can be called after TclFinalizeThreadData() has
     * already killed the thread-global data structures. Performing
     * TCL_TSD_INIT will leave us with an uninitialized memory block upon
     * which we crash (if we where to access the uninitialized hashtable).
     */

    {
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
        Tcl_HashEntry *hPtr;

3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
 *	the object if necessary.
 *
 * Results:
 *	Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise.
 *
 * Side effects:
 *	A copy of bignum is stored in *bignumValue, which is expected to be
 *	uninitialized or cleared. If conversion fails, an the 'interp'
 *	argument is not NULL, an error message is stored in the interpreter
 *	result.
 *
 *	It is expected that the caller will NOT have invoked mp_init on the
 *	bignum value before passing it in. Tcl will initialize the mp_int as
 *	it sets the value. The value is transferred from the internals of
 *	objPtr to the caller, passing responsibility of the caller to call







|







3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
 *	the object if necessary.
 *
 * Results:
 *	Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise.
 *
 * Side effects:
 *	A copy of bignum is stored in *bignumValue, which is expected to be
 *	uninitialized or cleared. If conversion fails and the 'interp'
 *	argument is not NULL, an error message is stored in the interpreter
 *	result.
 *
 *	It is expected that the caller will NOT have invoked mp_init on the
 *	bignum value before passing it in. Tcl will initialize the mp_int as
 *	it sets the value. The value is transferred from the internals of
 *	objPtr to the caller, passing responsibility of the caller to call

Changes to generic/tclPanic.c.

140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
 *
 *----------------------------------------------------------------------
 */

/* ARGSUSED */

/*
 * The following comment is here so that Coverity's static analizer knows that
 * a Tcl_Panic() call can never return and avoids lots of false positives.
 */

/* coverity[+kill] */
void
Tcl_Panic(
    const char *format,







|







140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
 *
 *----------------------------------------------------------------------
 */

/* ARGSUSED */

/*
 * The following comment is here so that Coverity's static analyzer knows that
 * a Tcl_Panic() call can never return and avoids lots of false positives.
 */

/* coverity[+kill] */
void
Tcl_Panic(
    const char *format,

Changes to generic/tclParse.c.

828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclParseBackslash(
    const char *src,		/* Points to the backslash character of a a
				 * backslash sequence. */
    int numBytes,		/* Max number of bytes to scan. */
    int *readPtr,		/* NULL, or points to storage where the number
				 * of bytes scanned should be written. */
    char *dst)			/* NULL, or points to buffer where the UTF-8
				 * encoding of the backslash sequence is to be
				 * written. At most TCL_UTF_MAX bytes will be







|







828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclParseBackslash(
    const char *src,		/* Points to the backslash character of a
				 * backslash sequence. */
    int numBytes,		/* Max number of bytes to scan. */
    int *readPtr,		/* NULL, or points to storage where the number
				 * of bytes scanned should be written. */
    char *dst)			/* NULL, or points to buffer where the UTF-8
				 * encoding of the backslash sequence is to be
				 * written. At most TCL_UTF_MAX bytes will be
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
     * Tcl_Obj creation if possible, to aid performance and limit shimmering.
     *
     * Further optimization opportunities might be to check for the equivalent
     * of Tcl_SetObjResult(interp, Tcl_GetObjResult(interp)) and omit them.
     */

    /*
     * For the handling of continuation lines in literals we first check if
     * this is actually a literal. For if not we can forego the additional
     * processing. Otherwise we pre-allocate a small table to store the
     * locations of all continuation lines we find in this literal, if any.
     * The table is extended if needed.
     */

    numCL = 0;
    maxNumCL = 0;
    isLiteral = 1;







|
|
|







2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
     * Tcl_Obj creation if possible, to aid performance and limit shimmering.
     *
     * Further optimization opportunities might be to check for the equivalent
     * of Tcl_SetObjResult(interp, Tcl_GetObjResult(interp)) and omit them.
     */

    /*
     * For the handling of continuation lines in literals, first check if
     * this is actually a literal. If not then forego the additional
     * processing. Otherwise preallocate a small table to store the
     * locations of all continuation lines we find in this literal, if any.
     * The table is extended if needed.
     */

    numCL = 0;
    maxNumCL = 0;
    isLiteral = 1;

Changes to generic/tclPathObj.c.

844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
}

Tcl_Obj *
TclJoinPath(
    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;
    const Tcl_Filesystem *fsPtr = NULL;

    assert ( elements >= 0 );








|







844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
}

Tcl_Obj *
TclJoinPath(
    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;
    const Tcl_Filesystem *fsPtr = NULL;

    assert ( elements >= 0 );

899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
		     * the base itself is just fine!
		     */

		    return elt;
		}

		/*
		 * If it doesn't begin with '.' and is a unix path or it a
		 * windows path without backslashes, then we can be very
		 * efficient here. (In fact even a windows path with
		 * backslashes can be joined efficiently, but the path object
		 * would not have forward slashes only, and this would
		 * therefore contradict our 'file join' documentation).
		 */








|







899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
		     * the base itself is just fine!
		     */

		    return elt;
		}

		/*
		 * If it doesn't begin with '.' and is a Unix path or it a
		 * windows path without backslashes, then we can be very
		 * efficient here. (In fact even a windows path with
		 * backslashes can be joined efficiently, but the path object
		 * would not have forward slashes only, and this would
		 * therefore contradict our 'file join' documentation).
		 */

Changes to generic/tclPipe.c.

56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
 *	None.
 *
 *----------------------------------------------------------------------
 */

static TclFile
FileForRedirect(
    Tcl_Interp *interp,		/* Intepreter to use for error reporting. */
    const char *spec,		/* Points to character just after redirection
				 * character. */
    int atOK,			/* Non-zero means that '@' notation can be
				 * used to specify a channel, zero means that
				 * it isn't. */
    const char *arg,		/* Pointer to entire argument containing spec:
				 * used for error reporting. */







|







56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
 *	None.
 *
 *----------------------------------------------------------------------
 */

static TclFile
FileForRedirect(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting. */
    const char *spec,		/* Points to character just after redirection
				 * character. */
    int atOK,			/* Non-zero means that '@' notation can be
				 * used to specify a channel, zero means that
				 * it isn't. */
    const char *arg,		/* Pointer to entire argument containing spec:
				 * used for error reporting. */
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
				 * redirection in the command). The file id
				 * with which to write to this pipe is stored
				 * at *inPipePtr. NULL means command specified
				 * its own input source. */
    TclFile *outPipePtr,	/* If non-NULL, output to the pipeline goes to
				 * a pipe, unless overridden by redirection in
				 * the command. The file id with which to read
				 * frome this pipe is stored at *outPipePtr.
				 * NULL means command specified its own output
				 * sink. */
    TclFile *errFilePtr)	/* If non-NULL, all stderr output from the
				 * pipeline will go to a temporary file
				 * created here, and a descriptor to read the
				 * file will be left at *errFilePtr. The file
				 * will be removed already, so closing this







|







448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
				 * redirection in the command). The file id
				 * with which to write to this pipe is stored
				 * at *inPipePtr. NULL means command specified
				 * its own input source. */
    TclFile *outPipePtr,	/* If non-NULL, output to the pipeline goes to
				 * a pipe, unless overridden by redirection in
				 * the command. The file id with which to read
				 * from this pipe is stored at *outPipePtr.
				 * NULL means command specified its own output
				 * sink. */
    TclFile *errFilePtr)	/* If non-NULL, all stderr output from the
				 * pipeline will go to a temporary file
				 * created here, and a descriptor to read the
				 * file will be left at *errFilePtr. The file
				 * will be removed already, so closing this
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536

    /*
     * First, scan through all the arguments to figure out the structure of
     * the pipeline. Process all of the input and output redirection arguments
     * and remove them from the argument list in the pipeline. Count the
     * number of distinct processes (it's the number of "|" arguments plus
     * one) but don't remove the "|" arguments because they'll be used in the
     * second pass to seperate the individual child processes. Cannot start
     * the child processes in this pass because the redirection symbols may
     * appear anywhere in the command line - e.g., the '<' that specifies the
     * input to the entire pipe may appear at the very end of the argument
     * list.
     */

    lastBar = -1;







|







522
523
524
525
526
527
528
529
530
531
532
533
534
535
536

    /*
     * First, scan through all the arguments to figure out the structure of
     * the pipeline. Process all of the input and output redirection arguments
     * and remove them from the argument list in the pipeline. Count the
     * number of distinct processes (it's the number of "|" arguments plus
     * one) but don't remove the "|" arguments because they'll be used in the
     * second pass to separate the individual child processes. Cannot start
     * the child processes in this pass because the redirection symbols may
     * appear anywhere in the command line - e.g., the '<' that specifies the
     * input to the entire pipe may appear at the very end of the argument
     * list.
     */

    lastBar = -1;

Changes to generic/tclPkg.c.

1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551

static int
CompareVersions(
    char *v1, char *v2,		/* Versions strings, of form 2.1.3 (any number
				 * of version numbers). */
    int *isMajorPtr)		/* If non-null, the word pointed to is filled
				 * in with a 0/1 value. 1 means that the
				 * difference occured in the first element. */
{
    int thisIsMajor, res, flip;
    char *s1, *e1, *s2, *e2, o1, o2;

    /*
     * Each iteration of the following loop processes one number from each
     * string, terminated by a " " (space). If those numbers don't match then







|







1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551

static int
CompareVersions(
    char *v1, char *v2,		/* Versions strings, of form 2.1.3 (any number
				 * of version numbers). */
    int *isMajorPtr)		/* If non-null, the word pointed to is filled
				 * in with a 0/1 value. 1 means that the
				 * difference occurred in the first element. */
{
    int thisIsMajor, res, flip;
    char *s1, *e1, *s2, *e2, o1, o2;

    /*
     * Each iteration of the following loop processes one number from each
     * string, terminated by a " " (space). If those numbers don't match then
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
	ckfree(min);
	ckfree(buf);
	return satisfied;
    }

    /*
     * We have both min and max, and generate their internal reps. When
     * identical we compare as is, otherwise we pad with 'a0' to ove the range
     * a bit.
     */

    CheckVersionAndConvert(NULL, buf, &min, NULL);
    CheckVersionAndConvert(NULL, dash, &max, NULL);

    if (CompareVersions(min, max, NULL) == 0) {







|







1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
	ckfree(min);
	ckfree(buf);
	return satisfied;
    }

    /*
     * We have both min and max, and generate their internal reps. When
     * identical we compare as is, otherwise we pad with 'a0' to over the range
     * a bit.
     */

    CheckVersionAndConvert(NULL, buf, &min, NULL);
    CheckVersionAndConvert(NULL, dash, &max, NULL);

    if (CompareVersions(min, max, NULL) == 0) {

Changes to generic/tclStrToD.c.

1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
			((Tcl_WideInt)significand / pow10vals[-exponent]);
		goto returnValue;
	    }
	}
    }

    /*
     * All the easy cases have failed. Promote ths significand to bignum and
     * call MakeHighPrecisionDouble to do it the hard way.
     */

    TclBNInitBignumFromWideUInt(&significandBig, significand);
    retval = MakeHighPrecisionDouble(0, &significandBig, numSigDigs,
	    exponent);
    mp_clear(&significandBig);







|







1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
			((Tcl_WideInt)significand / pow10vals[-exponent]);
		goto returnValue;
	    }
	}
    }

    /*
     * All the easy cases have failed. Promote the significand to bignum and
     * call MakeHighPrecisionDouble to do it the hard way.
     */

    TclBNInitBignumFromWideUInt(&significandBig, significand);
    retval = MakeHighPrecisionDouble(0, &significandBig, numSigDigs,
	    exponent);
    mp_clear(&significandBig);
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
	    mp_mul(&twoMv, pow5+i, &twoMv);
	}
    }

    /*
     * Compute twoMd as 2*M*d, where d is the exact value.
     * This is done by multiplying by 5**(M5+exponent) and then multiplying
     * by 2**(M5+exponent+1), which is, of couse, a left shift.
     */

    mp_init_copy(&twoMd, exactSignificand);
    for (i=0; i<=8; ++i) {
	if ((M5 + exponent) & (1 << i)) {
	    mp_mul(&twoMd, pow5+i, &twoMd);
	}







|







1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
	    mp_mul(&twoMv, pow5+i, &twoMv);
	}
    }

    /*
     * Compute twoMd as 2*M*d, where d is the exact value.
     * This is done by multiplying by 5**(M5+exponent) and then multiplying
     * by 2**(M5+exponent+1), which is, of course, a left shift.
     */

    mp_init_copy(&twoMd, exactSignificand);
    for (i=0; i<=8; ++i) {
	if ((M5 + exponent) & (1 << i)) {
	    mp_mul(&twoMd, pow5+i, &twoMd);
	}
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
}

/*
 *----------------------------------------------------------------------
 *
 * RequiredPrecision --
 *
 *	Determines the number of bits needed to hold an intger.
 *
 * Results:
 *	Returns the position of the most significant bit (0 - 63).  Returns 0
 *	if the number is zero.
 *
 *----------------------------------------------------------------------
 */







|







2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
}

/*
 *----------------------------------------------------------------------
 *
 * RequiredPrecision --
 *
 *	Determines the number of bits needed to hold an integer.
 *
 * Results:
 *	Returns the position of the most significant bit (0 - 63).  Returns 0
 *	if the number is zero.
 *
 *----------------------------------------------------------------------
 */

Changes to generic/tclStringObj.c.

131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
static void
GrowStringBuffer(
    Tcl_Obj *objPtr,
    int needed,
    int flag)
{
    /*
     * Pre-conditions:
     *	objPtr->typePtr == &tclStringType
     *	needed > stringPtr->allocated
     *	flag || objPtr->bytes != NULL
     */

    String *stringPtr = GET_STRING(objPtr);
    char *ptr = NULL;







|







131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
static void
GrowStringBuffer(
    Tcl_Obj *objPtr,
    int needed,
    int flag)
{
    /*
     * Preconditions:
     *	objPtr->typePtr == &tclStringType
     *	needed > stringPtr->allocated
     *	flag || objPtr->bytes != NULL
     */

    String *stringPtr = GET_STRING(objPtr);
    char *ptr = NULL;
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195

static void
GrowUnicodeBuffer(
    Tcl_Obj *objPtr,
    int needed)
{
    /*
     * Pre-conditions:
     *	objPtr->typePtr == &tclStringType
     *	needed > stringPtr->maxChars
     *	needed < STRING_MAXCHARS
     */

    String *ptr = NULL, *stringPtr = GET_STRING(objPtr);
    int attempt;







|







181
182
183
184
185
186
187
188
189
190
191
192
193
194
195

static void
GrowUnicodeBuffer(
    Tcl_Obj *objPtr,
    int needed)
{
    /*
     * Preconditions:
     *	objPtr->typePtr == &tclStringType
     *	needed > stringPtr->maxChars
     *	needed < STRING_MAXCHARS
     */

    String *ptr = NULL, *stringPtr = GET_STRING(objPtr);
    int attempt;
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
 *----------------------------------------------------------------------
 *
 * Tcl_GetCharLength --
 *
 *	Get the length of the Unicode string from the Tcl object.
 *
 * Results:
 *	Pointer to unicode string representing the unicode object.
 *
 * Side effects:
 *	Frees old internal rep. Allocates memory for new "String" internal
 *	rep.
 *
 *----------------------------------------------------------------------
 */







|







396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
 *----------------------------------------------------------------------
 *
 * Tcl_GetCharLength --
 *
 *	Get the length of the Unicode string from the Tcl object.
 *
 * Results:
 *	Pointer to Unicode string representing the Unicode object.
 *
 * Side effects:
 *	Frees old internal rep. Allocates memory for new "String" internal
 *	rep.
 *
 *----------------------------------------------------------------------
 */
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440

    if ((objPtr->bytes) && (objPtr->length < 2)) {
	/* 0 bytes -> 0 chars; 1 byte -> 1 char */
	return objPtr->length;
    }

    /*
     * Optimize the case where we're really dealing with a bytearray object;
     * we don't need to convert to a string to perform the get-length operation.
     *
     * NOTE that we do not need the bytearray to be "pure".  A ByteArray value
     * with a string rep cannot be trusted to represent the same value as the
     * string rep, but it *can* be trusted to have the same character length
     * as the string rep, which is all this routine cares about.
     */

    if (objPtr->typePtr == &tclByteArrayType) {
	int length;







|


|







423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440

    if ((objPtr->bytes) && (objPtr->length < 2)) {
	/* 0 bytes -> 0 chars; 1 byte -> 1 char */
	return objPtr->length;
    }

    /*
     * Optimize the case where we're really dealing with a ByteArray object;
     * we don't need to convert to a string to perform the get-length operation.
     *
     * NOTE that we do not need the ByteArray to be "pure".  A ByteArray value
     * with a string rep cannot be trusted to represent the same value as the
     * string rep, but it *can* be trusted to have the same character length
     * as the string rep, which is all this routine cares about.
     */

    if (objPtr->typePtr == &tclByteArrayType) {
	int length;
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
	TclNumUtfChars(numChars, objPtr->bytes, objPtr->length);
	stringPtr->numChars = numChars;

#if COMPAT
	if (numChars < objPtr->length) {
	    /*
	     * Since we've just computed the number of chars, and not all UTF
	     * chars are 1-byte long, go ahead and populate the unicode
	     * string.
	     */

	    FillUnicodeRep(objPtr);
	}
#endif
    }







|







459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
	TclNumUtfChars(numChars, objPtr->bytes, objPtr->length);
	stringPtr->numChars = numChars;

#if COMPAT
	if (numChars < objPtr->length) {
	    /*
	     * Since we've just computed the number of chars, and not all UTF
	     * chars are 1-byte long, go ahead and populate the Unicode
	     * string.
	     */

	    FillUnicodeRep(objPtr);
	}
#endif
    }
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
    int length;

    if (index < 0) {
	return 0xFFFD;
    }

    /*
     * Optimize the case where we're really dealing with a bytearray object
     * we don't need to convert to a string to perform the indexing operation.
     */

    if (TclIsPureByteArray(objPtr)) {
	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
	if (index >= length) {
		return 0xFFFD;







|







543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
    int length;

    if (index < 0) {
	return 0xFFFD;
    }

    /*
     * Optimize the case where we're really dealing with a ByteArray object
     * we don't need to convert to a string to perform the indexing operation.
     */

    if (TclIsPureByteArray(objPtr)) {
	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
	if (index >= length) {
		return 0xFFFD;
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
    }
    return stringPtr->unicode[index];
}

#if TCL_UTF_MAX == 4
int
TclGetUCS4(
    Tcl_Obj *objPtr,		/* The object to get the Unicode charater
				 * from. */
    int index)			/* Get the index'th Unicode character. */
{
    String *stringPtr;
    int ch, length;

    if (index < 0) {
	return -1;
    }

    /*
     * Optimize the case where we're really dealing with a bytearray object
     * we don't need to convert to a string to perform the indexing operation.
     */

    if (TclIsPureByteArray(objPtr)) {
	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
	if (index >= length) {
		return -1;







|











|







587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
    }
    return stringPtr->unicode[index];
}

#if TCL_UTF_MAX == 4
int
TclGetUCS4(
    Tcl_Obj *objPtr,		/* The object to get the Unicode character
				 * from. */
    int index)			/* Get the index'th Unicode character. */
{
    String *stringPtr;
    int ch, length;

    if (index < 0) {
	return -1;
    }

    /*
     * Optimize the case where we're really dealing with a ByteArray object
     * we don't need to convert to a string to perform the indexing operation.
     */

    if (TclIsPureByteArray(objPtr)) {
	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
	if (index >= length) {
		return -1;
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
 *	Converts the object to have the String internal rep.
 *
 *----------------------------------------------------------------------
 */

Tcl_UniChar *
Tcl_GetUnicode(
    Tcl_Obj *objPtr)		/* The object to find the unicode string
				 * for. */
{
    return Tcl_GetUnicodeFromObj(objPtr, NULL);
}

/*
 *----------------------------------------------------------------------







|







679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
 *	Converts the object to have the String internal rep.
 *
 *----------------------------------------------------------------------
 */

Tcl_UniChar *
Tcl_GetUnicode(
    Tcl_Obj *objPtr)		/* The object to find the Unicode string
				 * for. */
{
    return Tcl_GetUnicodeFromObj(objPtr, NULL);
}

/*
 *----------------------------------------------------------------------
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
 *	Converts the object to have the String internal rep.
 *
 *----------------------------------------------------------------------
 */

Tcl_UniChar *
Tcl_GetUnicodeFromObj(
    Tcl_Obj *objPtr,		/* The object to find the unicode string
				 * for. */
    int *lengthPtr)		/* If non-NULL, the location where the string
				 * rep's unichar length should be stored. If
				 * NULL, no length is stored. */
{
    String *stringPtr;

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);








|


|







706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
 *	Converts the object to have the String internal rep.
 *
 *----------------------------------------------------------------------
 */

Tcl_UniChar *
Tcl_GetUnicodeFromObj(
    Tcl_Obj *objPtr,		/* The object to find the Unicode string
				 * for. */
    int *lengthPtr)		/* If non-NULL, the location where the string
				 * rep's Tcl_UniChar length should be stored. If
				 * NULL, no length is stored. */
{
    String *stringPtr;

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
    int length;

    if (first < 0) {
	first = 0;
    }

    /*
     * Optimize the case where we're really dealing with a bytearray object
     * we don't need to convert to a string to perform the substring operation.
     */

    if (TclIsPureByteArray(objPtr)) {
	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);

	if (last < 0 || last >= length) {







|







763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
    int length;

    if (first < 0) {
	first = 0;
    }

    /*
     * Optimize the case where we're really dealing with a ByteArray object
     * we don't need to convert to a string to perform the substring operation.
     */

    if (TclIsPureByteArray(objPtr)) {
	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);

	if (last < 0 || last >= length) {
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
	if (length > stringPtr->maxChars) {
	    stringPtr = stringRealloc(stringPtr, length);
	    SET_STRING(objPtr, stringPtr);
	    stringPtr->maxChars = length;
	}

	/*
	 * Mark the new end of the unicode string
	 */

	stringPtr->numChars = length;
	stringPtr->unicode[length] = 0;
	stringPtr->hasUnicode = 1;

	/*







|







983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
	if (length > stringPtr->maxChars) {
	    stringPtr = stringRealloc(stringPtr, length);
	    SET_STRING(objPtr, stringPtr);
	    stringPtr->maxChars = length;
	}

	/*
	 * Mark the new end of the Unicode string
	 */

	stringPtr->numChars = length;
	stringPtr->unicode[length] = 0;
	stringPtr->hasUnicode = 1;

	/*
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
	    stringPtr->allocated = length;
	}

	objPtr->length = length;
	objPtr->bytes[length] = 0;

	/*
	 * Invalidate the unicode data.
	 */

	stringPtr->numChars = -1;
	stringPtr->hasUnicode = 0;
    } else {
	/*
	 * Changing length of pure unicode string.
	 */

	if (length > STRING_MAXCHARS) {
	    return 0;
	}
	if (length > stringPtr->maxChars) {
	    stringPtr = stringAttemptRealloc(stringPtr, length);
	    if (stringPtr == NULL) {
		return 0;
	    }
	    SET_STRING(objPtr, stringPtr);
	    stringPtr->maxChars = length;
	}

	/*
	 * Mark the new end of the unicode string.
	 */

	stringPtr->unicode[length] = 0;
	stringPtr->numChars = length;
	stringPtr->hasUnicode = 1;

	/*







|






|















|







1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
	    stringPtr->allocated = length;
	}

	objPtr->length = length;
	objPtr->bytes[length] = 0;

	/*
	 * Invalidate the Unicode data.
	 */

	stringPtr->numChars = -1;
	stringPtr->hasUnicode = 0;
    } else {
	/*
	 * Changing length of pure Unicode string.
	 */

	if (length > STRING_MAXCHARS) {
	    return 0;
	}
	if (length > stringPtr->maxChars) {
	    stringPtr = stringAttemptRealloc(stringPtr, length);
	    if (stringPtr == NULL) {
		return 0;
	    }
	    SET_STRING(objPtr, stringPtr);
	    stringPtr->maxChars = length;
	}

	/*
	 * Mark the new end of the Unicode string.
	 */

	stringPtr->unicode[length] = 0;
	stringPtr->numChars = length;
	stringPtr->hasUnicode = 1;

	/*
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
 *
 *---------------------------------------------------------------------------
 */

void
Tcl_SetUnicodeObj(
    Tcl_Obj *objPtr,		/* The object to set the string of. */
    const Tcl_UniChar *unicode,	/* The unicode string used to initialize the
				 * object. */
    int numChars)		/* Number of characters in the unicode
				 * string. */
{
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj");
    }
    TclFreeIntRep(objPtr);
    SetUnicodeObj(objPtr, unicode, numChars);







|

|







1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
 *
 *---------------------------------------------------------------------------
 */

void
Tcl_SetUnicodeObj(
    Tcl_Obj *objPtr,		/* The object to set the string of. */
    const Tcl_UniChar *unicode,	/* The Unicode string used to initialize the
				 * object. */
    int numChars)		/* Number of characters in the Unicode
				 * string. */
{
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj");
    }
    TclFreeIntRep(objPtr);
    SetUnicodeObj(objPtr, unicode, numChars);
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
    stringCheckLimits(numChars);
    return numChars;
}

static void
SetUnicodeObj(
    Tcl_Obj *objPtr,		/* The object to set the string of. */
    const Tcl_UniChar *unicode,	/* The unicode string used to initialize the
				 * object. */
    int numChars)		/* Number of characters in the unicode
				 * string. */
{
    String *stringPtr;

    if (numChars < 0) {
	numChars = UnicodeLength(unicode);
    }







|

|







1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
    stringCheckLimits(numChars);
    return numChars;
}

static void
SetUnicodeObj(
    Tcl_Obj *objPtr,		/* The object to set the string of. */
    const Tcl_UniChar *unicode,	/* The Unicode string used to initialize the
				 * object. */
    int numChars)		/* Number of characters in the Unicode
				 * string. */
{
    String *stringPtr;

    if (numChars < 0) {
	numChars = UnicodeLength(unicode);
    }
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendUnicodeToObj(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const Tcl_UniChar *unicode,	/* The unicode string to append to the
				 * object. */
    int length)			/* Number of chars in "unicode". */
{
    String *stringPtr;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj");
    }

    if (length == 0) {
	return;
    }

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    /*
     * If objPtr has a valid Unicode rep, then append the "unicode" to the
     * objPtr's Unicode rep, otherwise the UTF conversion of "unicode" to
     * objPtr's string rep.
     */

    if (stringPtr->hasUnicode
#if COMPAT
		&& stringPtr->numChars > 0
#endif
	    ) {
	AppendUnicodeToUnicodeRep(objPtr, unicode, length);
    } else {
	AppendUnicodeToUtfRep(objPtr, unicode, length);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendObjToObj --
 *
 *	This function appends the string rep of one object to another.
 *	"objPtr" cannot be a shared object.







|

|















|
|













|







1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendUnicodeToObj(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const Tcl_UniChar *unicode,	/* The Unicode string to append to the
				 * object. */
    int length)			/* Number of chars in unicode. */
{
    String *stringPtr;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj");
    }

    if (length == 0) {
	return;
    }

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    /*
     * If objPtr has a valid Unicode rep, then append unicode to the
     * objPtr's Unicode rep, otherwise the UTF conversion of unicode to
     * objPtr's string rep.
     */

    if (stringPtr->hasUnicode
#if COMPAT
		&& stringPtr->numChars > 0
#endif
	    ) {
	AppendUnicodeToUnicodeRep(objPtr, unicode, length);
    } else {
	AppendUnicodeToUtfRep(objPtr, unicode, length);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendObjToObj --
 *
 *	This function appends the string rep of one object to another.
 *	"objPtr" cannot be a shared object.
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
     */

    if (appendObjPtr->bytes == tclEmptyStringRep) {
	return;
    }

    /*
     * Handle append of one bytearray object to another as a special case.
     * Note that we only do this when the objects don't have string reps; if
     * it did, then appending the byte arrays together could well lose
     * information; this is a special-case optimization only.
     */

    if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep)
	    && TclIsPureByteArray(appendObjPtr)) {







|







1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
     */

    if (appendObjPtr->bytes == tclEmptyStringRep) {
	return;
    }

    /*
     * Handle append of one ByteArray object to another as a special case.
     * Note that we only do this when the objects don't have string reps; if
     * it did, then appending the byte arrays together could well lose
     * information; this is a special-case optimization only.
     */

    if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep)
	    && TclIsPureByteArray(appendObjPtr)) {
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
}

/*
 *----------------------------------------------------------------------
 *
 * AppendUnicodeToUnicodeRep --
 *
 *	This function appends the contents of "unicode" to the Unicode rep of
 *	"objPtr". objPtr must already have a valid Unicode rep.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	objPtr's internal rep is reallocated.
 *







|
|







1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
}

/*
 *----------------------------------------------------------------------
 *
 * AppendUnicodeToUnicodeRep --
 *
 *	Appends the contents of unicode to the Unicode rep of
 *	objPtr, which must already have a valid Unicode rep.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	objPtr's internal rep is reallocated.
 *
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
	return;
    }

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    /*
     * If not enough space has been allocated for the unicode rep, reallocate
     * the internal rep object with additional space. First try to double the
     * required allocation; if that fails, try a more modest increase. See the
     * "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an
     * explanation of this growth algorithm.
     */

    numChars = stringPtr->numChars + appendNumChars;
    stringCheckLimits(numChars);

    if (numChars > stringPtr->maxChars) {
	int offset = -1;

	/*
	 * Protect against case where unicode points into the existing
	 * stringPtr->unicode array. Force it to follow any relocations due to
	 * the reallocs below.
	 */

	if (unicode && unicode >= stringPtr->unicode
		&& unicode <= stringPtr->unicode + stringPtr->maxChars) {
	    offset = unicode - stringPtr->unicode;
	}

	GrowUnicodeBuffer(objPtr, numChars);
	stringPtr = GET_STRING(objPtr);

	/*
	 * Relocate unicode if needed; see above.
	 */

	if (offset >= 0) {
	    unicode = stringPtr->unicode + offset;
	}
    }








|













|













|







1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
	return;
    }

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    /*
     * If not enough space has been allocated for the Unicode rep, reallocate
     * the internal rep object with additional space. First try to double the
     * required allocation; if that fails, try a more modest increase. See the
     * "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an
     * explanation of this growth algorithm.
     */

    numChars = stringPtr->numChars + appendNumChars;
    stringCheckLimits(numChars);

    if (numChars > stringPtr->maxChars) {
	int offset = -1;

	/*
	 * Protect against case where Unicode points into the existing
	 * stringPtr->unicode array. Force it to follow any relocations due to
	 * the reallocs below.
	 */

	if (unicode && unicode >= stringPtr->unicode
		&& unicode <= stringPtr->unicode + stringPtr->maxChars) {
	    offset = unicode - stringPtr->unicode;
	}

	GrowUnicodeBuffer(objPtr, numChars);
	stringPtr = GET_STRING(objPtr);

	/*
	 * Relocate Unicode if needed; see above.
	 */

	if (offset >= 0) {
	    unicode = stringPtr->unicode + offset;
	}
    }

1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
 *----------------------------------------------------------------------
 */

static void
AppendUnicodeToUtfRep(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const Tcl_UniChar *unicode,	/* String to convert to UTF. */
    int numChars)		/* Number of chars of "unicode" to convert. */
{
    String *stringPtr = GET_STRING(objPtr);

    numChars = ExtendStringRepWithUnicode(objPtr, unicode, numChars);

    if (stringPtr->numChars != -1) {
	stringPtr->numChars += numChars;
    }

#if COMPAT
    /*
     * Invalidate the unicode rep.
     */

    stringPtr->hasUnicode = 0;
#endif
}

/*







|











|







1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
 *----------------------------------------------------------------------
 */

static void
AppendUnicodeToUtfRep(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const Tcl_UniChar *unicode,	/* String to convert to UTF. */
    int numChars)		/* Number of chars of unicode to convert. */
{
    String *stringPtr = GET_STRING(objPtr);

    numChars = ExtendStringRepWithUnicode(objPtr, unicode, numChars);

    if (stringPtr->numChars != -1) {
	stringPtr->numChars += numChars;
    }

#if COMPAT
    /*
     * Invalidate the Unicode rep.
     */

    stringPtr->hasUnicode = 0;
#endif
}

/*
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
    if (stringPtr->hasUnicode) {
	Tcl_UniChar *from = Tcl_GetUnicode(objPtr);
	Tcl_UniChar *src = from + stringPtr->numChars;
	Tcl_UniChar *to;

	if (Tcl_IsShared(objPtr)) {
	    /*
	     * Create a non-empty, pure unicode value, so we can coax
	     * Tcl_SetObjLength into growing the unicode rep buffer.
	     */

	    objPtr = Tcl_NewUnicodeObj(&ch, 1);
	    Tcl_SetObjLength(objPtr, stringPtr->numChars);
	    to = Tcl_GetUnicode(objPtr);
	    while (--src >= from) {
#if TCL_UTF_MAX <= 4







|
|







2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
    if (stringPtr->hasUnicode) {
	Tcl_UniChar *from = Tcl_GetUnicode(objPtr);
	Tcl_UniChar *src = from + stringPtr->numChars;
	Tcl_UniChar *to;

	if (Tcl_IsShared(objPtr)) {
	    /*
	     * Create a non-empty, pure Unicode value, so we can coax
	     * Tcl_SetObjLength into growing the Unicode rep buffer.
	     */

	    objPtr = Tcl_NewUnicodeObj(&ch, 1);
	    Tcl_SetObjLength(objPtr, stringPtr->numChars);
	    to = Tcl_GetUnicode(objPtr);
	    while (--src >= from) {
#if TCL_UTF_MAX <= 4
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
 *	Update the string representation for an object whose internal
 *	representation is "String".
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string may be set by converting its Unicode represention
 *	to UTF format.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfString(







|







3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
 *	Update the string representation for an object whose internal
 *	representation is "String".
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string may be set by converting its Unicode representation
 *	to UTF format.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfString(
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
static int
ExtendStringRepWithUnicode(
    Tcl_Obj *objPtr,
    const Tcl_UniChar *unicode,
    int numChars)
{
    /*
     * Pre-condition: this is the "string" Tcl_ObjType.
     */

    int i, origLength, size = 0;
    char *dst, buf[4] = "";
    String *stringPtr = GET_STRING(objPtr);

    if (numChars < 0) {







|







3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
static int
ExtendStringRepWithUnicode(
    Tcl_Obj *objPtr,
    const Tcl_UniChar *unicode,
    int numChars)
{
    /*
     * Precondition: this is the "string" Tcl_ObjType.
     */

    int i, origLength, size = 0;
    char *dst, buf[4] = "";
    String *stringPtr = GET_STRING(objPtr);

    if (numChars < 0) {

Changes to generic/tclStringRep.h.

52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
				 * means that there is a valid Unicode rep, or
				 * that the number of UTF bytes == the number
				 * of chars. */
    int allocated;		/* The amount of space actually allocated for
				 * the UTF string (minus 1 byte for the
				 * termination char). */
    int maxChars;		/* Max number of chars that can fit in the
				 * space allocated for the unicode array. */
    int hasUnicode;		/* Boolean determining whether the string has
				 * a Unicode representation. */
    Tcl_UniChar unicode[TCLFLEXARRAY];	/* The array of Unicode chars. The actual size
				 * of this field depends on the 'maxChars'
				 * field above. */
} String;








|







52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
				 * means that there is a valid Unicode rep, or
				 * that the number of UTF bytes == the number
				 * of chars. */
    int allocated;		/* The amount of space actually allocated for
				 * the UTF string (minus 1 byte for the
				 * termination char). */
    int maxChars;		/* Max number of chars that can fit in the
				 * space allocated for the Unicode array. */
    int hasUnicode;		/* Boolean determining whether the string has
				 * a Unicode representation. */
    Tcl_UniChar unicode[TCLFLEXARRAY];	/* The array of Unicode chars. The actual size
				 * of this field depends on the 'maxChars'
				 * field above. */
} String;

Changes to generic/tclTest.c.

2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883

/*
 *----------------------------------------------------------------------
 *
 * TestgetplatformCmd --
 *
 *	This procedure implements the "testgetplatform" command. It is
 *	used to retrievel the value of the tclPlatform global variable.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *







|







2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883

/*
 *----------------------------------------------------------------------
 *
 * TestgetplatformCmd --
 *
 *	This procedure implements the "testgetplatform" command. It is
 *	used to retrieve the value of the tclPlatform global variable.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
 *	This procedure implements the "teststaticpkg" command.
 *	It is used to test the procedure Tcl_StaticPackage.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	When the packge given by argv[1] is loaded into an interpreter,
 *	variable "x" in that interpreter is set to "loaded".
 *
 *----------------------------------------------------------------------
 */

static int
TeststaticpkgCmd(







|







4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
 *	This procedure implements the "teststaticpkg" command.
 *	It is used to test the procedure Tcl_StaticPackage.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	When the package given by argv[1] is loaded into an interpreter,
 *	variable "x" in that interpreter is set to "loaded".
 *
 *----------------------------------------------------------------------
 */

static int
TeststaticpkgCmd(
7446
7447
7448
7449
7450
7451
7452
7453
7454
7455
7456
7457
7458
7459
7460
/*
 *----------------------------------------------------------------------
 *
 * TestconcatobjCmd --
 *
 *	This procedure implements the "testconcatobj" command. It is used
 *	to test that Tcl_ConcatObj does indeed return a fresh Tcl_Obj in all
 *	cases and thet it never corrupts its arguments. In other words, that
 *	[Bug 1447328] was fixed properly.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.







|







7446
7447
7448
7449
7450
7451
7452
7453
7454
7455
7456
7457
7458
7459
7460
/*
 *----------------------------------------------------------------------
 *
 * TestconcatobjCmd --
 *
 *	This procedure implements the "testconcatobj" command. It is used
 *	to test that Tcl_ConcatObj does indeed return a fresh Tcl_Obj in all
 *	cases and that it never corrupts its arguments. In other words, that
 *	[Bug 1447328] was fixed properly.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.

Changes to generic/tclTestObj.c.

620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
    for (i = 4; i < objc; i++) {
	argv[i-4] = Tcl_GetString(objv[i]);
    }
    argv[objc-4] = NULL;

    /*
     * Tcl_GetIndexFromObj assumes that the table is statically-allocated so
     * that its address is different for each index object. If we accidently
     * allocate a table at the same address as that cached in the index
     * object, clear out the object's cached state.
     */

    if (objv[3]->typePtr != NULL
	    && !strcmp("index", objv[3]->typePtr->name)) {
	indexRep = objv[3]->internalRep.twoPtrValue.ptr1;







|







620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
    for (i = 4; i < objc; i++) {
	argv[i-4] = Tcl_GetString(objv[i]);
    }
    argv[objc-4] = NULL;

    /*
     * Tcl_GetIndexFromObj assumes that the table is statically-allocated so
     * that its address is different for each index object. If we accidentally
     * allocate a table at the same address as that cached in the index
     * object, clear out the object's cached state.
     */

    if (objv[3]->typePtr != NULL
	    && !strcmp("index", objv[3]->typePtr->name)) {
	indexRep = objv[3]->internalRep.twoPtrValue.ptr1;

Changes to generic/tclThreadAlloc.c.

969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
    Cache *cachePtr,
    int bucket)
{
    Block *blockPtr;
    int n;

    /*
     * First, atttempt to move blocks from the shared cache. Note the
     * potentially dirty read of numFree before acquiring the lock which is a
     * slight performance enhancement. The value is verified after the lock is
     * actually acquired.
     */

    if (cachePtr != sharedPtr && sharedPtr->buckets[bucket].numFree > 0) {
	LockBucket(cachePtr, bucket);







|







969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
    Cache *cachePtr,
    int bucket)
{
    Block *blockPtr;
    int n;

    /*
     * First, attempt to move blocks from the shared cache. Note the
     * potentially dirty read of numFree before acquiring the lock which is a
     * slight performance enhancement. The value is verified after the lock is
     * actually acquired.
     */

    if (cachePtr != sharedPtr && sharedPtr->buckets[bucket].numFree > 0) {
	LockBucket(cachePtr, bucket);

Changes to generic/tclThreadJoin.c.

207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
}

/*
 *----------------------------------------------------------------------
 *
 * TclRememberJoinableThread --
 *
 *	This procedure remebers a thread as joinable. Only a call to
 *	TclJoinThread will remove the structre created (and initialized) here.
 *	IOW, not waiting upon a joinable thread will cause memory leaks.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Allocates memory, adds it to the global list of all joinable threads.







|
|







207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
}

/*
 *----------------------------------------------------------------------
 *
 * TclRememberJoinableThread --
 *
 *	This procedure remembers a thread as joinable. Only a call to
 *	TclJoinThread will remove the structure created (and initialized) here.
 *	IOW, not waiting upon a joinable thread will cause memory leaks.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Allocates memory, adds it to the global list of all joinable threads.

Changes to generic/tclThreadTest.c.

823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
    if (!found) {
	Tcl_MutexUnlock(&threadMutex);
	Tcl_AppendResult(interp, "invalid thread id", NULL);
	return TCL_ERROR;
    }

    /*
     * Short circut sends to ourself. Ought to do something with -async, like
     * run in an idle handler.
     */

    if (threadId == Tcl_GetCurrentThread()) {
	Tcl_MutexUnlock(&threadMutex);
	return Tcl_EvalEx(interp, script,-1,TCL_EVAL_GLOBAL);
    }







|







823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
    if (!found) {
	Tcl_MutexUnlock(&threadMutex);
	Tcl_AppendResult(interp, "invalid thread id", NULL);
	return TCL_ERROR;
    }

    /*
     * Short circuit sends to ourself. Ought to do something with -async, like
     * run in an idle handler.
     */

    if (threadId == Tcl_GetCurrentThread()) {
	Tcl_MutexUnlock(&threadMutex);
	return Tcl_EvalEx(interp, script,-1,TCL_EVAL_GLOBAL);
    }

Changes to generic/tclTrace.c.

1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
 *	function to be invoked.
 *
 * Results:
 *	A standard Tcl return value.
 *
 * Side effects:
 *	A trace is set up on the command given by cmdName, such that future
 *	changes to the command will be intermediated by proc. See the manual
 *	entry for complete details on the calling sequence for proc.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_TraceCommand(







|







1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
 *	function to be invoked.
 *
 * Results:
 *	A standard Tcl return value.
 *
 * Side effects:
 *	A trace is set up on the command given by cmdName, such that future
 *	changes to the command will be mediated by proc. See the manual
 *	entry for complete details on the calling sequence for proc.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_TraceCommand(
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
    const char *part2,		/* Name of element within array; NULL means
				 * trace applies to scalar variable or array
				 * as-a-whole. */
    int flags,			/* OR-ed collection of bits describing current
				 * trace, including any of TCL_TRACE_READS,
				 * TCL_TRACE_WRITES, TCL_TRACE_UNSETS,
				 * TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc,	/* Function assocated with trace. */
    ClientData clientData)	/* Arbitrary argument to pass to proc. */
{
    VarTrace *tracePtr;
    VarTrace *prevPtr, *nextPtr;
    Var *varPtr, *arrayPtr;
    Interp *iPtr = (Interp *) interp;
    ActiveVarTrace *activePtr;







|







2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
    const char *part2,		/* Name of element within array; NULL means
				 * trace applies to scalar variable or array
				 * as-a-whole. */
    int flags,			/* OR-ed collection of bits describing current
				 * trace, including any of TCL_TRACE_READS,
				 * TCL_TRACE_WRITES, TCL_TRACE_UNSETS,
				 * TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc,	/* Function associated with trace. */
    ClientData clientData)	/* Arbitrary argument to pass to proc. */
{
    VarTrace *tracePtr;
    VarTrace *prevPtr, *nextPtr;
    Var *varPtr, *arrayPtr;
    Interp *iPtr = (Interp *) interp;
    ActiveVarTrace *activePtr;
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
ClientData
Tcl_VarTraceInfo(
    Tcl_Interp *interp,		/* Interpreter containing variable. */
    const char *varName,	/* Name of variable; may end with "(index)" to
				 * signify an array reference. */
    int flags,			/* OR-ed combo or TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY (can be 0). */
    Tcl_VarTraceProc *proc,	/* Function assocated with trace. */
    ClientData prevClientData)	/* If non-NULL, gives last value returned by
				 * this function, so this call will return the
				 * next trace after that one. If NULL, this
				 * call will return the first trace. */
{
    return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc,
	    prevClientData);







|







3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
ClientData
Tcl_VarTraceInfo(
    Tcl_Interp *interp,		/* Interpreter containing variable. */
    const char *varName,	/* Name of variable; may end with "(index)" to
				 * signify an array reference. */
    int flags,			/* OR-ed combo or TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY (can be 0). */
    Tcl_VarTraceProc *proc,	/* Function associated with trace. */
    ClientData prevClientData)	/* If non-NULL, gives last value returned by
				 * this function, so this call will return the
				 * next trace after that one. If NULL, this
				 * call will return the first trace. */
{
    return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc,
	    prevClientData);
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
    Tcl_Interp *interp,		/* Interpreter containing variable. */
    const char *part1,		/* Name of variable or array. */
    const char *part2,		/* Name of element within array; NULL means
				 * trace applies to scalar variable or array
				 * as-a-whole. */
    int flags,			/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc,	/* Function assocated with trace. */
    ClientData prevClientData)	/* If non-NULL, gives last value returned by
				 * this function, so this call will return the
				 * next trace after that one. If NULL, this
				 * call will return the first trace. */
{
    Interp *iPtr = (Interp *) interp;
    Var *varPtr, *arrayPtr;







|







3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
    Tcl_Interp *interp,		/* Interpreter containing variable. */
    const char *part1,		/* Name of variable or array. */
    const char *part2,		/* Name of element within array; NULL means
				 * trace applies to scalar variable or array
				 * as-a-whole. */
    int flags,			/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc,	/* Function associated with trace. */
    ClientData prevClientData)	/* If non-NULL, gives last value returned by
				 * this function, so this call will return the
				 * next trace after that one. If NULL, this
				 * call will return the first trace. */
{
    Interp *iPtr = (Interp *) interp;
    Var *varPtr, *arrayPtr;
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
 *	actions.
 *
 * Results:
 *	A standard Tcl return value.
 *
 * Side effects:
 *	A trace is set up on the variable given by varName, such that future
 *	references to the variable will be intermediated by proc. See the
 *	manual entry for complete details on the calling sequence for proc.
 *     The variable's flags are updated.
 *
 *----------------------------------------------------------------------
 */

#undef Tcl_TraceVar







|







3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
 *	actions.
 *
 * Results:
 *	A standard Tcl return value.
 *
 * Side effects:
 *	A trace is set up on the variable given by varName, such that future
 *	references to the variable will be mediated by proc. See the
 *	manual entry for complete details on the calling sequence for proc.
 *     The variable's flags are updated.
 *
 *----------------------------------------------------------------------
 */

#undef Tcl_TraceVar
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
 *	actions.
 *
 * Results:
 *	A standard Tcl return value.
 *
 * Side effects:
 *	A trace is set up on the variable given by part1 and part2, such that
 *	future references to the variable will be intermediated by proc. See
 *	the manual entry for complete details on the calling sequence for
 *	proc. The variable's flags are updated.
 *
 *----------------------------------------------------------------------
 */

int







|







3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
 *	actions.
 *
 * Results:
 *	A standard Tcl return value.
 *
 * Side effects:
 *	A trace is set up on the variable given by part1 and part2, such that
 *	future references to the variable will be mediated by proc. See
 *	the manual entry for complete details on the calling sequence for
 *	proc. The variable's flags are updated.
 *
 *----------------------------------------------------------------------
 */

int
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
 *	actions.
 *
 * Results:
 *	A standard Tcl return value.
 *
 * Side effects:
 *	A trace is set up on the variable given by part1 and part2, such that
 *	future references to the variable will be intermediated by the
 *	traceProc listed in tracePtr. See the manual entry for complete
 *	details on the calling sequence for proc.
 *
 *----------------------------------------------------------------------
 */

static int







|







3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
 *	actions.
 *
 * Results:
 *	A standard Tcl return value.
 *
 * Side effects:
 *	A trace is set up on the variable given by part1 and part2, such that
 *	future references to the variable will be mediated by the
 *	traceProc listed in tracePtr. See the manual entry for complete
 *	details on the calling sequence for proc.
 *
 *----------------------------------------------------------------------
 */

static int

Changes to generic/tclUtf.c.

1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharNcasecmp(
    const Tcl_UniChar *ucs,	/* Unicode string to compare to uct. */
    const Tcl_UniChar *uct,	/* Unicode string ucs is compared to. */
    unsigned long numChars)	/* Number of unichars to compare. */
{
    for ( ; numChars != 0; numChars--, ucs++, uct++) {
	if (*ucs != *uct) {
	    Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs);
	    Tcl_UniChar lct = Tcl_UniCharToLower(*uct);

	    if (lcs != lct) {







|







1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharNcasecmp(
    const Tcl_UniChar *ucs,	/* Unicode string to compare to uct. */
    const Tcl_UniChar *uct,	/* Unicode string ucs is compared to. */
    unsigned long numChars)	/* Number of Unichars to compare. */
{
    for ( ; numChars != 0; numChars--, ucs++, uct++) {
	if (*ucs != *uct) {
	    Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs);
	    Tcl_UniChar lct = Tcl_UniCharToLower(*uct);

	    if (lcs != lct) {

Changes to generic/tclUtil.c.

1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238

#if COMPAT
	if (preferEscape && !preferBrace) {
	    /*
	     * If we are quoting solely due to ] or internal " characters use
	     * the CONVERT_MASK mode where we escape all special characters
	     * except for braces. "extra" counted space needed to escape
	     * braces too, so substract "braceCount" to get our actual needs.
	     */

	    bytesNeeded += (extra - braceCount);
	    /* Make room to escape leading #, if needed. */
	    if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
		bytesNeeded++;
	    }







|







1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238

#if COMPAT
	if (preferEscape && !preferBrace) {
	    /*
	     * If we are quoting solely due to ] or internal " characters use
	     * the CONVERT_MASK mode where we escape all special characters
	     * except for braces. "extra" counted space needed to escape
	     * braces too, so subtract "braceCount" to get our actual needs.
	     */

	    bytesNeeded += (extra - braceCount);
	    /* Make room to escape leading #, if needed. */
	    if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
		bytesNeeded++;
	    }
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
    }

  slow:
    /*
     * Something cannot be determined to be safe, so build the concatenation
     * the slow way, using the string representations.
     *
     * First try to pre-allocate the size required.
     */

    for (i = 0;  i < objc;  i++) {
	element = TclGetStringFromObj(objv[i], &elemLength);
	bytesNeeded += elemLength;
	if (bytesNeeded < 0) {
	    break;







|







2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
    }

  slow:
    /*
     * Something cannot be determined to be safe, so build the concatenation
     * the slow way, using the string representations.
     *
     * First try to preallocate the size required.
     */

    for (i = 0;  i < objc;  i++) {
	element = TclGetStringFromObj(objv[i], &elemLength);
	bytesNeeded += elemLength;
	if (bytesNeeded < 0) {
	    break;

Changes to generic/tclVar.c.

592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
		goto donePart1;
	    }
	}
	goto doneParsing;
    }

    /*
     * If part1Ptr is a tclParsedVarNameType, separate it into the pre-parsed
     * parts.
     */

    if (typePtr == &tclParsedVarNameType) {
	if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) {
	    if (part2Ptr != NULL) {
		/*







|







592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
		goto donePart1;
	    }
	}
	goto doneParsing;
    }

    /*
     * If part1Ptr is a tclParsedVarNameType, separate it into the preparsed
     * parts.
     */

    if (typePtr == &tclParsedVarNameType) {
	if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) {
	    if (part2Ptr != NULL) {
		/*
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
 *
 *	If the current CallFrame corresponds to a proc and the variable found
 *	is one of the compiledLocals, its index is placed in *indexPtr.
 *	Otherwise, *indexPtr will be set to (according to the needs of
 *	TclObjLookupVar):
 *	    -1 a global reference
 *	    -2 a reference to a namespace variable
 *	    -3 a non-cachable reference, i.e., one of:
 *		. non-indexed local var
 *		. a reference of unknown origin;
 *		. resolution by a namespace or interp resolver
 *
 *	If the variable isn't found and creation wasn't specified, or some
 *	other error occurs, NULL is returned and the corresponding error
 *	message is left in *errMsgPtr.







|







790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
 *
 *	If the current CallFrame corresponds to a proc and the variable found
 *	is one of the compiledLocals, its index is placed in *indexPtr.
 *	Otherwise, *indexPtr will be set to (according to the needs of
 *	TclObjLookupVar):
 *	    -1 a global reference
 *	    -2 a reference to a namespace variable
 *	    -3 a non-cacheable reference, i.e., one of:
 *		. non-indexed local var
 *		. a reference of unknown origin;
 *		. resolution by a namespace or interp resolver
 *
 *	If the variable isn't found and creation wasn't specified, or some
 *	other error occurs, NULL is returned and the corresponding error
 *	message is left in *errMsgPtr.

Changes to generic/tclZlib.c.

1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
    }

    if (e != Z_OK) {
	goto error;
    }

    /*
     * Reduce the bytearray length to the actual data length produced by
     * deflate.
     */

    Tcl_SetByteArrayLength(obj, stream.total_out);
    Tcl_SetObjResult(interp, obj);
    return TCL_OK;








|







1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
    }

    if (e != Z_OK) {
	goto error;
    }

    /*
     * Reduce the ByteArray length to the actual data length produced by
     * deflate.
     */

    Tcl_SetByteArrayLength(obj, stream.total_out);
    Tcl_SetObjResult(interp, obj);
    return TCL_OK;

Changes to library/auto.tcl.

115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
	if {0} {
	    lappend dirs [file join $grandParentDir library]
	    lappend dirs [file join $grandParentDir $basename$patch library]
	    lappend dirs [file join [file dirname $grandParentDir] \
			      $basename$patch library]
	}
    }
    # uniquify $dirs in order
    array set seen {}
    foreach i $dirs {
	# Make sure $i is unique under normalization. Avoid repeated [source].
	if {[interp issafe]} {
	    # Safe interps have no [file normalize].
	    set norm $i
	} else {







|







115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
	if {0} {
	    lappend dirs [file join $grandParentDir library]
	    lappend dirs [file join $grandParentDir $basename$patch library]
	    lappend dirs [file join [file dirname $grandParentDir] \
			      $basename$patch library]
	}
    }
    # make $dirs unique, preserving order
    array set seen {}
    foreach i $dirs {
	# Make sure $i is unique under normalization. Avoid repeated [source].
	if {[interp issafe]} {
	    # Safe interps have no [file normalize].
	    set norm $i
	} else {
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
	    # interp.  Put it back, but move it out of the way.

	    $parser expose namespace
	    $parser invokehidden rename namespace _%@namespace
	    $parser expose eval
	    $parser invokehidden rename eval _%@eval

	    # Install all the registered psuedo-command implementations

	    foreach cmd $initCommands {
		eval $cmd
	    }
	}
    }
    proc cleanup {} {







|







313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
	    # interp.  Put it back, but move it out of the way.

	    $parser expose namespace
	    $parser invokehidden rename namespace _%@namespace
	    $parser expose eval
	    $parser invokehidden rename eval _%@eval

	    # Install all the registered pseudo-command implementations

	    foreach cmd $initCommands {
		eval $cmd
	    }
	}
    }
    proc cleanup {} {
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
    } on ok {} {
	if {[namespace which -command tbcload::bcproc] eq ""} {
	    auto_load tbcload::bcproc
	}
	load {} tbcload $auto_mkindex_parser::parser

	# AUTO MKINDEX:  tbcload::bcproc name arglist body
	# Adds an entry to the auto index list for the given pre-compiled
	# procedure name.

	auto_mkindex_parser::commandInit tbcload::bcproc {name args} {
	    indexEntry $name
	}
    }
}







|







566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
    } on ok {} {
	if {[namespace which -command tbcload::bcproc] eq ""} {
	    auto_load tbcload::bcproc
	}
	load {} tbcload $auto_mkindex_parser::parser

	# AUTO MKINDEX:  tbcload::bcproc name arglist body
	# Adds an entry to the auto index list for the given precompiled
	# procedure name.

	auto_mkindex_parser::commandInit tbcload::bcproc {name args} {
	    indexEntry $name
	}
    }
}
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
		catch {
		    set name [dict get [lrange $args 1 end] -command]
		    if {![string match ::* $name]} {
			set name ::[join [lreverse $contextStack] ::]$name
		    }
		    regsub -all ::+ $name :: name
		}
		# create artifical proc to force an entry in the tclIndex
		$parser eval [list ::proc $name {} {}]
	    }
	}
    }
}

# AUTO MKINDEX:  oo::class create name ?definition?







|







621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
		catch {
		    set name [dict get [lrange $args 1 end] -command]
		    if {![string match ::* $name]} {
			set name ::[join [lreverse $contextStack] ::]$name
		    }
		    regsub -all ::+ $name :: name
		}
		# create artificial proc to force an entry in the tclIndex
		$parser eval [list ::proc $name {} {}]
	    }
	}
    }
}

# AUTO MKINDEX:  oo::class create name ?definition?

Changes to library/clock.tcl.

2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
# Parameters:
#	locale -- Desired locale
#
# Results:
#	Returns the locale that was previously current.
#
# Side effects:
#	Does [mclocale].  If necessary, loades the designated locale's files.
#
#----------------------------------------------------------------------

proc ::tcl::clock::EnterLocale { locale } {
    if { $locale eq {system} } {
	if { $::tcl_platform(platform) ne {windows} } {
	    # On a non-windows platform, the 'system' locale is the same as







|







2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
# Parameters:
#	locale -- Desired locale
#
# Results:
#	Returns the locale that was previously current.
#
# Side effects:
#	Does [mclocale].  If necessary, loads the designated locale's files.
#
#----------------------------------------------------------------------

proc ::tcl::clock::EnterLocale { locale } {
    if { $locale eq {system} } {
	if { $::tcl_platform(platform) ne {windows} } {
	    # On a non-windows platform, the 'system' locale is the same as
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
#
# ParseStarDate --
#
#	Parses a StarDate
#
# Parameters:
#	year - Year from the Roddenberry epoch
#	fractYear - Fraction of a year specifiying the day of year.
#	fractDay - Fraction of a day
#
# Results:
#	Returns a count of seconds from the Posix epoch.
#
# Side effects:
#	None.







|







2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
#
# ParseStarDate --
#
#	Parses a StarDate
#
# Parameters:
#	year - Year from the Roddenberry epoch
#	fractYear - Fraction of a year specifying the day of year.
#	fractDay - Fraction of a day
#
# Results:
#	Returns a count of seconds from the Posix epoch.
#
# Side effects:
#	None.
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
# Parameters:
#	None.
#
# Results:
#	Returns the system time zone.
#
# Side effects:
#	Stores the sustem time zone in the 'CachedSystemTimeZone'
#	variable, since determining it may be an expensive process.
#
#----------------------------------------------------------------------

proc ::tcl::clock::GetSystemTimeZone {} {
    variable CachedSystemTimeZone
    variable TimeZoneBad







|







2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
# Parameters:
#	None.
#
# Results:
#	Returns the system time zone.
#
# Side effects:
#	Stores the system time zone in the 'CachedSystemTimeZone'
#	variable, since determining it may be an expensive process.
#
#----------------------------------------------------------------------

proc ::tcl::clock::GetSystemTimeZone {} {
    variable CachedSystemTimeZone
    variable TimeZoneBad
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411

    set f [open $fname r]
    fconfigure $f -translation binary
    set d [read $f]
    close $f

    # The file begins with a magic number, sixteen reserved bytes, and then
    # six 4-byte integers giving counts of fileds in the file.

    binary scan $d a4a1x15IIIIII \
	magic version nIsGMT nIsStd nLeap nTime nType nChar
    set seek 44
    set ilen 4
    set iformat I
    if { $magic != {TZif} } {







|







3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411

    set f [open $fname r]
    fconfigure $f -translation binary
    set d [read $f]
    close $f

    # The file begins with a magic number, sixteen reserved bytes, and then
    # six 4-byte integers giving counts of fields in the file.

    binary scan $d a4a1x15IIIIII \
	magic version nIsGMT nIsStd nLeap nTime nType nChar
    set seek 44
    set ilen 4
    set iformat I
    if { $magic != {TZif} } {

Changes to library/history.tcl.

264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
    } else {
	set i $event
    }
    if {$i <= $history(oldest)} {
	return -code error "event \"$event\" is too far in the past"
    }
    if {$i > $history(nextid)} {
	return -code error "event \"$event\" hasn't occured yet"
    }
    return $i
}

# tcl::HistEvent --
#
#	Map from an event specifier to the value in the history list.







|







264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
    } else {
	set i $event
    }
    if {$i <= $history(oldest)} {
	return -code error "event \"$event\" is too far in the past"
    }
    if {$i > $history(nextid)} {
	return -code error "event \"$event\" hasn't occurred yet"
    }
    return $i
}

# tcl::HistEvent --
#
#	Map from an event specifier to the value in the history list.

Changes to library/http/http.tcl.

2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
#
#	Garbage collect the state associated with a transaction
#
# Arguments
#	token	The token returned from http::geturl
#
# Side Effects
#	unsets the state array

proc http::cleanup {token} {
    variable $token
    upvar 0 $token state
    if {[info commands ${token}EventCoroutine] ne {}} {
	rename ${token}EventCoroutine {}
    }
    if {[info exists state(after)]} {
	after cancel $state(after)
	unset state(after)
    }
    if {[info exists state]} {
	unset state
    }
}

# http::Connect
#
#	This callback is made when an asyncronous connection completes.
#
# Arguments
#	token	The token returned from http::geturl
#
# Side Effects
#	Sets the status of the connection, which unblocks
# 	the waiting geturl call







|


















|







2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
#
#	Garbage collect the state associated with a transaction
#
# Arguments
#	token	The token returned from http::geturl
#
# Side Effects
#	Unsets the state array.

proc http::cleanup {token} {
    variable $token
    upvar 0 $token state
    if {[info commands ${token}EventCoroutine] ne {}} {
	rename ${token}EventCoroutine {}
    }
    if {[info exists state(after)]} {
	after cancel $state(after)
	unset state(after)
    }
    if {[info exists state]} {
	unset state
    }
}

# http::Connect
#
#	This callback is made when an asynchronous connection completes.
#
# Arguments
#	token	The token returned from http::geturl
#
# Side Effects
#	Sets the status of the connection, which unblocks
# 	the waiting geturl call
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260

# http::CopyDone
#
#	fcopy completion callback
#
# Arguments
#	token	The token returned from http::geturl
#	count	The amount transfered
#
# Side Effects
#	Invokes callbacks

proc http::CopyDone {token count {error {}}} {
    variable $token
    upvar 0 $token state







|







3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260

# http::CopyDone
#
#	fcopy completion callback
#
# Arguments
#	token	The token returned from http::geturl
#	count	The amount transferred
#
# Side Effects
#	Invokes callbacks

proc http::CopyDone {token count {error {}}} {
    variable $token
    upvar 0 $token state
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
#
# Arguments
#	token	The token returned from http::geturl
#	force	(previously) optional, has no effect
#	reason	- "eof" means premature EOF (not EOF as the natural end of
#		  the response)
#		- "" means completion of response, with or without EOF
#		- anything else describes an error confition other than
#		  premature EOF.
#
# Side Effects
#	Clean up the socket

proc http::Eot {token {reason {}}} {
    variable $token







|







3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
#
# Arguments
#	token	The token returned from http::geturl
#	force	(previously) optional, has no effect
#	reason	- "eof" means premature EOF (not EOF as the natural end of
#		  the response)
#		- "" means completion of response, with or without EOF
#		- anything else describes an error condition other than
#		  premature EOF.
#
# Side Effects
#	Clean up the socket

proc http::Eot {token {reason {}}} {
    variable $token

Changes to library/init.tcl.

196
197
198
199
200
201
202
203
204
205
206
207
208
209
210

    # Some machines do not have exec. Also, on all
    # platforms, safe interpreters do not have exec.

    set auto_noexec 1
}

# Define a log command (which can be overwitten to log errors
# differently, specially when stderr is not available)

if {[namespace which -command tclLog] eq ""} {
    proc tclLog {string} {
	catch {puts stderr $string}
    }
}







|







196
197
198
199
200
201
202
203
204
205
206
207
208
209
210

    # Some machines do not have exec. Also, on all
    # platforms, safe interpreters do not have exec.

    set auto_noexec 1
}

# Define a log command (which can be overwritten to log errors
# differently, specially when stderr is not available)

if {[namespace which -command tclLog] eq ""} {
    proc tclLog {string} {
	catch {puts stderr $string}
    }
}

Changes to library/msgcat/msgcat.tcl.

28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
    variable LoadedLocales {}

    # Records the locale of the currently sourced message catalogue file
    variable FileLocale

    # Configuration values per Package (e.g. client namespace).
    # The dict key is of the form "<option> <namespace>" and the value is the
    # configuration option. A nonexisting key is an unset option.
    variable PackageConfig [dict create mcfolder {} loadcmd {} changecmd {}\
	    unknowncmd {} loadedlocales {} loclist {}]

    # Records the mapping between source strings and translated strings.  The
    # dict key is of the form "<namespace> <locale> <src>", where locale and
    # namespace should be themselves dict values and the value is
    # the translated string.







|







28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
    variable LoadedLocales {}

    # Records the locale of the currently sourced message catalogue file
    variable FileLocale

    # Configuration values per Package (e.g. client namespace).
    # The dict key is of the form "<option> <namespace>" and the value is the
    # configuration option. A non-existing key is an unset option.
    variable PackageConfig [dict create mcfolder {} loadcmd {} changecmd {}\
	    unknowncmd {} loadedlocales {} loclist {}]

    # Records the mapping between source strings and translated strings.  The
    # dict key is of the form "<namespace> <locale> <src>", where locale and
    # namespace should be themselves dict values and the value is
    # the translated string.
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
}

# msgcat::mc --
#
#	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
#	string.
#	If no catalog item is found, mcunknown is called in the caller frame
#	and its result is returned.
#
# Arguments:
#	src	The string to translate.
#	args	Args to pass to the format command







|







175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
}

# msgcat::mc --
#
#	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 translated
#	string.
#	If no catalog item is found, mcunknown is called in the caller frame
#	and its result is returned.
#
# Arguments:
#	src	The string to translate.
#	args	Args to pass to the format command
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
#	    unset	Clear option. return "".
#
#	Available options are:
#
#	mcfolder
#	    The message catalog folder of the package.
#	    This is automatically set by mcload.
#	    If the value is changed using the set subcommand, an evntual
#	    loadcmd is invoked and all message files of the package locale are
#	    loaded.
#
#	loadcmd
#	    The command gets executed before a message file would be
#	    sourced for this module.
#	    The command is invoked with the expanded locale list to load.







|







574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
#	    unset	Clear option. return "".
#
#	Available options are:
#
#	mcfolder
#	    The message catalog folder of the package.
#	    This is automatically set by mcload.
#	    If the value is changed using the set subcommand, an eventual
#	    loadcmd is invoked and all message files of the package locale are
#	    loaded.
#
#	loadcmd
#	    The command gets executed before a message file would be
#	    sourced for this module.
#	    The command is invoked with the expanded locale list to load.
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
#
#	This routine is called by msgcat::mc if a translation cannot
#	be found for a string and no unknowncmd is set for the current
#	package. This routine is intended to be replaced
#	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.
#
# Arguments:
#	locale		The current locale.
#	src		The string to be translated.
#	args		Args to pass to the format command
#
# Results:
#	Returns the translated value.

proc msgcat::mcunknown {args} {
    return [uplevel 1 [list [namespace origin DefaultUnknown] {*}$args]]
}

# msgcat::DefaultUnknown --
#
#	This routine is called by msgcat::mc if a translation cannot
#	be found for a string in the following circumstances:
#	- 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.
#	If additional args are specified, the format command will be used
#	to work them into the traslated string.
#
# Arguments:
#	locale		(unused) The current locale.
#	src		The string to be translated.
#	args		Args to pass to the format command
#
# Results:







|




















|

|







1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
#
#	This routine is called by msgcat::mc if a translation cannot
#	be found for a string and no unknowncmd is set for the current
#	package. This routine is intended to be replaced
#	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 translated string.
#
# Arguments:
#	locale		The current locale.
#	src		The string to be translated.
#	args		Args to pass to the format command
#
# Results:
#	Returns the translated value.

proc msgcat::mcunknown {args} {
    return [uplevel 1 [list [namespace origin DefaultUnknown] {*}$args]]
}

# msgcat::DefaultUnknown --
#
#	This routine is called by msgcat::mc if a translation cannot
#	be found for a string in the following circumstances:
#	- Default global handler, if mcunknown is not redefined.
#	- Per package handler, if the package sets unknowncmd to the empty
#	  string.
#	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 translated string.
#
# Arguments:
#	locale		(unused) The current locale.
#	src		The string to be translated.
#	args		Args to pass to the format command
#
# Results:

Changes to library/opt/optparse.tcl.

71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
    # Array storing the parsed descriptions
    variable OptDesc
    array set OptDesc {}
    # Next potentially free key id (numeric)
    variable OptDescN 0

# Inside algorithm/mechanism description:
# (not for the faint hearted ;-)
#
# The argument description is parsed into a "program tree"
# It is called a "program" because it is the program used by
# the state machine interpreter that use that program to
# actually parse the arguments at run time.
#
# The general structure of a "program" is







|







71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
    # Array storing the parsed descriptions
    variable OptDesc
    array set OptDesc {}
    # Next potentially free key id (numeric)
    variable OptDescN 0

# Inside algorithm/mechanism description:
# (not for the faint-hearted ;-)
#
# The argument description is parsed into a "program tree"
# It is called a "program" because it is the program used by
# the state machine interpreter that use that program to
# actually parse the arguments at run time.
#
# The general structure of a "program" is
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146

# Performance/Implementation issues
# ---------------------------------
# We use tcl lists instead of arrays because with tcl8.0
# they should start to be much faster.
# But this code use a lot of helper procs (like Lvarset)
# which are quite slow and would be helpfully optimized
# for instance by being written in C. Also our struture
# is complex and there is maybe some places where the
# string rep might be calculated at great exense. to be checked.

#
# Parse a given description and saves it here under the given key
# generate a unused keyid if not given
#
proc ::tcl::OptKeyRegister {desc {key ""}} {
    variable OptDesc







|

|







130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146

# Performance/Implementation issues
# ---------------------------------
# We use tcl lists instead of arrays because with tcl8.0
# they should start to be much faster.
# But this code use a lot of helper procs (like Lvarset)
# which are quite slow and would be helpfully optimized
# for instance by being written in C. Also our structure
# is complex and there is maybe some places where the
# string rep might be calculated at great expense. to be checked.

#
# Parse a given description and saves it here under the given key
# generate a unused keyid if not given
#
proc ::tcl::OptKeyRegister {desc {key ""}} {
    variable OptDesc
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
        variable OptDesc
        if {![info exists OptDesc($descKey)]} {
            return -code error "Unknown option description key \"$descKey\""
        }
        set OptDesc($descKey)
    }

# Parse entry point for ppl who don't want to register with a key,
# for instance because the description changes dynamically.
#  (otherwise one should really use OptKeyRegister once + OptKeyParse
#   as it is way faster or simply OptProc which does it all)
# Assign a temporary key, call OptKeyParse and then free the storage
proc ::tcl::OptParse {desc arglist} {
    set tempkey [OptKeyRegister $desc]
    set ret [catch {uplevel 1 [list ::tcl::OptKeyParse $tempkey $arglist]} res]







|







222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
        variable OptDesc
        if {![info exists OptDesc($descKey)]} {
            return -code error "Unknown option description key \"$descKey\""
        }
        set OptDesc($descKey)
    }

# Parse entry point for people who don't want to register with a key,
# for instance because the description changes dynamically.
#  (otherwise one should really use OptKeyRegister once + OptKeyParse
#   as it is way faster or simply OptProc which does it all)
# Assign a temporary key, call OptKeyParse and then free the storage
proc ::tcl::OptParse {desc arglist} {
    set tempkey [OptKeyRegister $desc]
    set ret [catch {uplevel 1 [list ::tcl::OptKeyParse $tempkey $arglist]} res]
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
	set item [lindex $descriptions $adress]
	if {[OptIsPrg $item]} {
	    return [OptCurAddr $item $start]
	} else {
	    return $start
	}
    }
    # Set the value field of the current instruction
    proc OptCurSetValue {descriptionsName value} {
	upvar $descriptionsName descriptions
	# get the current item full adress
        set adress [OptCurAddr $descriptions]
	# use the 3th field of the item  (see OptValue / OptNewInst)
	lappend adress 2
	Lvarset descriptions $adress [list 1 $value]
	#                                  ^hasBeenSet flag
    }

    # empty state means done/paste the end of the program
    proc OptState {item} {
        lindex $item 0
    }

    # current state
    proc OptCurState {descriptions} {
        OptState [OptCurDesc $descriptions]
    }

    #######
    # Arguments manipulation

    # Returns the argument that has to be processed now
    proc OptCurrentArg {lst} {
        lindex $lst 0
    }
    # Advance to next argument
    proc OptNextArg {argsName} {
        uplevel 1 [list Lvarpop1 $argsName]
    }
    #######










|


|

|





|












|



|







324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
	set item [lindex $descriptions $adress]
	if {[OptIsPrg $item]} {
	    return [OptCurAddr $item $start]
	} else {
	    return $start
	}
    }
    # Set the value field of the current instruction.
    proc OptCurSetValue {descriptionsName value} {
	upvar $descriptionsName descriptions
	# Get the current item full address.
        set adress [OptCurAddr $descriptions]
	# Use the 3rd field of the item  (see OptValue / OptNewInst).
	lappend adress 2
	Lvarset descriptions $adress [list 1 $value]
	#                                  ^hasBeenSet flag
    }

    # Empty state means done/paste the end of the program.
    proc OptState {item} {
        lindex $item 0
    }

    # current state
    proc OptCurState {descriptions} {
        OptState [OptCurDesc $descriptions]
    }

    #######
    # Arguments manipulation

    # Returns the argument that has to be processed now.
    proc OptCurrentArg {lst} {
        lindex $lst 0
    }
    # Advance to next argument.
    proc OptNextArg {argsName} {
        uplevel 1 [list Lvarpop1 $argsName]
    }
    #######



549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
		set vnamesLst [OptTreeVars $item $level $vnamesLst]
	    } else {
		set vname [OptVarName $item]
		upvar $level $vname var
		if {[OptHasBeenSet $item]} {
#		    puts "adding $vname"
		    # lets use the input name for the returned list
		    # it is more usefull, for instance you can check that
		    # no flags at all was given with expr
		    # {![string match "*-*" $Args]}
		    lappend vnamesLst [OptName $item]
		    set var [OptValue $item]
		} else {
		    set var [OptDefaultValue $item]
		}







|







549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
		set vnamesLst [OptTreeVars $item $level $vnamesLst]
	    } else {
		set vname [OptVarName $item]
		upvar $level $vname var
		if {[OptHasBeenSet $item]} {
#		    puts "adding $vname"
		    # lets use the input name for the returned list
		    # it is more useful, for instance you can check that
		    # no flags at all was given with expr
		    # {![string match "*-*" $Args]}
		    lappend vnamesLst [OptName $item]
		    set var [OptValue $item]
		} else {
		    set var [OptDefaultValue $item]
		}

Changes to library/package.tcl.

65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
# Arguments:
# -direct		(optional) If this flag is present, the generated
#			code in pkgMkIndex.tcl will cause the package to be
#			loaded when "package require" is executed, rather
#			than lazily when the first reference to an exported
#			procedure in the package is made.
# -verbose		(optional) Verbose output; the name of each file that
#			was successfully rocessed is printed out. Additionally,
#			if processing of a file failed a message is printed.
# -load pat		(optional) Preload any packages whose names match
#			the pattern.  Used to handle DLLs that depend on
#			other packages during their Init procedure.
# dir -			Name of the directory in which to create the index.
# args -		Any number of additional arguments, each giving
#			a glob pattern that matches the names of one or







|







65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
# Arguments:
# -direct		(optional) If this flag is present, the generated
#			code in pkgMkIndex.tcl will cause the package to be
#			loaded when "package require" is executed, rather
#			than lazily when the first reference to an exported
#			procedure in the package is made.
# -verbose		(optional) Verbose output; the name of each file that
#			was successfully processed is printed out. Additionally,
#			if processing of a file failed a message is printed.
# -load pat		(optional) Preload any packages whose names match
#			the pattern.  Used to handle DLLs that depend on
#			other packages during their Init procedure.
# dir -			Name of the directory in which to create the index.
# args -		Any number of additional arguments, each giving
#			a glob pattern that matches the names of one or
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
		    }
		}
	    }
	    proc tclPkgUnknown args {}
	    package unknown tclPkgUnknown

	    # Stub out the unknown command so package can call into each other
	    # during their initialilzation.

	    proc unknown {args} {}

	    # Stub out the auto_import mechanism

	    proc auto_import {args} {}








|







202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
		    }
		}
	    }
	    proc tclPkgUnknown args {}
	    package unknown tclPkgUnknown

	    # Stub out the unknown command so package can call into each other
	    # during their initialization.

	    proc unknown {args} {}

	    # Stub out the auto_import mechanism

	    proc auto_import {args} {}

716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
	error [format $err(valueMissing) "-version"]
    }

    if {!([llength $opts(-source)] || [llength $opts(-load)])} {
	error $err(noLoadOrSource)
    }

    # OK, now everything is good.  Generate the package ifneeded statment.
    set cmdline "package ifneeded $opts(-name) $opts(-version) "

    set cmdList {}
    set lazyFileList {}

    # Handle -load and -source specs
    foreach key {load source} {







|







716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
	error [format $err(valueMissing) "-version"]
    }

    if {!([llength $opts(-source)] || [llength $opts(-load)])} {
	error $err(noLoadOrSource)
    }

    # OK, now everything is good.  Generate the package ifneeded statement.
    set cmdline "package ifneeded $opts(-name) $opts(-version) "

    set cmdList {}
    set lazyFileList {}

    # Handle -load and -source specs
    foreach key {load source} {

Changes to library/platform/platform.tcl.

261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
    upvar 1 $vv v
    set libclist [lsort [glob -nocomplain -directory $base libc*]]

    if {![llength $libclist]} { return 0 }

    set libc [lindex $libclist 0]

    # Try executing the library first. This should suceed
    # for a glibc library, and return the version
    # information.

    if {![catch {
	set vdata [lindex [split [exec $libc] \n] 0]
    }]} {
	regexp {version ([0-9]+(\.[0-9]+)*)} $vdata -> v







|







261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
    upvar 1 $vv v
    set libclist [lsort [glob -nocomplain -directory $base libc*]]

    if {![llength $libclist]} { return 0 }

    set libc [lindex $libclist 0]

    # Try executing the library first. This should succeed
    # for a glibc library, and return the version
    # information.

    if {![catch {
	set vdata [lindex [split [exec $libc] \n] 0]
    }]} {
	regexp {version ([0-9]+(\.[0-9]+)*)} $vdata -> v

Changes to library/platform/shell.tcl.

23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
proc ::platform::shell::generic {shell} {
    # Argument is the path to a tcl shell.

    CHECK $shell
    LOCATE base out

    set     code {}
    # Forget any pre-existing platform package, it might be in
    # conflict with this one.
    lappend code {package forget platform}
    # Inject our platform package
    lappend code [list source $base]
    # Query and print the architecture
    lappend code {puts [platform::generic]}
    # And done







|







23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
proc ::platform::shell::generic {shell} {
    # Argument is the path to a tcl shell.

    CHECK $shell
    LOCATE base out

    set     code {}
    # Forget any preexisting platform package, it might be in
    # conflict with this one.
    lappend code {package forget platform}
    # Inject our platform package
    lappend code [list source $base]
    # Query and print the architecture
    lappend code {puts [platform::generic]}
    # And done
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
proc ::platform::shell::identify {shell} {
    # Argument is the path to a tcl shell.

    CHECK $shell
    LOCATE base out

    set     code {}
    # Forget any pre-existing platform package, it might be in
    # conflict with this one.
    lappend code {package forget platform}
    # Inject our platform package
    lappend code [list source $base]
    # Query and print the architecture
    lappend code {puts [platform::identify]}
    # And done







|







48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
proc ::platform::shell::identify {shell} {
    # Argument is the path to a tcl shell.

    CHECK $shell
    LOCATE base out

    set     code {}
    # Forget any preexisting platform package, it might be in
    # conflict with this one.
    lappend code {package forget platform}
    # Inject our platform package
    lappend code [list source $base]
    # Query and print the architecture
    lappend code {puts [platform::identify]}
    # And done
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
    return
}

proc ::platform::shell::LOCATE {bv ov} {
    upvar 1 $bv base $ov out

    # Locate the platform package for injection into the specified
    # shell. We are using package management to find it, whereever it
    # is, instead of using hardwired relative paths. This allows us to
    # install the two packages as TMs without breaking the code
    # here. If the found package is wrapped we copy the code somewhere
    # where the spawned shell will be able to read it.

    # This code is brittle, it needs has to adapt to whatever changes
    # are made to the TM code, i.e. the provide statement generated by
    # tm.tcl

    set pl [package ifneeded platform [package require platform]]
    set base [lindex $pl end]

    set out 0
    if {[lindex [file system $base]] ne "native"} {







|






|







95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
    return
}

proc ::platform::shell::LOCATE {bv ov} {
    upvar 1 $bv base $ov out

    # Locate the platform package for injection into the specified
    # shell. We are using package management to find it, wherever it
    # is, instead of using hardwired relative paths. This allows us to
    # install the two packages as TMs without breaking the code
    # here. If the found package is wrapped we copy the code somewhere
    # where the spawned shell will be able to read it.

    # This code is brittle, it needs has to adapt to whatever changes
    # are made to the TM code, i.e. the "provide" statement generated by
    # tm.tcl

    set pl [package ifneeded platform [package require platform]]
    set base [lindex $pl end]

    set out 0
    if {[lindex [file system $base]] ne "native"} {

Changes to library/safe.tcl.

165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
		-deleteHook {
		    return [list -deleteHook $state(cleanupHook)]
		}
		-noStatics {
		    # it is most probably a set in fact but we would need
		    # then to jump to the set part and it is not *sure*
		    # that it is a set action that the user want, so force
		    # it to use the unambigous -statics ?value? instead:
		    return -code error\
			"ambigous query (get or set -noStatics ?)\
				use -statics instead"
		}
		-nestedLoadOk {
		    return -code error\
			"ambigous query (get or set -nestedLoadOk ?)\







|







165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
		-deleteHook {
		    return [list -deleteHook $state(cleanupHook)]
		}
		-noStatics {
		    # it is most probably a set in fact but we would need
		    # then to jump to the set part and it is not *sure*
		    # that it is a set action that the user want, so force
		    # it to use the unambiguous -statics ?value? instead:
		    return -code error\
			"ambigous query (get or set -noStatics ?)\
				use -statics instead"
		}
		-nestedLoadOk {
		    return -code error\
			"ambigous query (get or set -nestedLoadOk ?)\
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
		set nested     $state(nestedok)
	    }
	    if {![::tcl::OptProcArgGiven -deleteHook]} {
		set deleteHook $state(cleanupHook)
	    }
	    # we can now reconfigure :
	    InterpSetConfig $slave $accessPath $statics $nested $deleteHook
	    # auto_reset the child (to completly synch the new access_path)
	    if {$doreset} {
		if {[catch {::interp eval $slave {auto_reset}} msg]} {
		    Log $slave "auto_reset failed: $msg"
		} else {
		    Log $slave "successful auto_reset" NOTICE
		}








|







216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
		set nested     $state(nestedok)
	    }
	    if {![::tcl::OptProcArgGiven -deleteHook]} {
		set deleteHook $state(cleanupHook)
	    }
	    # we can now reconfigure :
	    InterpSetConfig $slave $accessPath $statics $nested $deleteHook
	    # auto_reset the child (to completely synch the new access_path)
	    if {$doreset} {
		if {[catch {::interp eval $slave {auto_reset}} msg]} {
		    Log $slave "auto_reset failed: $msg"
		} else {
		    Log $slave "successful auto_reset" NOTICE
		}

328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
	    set access_path [linsert \
				 [lreplace $access_path $where $where] \
				 0 [info library]]
	    Log $child "tcl_libray was not in first in auto_path,\
			moved it to front of slave's access_path" NOTICE
	}

	# Add 1st level sub dirs (will searched by auto loading from tcl
	# code in the child using glob and thus fail, so we add them here
	# so by default it works the same).
	set access_path [AddSubDirs $access_path]
    }

    Log $child "Setting accessPath=($access_path) staticsok=$staticsok\
		nestedok=$nestedok deletehook=($deletehook)" NOTICE







|







328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
	    set access_path [linsert \
				 [lreplace $access_path $where $where] \
				 0 [info library]]
	    Log $child "tcl_libray was not in first in auto_path,\
			moved it to front of slave's access_path" NOTICE
	}

	# Add 1st level subdirs (will searched by auto loading from tcl
	# code in the child using glob and thus fail, so we add them here
	# so by default it works the same).
	set access_path [AddSubDirs $access_path]
    }

    Log $child "Setting accessPath=($access_path) staticsok=$staticsok\
		nestedok=$nestedok deletehook=($deletehook)" NOTICE
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
    foreach sub [interp children $child] {
        if {[info exists ::safe::[VarName [list $child $sub]]]} {
            ::safe::interpDelete [list $child $sub]
        }
    }

    # If the child has a cleanup hook registered, call it.  Check the
    # existance because we might be called to delete an interp which has
    # not been registered with us at all

    if {[info exists state(cleanupHook)]} {
	set hook $state(cleanupHook)
	if {[llength $hook]} {
	    # remove the hook now, otherwise if the hook calls us somehow,
	    # we'll loop







|







598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
    foreach sub [interp children $child] {
        if {[info exists ::safe::[VarName [list $child $sub]]]} {
            ::safe::interpDelete [list $child $sub]
        }
    }

    # If the child has a cleanup hook registered, call it.  Check the
    # existence because we might be called to delete an interp which has
    # not been registered with us at all

    if {[info exists state(cleanupHook)]} {
	set hook $state(cleanupHook)
	if {[llength $hook]} {
	    # remove the hook now, otherwise if the hook calls us somehow,
	    # we'll loop
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
	::interp delete $child
	Log $child "Deleted" NOTICE
    }

    return
}

# Set (or get) the logging mecanism

proc ::safe::setLogCmd {args} {
    variable Log
    set la [llength $args]
    if {$la == 0} {
	return $Log
    } elseif {$la == 1} {







|







632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
	::interp delete $child
	Log $child "Deleted" NOTICE
    }

    return
}

# Set (or get) the logging mechanism

proc ::safe::setLogCmd {args} {
    variable Log
    set la [llength $args]
    if {$la == 0} {
	return $Log
    } elseif {$la == 1} {

Changes to library/tcltest/tcltest.tcl.

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
	if {![file isdir $directory]} {
	    return -code error "\"$directory\" is not a directory"
	}
	return [AcceptReadable $directory]
    }

##### Initialize internal arrays of tcltest, but only if the caller
    # has not already pre-initialized them.  This is done to support
    # compatibility with older tests that directly access internals
    # rather than go through command interfaces.
    #
    proc ArrayDefault {varName value} {
	variable $varName
	if {[array exists $varName]} {
	    return
	}
	if {[info exists $varName]} {
	    # Pre-initialized value is a scalar: destroy it!
	    unset $varName
	}
	array set $varName $value
    }

    # save the original environment so that it can be restored later
    ArrayDefault originalEnv [array get ::env]







|









|







149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
	if {![file isdir $directory]} {
	    return -code error "\"$directory\" is not a directory"
	}
	return [AcceptReadable $directory]
    }

##### Initialize internal arrays of tcltest, but only if the caller
    # has not already preinitialized them.  This is done to support
    # compatibility with older tests that directly access internals
    # rather than go through command interfaces.
    #
    proc ArrayDefault {varName value} {
	variable $varName
	if {[array exists $varName]} {
	    return
	}
	if {[info exists $varName]} {
	    # Preinitialized value is a scalar:  Destroy it!
	    unset $varName
	}
	array set $varName $value
    }

    # save the original environment so that it can be restored later
    ArrayDefault originalEnv [array get ::env]
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206

    # initialize the testConstraints array to keep track of valid
    # predefined constraints (see the explanation for the
    # InitConstraints proc for more details).
    ArrayDefault testConstraints {}

##### Initialize internal variables of tcltest, but only if the caller
    # has not already pre-initialized them.  This is done to support
    # compatibility with older tests that directly access internals
    # rather than go through command interfaces.
    #
    proc Default {varName value {verify AcceptAll}} {
	variable $varName
	if {![info exists $varName]} {
	    variable $varName [$verify $value]







|







192
193
194
195
196
197
198
199
200
201
202
203
204
205
206

    # initialize the testConstraints array to keep track of valid
    # predefined constraints (see the explanation for the
    # InitConstraints proc for more details).
    ArrayDefault testConstraints {}

##### Initialize internal variables of tcltest, but only if the caller
    # has not already preinitialized them.  This is done to support
    # compatibility with older tests that directly access internals
    # rather than go through command interfaces.
    #
    proc Default {varName value {verify AcceptAll}} {
	variable $varName
	if {![info exists $varName]} {
	    variable $varName [$verify $value]
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
    Default currentFailure false AcceptBoolean
    Default failFiles {} AcceptList

    # Tests should remove all files they create.  The test suite will
    # check the current working dir for files created by the tests.
    # filesMade keeps track of such files created using the makeFile and
    # makeDirectory procedures.  filesExisted stores the names of
    # pre-existing files.
    #
    # Note that $filesExisted lists only those files that exist in
    # the original [temporaryDirectory].
    Default filesMade {} AcceptList
    Default filesExisted {} AcceptList
    proc FillFilesExisted {} {
	variable filesExisted







|







225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
    Default currentFailure false AcceptBoolean
    Default failFiles {} AcceptList

    # Tests should remove all files they create.  The test suite will
    # check the current working dir for files created by the tests.
    # filesMade keeps track of such files created using the makeFile and
    # makeDirectory procedures.  filesExisted stores the names of
    # preexisting files.
    #
    # Note that $filesExisted lists only those files that exist in
    # the original [temporaryDirectory].
    Default filesMade {} AcceptList
    Default filesExisted {} AcceptList
    proc FillFilesExisted {} {
	variable filesExisted
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
    # stdout and stderr buffers for use when we want to store them
    Default outData {}
    Default errData {}

    # keep track of test level for nested test commands
    variable testLevel 0

    # the variables and procs that existed when saveState was called are
    # stored in a variable of the same name
    Default saveState {}

    # Internationalization support -- used in [SetIso8859_1_Locale] and
    # [RestoreLocale]. Those commands are used in cmdIL.test.

    if {![info exists [namespace current]::isoLocale]} {







|







294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
    # stdout and stderr buffers for use when we want to store them
    Default outData {}
    Default errData {}

    # keep track of test level for nested test commands
    variable testLevel 0

    # the variables and procedures that existed when saveState was called are
    # stored in a variable of the same name
    Default saveState {}

    # Internationalization support -- used in [SetIso8859_1_Locale] and
    # [RestoreLocale]. Those commands are used in cmdIL.test.

    if {![info exists [namespace current]::isoLocale]} {
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
	# (Hopefully this longer comment will be clear when I come
	# back in a few months, unlike its predecessor :) )
	#
	# The [outputChannel] command (and underlying variable) have to
	# be kept in sync with the [configure -outfile] configuration
	# option ( and underlying variable Option(-outfile) ).  This is
	# accomplished with a write trace on Option(-outfile) that will
	# update [outputChannel] whenver a new value is written.  That
	# much is easy.
	#
	# The trick is that in order to maintain compatibility with
	# version 1 of tcltest, we must allow every configuration option
	# to get its inital value from command line arguments.  This is
	# accomplished by setting initial read traces on all the
	# configuration options to parse the command line option the first
	# time they are read.  These traces are cancelled whenever the
	# program itself calls [configure].
	#
	# OK, then so to support tcltest 1 compatibility, it seems we want
	# to get the return from [outputFile] to trigger the read traces,







|




|







350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
	# (Hopefully this longer comment will be clear when I come
	# back in a few months, unlike its predecessor :) )
	#
	# The [outputChannel] command (and underlying variable) have to
	# be kept in sync with the [configure -outfile] configuration
	# option ( and underlying variable Option(-outfile) ).  This is
	# accomplished with a write trace on Option(-outfile) that will
	# update [outputChannel] whenever a new value is written.  That
	# much is easy.
	#
	# The trick is that in order to maintain compatibility with
	# version 1 of tcltest, we must allow every configuration option
	# to get its initial value from command line arguments.  This is
	# accomplished by setting initial read traces on all the
	# configuration options to parse the command line option the first
	# time they are read.  These traces are cancelled whenever the
	# program itself calls [configure].
	#
	# OK, then so to support tcltest 1 compatibility, it seems we want
	# to get the return from [outputFile] to trigger the read traces,
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
    variable Usage; array set Usage {}

    # Verification commands for those options
    variable Verify; array set Verify {}

    # Initialize the default values of the configurable options that are
    # historically associated with an exported variable.  If that variable
    # is already set, support compatibility by accepting its pre-set value.
    # Use [trace] to establish ongoing connection between the deprecated
    # exported variable and the modern option kept as a true internal var.
    # Also set up usage string and value testing for the option.
    proc Option {option value usage {verify AcceptAll} {varName {}}} {
	variable Option
	variable Verify
	variable Usage







|







478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
    variable Usage; array set Usage {}

    # Verification commands for those options
    variable Verify; array set Verify {}

    # Initialize the default values of the configurable options that are
    # historically associated with an exported variable.  If that variable
    # is already set, support compatibility by accepting its preset value.
    # Use [trace] to establish ongoing connection between the deprecated
    # exported variable and the modern option kept as a true internal var.
    # Also set up usage string and value testing for the option.
    proc Option {option value usage {verify AcceptAll} {varName {}}} {
	variable Option
	variable Verify
	variable Usage
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
	set directory [AcceptDirectory $directory]
	if {![file writable $directory]} {
	    if {[workingDirectory] eq $directory} {
		# Special exception: accept the default value
		# even if the directory is not writable
		return $directory
	    }
	    return -code error "\"$directory\" is not writeable"
	}
	return $directory
    }

    # Directory where files should be created
    Option -tmpdir [workingDirectory] {
	Save temporary files in the specified directory.







|







757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
	set directory [AcceptDirectory $directory]
	if {![file writable $directory]} {
	    if {[workingDirectory] eq $directory} {
		# Special exception: accept the default value
		# even if the directory is not writable
		return $directory
	    }
	    return -code error "\"$directory\" is not writable"
	}
	return $directory
    }

    # Directory where files should be created
    Option -tmpdir [workingDirectory] {
	Save temporary files in the specified directory.
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
}

#####################################################################

# tcltest::Debug* --
#
#     Internal helper procedures to write out debug information
#     dependent on the chosen level. A test shell may overide
#     them, f.e. to redirect the output into a different
#     channel, or even into a GUI.

# tcltest::DebugPuts --
#
#     Prints the specified string if the current debug level is
#     higher than the provided level argument.







|







848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
}

#####################################################################

# tcltest::Debug* --
#
#     Internal helper procedures to write out debug information
#     dependent on the chosen level. A test shell may override
#     them, f.e. to redirect the output into a different
#     channel, or even into a GUI.

# tcltest::DebugPuts --
#
#     Prints the specified string if the current debug level is
#     higher than the provided level argument.
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
#

proc tcltest::SubstArguments {argList} {

    # We need to split the argList up into tokens but cannot use list
    # operations as they throw away some significant quoting, and
    # [split] ignores braces as it should.  Therefore what we do is
    # gradually build up a string out of whitespace seperated strings.
    # We cannot use [split] to split the argList into whitespace
    # separated strings as it throws away the whitespace which maybe
    # important so we have to do it all by hand.

    set result {}
    set token ""








|







1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
#

proc tcltest::SubstArguments {argList} {

    # We need to split the argList up into tokens but cannot use list
    # operations as they throw away some significant quoting, and
    # [split] ignores braces as it should.  Therefore what we do is
    # gradually build up a string out of whitespace-separated strings.
    # We cannot use [split] to split the argList into whitespace
    # separated strings as it throws away the whitespace which maybe
    # important so we have to do it all by hand.

    set result {}
    set token ""

1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
#   setup -             Code to run before $script (above).  This
#                       attribute is optional; default is {}.
#   cleanup -           Code to run after $script (above).  This
#                       attribute is optional; default is {}.
#   match -             specifies type of matching to do on result,
#                       output, errorOutput; this must be a string
#			previously registered by a call to [customMatch].
#			The strings exact, glob, and regexp are pre-registered
#			by the tcltest package.  Default value is exact.
#
# Arguments:
#   name -		Name of test, in the form foo-1.2.
#   description -	Short textual description of the test, to
#  		  	help humans understand what it does.
#







|







1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
#   setup -             Code to run before $script (above).  This
#                       attribute is optional; default is {}.
#   cleanup -           Code to run after $script (above).  This
#                       attribute is optional; default is {}.
#   match -             specifies type of matching to do on result,
#                       output, errorOutput; this must be a string
#			previously registered by a call to [customMatch].
#			The strings exact, glob, and regexp are preregistered
#			by the tcltest package.  Default value is exact.
#
# Arguments:
#   name -		Name of test, in the form foo-1.2.
#   description -	Short textual description of the test, to
#  		  	help humans understand what it does.
#
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
	}
	set TestNames($name) [info script]
    }

    FillFilesExisted
    incr testLevel

    # 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 errorCode match

    # Set the default match mode
    set match exact








|







1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
	}
	set TestNames($name) [info script]
    }

    FillFilesExisted
    incr testLevel

    # Predefine 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 errorCode match

    # Set the default match mode
    set match exact

2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
    }

    # Call the cleanup hook
    cleanupTestsHook

    # Remove files and directories created by the makeFile and
    # makeDirectory procedures.  Record the names of files in
    # workingDirectory that were not pre-existing, and associate them
    # with the test file that created them.

    if {!$calledFromAllFile} {
	foreach file $filesMade {
	    if {[file exists $file]} {
		DebugDo 1 {Warn "cleanupTests deleting $file..."}
		catch {file delete -force -- $file}







|







2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
    }

    # Call the cleanup hook
    cleanupTestsHook

    # Remove files and directories created by the makeFile and
    # makeDirectory procedures.  Record the names of files in
    # workingDirectory that were not preexisting, and associate them
    # with the test file that created them.

    if {!$calledFromAllFile} {
	foreach file $filesMade {
	    if {[file exists $file]} {
		DebugDo 1 {Warn "cleanupTests deleting $file..."}
		catch {file delete -force -- $file}
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
	return 1
    }
    return 0
}

# Initialize the constraints and set up command line arguments
namespace eval tcltest {
    # Define initializers for all the built-in contraint definitions
    DefineConstraintInitializers

    # Set up the constraints in the testConstraints array to be lazily
    # initialized by a registered initializer, or by "false" if no
    # initializer is registered.
    trace add variable testConstraints read [namespace code SafeFetch]

    # Only initialize constraints at package load time if an
    # [initConstraintsHook] has been pre-defined.  This is only
    # for compatibility support.  The modern way to add a custom
    # test constraint is to just call the [testConstraint] command
    # straight away, without all this "hook" nonsense.
    if {[namespace current] eq
	    [namespace qualifiers [namespace which initConstraintsHook]]} {
	InitConstraints
    } else {







|








|







3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
	return 1
    }
    return 0
}

# Initialize the constraints and set up command line arguments
namespace eval tcltest {
    # Define initializers for all the built-in constraint definitions
    DefineConstraintInitializers

    # Set up the constraints in the testConstraints array to be lazily
    # initialized by a registered initializer, or by "false" if no
    # initializer is registered.
    trace add variable testConstraints read [namespace code SafeFetch]

    # Only initialize constraints at package load time if an
    # [initConstraintsHook] has been predefined.  This is only
    # for compatibility support.  The modern way to add a custom
    # test constraint is to just call the [testConstraint] command
    # straight away, without all this "hook" nonsense.
    if {[namespace current] eq
	    [namespace qualifiers [namespace which initConstraintsHook]]} {
	InitConstraints
    } else {

Changes to library/tm.tcl.

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
#   [package require] something that wasn't there on the first scan.
#
#   Either
#   1) It is there now:  If we rescan, you get it; if not you don't.
#
#      This covers the possibility that the application asked for a package
#      late, and the package was actually added to the installation after the
#      application was started. It shoukld still be able to find it.
#
#   2) It still is not there: Either way, you don't get it, but the rescan
#      takes time. This is however an error case and we dont't care that much
#      about it
#
#   3) It was there the first time; but for some reason a "package forget" has
#      been run, and "package" doesn't know about it anymore.
#
#      This can be an indication that the application wishes to reload some
#      functionality. And should work as well.







|


|







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
#   [package require] something that wasn't there on the first scan.
#
#   Either
#   1) It is there now:  If we rescan, you get it; if not you don't.
#
#      This covers the possibility that the application asked for a package
#      late, and the package was actually added to the installation after the
#      application was started. It should still be able to find it.
#
#   2) It still is not there: Either way, you don't get it, but the rescan
#      takes time. This is however an error case and we don't care that much
#      about it
#
#   3) It was there the first time; but for some reason a "package forget" has
#      been run, and "package" doesn't know about it anymore.
#
#      This can be an indication that the application wishes to reload some
#      functionality. And should work as well.
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
#	args -	The paths to add/remove. Must not appear querying the
#		path with 'list'.
#
# Results
#	No result for subcommands 'add' and 'remove'. A list of paths for
#	'list'.
#
# Sideeffects
#	The subcommands 'add' and 'remove' manipulate the list of paths to
#	search for Tcl Modules. The subcommand 'list' has no sideeffects.

proc ::tcl::tm::add {args} {
    # PART OF THE ::tcl::tm::path ENSEMBLE
    #
    # The path is added at the head to the list of module paths.
    #
    # The command enforces the restriction that no path may be an ancestor
    # directory of any other path on the list. If the new path violates this
    # restriction an error wil be raised.
    #
    # If the path is already present as is no error will be raised and no
    # action will be taken.

    variable paths

    # We use a copy of the path as source during validation, and extend it as







|

|








|







66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
#	args -	The paths to add/remove. Must not appear querying the
#		path with 'list'.
#
# Results
#	No result for subcommands 'add' and 'remove'. A list of paths for
#	'list'.
#
# Side effects
#	The subcommands 'add' and 'remove' manipulate the list of paths to
#	search for Tcl Modules. The subcommand 'list' has no side effects.

proc ::tcl::tm::add {args} {
    # PART OF THE ::tcl::tm::path ENSEMBLE
    #
    # The path is added at the head to the list of module paths.
    #
    # The command enforces the restriction that no path may be an ancestor
    # directory of any other path on the list. If the new path violates this
    # restriction an error will be raised.
    #
    # If the path is already present as is no error will be raised and no
    # action will be taken.

    variable paths

    # We use a copy of the path as source during validation, and extend it as
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
#	Unknown handler for Tcl Modules, i.e. packages in module form.
#
# Arguments
#	original	- Original [package unknown] procedure.
#	name		- Name of desired package.
#	version		- Version of desired package. Can be the
#			  empty string.
#	exact		- Either -exact or ommitted.
#
#	Name, version, and exact are used to determine satisfaction. The
#	original is called iff no satisfaction was achieved. The name is also
#	used to compute the directory to target in the search.
#
# Results
#	None.
#
# Sideeffects
#	May populate the package ifneeded database with additional provide
#	scripts.

proc ::tcl::tm::UnknownHandler {original name args} {
    # Import the list of paths to search for packages in module form.
    # Import the pattern used to check package names in detail.








|








|







162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
#	Unknown handler for Tcl Modules, i.e. packages in module form.
#
# Arguments
#	original	- Original [package unknown] procedure.
#	name		- Name of desired package.
#	version		- Version of desired package. Can be the
#			  empty string.
#	exact		- Either -exact or omitted.
#
#	Name, version, and exact are used to determine satisfaction. The
#	original is called iff no satisfaction was achieved. The name is also
#	used to compute the directory to target in the search.
#
# Results
#	None.
#
# Side effects
#	May populate the package ifneeded database with additional provide
#	scripts.

proc ::tcl::tm::UnknownHandler {original name args} {
    # Import the list of paths to search for packages in module form.
    # Import the pattern used to check package names in detail.

306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
#
# Arguments
#	None
#
# Results
#	None.
#
# Sideeffects
#	May add paths to the list of defaults.

proc ::tcl::tm::Defaults {} {
    global env tcl_platform

    regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
    set exe [file normalize [info nameofexecutable]]







|







306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
#
# Arguments
#	None
#
# Results
#	None.
#
# Side effects
#	May add paths to the list of defaults.

proc ::tcl::tm::Defaults {} {
    global env tcl_platform

    regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
    set exe [file normalize [info nameofexecutable]]
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
#
# Arguments
#	paths -	List of 'root' paths to derive search paths from.
#
# Results
#	No result.
#
# Sideeffects
#	Calls 'path add' to paths to the list of module search paths.

proc ::tcl::tm::roots {paths} {
    regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
    foreach pa $paths {
	set p [file join $pa tcl$major]
	for {set n $minor} {$n >= 0} {incr n -1} {







|







351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
#
# Arguments
#	paths -	List of 'root' paths to derive search paths from.
#
# Results
#	No result.
#
# Side effects
#	Calls 'path add' to paths to the list of module search paths.

proc ::tcl::tm::roots {paths} {
    regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
    foreach pa $paths {
	set p [file join $pa tcl$major]
	for {set n $minor} {$n >= 0} {incr n -1} {

Changes to library/word.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
# word.tcl --
#
# This file defines various procedures for computing word boundaries in
# strings. This file is primarily needed so Tk text and entry widgets behave
# properly for different platforms.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998 Scritpics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

# The following variables are used to determine which characters are
# interpreted as white space.

if {$::tcl_platform(platform) eq "windows"} {
    # Windows style - any but a unicode space char
    if {![info exists ::tcl_wordchars]} {
	set ::tcl_wordchars {\S}
    }
    if {![info exists ::tcl_nonwordchars]} {
	set ::tcl_nonwordchars {\s}
    }
} else {
    # Motif style - any unicode word char (number, letter, or underscore)
    if {![info exists ::tcl_wordchars]} {
	set ::tcl_wordchars {\w}
    }
    if {![info exists ::tcl_nonwordchars]} {
	set ::tcl_nonwordchars {\W}
    }
}







|








|







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
# word.tcl --
#
# This file defines various procedures for computing word boundaries in
# strings. This file is primarily needed so Tk text and entry widgets behave
# properly for different platforms.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

# The following variables are used to determine which characters are
# interpreted as white space.

if {$::tcl_platform(platform) eq "windows"} {
    # Windows style - any but a Unicode space char
    if {![info exists ::tcl_wordchars]} {
	set ::tcl_wordchars {\S}
    }
    if {![info exists ::tcl_nonwordchars]} {
	set ::tcl_nonwordchars {\s}
    }
} else {
    # Motif style - any Unicode word char (number, letter, or underscore)
    if {![info exists ::tcl_wordchars]} {
	set ::tcl_wordchars {\w}
    }
    if {![info exists ::tcl_nonwordchars]} {
	set ::tcl_nonwordchars {\W}
    }
}

Changes to libtommath/changes.txt.

408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
          to other functions like mp_invmod, mp_div, etc...
       -- Sped up mp_exptmod_fast by using new code to find R mod m [e.g. B^n mod m]
       -- minor fixes

Jan 17th, 2003
v0.12  -- re-wrote the majority of the makefile so its more portable and will
          install via "make install" on most *nix platforms
       -- Re-packaged all the source as seperate files.  Means the library a single
          file packagage any more.  Instead of just adding "bn.c" you have to add
          libtommath.a
       -- Renamed "bn.h" to "tommath.h"
       -- Changes to the manual to reflect all of this
       -- Used GNU Indent to clean up the source

Jan 15th, 2003







|







408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
          to other functions like mp_invmod, mp_div, etc...
       -- Sped up mp_exptmod_fast by using new code to find R mod m [e.g. B^n mod m]
       -- minor fixes

Jan 17th, 2003
v0.12  -- re-wrote the majority of the makefile so its more portable and will
          install via "make install" on most *nix platforms
       -- Re-packaged all the source as separate files.  Means the library a single
          file packagage any more.  Instead of just adding "bn.c" you have to add
          libtommath.a
       -- Renamed "bn.h" to "tommath.h"
       -- Changes to the manual to reflect all of this
       -- Used GNU Indent to clean up the source

Jan 15th, 2003

Changes to macosx/GNUmakefile.

1
2
3
4
5
6
7
8
9
10
11
########################################################################################################
#
# Makefile wrapper to build tcl on Mac OS X in a way compatible with the tk/macosx Xcode buildsystem
#	uses the standard unix build system in tcl/unix (which can be used directly instead of this
#	if you are not using the tk/macosx projects).
#
# Copyright (c) 2002-2008 Daniel A. Steffen <[email protected]>
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
########################################################################################################



|







1
2
3
4
5
6
7
8
9
10
11
########################################################################################################
#
# Makefile wrapper to build tcl on Mac OS X in a way compatible with the tk/macosx Xcode buildsystem
#	uses the standard Unix build system in tcl/unix (which can be used directly instead of this
#	if you are not using the tk/macosx projects).
#
# Copyright (c) 2002-2008 Daniel A. Steffen <[email protected]>
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
########################################################################################################
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
	--prefix="${PREFIX}" --bindir="${BINDIR}" --libdir="${LIBDIR}" \
	--mandir="${MANDIR}" --enable-threads --enable-framework --enable-dtrace \
	${CONFIGURE_ARGS} ${EXTRA_CONFIGURE_ARGS}; else ./config.status; fi

build-${PROJECT}: ${objdir}/Makefile
	${DO_MAKE}
ifeq (${INSTALL_BUILD},)
# symolic link hackery to trick
# 'make install INSTALL_ROOT=${OBJ_DIR}'
# into building Tcl.framework and tclsh in ${SYMROOT}
	@cd "${OBJ_DIR}" && mkdir -p $(dir $(subst ${space},\ ,.${LIBDIR})) $(dir $(subst ${space},\ ,.${BINDIR})) "${SYMROOT}" && \
	rm -f ".${LIBDIR}" ".${BINDIR}" && ln -fs "${SYMROOT}" ".${LIBDIR}" && \
	ln -fs "${SYMROOT}" ".${BINDIR}" && ln -fs "${OBJ_DIR}/tcltest" "${SYMROOT}"
endif








|







146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
	--prefix="${PREFIX}" --bindir="${BINDIR}" --libdir="${LIBDIR}" \
	--mandir="${MANDIR}" --enable-threads --enable-framework --enable-dtrace \
	${CONFIGURE_ARGS} ${EXTRA_CONFIGURE_ARGS}; else ./config.status; fi

build-${PROJECT}: ${objdir}/Makefile
	${DO_MAKE}
ifeq (${INSTALL_BUILD},)
# symbolic link hackery to trick
# 'make install INSTALL_ROOT=${OBJ_DIR}'
# into building Tcl.framework and tclsh in ${SYMROOT}
	@cd "${OBJ_DIR}" && mkdir -p $(dir $(subst ${space},\ ,.${LIBDIR})) $(dir $(subst ${space},\ ,.${BINDIR})) "${SYMROOT}" && \
	rm -f ".${LIBDIR}" ".${BINDIR}" && ln -fs "${SYMROOT}" ".${LIBDIR}" && \
	ln -fs "${SYMROOT}" ".${BINDIR}" && ln -fs "${OBJ_DIR}/tcltest" "${SYMROOT}"
endif

Changes to macosx/tclMacOSXFCmd.c.

487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
 * TclMacOSXMatchType --
 *
 *	This routine is used by the globbing code to check if a file matches a
 *	given mac type and/or creator code.
 *
 * Results:
 *	The return value is 1, 0 or -1 indicating whether the file matches the
 *	given criteria, does not match them, or an error occurred (in wich
 *	case an error is left in interp).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */







|







487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
 * TclMacOSXMatchType --
 *
 *	This routine is used by the globbing code to check if a file matches a
 *	given mac type and/or creator code.
 *
 * Results:
 *	The return value is 1, 0 or -1 indicating whether the file matches the
 *	given criteria, does not match them, or an error occurred (in which
 *	case an error is left in interp).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Changes to macosx/tclMacOSXNotify.c.

1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
 * Tcl_WaitForEvent --
 *
 *	This function is called by Tcl_DoOneEvent to wait for new events on
 *	the message queue. If the block time is 0, then Tcl_WaitForEvent just
 *	polls without blocking.
 *
 * Results:
 *	Returns 0 if a tcl event or timeout ocurred and 1 if a non-tcl
 *	CFRunLoop source was processed.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */







|







1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
 * Tcl_WaitForEvent --
 *
 *	This function is called by Tcl_DoOneEvent to wait for new events on
 *	the message queue. If the block time is 0, then Tcl_WaitForEvent just
 *	polls without blocking.
 *
 * Results:
 *	Returns 0 if a tcl event or timeout occurred and 1 if a non-tcl
 *	CFRunLoop source was processed.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Changes to tests/appendComp.test.

380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
# Note also the tests above now constrained by bug-3057639, these changed
# behaviour with the triggering of read traces in bc mode gone.

# Going back to the tests below. The direct-eval tests are ok before and after
# patch (no read traces run for lappend, append). The compiled tests are
# failing for lappend (9.0/1) before the patch, showing how it invokes read
# traces in the compiled path. The append tests are good (9.2/3). After the
# patch the failues are gone.

test appendComp-9.0 {bug 3057639, lappend compiled, read trace on non-existing array variable element} -setup {
    unset -nocomplain myvar
    array set myvar {}
} -body {
    proc nonull {var key val} {
	upvar 1 $var lvar







|







380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
# Note also the tests above now constrained by bug-3057639, these changed
# behaviour with the triggering of read traces in bc mode gone.

# Going back to the tests below. The direct-eval tests are ok before and after
# patch (no read traces run for lappend, append). The compiled tests are
# failing for lappend (9.0/1) before the patch, showing how it invokes read
# traces in the compiled path. The append tests are good (9.2/3). After the
# patch the failures are gone.

test appendComp-9.0 {bug 3057639, lappend compiled, read trace on non-existing array variable element} -setup {
    unset -nocomplain myvar
    array set myvar {}
} -body {
    proc nonull {var key val} {
	upvar 1 $var lvar

Changes to tests/chanio.test.

3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
    chan configure $f -translation binary
    chan configure $f -translation
} -cleanup {
    chan close $f
} -result lf
#
# Test chan-io-9.14 has been removed because "auto" output translation mode is
# not supoprted.
#
test chan-io-31.14 {Tcl_Write mixed, Tcl_Gets auto} -setup {
    file delete $path(test1)
    set l ""
} -body {
    set f [open $path(test1) w]
    chan configure $f -translation lf







|







3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
    chan configure $f -translation binary
    chan configure $f -translation
} -cleanup {
    chan close $f
} -result lf
#
# Test chan-io-9.14 has been removed because "auto" output translation mode is
# not supported.
#
test chan-io-31.14 {Tcl_Write mixed, Tcl_Gets auto} -setup {
    file delete $path(test1)
    set l ""
} -body {
    set f [open $path(test1) w]
    chan configure $f -translation lf
5300
5301
5302
5303
5304
5305
5306

5307
5308

5309
5310
5311
5312
5313
5314
5315
    lappend l [chan configure $f1 -eofchar]
    chan configure $f1 -eofchar D
    lappend l [chan configure $f1 -eofchar]
    lappend l [list [catch {chan configure $f1 -eofchar {1 2 3}} msg] $msg]
} -cleanup {
    chan close $f1
} -result {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}}

test chan-io-39.23 {Tcl_GetChannelOption, server socket is not readable or\
        writeable, it should still have valid -eofchar and -translation options} -setup {

    set l [list]
} -body {
    set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
    lappend l [chan configure $sock -eofchar] \
	[chan configure $sock -translation]
} -cleanup {
    chan close $sock







>
|
|
>







5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
    lappend l [chan configure $f1 -eofchar]
    chan configure $f1 -eofchar D
    lappend l [chan configure $f1 -eofchar]
    lappend l [list [catch {chan configure $f1 -eofchar {1 2 3}} msg] $msg]
} -cleanup {
    chan close $f1
} -result {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}}
test chan-io-39.23 {
	Tcl_GetChannelOption, server socket is not readable or writable, but should
	still have valid -eofchar and -translation options.
} -setup {
    set l [list]
} -body {
    set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
    lappend l [chan configure $sock -eofchar] \
	[chan configure $sock -translation]
} -cleanup {
    chan close $sock
7549
7550
7551
7552
7553
7554
7555
7556
7557
7558
7559
7560
7561
7562
7563
    #chan seek $f 0 current
    #lappend res [chan read $f; chan tell $f]
} -cleanup {
    chan close $f
    removeFile eofchar
} -result {77 = 23431}

# Test the cutting and splicing of channels, this is incidentially the
# attach/detach facility of package Thread, but __without any safeguards__. It
# can also be used to emulate transfer of channels between threads, and is
# used for that here.

test chan-io-70.0 {Cutting & Splicing channels} -setup {
    set f [makeFile {... dummy ...} cutsplice]
    set res {}







|







7551
7552
7553
7554
7555
7556
7557
7558
7559
7560
7561
7562
7563
7564
7565
    #chan seek $f 0 current
    #lappend res [chan read $f; chan tell $f]
} -cleanup {
    chan close $f
    removeFile eofchar
} -result {77 = 23431}

# Test the cutting and splicing of channels, this is incidentally the
# attach/detach facility of package Thread, but __without any safeguards__. It
# can also be used to emulate transfer of channels between threads, and is
# used for that here.

test chan-io-70.0 {Cutting & Splicing channels} -setup {
    set f [makeFile {... dummy ...} cutsplice]
    set res {}

Changes to tests/clock.test.

36043
36044
36045
36046
36047
36048
36049
36050
36051
36052
36053
36054
36055
36056
36057
	    unset oldTZ
	} else {
	    unset env(TZ)
	}
    } \
    -result {-0500}

# 43.1 was a bad test - mktime returning -1 is an error according to posix.

test clock-44.1 {regression test - time zone name containing hyphen } \
    -setup {
	if { [info exists env(TZ)] } {
	    set oldTZ $env(TZ)
	}
	set env(TZ) US/East-Indiana







|







36043
36044
36045
36046
36047
36048
36049
36050
36051
36052
36053
36054
36055
36056
36057
	    unset oldTZ
	} else {
	    unset env(TZ)
	}
    } \
    -result {-0500}

# 43.1 was a bad test - mktime returning -1 is an error according to Posix.

test clock-44.1 {regression test - time zone name containing hyphen } \
    -setup {
	if { [info exists env(TZ)] } {
	    set oldTZ $env(TZ)
	}
	set env(TZ) US/East-Indiana

Changes to tests/cmdAH.test.

1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
} -result "could not get modification time for file \"con\"" -returnCodes error
test cmdAH-24.14.1 {
    Tcl_FileObjCmd: mtime (built-in Windows names with dir path and extension)
} -constraints {win} -body {
    file mtime [file join [temporaryDirectory] CON.txt]
} -match regexp -result {could not (?:get modification time|read)} -returnCodes error

# 3155760000 is 64-bit unix time, Wed Jan 01 00:00:00 GMT 2070:
test cmdAH-24.20.1 {Tcl_FileObjCmd: atime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup {
    set filename [makeFile "" foo.text]
} -body {
    list [file atime $filename 3155760000] [file atime $filename]
} -cleanup {
    removeFile $filename
} -result {3155760000 3155760000}







|







1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
} -result "could not get modification time for file \"con\"" -returnCodes error
test cmdAH-24.14.1 {
    Tcl_FileObjCmd: mtime (built-in Windows names with dir path and extension)
} -constraints {win} -body {
    file mtime [file join [temporaryDirectory] CON.txt]
} -match regexp -result {could not (?:get modification time|read)} -returnCodes error

# 3155760000 is 64-bit Unix time, Wed Jan 01 00:00:00 GMT 2070:
test cmdAH-24.20.1 {Tcl_FileObjCmd: atime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup {
    set filename [makeFile "" foo.text]
} -body {
    list [file atime $filename 3155760000] [file atime $filename]
} -cleanup {
    removeFile $filename
} -result {3155760000 3155760000}
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
test cmdAH-32.5 {file tempfile - templates} -constraints unix -body {
    set template [file join $dirfile foo]
    close [file tempfile name $template]
    expr {[string match $template* $name] ? "ok" : "$template produced $name"}
} -cleanup {
    catch {file delete $name}
} -result ok
# Not portable; not all unix systems have mkstemps()
test cmdAH-32.6 {file tempfile - templates} -body {
    set template [file join $dirfile foo]
    close [file tempfile name $template.bar]
    expr {[string match $template*.bar $name] ? "ok" :
	  "$template.bar produced $name"}
} -constraints {unix nonPortable} -cleanup {
    catch {file delete $name}







|







1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
test cmdAH-32.5 {file tempfile - templates} -constraints unix -body {
    set template [file join $dirfile foo]
    close [file tempfile name $template]
    expr {[string match $template* $name] ? "ok" : "$template produced $name"}
} -cleanup {
    catch {file delete $name}
} -result ok
# Not portable; not all Unix systems have mkstemps()
test cmdAH-32.6 {file tempfile - templates} -body {
    set template [file join $dirfile foo]
    close [file tempfile name $template.bar]
    expr {[string match $template*.bar $name] ? "ok" :
	  "$template.bar produced $name"}
} -constraints {unix nonPortable} -cleanup {
    catch {file delete $name}

Changes to tests/cmdMZ.test.

55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
} -match glob -result {?*}
test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} -setup {
    set cwd [pwd]
    set foodir [file join [temporaryDirectory] foo]
    file delete -force $foodir
    file mkdir $foodir
    cd $foodir
} -constraints {unix nonPortable} -body {
    # This test fails on various unix platforms (eg Linux) where permissions
    # caching causes this to fail. The caching is strictly incorrect, but we
    # have no control over that.
    file attr . -permissions 0o000
    pwd
} -returnCodes error -cleanup {
    cd $cwd
    file delete -force $foodir







|
|







55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
} -match glob -result {?*}
test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} -setup {
    set cwd [pwd]
    set foodir [file join [temporaryDirectory] foo]
    file delete -force $foodir
    file mkdir $foodir
    cd $foodir
} -constraints {Unix nonPortable} -body {
    # This test fails on various Unix platforms (eg Linux) where permissions
    # caching causes this to fail. The caching is strictly incorrect, but we
    # have no control over that.
    file attr . -permissions 0o000
    pwd
} -returnCodes error -cleanup {
    cd $cwd
    file delete -force $foodir

Changes to tests/compile.test.

515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
    ti eval {foreach cmd {eval "if 1" try catch} {
	set c [gencode 500 $cmd]
	lappend errors [catch $c e] $e
    }}
    #puts $errors
    # all of nested calls exceed the limit, so must end with "too many nested compilations"
    # (or evaluations, depending on compile method/instruction and "mixed" compile within
    # evaliation), so no one succeeds, the result must be empty:
    ti eval {set result}
} -result {}
#
# clean up:
if {[interp exists ti]} {
    interp delete ti
}







|







515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
    ti eval {foreach cmd {eval "if 1" try catch} {
	set c [gencode 500 $cmd]
	lappend errors [catch $c e] $e
    }}
    #puts $errors
    # all of nested calls exceed the limit, so must end with "too many nested compilations"
    # (or evaluations, depending on compile method/instruction and "mixed" compile within
    # evaluation), so no one succeeds, the result must be empty:
    ti eval {set result}
} -result {}
#
# clean up:
if {[interp exists ti]} {
    interp delete ti
}

Changes to tests/dict.test.

1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
        dict get $successors x
    }}
} [dict create c d a b]
test dict-19.2 {dict: testing for leaks} -constraints memory -body {
    # This test is made to stress object reference management
    memtest {
	apply {{} {
	    # A shared invalid dictinary
	    set apa {a {}b c d}
	    set bepa $apa
	    catch {dict replace $apa e f}
	    catch {dict remove  $apa c d}
	    catch {dict incr    apa  a 5}
	    catch {dict lappend apa  a 5}
	    catch {dict append  apa  a 5}







|







1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
        dict get $successors x
    }}
} [dict create c d a b]
test dict-19.2 {dict: testing for leaks} -constraints memory -body {
    # This test is made to stress object reference management
    memtest {
	apply {{} {
	    # A shared invalid dictionary
	    set apa {a {}b c d}
	    set bepa $apa
	    catch {dict replace $apa e f}
	    catch {dict remove  $apa c d}
	    catch {dict incr    apa  a 5}
	    catch {dict lappend apa  a 5}
	    catch {dict append  apa  a 5}

Changes to tests/env.test.

217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
    getenv
} -cleanup { cleanup1
} -result {NAME1=test string
NAME2=more
XYZZY=garbage}

test env-2.5 {different encoding (wide chars)} -constraints {win exec} -setup {
    # be sure set of (unicode) environment occurs if single-byte encoding is used:
    encodingswitch cp1252
    # german (cp1252) and russian (cp1251) characters together encoded as utf-8:
    set val 2d2dc3a4c3b6c3bcc39f2dd182d0b5d181d1822d2d
    set env(XYZZY) [encoding convertfrom utf-8 [binary decode hex $val]]
    # now switch to utf-8 (to see correct values from test):
    encoding system utf-8
} -body {
    exec [interpreter] << [string map [list \$val $val] {
	encoding system utf-8; fconfigure stdout -encoding utf-8







|

|







217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
    getenv
} -cleanup { cleanup1
} -result {NAME1=test string
NAME2=more
XYZZY=garbage}

test env-2.5 {different encoding (wide chars)} -constraints {win exec} -setup {
    # be sure set of (Unicode) environment occurs if single-byte encoding is used:
    encodingswitch cp1252
    # German (cp1252) and Russian (cp1251) characters together encoded as utf-8:
    set val 2d2dc3a4c3b6c3bcc39f2dd182d0b5d181d1822d2d
    set env(XYZZY) [encoding convertfrom utf-8 [binary decode hex $val]]
    # now switch to utf-8 (to see correct values from test):
    encoding system utf-8
} -body {
    exec [interpreter] << [string map [list \$val $val] {
	encoding system utf-8; fconfigure stdout -encoding utf-8
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
} -cleanup cleanup1 -result a


test env-5.1 {
    corner cases - remove one elem at a time
} -setup setup1 -body {
    # When no environment variables exist, the env var will contain no
    # entries. The "array names" call synchs up the C-level environ array with
    # the Tcl level env array. Make sure an empty Tcl array is created.
    foreach e [array names env] {
	unset env($e)
    }
    array size env
} -cleanup cleanup1 -result 0








|







299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
} -cleanup cleanup1 -result a


test env-5.1 {
    corner cases - remove one elem at a time
} -setup setup1 -body {
    # When no environment variables exist, the env var will contain no
    # entries. The "array names" call syncs up the C-level environ array with
    # the Tcl level env array. Make sure an empty Tcl array is created.
    foreach e [array names env] {
	unset env($e)
    }
    array size env
} -cleanup cleanup1 -result 0

343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
} -result {a 1}


test env-5.4 {corner cases - unset the env array} -setup {
    setup1
    interp create i
} -body {
    # The info exists command should be in synch with the env array.
    # Know Bug: 1737
    i eval {set env(THIS_SHOULD_EXIST) a}
    set     result [info exists env(THIS_SHOULD_EXIST)]
    lappend result [set env(THIS_SHOULD_EXIST)]
    lappend result [info exists env(THIS_SHOULD_EXIST)]
} -cleanup {
    cleanup1







|







343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
} -result {a 1}


test env-5.4 {corner cases - unset the env array} -setup {
    setup1
    interp create i
} -body {
    # The info exists command should be in sync with the env array.
    # Know Bug: 1737
    i eval {set env(THIS_SHOULD_EXIST) a}
    set     result [info exists env(THIS_SHOULD_EXIST)]
    lappend result [set env(THIS_SHOULD_EXIST)]
    lappend result [info exists env(THIS_SHOULD_EXIST)]
} -cleanup {
    cleanup1

Changes to tests/error.test.

920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
	} finally {
	    throw BAR baz
	}
    }
    list $em [dict get $opts -errorcode]
} {bar FOO}

# try tests - fallthough body cases

test error-19.1 {try with fallthrough body #1} {
    set RES {}
    try { list a b c } on ok { set RES 0 } - on error {} { set RES 1 }
    set RES
} {1}
test error-19.2 {try with fallthrough body #2} {







|







920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
	} finally {
	    throw BAR baz
	}
    }
    list $em [dict get $opts -errorcode]
} {bar FOO}

# try tests - fall-through body cases

test error-19.1 {try with fallthrough body #1} {
    set RES {}
    try { list a b c } on ok { set RES 0 } - on error {} { set RES 1 }
    set RES
} {1}
test error-19.2 {try with fallthrough body #2} {

Changes to tests/eval.test.

60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
    eval [list list 1 2 3 4 5]
} {1 2 3 4 5}
test eval-3.2 {concatenating eval and pure lists} {
    eval [list list 1] [list 2 3 4 5]
} {1 2 3 4 5}
test eval-3.3 {eval and canonical lists} {
    set cmd [list list 1 2 3 4 5]
    # Force existance of utf-8 rep
    set dummy($cmd) $cmd
    unset dummy
    eval $cmd
} {1 2 3 4 5}
test eval-3.4 {concatenating eval and canonical lists} {
    set cmd  [list list 1]
    set cmd2 [list 2 3 4 5]
    # Force existance of utf-8 rep
    set dummy($cmd) $cmd
    set dummy($cmd2) $cmd2
    unset dummy
    eval $cmd $cmd2
} {1 2 3 4 5}

# cleanup







|







|







60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
    eval [list list 1 2 3 4 5]
} {1 2 3 4 5}
test eval-3.2 {concatenating eval and pure lists} {
    eval [list list 1] [list 2 3 4 5]
} {1 2 3 4 5}
test eval-3.3 {eval and canonical lists} {
    set cmd [list list 1 2 3 4 5]
    # Force existence of utf-8 rep
    set dummy($cmd) $cmd
    unset dummy
    eval $cmd
} {1 2 3 4 5}
test eval-3.4 {concatenating eval and canonical lists} {
    set cmd  [list list 1]
    set cmd2 [list 2 3 4 5]
    # Force existence of utf-8 rep
    set dummy($cmd) $cmd
    set dummy($cmd2) $cmd2
    unset dummy
    eval $cmd $cmd2
} {1 2 3 4 5}

# cleanup

Changes to tests/event.test.

425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
    while executing
"error foo"
    ("after" script)
}

# someday : add a test checking that when there is no bgerror, an error msg
# goes to stderr ideally one would use sub interp and transfer a fake stderr
# to it, unfortunatly the current interp tcl API does not allow that. The
# other option would be to use fork a test but it then becomes more a
# file/exec test than a bgerror test.

# end of bgerror tests
catch {rename bgerror {}}

test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} {







|







425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
    while executing
"error foo"
    ("after" script)
}

# someday : add a test checking that when there is no bgerror, an error msg
# goes to stderr ideally one would use sub interp and transfer a fake stderr
# to it, unfortunately the current interp tcl API does not allow that. The
# other option would be to use fork a test but it then becomes more a
# file/exec test than a bgerror test.

# end of bgerror tests
catch {rename bgerror {}}

test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} {

Changes to tests/exec.test.

21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
source [file join [file dirname [info script]] tcltests.tcl]

# Some skips when running in a macOS CI environment
testConstraint noosxCI [expr {![info exists ::env(MAC_CI)]}]

unset -nocomplain path

# Utilities that are like bourne shell stalwarts, but cross-platform.
set path(echo) [makeFile {
    puts -nonewline [lindex $argv 0]
    foreach str [lrange $argv 1 end] {
	puts -nonewline " $str"
    }
    puts {}
    exit







|







21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
source [file join [file dirname [info script]] tcltests.tcl]

# Some skips when running in a macOS CI environment
testConstraint noosxCI [expr {![info exists ::env(MAC_CI)]}]

unset -nocomplain path

# Utilities that are like Bourne shell stalwarts, but cross-platform.
set path(echo) [makeFile {
    puts -nonewline [lindex $argv 0]
    foreach str [lrange $argv 1 end] {
	puts -nonewline " $str"
    }
    puts {}
    exit

Changes to tests/expr.test.

7276
7277
7278
7279
7280
7281
7282
7283
7284
7285
7286
7287
7288
7289
7290
		string match {*no string representation*} [
		::tcl::unsupported::representation $a]]
} {0 0 1 1}

# Bug e3dcab1d14
proc do-one-test-expr-63 {e p float athreshold} {
    # e - power of 2 to test
    # p - tcl_precision to test wuth
    # float - floating point value 2**-$p
    # athreshold - tolerable absolute error (1/2 decimal digit in
    #              least significant place plus 1/2 least significant bit)
    set trouble {}
    set ::tcl_precision $p
    set xfmt x[expr $float]
    set ::tcl_precision 0







|







7276
7277
7278
7279
7280
7281
7282
7283
7284
7285
7286
7287
7288
7289
7290
		string match {*no string representation*} [
		::tcl::unsupported::representation $a]]
} {0 0 1 1}

# Bug e3dcab1d14
proc do-one-test-expr-63 {e p float athreshold} {
    # e - power of 2 to test
    # p - tcl_precision to test with
    # float - floating point value 2**-$p
    # athreshold - tolerable absolute error (1/2 decimal digit in
    #              least significant place plus 1/2 least significant bit)
    set trouble {}
    set ::tcl_precision $p
    set xfmt x[expr $float]
    set ::tcl_precision 0

Changes to tests/fCmd.test.

92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
testConstraint notContinuousIntegration [expr {![info exists ::env(CI)]}]

testConstraint fileSharing 0
testConstraint notFileSharing 1
testConstraint linkFile 1
testConstraint linkDirectory 1

# Several tests require need to match results against the unix username
set user {}
if {[testConstraint unix]} {
    catch {
	set user [exec whoami]
    }
    if {$user eq ""} {
	catch {







|







92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
testConstraint notContinuousIntegration [expr {![info exists ::env(CI)]}]

testConstraint fileSharing 0
testConstraint notFileSharing 1
testConstraint linkFile 1
testConstraint linkDirectory 1

# Several tests require need to match results against the Unix username
set user {}
if {[testConstraint unix]} {
    catch {
	set user [exec whoami]
    }
    if {$user eq ""} {
	catch {
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
    createfile -force
    file delete -force -force -- -- -force
    glob -- -- -force
} -result {no files matched glob patterns "-- -force"}

test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \
    -constraints {unix notRoot knownBug} -body {
    # Labelled knownBug because it is dangerous [Bug: 3881]
    file mkdir td1
    file attr td1 -perm 0o40000
    file rename ~$user td1
} -returnCodes error -cleanup {
    file delete -force td1
} -result "error renaming \"~$user\" to \"td1/[file tail ~$user]\": permission denied"
test fCmd-8.2 {FileBasename: basename of ~user: argc == 1 && *path == ~} \







|







753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
    createfile -force
    file delete -force -force -- -- -force
    glob -- -- -force
} -result {no files matched glob patterns "-- -force"}

test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \
    -constraints {unix notRoot knownBug} -body {
    # Labeled knownBug because it is dangerous [Bug: 3881]
    file mkdir td1
    file attr td1 -perm 0o40000
    file rename ~$user td1
} -returnCodes error -cleanup {
    file delete -force td1
} -result "error renaming \"~$user\" to \"td1/[file tail ~$user]\": permission denied"
test fCmd-8.2 {FileBasename: basename of ~user: argc == 1 && *path == ~} \
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
    file rename -force tfs3 tfd3
    file rename -force tfs4 tfd4
    list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4]
} -result {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0}
test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup {
    cleanup
} -constraints {notRoot testchmod notNetworkFilesystem} -body {
    # Under unix, you can rename a read-only directory, but you can't move it
    # into another directory.
    file mkdir td1
    file mkdir [file join td2 td1]
    file mkdir tds1
    file mkdir tds2
    file mkdir tds3
    file mkdir tds4







|







874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
    file rename -force tfs3 tfd3
    file rename -force tfs4 tfd4
    list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4]
} -result {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0}
test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup {
    cleanup
} -constraints {notRoot testchmod notNetworkFilesystem} -body {
    # Under Unix you can rename a read-only directory, but you can't move it
    # into another directory.
    file mkdir td1
    file mkdir [file join td2 td1]
    file mkdir tds1
    file mkdir tds2
    file mkdir tds3
    file mkdir tds4
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
    cd abc.link
    set dir [pwd]
    cd ..
    set up [pwd]
    cd $orig
    # Now '$up' should be either $orig or [file dirname abc.dir], depending on
    # whether 'cd' actually moves to the destination of a link, or simply
    # treats the link as a directory. (On windows the former, on unix the
    # latter, I believe)
    if {
	([file normalize $up] ne [file normalize $orig]) &&
	([file normalize $up] ne [file normalize [file dirname abc.dir]])
    } then {
	return "wrong directory with 'cd abc.link ; cd ..': \
		\"[file normalize $up]\" should be \"[file normalize $orig]\"\







|







2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
    cd abc.link
    set dir [pwd]
    cd ..
    set up [pwd]
    cd $orig
    # Now '$up' should be either $orig or [file dirname abc.dir], depending on
    # whether 'cd' actually moves to the destination of a link, or simply
    # treats the link as a directory. (On windows the former, on Unix the
    # latter, I believe)
    if {
	([file normalize $up] ne [file normalize $orig]) &&
	([file normalize $up] ne [file normalize [file dirname abc.dir]])
    } then {
	return "wrong directory with 'cd abc.link ; cd ..': \
		\"[file normalize $up]\" should be \"[file normalize $orig]\"\

Changes to tests/fileName.test.

1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
    # test fails because if an error occurs, the interp's result is reset...
    glob -nocomplain globTest/a2 globTest/a1/* globTest/a3
} {globTest/a2 globTest/a3}
catch {file attributes globTest/a1 -permissions 0o755}
test filename-15.4 {unix specific no complain: no errors, good result} \
	{unix nonPortable} {
    # test fails because if an error occurs, the interp's result is reset...
    # or you don't run at scriptics where the outser and welch users exists
    glob -nocomplain ~ouster ~foo ~welch
} {/home/ouster /home/welch}
test filename-15.4.1 {no complain: errors, sequencing} {
    # test used to fail because if an error occurs, the interp's result is
    # reset... But, the sequence means we throw a different error first.
    list [catch {glob -nocomplain ~wontexist ~blahxyz ~} res1] $res1 \
	[catch {glob -nocomplain ~ ~blahxyz ~wontexist} res2] $res2







|







1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
    # test fails because if an error occurs, the interp's result is reset...
    glob -nocomplain globTest/a2 globTest/a1/* globTest/a3
} {globTest/a2 globTest/a3}
catch {file attributes globTest/a1 -permissions 0o755}
test filename-15.4 {unix specific no complain: no errors, good result} \
	{unix nonPortable} {
    # test fails because if an error occurs, the interp's result is reset...
    # or you don't run at scriptics where the ouster and welch users exists
    glob -nocomplain ~ouster ~foo ~welch
} {/home/ouster /home/welch}
test filename-15.4.1 {no complain: errors, sequencing} {
    # test used to fail because if an error occurs, the interp's result is
    # reset... But, the sequence means we throw a different error first.
    list [catch {glob -nocomplain ~wontexist ~blahxyz ~} res1] $res1 \
	[catch {glob -nocomplain ~ ~blahxyz ~wontexist} res2] $res2

Changes to tests/fileSystem.test.

295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
    testsetplatform unix
    file normalize /../bar
} {/bar}
test filesystem-1.33 {link normalisation: link near filesystem root} {testsetplatform} {
    testsetplatform windows
    set res [file normalize C:/../bar]
    if {[testConstraint unix]} {
	# Some unices go further in normalizing this -- not really a problem
	# since this is a Windows test.
	regexp {C:/bar$} $res res
    }
    set res
} {C:/bar}
if {[testConstraint testsetplatform]} {
    testsetplatform $platform







|







295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
    testsetplatform unix
    file normalize /../bar
} {/bar}
test filesystem-1.33 {link normalisation: link near filesystem root} {testsetplatform} {
    testsetplatform windows
    set res [file normalize C:/../bar]
    if {[testConstraint unix]} {
	# Some Unices go further in normalizing this -- not really a problem
	# since this is a Windows test.
	regexp {C:/bar$} $res res
    }
    set res
} {C:/bar}
if {[testConstraint testsetplatform]} {
    testsetplatform $platform

Changes to tests/for.test.

333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
        46 {changes in the C APIs for custom channel drivers. Scripts written for earlier releases} \
        47 {should work on these new releases as well.} \
        48 {} \
        49 {Obtaining The Releases} \
        50 {} \
        51 {Binary Releases} \
        52 {} \
        53 {Pre-compiled releases are available for the following platforms: } \
        54 {} \
        55 {     Windows 3.1, Windows 95, and Windows NT: Fetch} \
        56 {     ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then execute it. The file is a} \
        57 {     self-extracting executable. It will install the Tcl and Tk libraries, the wish and} \
        58 {     tclsh programs, and documentation.} \
        59 {     Macintosh (both 68K and PowerPC): Fetch} \
        60 {     ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. The file is in binhex format,} \







|







333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
        46 {changes in the C APIs for custom channel drivers. Scripts written for earlier releases} \
        47 {should work on these new releases as well.} \
        48 {} \
        49 {Obtaining The Releases} \
        50 {} \
        51 {Binary Releases} \
        52 {} \
        53 {Precompiled releases are available for the following platforms: } \
        54 {} \
        55 {     Windows 3.1, Windows 95, and Windows NT: Fetch} \
        56 {     ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then execute it. The file is a} \
        57 {     self-extracting executable. It will install the Tcl and Tk libraries, the wish and} \
        58 {     tclsh programs, and documentation.} \
        59 {     Macintosh (both 68K and PowerPC): Fetch} \
        60 {     ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. The file is in binhex format,} \
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
ts written for earlier releases
should work on these new releases as well.

Obtaining The Releases

Binary Releases

Pre-compiled releases are available for the following
platforms:

     Windows 3.1, Windows 95, and Windows NT: Fetch
     ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then
execute it. The file is a
     self-extracting executable. It will install the
Tcl and Tk libraries, the wish and







|







552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
ts written for earlier releases
should work on these new releases as well.

Obtaining The Releases

Binary Releases

Precompiled releases are available for the following
platforms:

     Windows 3.1, Windows 95, and Windows NT: Fetch
     ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then
execute it. The file is a
     self-extracting executable. It will install the
Tcl and Tk libraries, the wish and

Changes to tests/indexObj.test.

1
2
3
4
5
6
7
8
# This file is a Tcl script to test out the the procedures in file
# tkIndexObj.c, which implement indexed table lookups.  The tests here are
# organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
|







1
2
3
4
5
6
7
8
# This file is a Tcl script to test out the procedures in file
# tkIndexObj.c, which implement indexed table lookups.  The tests here are
# organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of

Changes to tests/internals.tcl.

32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
	set pipe [open |[list [interpreter]] r+]
	set ppid [pid $pipe]
	# create prlimit args:
	set args {}
	# with limited address space:
	if {[info exists in(-addmem)] || [info exists in(-maxmem)]} {
	    if {[info exists in(-addmem)]} {
		# as differnce to normal usage, so try to retrieve current memory usage:
		if {[catch {
		    # using ps (vsz is in KB):
		    incr in(-addmem) [expr {[lindex [exec ps -hq $ppid -o vsz] end] * 1024}]
		}]} {
		    # ps failed, use default size 20MB:
		    incr in(-addmem) 20000000
		    # + size of locale-archive (may be up to 100MB):







|







32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
	set pipe [open |[list [interpreter]] r+]
	set ppid [pid $pipe]
	# create prlimit args:
	set args {}
	# with limited address space:
	if {[info exists in(-addmem)] || [info exists in(-maxmem)]} {
	    if {[info exists in(-addmem)]} {
		# as difference to normal usage, so try to retrieve current memory usage:
		if {[catch {
		    # using ps (vsz is in KB):
		    incr in(-addmem) [expr {[lindex [exec ps -hq $ppid -o vsz] end] * 1024}]
		}]} {
		    # ps failed, use default size 20MB:
		    incr in(-addmem) 20000000
		    # + size of locale-archive (may be up to 100MB):

Changes to tests/io.test.

3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
    fconfigure $f -translation binary
    set x [fconfigure $f -translation]
    close $f
    set x
} lf
#
# Test io-9.14 has been removed because "auto" output translation mode is
# not supoprted.
#
test io-31.14 {Tcl_Write mixed, Tcl_Gets auto} {
    file delete $path(test1)
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts $f hello\nthere\rand\r\nhere
    close $f







|







3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
    fconfigure $f -translation binary
    set x [fconfigure $f -translation]
    close $f
    set x
} lf
#
# Test io-9.14 has been removed because "auto" output translation mode is
# not supported.
#
test io-31.14 {Tcl_Write mixed, Tcl_Gets auto} {
    file delete $path(test1)
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts $f hello\nthere\rand\r\nhere
    close $f
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727
5728
5729
5730
    fconfigure $f1 -eofchar D
    lappend l [fconfigure $f1 -eofchar]
    lappend l [list [catch {fconfigure $f1 -eofchar {1 2 3}} msg] $msg]
    close $f1
    set l
} {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}}
test io-39.23 {Tcl_GetChannelOption, server socket is not readable or
        writeable, it should still have valid -eofchar and -translation options } {
    set l [list]
    set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
    lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
    close $sock
    set l
} {{{}} auto}
test io-39.24 {Tcl_SetChannelOption, server socket is not readable or







|







5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727
5728
5729
5730
    fconfigure $f1 -eofchar D
    lappend l [fconfigure $f1 -eofchar]
    lappend l [list [catch {fconfigure $f1 -eofchar {1 2 3}} msg] $msg]
    close $f1
    set l
} {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}}
test io-39.23 {Tcl_GetChannelOption, server socket is not readable or
        writable, it should still have valid -eofchar and -translation options } {
    set l [list]
    set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
    lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
    close $sock
    set l
} {{{}} auto}
test io-39.24 {Tcl_SetChannelOption, server socket is not readable or
8491
8492
8493
8494
8495
8496
8497
8498
8499
8500
8501
8502
8503
8504
8505
    close $f
    set res
} -cleanup {
    removeFile eofchar
} -result {77 = 23431}


# Test the cutting and splicing of channels, this is incidentially the
# attach/detach facility of package Thread, but __without any
# safeguards__. It can also be used to emulate transfer of channels
# between threads, and is used for that here.

test io-70.0 {Cutting & Splicing channels} {testchannel} {
    set f [makeFile {... dummy ...} cutsplice]
    set c [open $f r]







|







8491
8492
8493
8494
8495
8496
8497
8498
8499
8500
8501
8502
8503
8504
8505
    close $f
    set res
} -cleanup {
    removeFile eofchar
} -result {77 = 23431}


# Test the cutting and splicing of channels, this is incidentally the
# attach/detach facility of package Thread, but __without any
# safeguards__. It can also be used to emulate transfer of channels
# between threads, and is used for that here.

test io-70.0 {Cutting & Splicing channels} {testchannel} {
    set f [makeFile {... dummy ...} cutsplice]
    set c [open $f r]

Changes to tests/ioCmd.test.

656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
    set msg
} {wrong # args: should be "chan subcommand ?arg ...?"}
test iocmd-20.1 {chan, unknown method} -body {
    chan foo
} -returnCodes error -match glob -result {unknown or ambiguous subcommand "foo": must be *}

# --- --- --- --------- --------- ---------
# chan create, and method "initalize"

test iocmd-21.0 {chan create, wrong#args, not enough} {
    catch {chan create} msg
    set msg
} {wrong # args: should be "chan create mode cmdprefix"}
test iocmd-21.1 {chan create, wrong#args, too many} {
    catch {chan create a b c} msg







|







656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
    set msg
} {wrong # args: should be "chan subcommand ?arg ...?"}
test iocmd-20.1 {chan, unknown method} -body {
    chan foo
} -returnCodes error -match glob -result {unknown or ambiguous subcommand "foo": must be *}

# --- --- --- --------- --------- ---------
# chan create, and method "initialize"

test iocmd-21.0 {chan create, wrong#args, not enough} {
    catch {chan create} msg
    set msg
} {wrong # args: should be "chan create mode cmdprefix"}
test iocmd-21.1 {chan create, wrong#args, too many} {
    catch {chan create a b c} msg

Changes to tests/ioTrans.test.

110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
    chan
} -result {wrong # args: should be "chan subcommand ?arg ...?"}
test iortrans-1.1 {chan, unknown method} -returnCodes error -body {
    chan foo
} -match glob -result {unknown or ambiguous subcommand "foo": must be*}

# --- --- --- --------- --------- ---------
# chan push, and method "initalize"

test iortrans-2.0 {chan push, wrong#args, not enough} -returnCodes error -body {
    chan push
} -result {wrong # args: should be "chan push channel cmdprefix"}
test iortrans-2.1 {chan push, wrong#args, too many} -returnCodes error -body {
    chan push a b c
} -result {wrong # args: should be "chan push channel cmdprefix"}







|







110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
    chan
} -result {wrong # args: should be "chan subcommand ?arg ...?"}
test iortrans-1.1 {chan, unknown method} -returnCodes error -body {
    chan foo
} -match glob -result {unknown or ambiguous subcommand "foo": must be*}

# --- --- --- --------- --------- ---------
# chan push, and method "initialize"

test iortrans-2.0 {chan push, wrong#args, not enough} -returnCodes error -body {
    chan push
} -result {wrong # args: should be "chan push channel cmdprefix"}
test iortrans-2.1 {chan push, wrong#args, too many} -returnCodes error -body {
    chan push a b c
} -result {wrong # args: should be "chan push channel cmdprefix"}
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
#
## The id numbers refer to the original test without thread forwarding, and
## gaps due to tests not applicable to forwarding are left to keep this
## association.

# ### ### ### ######### ######### #########
## Helper command. Runs a script in a separate thread and returns the result.
## A channel is transfered into the thread as well, and a list of configuation
## variables

proc inthread {chan script args} {
    # Test thread.
    set tid [thread::create -preserved]
    thread::send $tid {load {} Tcltest}








|







1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
#
## The id numbers refer to the original test without thread forwarding, and
## gaps due to tests not applicable to forwarding are left to keep this
## association.

# ### ### ### ######### ######### #########
## Helper command. Runs a script in a separate thread and returns the result.
## A channel is transferred into the thread as well, and a list of configuration
## variables

proc inthread {chan script args} {
    # Test thread.
    set tid [thread::create -preserved]
    thread::send $tid {load {} Tcltest}

2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
    set c [chan push [tempchan] foo]
    lappend res {*}[inthread $c {
	# Flush, no writing
	seek $c 2
	# The close flushes again, this modifies the file!
	lappend notes | [close $c] |
	# NOTE: The flush generated by the close is recorded immediately, the
	# other note's here are defered until after the thread is done. This
	# changes the order of the result a bit from the non-threaded case
	# (The first | moves one to the right). This is an artifact of the
	# 'inthread' framework, not of the transformation itself.
	notes
    } c]
    lappend res [tempview]
} -cleanup {







|







2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
    set c [chan push [tempchan] foo]
    lappend res {*}[inthread $c {
	# Flush, no writing
	seek $c 2
	# The close flushes again, this modifies the file!
	lappend notes | [close $c] |
	# NOTE: The flush generated by the close is recorded immediately, the
	# other note's here are deferred until after the thread is done. This
	# changes the order of the result a bit from the non-threaded case
	# (The first | moves one to the right). This is an artifact of the
	# 'inthread' framework, not of the transformation itself.
	notes
    } c]
    lappend res [tempview]
} -cleanup {

Changes to tests/iogt.test.

839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
    set f [open $path(dummy) r]
    # contents of dummy = "abcdefghi..."
    read $f 3;		# skip behind "abc"
    constx -attach $f
    # expect to get "xxx" from the transform because of unread "def" input to
    # transform which returns "xxx".
    #
    # Actually the IO layer pre-read the whole file and will read "def"
    # directly from the buffer without bothering to consult the newly stacked
    # transformation. This is wrong.
    read $f 3
} -cleanup {
    close $f
} -result {xxx}
test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body {







|







839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
    set f [open $path(dummy) r]
    # contents of dummy = "abcdefghi..."
    read $f 3;		# skip behind "abc"
    constx -attach $f
    # expect to get "xxx" from the transform because of unread "def" input to
    # transform which returns "xxx".
    #
    # Actually the IO layer preread the whole file and will read "def"
    # directly from the buffer without bothering to consult the newly stacked
    # transformation. This is wrong.
    read $f 3
} -cleanup {
    close $f
} -result {xxx}
test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body {

Changes to tests/mathop.test.

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
# A namespace to test that operators are exported and that they
# work when imported
namespace eval ::testmathop2 {
    namespace import ::tcl::mathop::*
}

# Helper to test math ops.
# Test different invokation variants and see that they do the same thing.
# Byte compiled / non byte compiled version
# Shared / unshared arguments
# Original / imported
proc TestOp {op args} {
    set results {}

    # Non byte compiled version, shared args







|







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
# A namespace to test that operators are exported and that they
# work when imported
namespace eval ::testmathop2 {
    namespace import ::tcl::mathop::*
}

# Helper to test math ops.
# Test different invocation variants and see that they do the same thing.
# Byte compiled / non byte compiled version
# Shared / unshared arguments
# Original / imported
proc TestOp {op args} {
    set results {}

    # Non byte compiled version, shared args

Changes to tests/msgcat.test.

974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
    }
    set bgerrorsaved [interp bgerror {}]
    interp bgerror {} [namespace code callbackproc]

    variable locale
    if {![info exist locale]} { set locale [mclocale] }

	test msgcat-14.1 {invokation loadcmd} -setup {
	    mcforgetpackage
    	    mclocale $locale
	    mclocale ""
	    mcloadedlocales clear
	    set resultvariable ""
	} -cleanup {
	    mcforgetpackage
	} -body {
	    mcpackageconfig set loadcmd [namespace code callbackproc]
	    mclocale foo_bar
	    lsort $resultvariable
	} -result {foo foo_bar}

	test msgcat-14.2 {invokation failed in loadcmd} -setup {
	    mcforgetpackage
    	    mclocale $locale
	    mclocale ""
	    mcloadedlocales clear
	} -cleanup {
	    mcforgetpackage
	    after cancel set [namespace current]::resultvariable timeout
	} -body {
	    mcpackageconfig set loadcmd [namespace code callbackfailproc]
	    mclocale foo_bar
	    # let the bgerror run
	    after 100 set [namespace current]::resultvariable timeout
	    vwait [namespace current]::resultvariable
	    lassign $resultvariable err errdict
	    list $err [dict get $errdict -code]
	} -result {fail 1}

	test msgcat-14.3 {invokation changecmd} -setup {
	    mcforgetpackage
    	    mclocale $locale
	    mclocale ""
	    set resultvariable ""
	} -cleanup {
	    mcforgetpackage
	} -body {
	    mcpackageconfig set changecmd [namespace code callbackproc]
	    mclocale foo_bar
	    set resultvariable
	} -result {foo_bar foo {}}

	test msgcat-14.4 {invokation unknowncmd} -setup {
	    mcforgetpackage
    	    mclocale $locale
	    mclocale ""
	    mcloadedlocales clear
	    set resultvariable ""
	} -cleanup {
	    mcforgetpackage







|













|

















|












|







974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
    }
    set bgerrorsaved [interp bgerror {}]
    interp bgerror {} [namespace code callbackproc]

    variable locale
    if {![info exist locale]} { set locale [mclocale] }

	test msgcat-14.1 {invocation loadcmd} -setup {
	    mcforgetpackage
    	    mclocale $locale
	    mclocale ""
	    mcloadedlocales clear
	    set resultvariable ""
	} -cleanup {
	    mcforgetpackage
	} -body {
	    mcpackageconfig set loadcmd [namespace code callbackproc]
	    mclocale foo_bar
	    lsort $resultvariable
	} -result {foo foo_bar}

	test msgcat-14.2 {invocation failed in loadcmd} -setup {
	    mcforgetpackage
    	    mclocale $locale
	    mclocale ""
	    mcloadedlocales clear
	} -cleanup {
	    mcforgetpackage
	    after cancel set [namespace current]::resultvariable timeout
	} -body {
	    mcpackageconfig set loadcmd [namespace code callbackfailproc]
	    mclocale foo_bar
	    # let the bgerror run
	    after 100 set [namespace current]::resultvariable timeout
	    vwait [namespace current]::resultvariable
	    lassign $resultvariable err errdict
	    list $err [dict get $errdict -code]
	} -result {fail 1}

	test msgcat-14.3 {invocation changecmd} -setup {
	    mcforgetpackage
    	    mclocale $locale
	    mclocale ""
	    set resultvariable ""
	} -cleanup {
	    mcforgetpackage
	} -body {
	    mcpackageconfig set changecmd [namespace code callbackproc]
	    mclocale foo_bar
	    set resultvariable
	} -result {foo_bar foo {}}

	test msgcat-14.4 {invocation unknowncmd} -setup {
	    mcforgetpackage
    	    mclocale $locale
	    mclocale ""
	    mcloadedlocales clear
	    set resultvariable ""
	} -cleanup {
	    mcforgetpackage

Changes to tests/ooNext2.test.

122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
	}
    }
    oo::class create C {
	superclass A B
	variable result
	constructor {p q r} {
	    lappend result ==C== p=$p,q=$q,r=$r
	    # Route arguments to superclasses, in non-trival pattern
	    nextto B $q
	    nextto A $p $r
	}
	method result {} {return $result}
    }
    [C new x y z] result
} -cleanup {







|







122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
	}
    }
    oo::class create C {
	superclass A B
	variable result
	constructor {p q r} {
	    lappend result ==C== p=$p,q=$q,r=$r
	    # Route arguments to superclasses, in non-trivial pattern
	    nextto B $q
	    nextto A $p $r
	}
	method result {} {return $result}
    }
    [C new x y z] result
} -cleanup {

Changes to tests/pkgMkIndex.test.

486
487
488
489
490
491
492
493
494
495
496
497
498
499
500

removeFile [file join pkg pkg5.tcl]
removeFile [file join pkg pkg2_a.tcl]
removeFile [file join pkg pkg2_b.tcl]

makeFile {
#  This package requires circ2, and circ2 requires circ3, which in turn
#  requires circ1.  In case of cirularities, pkg_mkIndex should give up when
#  it gets stuck.
package require circ2 1.0
package provide circ1 1.0
namespace eval circ1 {
    namespace export c1-1 c1-2 c1-3 c1-4
}
proc circ1::c1-1 { num } {







|







486
487
488
489
490
491
492
493
494
495
496
497
498
499
500

removeFile [file join pkg pkg5.tcl]
removeFile [file join pkg pkg2_a.tcl]
removeFile [file join pkg pkg2_b.tcl]

makeFile {
#  This package requires circ2, and circ2 requires circ3, which in turn
#  requires circ1.  In case of circularities, pkg_mkIndex should give up when
#  it gets stuck.
package require circ2 1.0
package provide circ1 1.0
namespace eval circ1 {
    namespace export c1-1 c1-2 c1-3 c1-4
}
proc circ1::c1-1 { num } {
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662

test pkgMkIndex-12.1 {same name procs in different namespace} {
    pkgtest::runIndex -lazy $fullPkgPath samename.tcl
} {0 {{football:1.0 {tclPkgSetup {samename.tcl source {::college::team ::pro::team}}}}}}

removeFile [file join pkg samename.tcl]

# Proc names with embedded spaces are properly listed (ie, correct number of
# braces) in result
makeFile {
package provide spacename 1.0
proc {a b} {} {}
proc {c d} {} {}
} [file join pkg spacename.tcl]








|







648
649
650
651
652
653
654
655
656
657
658
659
660
661
662

test pkgMkIndex-12.1 {same name procs in different namespace} {
    pkgtest::runIndex -lazy $fullPkgPath samename.tcl
} {0 {{football:1.0 {tclPkgSetup {samename.tcl source {::college::team ::pro::team}}}}}}

removeFile [file join pkg samename.tcl]

# Proc names with embedded spaces are properly listed (i.e. correct number of
# braces) in result
makeFile {
package provide spacename 1.0
proc {a b} {} {}
proc {c d} {} {}
} [file join pkg spacename.tcl]

Changes to tests/remote.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# This file contains Tcl code to implement a remote server that can be
# used during testing of Tcl socket code. This server is used by some
# of the tests in socket.test.
#
# Source this file in the remote server you are using to test Tcl against.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

# Initialize message delimitor

# Initialize command array
catch {unset command}
set command(0) ""
set callerSocket ""

# Detect whether we should print out connection messages etc.











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# This file contains Tcl code to implement a remote server that can be
# used during testing of Tcl socket code. This server is used by some
# of the tests in socket.test.
#
# Source this file in the remote server you are using to test Tcl against.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

# Initialize message delimiter

# Initialize command array
catch {unset command}
set command(0) ""
set callerSocket ""

# Detect whether we should print out connection messages etc.

Changes to tests/resolver.test.

199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
# The test resolver-3.1* test bad interactions of resolvers on the "global"
# (per interp) literal pools. A resolver might resolve a cmd literal depending
# on a context differently, whereas the cmd literal sharing assumed that the
# namespace containing the literal solely determines the resolved cmd (and is
# resolver-agnostic).
#
# In order to make the test cases for the per-interpreter cmd literal pool
# reproducable and to minimize interactions between test cases, we use a child
# interpreter per test-case.
#
#
# Testing resolver in namespace-based context "ctx1"
#
test resolver-3.1a {
    interp command resolver,







|







199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
# The test resolver-3.1* test bad interactions of resolvers on the "global"
# (per interp) literal pools. A resolver might resolve a cmd literal depending
# on a context differently, whereas the cmd literal sharing assumed that the
# namespace containing the literal solely determines the resolved cmd (and is
# resolver-agnostic).
#
# In order to make the test cases for the per-interpreter cmd literal pool
# reproducible and to minimize interactions between test cases, we use a child
# interpreter per test-case.
#
#
# Testing resolver in namespace-based context "ctx1"
#
test resolver-3.1a {
    interp command resolver,

Changes to tests/safe-stock.test.

36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
    set listOut {}
    foreach element $listIn {
        lappend listOut [string map $map $element]
    }
    return $listOut
}

# Force actual loading of the safe package because we use un-exported (and
# thus un-autoindexed) APIs in this test result arguments:
catch {safe::interpConfigure}

# high level general test
test safe-stock-7.1 {tests that everything works at high level, uses http 2} -body {
    set i [safe::interpCreate]
    # no error shall occur:
    # (because the default access_path shall include 1st level sub dirs so







|
|







36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
    set listOut {}
    foreach element $listIn {
        lappend listOut [string map $map $element]
    }
    return $listOut
}

# Force actual loading of the safe package because we use unexported (and
# thus unautoindexed) APIs in this test result arguments:
catch {safe::interpConfigure}

# high level general test
test safe-stock-7.1 {tests that everything works at high level, uses http 2} -body {
    set i [safe::interpCreate]
    # no error shall occur:
    # (because the default access_path shall include 1st level sub dirs so

Changes to tests/safe.test.

46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
    set listOut {}
    foreach element $listIn {
        lappend listOut [string map $map $element]
    }
    lsort $listOut
}

# Force actual loading of the safe package because we use un-exported (and
# thus un-autoindexed) APIs in this test result arguments:
catch {safe::interpConfigure}

# testing that nested and statics do what is advertised (we use a static
# package - Tcltest - but it might be absent if we're in standard tclsh)

testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}]








|
|







46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
    set listOut {}
    foreach element $listIn {
        lappend listOut [string map $map $element]
    }
    lsort $listOut
}

# Force actual loading of the safe package because we use unexported (and
# thus unautoindexed) APIs in this test result arguments:
catch {safe::interpConfigure}

# testing that nested and statics do what is advertised (we use a static
# package - Tcltest - but it might be absent if we're in standard tclsh)

testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}]


Changes to tests/scan.test.

508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
} -result {4 12 34 56 78}
test scan-5.10 {integer scanning} -setup {
    set a {}; set b {}; set c {}; set d {}
} -body {
    list [scan "1 2 " "%hd %d %d %d" a b c d] $a $b $c $d
} -result {2 1 2 {} {}}
#
# The behavior for scaning intergers larger than MAX_INT is not defined by the
# ANSI spec.  Some implementations wrap the input (-16) some return MAX_INT.
#
test scan-5.11 {integer scanning} -constraints {nonPortable} -setup {
    set a {}; set b {}
} -body {
    list [scan "4294967280 4294967280" "%u %d" a b] $a \
	    [expr {$b == -16 || $b == 0x7fffffff}]







|







508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
} -result {4 12 34 56 78}
test scan-5.10 {integer scanning} -setup {
    set a {}; set b {}; set c {}; set d {}
} -body {
    list [scan "1 2 " "%hd %d %d %d" a b c d] $a $b $c $d
} -result {2 1 2 {} {}}
#
# The behavior for scanning integers larger than MAX_INT is not defined by the
# ANSI spec.  Some implementations wrap the input (-16) some return MAX_INT.
#
test scan-5.11 {integer scanning} -constraints {nonPortable} -setup {
    set a {}; set b {}
} -body {
    list [scan "4294967280 4294967280" "%u %d" a b] $a \
	    [expr {$b == -16 || $b == 0x7fffffff}]

Changes to tests/socket.test.

110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
puts $s2 test1; gets $s1
puts $s2 test2; gets $s1
close $s1; close $s2
set t2 [clock milliseconds]
set lat1 [expr {($t2-$t1)*2}]; # doubled as a safety margin

# Test the latency of failed connection attempts over the loopback
# interface. They can take more than a second under Windowos and requres
# additional [after]s in some tests that are not needed on systems that fail
# immediately.
set t1 [clock milliseconds]
catch {socket 127.0.0.1 [randport]}
set t2 [clock milliseconds]
set lat2 [expr {($t2-$t1)*3}]








|







110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
puts $s2 test1; gets $s1
puts $s2 test2; gets $s1
close $s1; close $s2
set t2 [clock milliseconds]
set lat1 [expr {($t2-$t1)*2}]; # doubled as a safety margin

# Test the latency of failed connection attempts over the loopback
# interface. They can take more than a second under Windows and requires
# additional [after]s in some tests that are not needed on systems that fail
# immediately.
set t1 [clock milliseconds]
catch {socket 127.0.0.1 [randport]}
set t2 [clock milliseconds]
set lat2 [expr {($t2-$t1)*3}]

1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
  try {
    set ::count 0
    set ::testmode $testmode
    set port 0
    set srvsock {}
    # if binding on port 0 is not possible (system related, blocked on ISPs etc):
    if {[catch {close [socket -async $::localhost $port]}]} {
      # simplest server on random port (immediatelly closing a connect):
      set port [randport]
      set srvsock [socket -server {apply {{ch args} {close $ch}}} -myaddr $::localhost $port]
      # socket on windows has some issues yet (e. g. bug [b6d0d8cc2c]), so we simply decrease iteration count (to 1/4):
      if {$::tcl_platform(platform) eq "windows" && $maxIter > 50} {
      	set ::count [expr {$maxIter / 4 * 3 - 1}]; # bypass 3/4 iterations
      }
    }







|







1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
  try {
    set ::count 0
    set ::testmode $testmode
    set port 0
    set srvsock {}
    # if binding on port 0 is not possible (system related, blocked on ISPs etc):
    if {[catch {close [socket -async $::localhost $port]}]} {
      # simplest server on random port (immediately closing a connect):
      set port [randport]
      set srvsock [socket -server {apply {{ch args} {close $ch}}} -myaddr $::localhost $port]
      # socket on windows has some issues yet (e. g. bug [b6d0d8cc2c]), so we simply decrease iteration count (to 1/4):
      if {$::tcl_platform(platform) eq "windows" && $maxIter > 50} {
      	set ::count [expr {$maxIter / 4 * 3 - 1}]; # bypass 3/4 iterations
      }
    }
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
          }} $fd]
        };#
        thread::detach $fd
        thread::send -async $::parent [list transf_parent $fd {*}$args]
      }
      iteration first
    }
    # parent proc commiting transfer attempt (attach) and checking acquire was successful:
    proc transf_parent {fd args} {
      tcltest::DebugPuts 2 "** trma / $::count ** $args **"
      thread::attach $fd
      if {"parent-close" in $::testmode} {;# to test close during connect
        set ::count $::count
        close $fd
        return







|







1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
          }} $fd]
        };#
        thread::detach $fd
        thread::send -async $::parent [list transf_parent $fd {*}$args]
      }
      iteration first
    }
    # parent proc committing transfer attempt (attach) and checking acquire was successful:
    proc transf_parent {fd args} {
      tcltest::DebugPuts 2 "** trma / $::count ** $args **"
      thread::attach $fd
      if {"parent-close" in $::testmode} {;# to test close during connect
        set ::count $::count
        close $fd
        return
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
    catch {close $s}
    unset -nocomplain x s
} -result {connection refused}
test socket-14.13 {testing writable event when quick failure} -body {
    # Test for bug 336441ed59 where a quick background fail was ignored
    #
    # Test only for windows as socket -async 255.255.255.255 fails
    # directly on unix
    #
    # The following connect should fail very quickly
    set a1 [after $latency {set x timeout}]
    set s [socket -async 255.255.255.255 43434]
    fileevent $s writable {set x writable}
    vwait x
    set x







|







2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
    catch {close $s}
    unset -nocomplain x s
} -result {connection refused}
test socket-14.13 {testing writable event when quick failure} -body {
    # Test for bug 336441ed59 where a quick background fail was ignored
    #
    # Test only for windows as socket -async 255.255.255.255 fails
    # directly on Unix
    #
    # The following connect should fail very quickly
    set a1 [after $latency {set x timeout}]
    set s [socket -async 255.255.255.255 43434]
    fileevent $s writable {set x writable}
    vwait x
    set x

Changes to tests/stringObj.test.

310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
    string length $x
    list [testobj objtype $x] [testobj objtype $y] [append x $y] \
	    [set y] [testobj objtype $x] [testobj objtype $y]
} "string int abc\u00ef\u00bf\u00aeghi9 9 string int"
test stringObj-9.11 {TclAppendObjToObj, mixed src & 1-byte dest index check} testobj {
    # bug 2678, in <=8.2.0, the second obj (the one to append) in
    # Tcl_AppendObjToObj was not correctly checked to see if it was all one
    # byte chars, so a unicode string would be added as one byte chars.
    set x abcdef
    set len [string length $x]
    set y a\u00fcb\u00e5c\u00ef
    set len [string length $y]
    append x $y
    string length $x
    set q {}







|







310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
    string length $x
    list [testobj objtype $x] [testobj objtype $y] [append x $y] \
	    [set y] [testobj objtype $x] [testobj objtype $y]
} "string int abc\u00ef\u00bf\u00aeghi9 9 string int"
test stringObj-9.11 {TclAppendObjToObj, mixed src & 1-byte dest index check} testobj {
    # bug 2678, in <=8.2.0, the second obj (the one to append) in
    # Tcl_AppendObjToObj was not correctly checked to see if it was all one
    # byte chars, so a Unicode string would be added as one byte chars.
    set x abcdef
    set len [string length $x]
    set y a\u00fcb\u00e5c\u00ef
    set len [string length $y]
    append x $y
    string length $x
    set q {}
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
    testdstring append abcdef -1
    set x [testdstring get]
    list [testobj objtype $x] [set y [string range $x 1 end-1]] \
	    [testobj objtype $x] [testobj objtype $y]
} [list none bcde string string]
test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstring} {
    # Because this test does not use \uXXXX notation below instead of
    # hardcoding the values, it may fail in multibyte locales. However, we
    # need to test that the parser produces untyped objects even when there
    # are high-ASCII characters in the input (like "ï"). I don't know what
    # else to do but inline those characters here.
    testdstring free
    testdstring append "abc\u00ef\u00efdef" -1
    set x [testdstring get]
    list [testobj objtype $x] [set y [string range $x 1 end-1]] \
	    [testobj objtype $x] [testobj objtype $y]
} [list none "bc\u00EF\u00EFde" string string]
test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj {
    # set x "abcïïdef"
    # Use \uXXXX notation below instead of hardcoding the values, otherwise
    # the test will fail in multibyte locales.
    set x "abc\u00EF\u00EFdef"
    string length $x
    list [testobj objtype $x] [set y [string range $x 1 end-1]] \
	    [testobj objtype $x] [testobj objtype $y]
} [list string "bc\u00EF\u00EFde" string string]
test stringObj-10.4 {Tcl_GetRange with some mixed width chars} testobj {
    # set a "ïa¿b®cï¿d®"
    # Use \uXXXX notation below instead of hardcoding the values, otherwise
    # the test will fail in multibyte locales.
    set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE"
    set result [list]
    while {[string length $a] > 0} {
	set a [string range $a 1 end-1]
	lappend result $a
    }







|











|








|







333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
    testdstring append abcdef -1
    set x [testdstring get]
    list [testobj objtype $x] [set y [string range $x 1 end-1]] \
	    [testobj objtype $x] [testobj objtype $y]
} [list none bcde string string]
test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstring} {
    # Because this test does not use \uXXXX notation below instead of
    # hard-coding the values, it may fail in multibyte locales. However, we
    # need to test that the parser produces untyped objects even when there
    # are high-ASCII characters in the input (like "ï"). I don't know what
    # else to do but inline those characters here.
    testdstring free
    testdstring append "abc\u00ef\u00efdef" -1
    set x [testdstring get]
    list [testobj objtype $x] [set y [string range $x 1 end-1]] \
	    [testobj objtype $x] [testobj objtype $y]
} [list none "bc\u00EF\u00EFde" string string]
test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj {
    # set x "abcïïdef"
    # Use \uXXXX notation below instead of hard-coding the values, otherwise
    # the test will fail in multibyte locales.
    set x "abc\u00EF\u00EFdef"
    string length $x
    list [testobj objtype $x] [set y [string range $x 1 end-1]] \
	    [testobj objtype $x] [testobj objtype $y]
} [list string "bc\u00EF\u00EFde" string string]
test stringObj-10.4 {Tcl_GetRange with some mixed width chars} testobj {
    # set a "ïa¿b®cï¿d®"
    # Use \uXXXX notation below instead of hard-coding the values, otherwise
    # the test will fail in multibyte locales.
    set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE"
    set result [list]
    while {[string length $a] > 0} {
	set a [string range $a 1 end-1]
	lappend result $a
    }
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
    list [string length $a] [string length $a]
} {6 6}
test stringObj-13.4 {Tcl_GetCharLength with mixed width chars} testobj {
    string length "\u00ae"
} 1
test stringObj-13.5 {Tcl_GetCharLength with mixed width chars} testobj {
    # string length "○○"
    # Use \uXXXX notation below instead of hardcoding the values, otherwise
    # the test will fail in multibyte locales.
    string length "\u00EF\u00BF\u00AE\u00EF\u00BF\u00AE"
} 6
test stringObj-13.6 {Tcl_GetCharLength with mixed width chars} testobj {
    # set a "ïa¿b®cï¿d®"
    # Use \uXXXX notation below instead of hardcoding the values, otherwise
    # the test will fail in multibyte locales.
    set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE"
    list [string length $a] [string length $a]
} {10 10}
test stringObj-13.7 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} {
    # SF bug #684699
    string length [testbytestring \x00]







|





|







414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
    list [string length $a] [string length $a]
} {6 6}
test stringObj-13.4 {Tcl_GetCharLength with mixed width chars} testobj {
    string length "\u00ae"
} 1
test stringObj-13.5 {Tcl_GetCharLength with mixed width chars} testobj {
    # string length "○○"
    # Use \uXXXX notation below instead of hard-coding the values, otherwise
    # the test will fail in multibyte locales.
    string length "\u00EF\u00BF\u00AE\u00EF\u00BF\u00AE"
} 6
test stringObj-13.6 {Tcl_GetCharLength with mixed width chars} testobj {
    # set a "ïa¿b®cï¿d®"
    # Use \uXXXX notation below instead of hard-coding the values, otherwise
    # the test will fail in multibyte locales.
    set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE"
    list [string length $a] [string length $a]
} {10 10}
test stringObj-13.7 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} {
    # SF bug #684699
    string length [testbytestring \x00]

Changes to tests/tcltest.test.

538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
    -body {
	child msg $a -tmpdir $tdiaf
	return $msg
    }
    -result {*not a directory*}
    -match glob
}
# Test non-writeable directories, non-readable directories with directory flags
set notReadableDir [file join [temporaryDirectory] notreadable]
set notWriteableDir [file join [temporaryDirectory] notwriteable]
makeDirectory notreadable
makeDirectory notwriteable
switch -- $::tcl_platform(platform) {
    unix {
	file attributes $notReadableDir -permissions 0o333
	file attributes $notWriteableDir -permissions 0o555
    }
    default {
	# note in FAT/NTFS we won't be able to protect directory with read-only attribute...
	catch {file attributes $notWriteableDir -readonly 1}
	catch {testchmod 0o444 $notWriteableDir}
    }
}
test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
    -constraints {unix notRoot notWsl}
    -body {
	child msg $a -tmpdir $notReadableDir
	return $msg
    }
    -result {*not readable*}
    -match glob
}
# This constraint doesn't go at the top of the file so that it doesn't
# interfere with tcltest-5.5
testConstraint notFAT [expr {
       ![regexp {^(FAT\d*|NTFS)$} [lindex [file system $notWriteableDir] 1]]
    || $::tcl_platform(platform) eq "unix" || [llength [info commands testchmod]]
}]
# FAT/NTFS permissions are fairly hopeless; ignore this test if that FS is used
test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {
    -constraints {unixOrWin notRoot notFAT notWsl}
    -body {
	child msg $a -tmpdir $notWriteableDir
	return $msg
    }
    -result {*not writeable*}
    -match glob
}
test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {
    -constraints unixOrWin
    -body {
	child msg $a -tmpdir $normaldirectory
	# The join is necessary because the message can be split on multiple







|

|

|



|



|
|














|



|


|


|







538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
    -body {
	child msg $a -tmpdir $tdiaf
	return $msg
    }
    -result {*not a directory*}
    -match glob
}
# Test non-writable directories, non-readable directories with directory flags
set notReadableDir [file join [temporaryDirectory] notreadable]
set notWritableDir [file join [temporaryDirectory] notwritable]
makeDirectory notreadable
makeDirectory notwritable
switch -- $::tcl_platform(platform) {
    unix {
	file attributes $notReadableDir -permissions 0o333
	file attributes $notWritableDir -permissions 0o555
    }
    default {
	# note in FAT/NTFS we won't be able to protect directory with read-only attribute...
	catch {file attributes $notWritableDir -readonly 1}
	catch {testchmod 0o444 $notWritableDir}
    }
}
test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
    -constraints {unix notRoot notWsl}
    -body {
	child msg $a -tmpdir $notReadableDir
	return $msg
    }
    -result {*not readable*}
    -match glob
}
# This constraint doesn't go at the top of the file so that it doesn't
# interfere with tcltest-5.5
testConstraint notFAT [expr {
       ![regexp {^(FAT\d*|NTFS)$} [lindex [file system $notWritableDir] 1]]
    || $::tcl_platform(platform) eq "unix" || [llength [info commands testchmod]]
}]
# FAT/NTFS permissions are fairly hopeless; ignore this test if that FS is used
test tcltest-8.4 {tcltest a.tcl -tmpdir notWritableDir} {
    -constraints {unixOrWin notRoot notFAT notWsl}
    -body {
	child msg $a -tmpdir $notWritableDir
	return $msg
    }
    -result {*not writable*}
    -match glob
}
test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {
    -constraints unixOrWin
    -body {
	child msg $a -tmpdir $normaldirectory
	# The join is necessary because the message can be split on multiple
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
}

# clean up from directory testing

switch -- $::tcl_platform(platform) {
    unix {
	file attributes $notReadableDir -permissions 0o777
	file attributes $notWriteableDir -permissions 0o777
    }
    default {
	catch {testchmod 0o777 $notWriteableDir}
	catch {file attributes $notWriteableDir -readonly 0}
    }
}

file delete -force -- $notReadableDir $notWriteableDir
removeFile a.tcl
removeFile thisdirectoryisafile
removeDirectory normaldirectory

# -file, -notfile, [matchFiles], [skipFiles]
test tcltest-9.1 {-file d*.tcl} -constraints {unixOrWin} -setup {
    set old [testsDirectory]







|


|
|



|







716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
}

# clean up from directory testing

switch -- $::tcl_platform(platform) {
    unix {
	file attributes $notReadableDir -permissions 0o777
	file attributes $notWritableDir -permissions 0o777
    }
    default {
	catch {testchmod 0o777 $notWritableDir}
	catch {file attributes $notWritableDir -readonly 0}
    }
}

file delete -force -- $notReadableDir $notWritableDir
removeFile a.tcl
removeFile thisdirectoryisafile
removeDirectory normaldirectory

# -file, -notfile, [matchFiles], [skipFiles]
test tcltest-9.1 {-file d*.tcl} -constraints {unixOrWin} -setup {
    set old [testsDirectory]

Changes to tests/unixFCmd.test.

22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
testConstraint notWsl [expr {[llength [array names ::env *WSL*]] == 0}]

# These tests really need to be run from a writable directory, which
# it is assumed [temporaryDirectory] is.
set oldcwd [pwd]
cd [temporaryDirectory]

# Several tests require need to match results against the unix username
set user {}
if {[testConstraint unix]} {
    catch {set user [exec whoami]}
    if {$user == ""} {
	catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
    }
    if {$user == ""} {







|







22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
testConstraint notWsl [expr {[llength [array names ::env *WSL*]] == 0}]

# These tests really need to be run from a writable directory, which
# it is assumed [temporaryDirectory] is.
set oldcwd [pwd]
cd [temporaryDirectory]

# Several tests require need to match results against the Unix username
set user {}
if {[testConstraint unix]} {
    catch {set user [exec whoami]}
    if {$user == ""} {
	catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
    }
    if {$user == ""} {
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
permcheck unixFCmd-17.11  --x--x--x	0o111
permcheck unixFCmd-17.12  {0 a+rwx} {0o000 0o777}
file delete -force -- foo.test

test unixFCmd-18.1 {Unix pwd} -constraints {unix notRoot nonPortable} -setup {
    set cd [pwd]
} -body {
    # This test is nonPortable because SunOS generates a weird error
    # message when the current directory isn't readable.
    set nd $cd/tstdir
    file mkdir $nd
    cd $nd
    file attributes $nd -permissions 0o000
    pwd
} -returnCodes error -cleanup {







|







383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
permcheck unixFCmd-17.11  --x--x--x	0o111
permcheck unixFCmd-17.12  {0 a+rwx} {0o000 0o777}
file delete -force -- foo.test

test unixFCmd-18.1 {Unix pwd} -constraints {unix notRoot nonPortable} -setup {
    set cd [pwd]
} -body {
    # This test is non-portable because SunOS generates a weird error
    # message when the current directory isn't readable.
    set nd $cd/tstdir
    file mkdir $nd
    cd $nd
    file attributes $nd -permissions 0o000
    pwd
} -returnCodes error -cleanup {

Changes to tests/unixForkEvent.test.

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
package require tcltest 2.5
namespace import -force ::tcltest::*

testConstraint testfork [llength [info commands testfork]]

# Test if the notifier thread is well initialized in a forked interpreter
# by Tcl_InitNotifier
test unixforkevent-1.1 {fork and test writeable event} \
    -constraints {testfork nonPortable} \
    -body {
	set myFolder [makeDirectory unixtestfork]
	set pid [testfork]
	if {$pid == 0} {
	    # we are the forked process
	    set result initialized







|







11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
package require tcltest 2.5
namespace import -force ::tcltest::*

testConstraint testfork [llength [info commands testfork]]

# Test if the notifier thread is well initialized in a forked interpreter
# by Tcl_InitNotifier
test unixforkevent-1.1 {fork and test writable event} \
    -constraints {testfork nonPortable} \
    -body {
	set myFolder [makeDirectory unixtestfork]
	set pid [testfork]
	if {$pid == 0} {
	    # we are the forked process
	    set result initialized

Changes to tests/winDde.test.

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
    dde eval self set \xe1 foo
} -result foo
test winDde-3.5 {DDE request locally} -constraints dde -body {
    set \xe1 ""
    dde execute TclEval self [list set \xe1 foo]
    dde request -binary TclEval self \xe1
} -result "foo\x00"
# Set variable a to A with diaeresis (unicode C4) by relying on the fact
# that utf-8 is sent (e.g. "c3 84" on the wire)
test winDde-3.6 {DDE request utf-8} -constraints dde -body {
    set \xe1 "not set"
    dde execute TclEval self "set \xe1 \xc4"
    scan [set \xe1] %c
} -result 196
# Set variable a to A with diaeresis (unicode C4) using binary execute
# and compose utf-8 (e.g. "c3 84" ) manualy
test winDde-3.7 {DDE request binary} -constraints dde -body {
    set \xe1 "not set"
    dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00]
    scan [set \xe1] %c
} -result 196
test winDde-3.8 {DDE poke locally} -constraints {dde debug} -body {
    set \xe1 ""







|






|
|







149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
    dde eval self set \xe1 foo
} -result foo
test winDde-3.5 {DDE request locally} -constraints dde -body {
    set \xe1 ""
    dde execute TclEval self [list set \xe1 foo]
    dde request -binary TclEval self \xe1
} -result "foo\x00"
# Set variable a to A with diaeresis (Unicode C4) by relying on the fact
# that utf-8 is sent (e.g. "c3 84" on the wire)
test winDde-3.6 {DDE request utf-8} -constraints dde -body {
    set \xe1 "not set"
    dde execute TclEval self "set \xe1 \xc4"
    scan [set \xe1] %c
} -result 196
# Set variable a to A with diaeresis (Unicode C4) using binary execute
# and compose utf-8 (e.g. "c3 84" ) manually
test winDde-3.7 {DDE request binary} -constraints dde -body {
    set \xe1 "not set"
    dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00]
    scan [set \xe1] %c
} -result 196
test winDde-3.8 {DDE poke locally} -constraints {dde debug} -body {
    set \xe1 ""

Changes to tests/winFCmd.test.

133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
append longname $longname
append longname $longname
append longname $longname

# Uses the "testfile" command instead of the "file" command.  The "file"
# command provides several layers of sanity checks on the arguments and
# it can be difficult to actually forward "insane" arguments to the
# low-level posix emulation layer.

test winFCmd-1.1 {TclpRenameFile: errno: EACCES} -body {
    testfile mv $cdfile $cdrom/dummy~~.fil
} -constraints {win cdrom testfile} -returnCodes error -result EACCES
test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} -setup {
    cleanup
} -constraints {win testfile} -body {







|







133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
append longname $longname
append longname $longname
append longname $longname

# Uses the "testfile" command instead of the "file" command.  The "file"
# command provides several layers of sanity checks on the arguments and
# it can be difficult to actually forward "insane" arguments to the
# low-level Posix emulation layer.

test winFCmd-1.1 {TclpRenameFile: errno: EACCES} -body {
    testfile mv $cdfile $cdrom/dummy~~.fil
} -constraints {win cdrom testfile} -returnCodes error -result EACCES
test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} -setup {
    cleanup
} -constraints {win testfile} -body {

Changes to tools/man2tcl.c.

48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
 * the file.
 */

static int status;

/*
 * The variable below is set to 1 if output should be generated. If it's 0, it
 * means we're doing a pre-pass to make sure that the file can be properly
 * parsed.
 */

static int writeOutput;

#define PRINT(args)	if (writeOutput) { printf args; }
#define PRINTC(chr)	if (writeOutput) { putc((chr), stdout); }







|







48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
 * the file.
 */

static int status;

/*
 * The variable below is set to 1 if output should be generated. If it's 0, it
 * means we're doing a prepass to make sure that the file can be properly
 * parsed.
 */

static int writeOutput;

#define PRINT(args)	if (writeOutput) { printf args; }
#define PRINTC(chr)	if (writeOutput) { putc((chr), stdout); }

Changes to tools/mkdepend.tcl.

248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
}

# addSearchPath --
#
#	Adds a new set of path and replacement string to the global list.
#
# Arguments:
#	newPathInfo	comma seperated path and replacement string
#
# Results:
#	None.

proc addSearchPath {newPathInfo} {
    global srcPathList srcPathReplaceList








|







248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
}

# addSearchPath --
#
#	Adds a new set of path and replacement string to the global list.
#
# Arguments:
#	newPathInfo	comma separated path and replacement string
#
# Results:
#	None.

proc addSearchPath {newPathInfo} {
    global srcPathList srcPathReplaceList

292
293
294
295
296
297
298
299
300
301
302
303
304
305
306

proc readInputListFile {objectListFile} {
    global srcFileList srcPathList source_extensions
    set f [open $objectListFile r]
    set fl [read $f]
    close $f

    # fix native path seperator so it isn't treated as an escape.
    regsub -all {\\} $fl {/} fl

    # Treat the string as a list so filenames between double quotes are
    # treated as list elements.
    foreach fname $fl {
	# Compiled .res resource files should be ignored.
	if {[file extension $fname] ne ".obj"} {continue}







|







292
293
294
295
296
297
298
299
300
301
302
303
304
305
306

proc readInputListFile {objectListFile} {
    global srcFileList srcPathList source_extensions
    set f [open $objectListFile r]
    set fl [read $f]
    close $f

    # fix native path separator so it isn't treated as an escape.
    regsub -all {\\} $fl {/} fl

    # Treat the string as a list so filenames between double quotes are
    # treated as list elements.
    foreach fname $fl {
	# Compiled .res resource files should be ignored.
	if {[file extension $fname] ne ".obj"} {continue}

Changes to tools/str2c.

25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
    regsub -all "\n" $what "\\\\n\\\\\n" what;
    return $what;
}

set lg [string length $r]
if {$lg<$MAX} {
    puts "/*
 * Single part writeable string generated by str2c
 */
static char data\[\]=\"[translate $r]\";"
} else {
    puts "/*
 * Multi parts read only string generated by str2c
 */
static const char * const data\[\]= {"







|







25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
    regsub -all "\n" $what "\\\\n\\\\\n" what;
    return $what;
}

set lg [string length $r]
if {$lg<$MAX} {
    puts "/*
 * Single part writable string generated by str2c
 */
static char data\[\]=\"[translate $r]\";"
} else {
    puts "/*
 * Multi parts read only string generated by str2c
 */
static const char * const data\[\]= {"

Changes to unix/configure.

10161
10162
10163
10164
10165
10166
10167
10168
10169
10170
10171
10172
10173
10174
10175
#define USEGETWD 1
_ACEOF

fi
done

# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
# define USEGETWD even if the posix getcwd exists. Add a test ?





for ac_func in mkstemp opendir strtol waitpid
do







|







10161
10162
10163
10164
10165
10166
10167
10168
10169
10170
10171
10172
10173
10174
10175
#define USEGETWD 1
_ACEOF

fi
done

# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
# define USEGETWD even if the Posix getcwd exists. Add a test ?





for ac_func in mkstemp opendir strtol waitpid
do

Changes to unix/configure.in.

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100

AC_PROG_CC
AC_C_INLINE

#--------------------------------------------------------------------
# Supply substitutes for missing POSIX header files.  Special notes:
#	- stdlib.h doesn't define strtol, strtoul, or
#	  strtod insome versions of SunOS
#	- some versions of string.h don't declare procedures such
#	  as strstr
# Do this early, otherwise an autoconf bug throws errors on configure
#--------------------------------------------------------------------

SC_MISSING_POSIX_HEADERS








|







86
87
88
89
90
91
92
93
94
95
96
97
98
99
100

AC_PROG_CC
AC_C_INLINE

#--------------------------------------------------------------------
# Supply substitutes for missing POSIX header files.  Special notes:
#	- stdlib.h doesn't define strtol, strtoul, or
#	  strtod in some versions of SunOS
#	- some versions of string.h don't declare procedures such
#	  as strstr
# Do this early, otherwise an autoconf bug throws errors on configure
#--------------------------------------------------------------------

SC_MISSING_POSIX_HEADERS

205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
#	Supply substitutes for missing POSIX library procedures, or
#	set flags so Tcl uses alternate procedures.
#--------------------------------------------------------------------

# Check if Posix compliant getcwd exists, if not we'll use getwd.
AC_CHECK_FUNCS(getcwd, , [AC_DEFINE(USEGETWD, 1, [Is getcwd Posix-compliant?])])
# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
# define USEGETWD even if the posix getcwd exists. Add a test ?

AC_REPLACE_FUNCS(mkstemp opendir strtol waitpid)
AC_CHECK_FUNC(strerror, , [AC_DEFINE(NO_STRERROR, 1, [Do we have strerror()])])
AC_CHECK_FUNC(getwd, , [AC_DEFINE(NO_GETWD, 1, [Do we have getwd()])])
AC_CHECK_FUNC(wait3, , [AC_DEFINE(NO_WAIT3, 1, [Do we have wait3()])])
AC_CHECK_FUNC(fork, , [AC_DEFINE(NO_FORK, 1, [Do we have fork()])])
AC_CHECK_FUNC(mknod, , [AC_DEFINE(NO_MKNOD, 1, [Do we have mknod()])])







|







205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
#	Supply substitutes for missing POSIX library procedures, or
#	set flags so Tcl uses alternate procedures.
#--------------------------------------------------------------------

# Check if Posix compliant getcwd exists, if not we'll use getwd.
AC_CHECK_FUNCS(getcwd, , [AC_DEFINE(USEGETWD, 1, [Is getcwd Posix-compliant?])])
# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
# define USEGETWD even if the Posix getcwd exists. Add a test ?

AC_REPLACE_FUNCS(mkstemp opendir strtol waitpid)
AC_CHECK_FUNC(strerror, , [AC_DEFINE(NO_STRERROR, 1, [Do we have strerror()])])
AC_CHECK_FUNC(getwd, , [AC_DEFINE(NO_GETWD, 1, [Do we have getwd()])])
AC_CHECK_FUNC(wait3, , [AC_DEFINE(NO_WAIT3, 1, [Do we have wait3()])])
AC_CHECK_FUNC(fork, , [AC_DEFINE(NO_FORK, 1, [Do we have fork()])])
AC_CHECK_FUNC(mknod, , [AC_DEFINE(NO_MKNOD, 1, [Do we have mknod()])])

Changes to unix/install-sh.

325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
	trap '
	  ret=$?
	  rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" 2>/dev/null
	  exit $ret
	' 0

	# Because "mkdir -p" follows existing symlinks and we likely work
	# directly in world-writeable /tmp, make sure that the '$tmpdir'
	# directory is successfully created first before we actually test
	# 'mkdir -p'.
	if (umask $mkdir_umask &&
	    $mkdirprog $mkdir_mode "$tmpdir" &&
	    exec $mkdirprog $mkdir_mode -p -- "$tmpdir/a/b") >/dev/null 2>&1
	then
	  if test -z "$dir_arg" || {







|







325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
	trap '
	  ret=$?
	  rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" 2>/dev/null
	  exit $ret
	' 0

	# Because "mkdir -p" follows existing symlinks and we likely work
	# directly in world-writable /tmp, make sure that the '$tmpdir'
	# directory is successfully created first before we actually test
	# 'mkdir -p'.
	if (umask $mkdir_umask &&
	    $mkdirprog $mkdir_mode "$tmpdir" &&
	    exec $mkdirprog $mkdir_mode -p -- "$tmpdir/a/b") >/dev/null 2>&1
	then
	  if test -z "$dir_arg" || {

Changes to unix/tclUnixChan.c.

1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279

    /*
     * Only allow setting mark/space parity on platforms that support it Make
     * sure to allow for the case where strchr is a macro. [Bug: 5089]
     *
     * We cannot if/else/endif the strchr arguments, it has to be the whole
     * function. On AIX this function is apparently a macro, and macros do
     * not allow pre-processor directives in their arguments.
     */

    if (
#if defined(PAREXT)
        strchr("noems", parity)
#else
        strchr("noe", parity)







|







1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279

    /*
     * Only allow setting mark/space parity on platforms that support it Make
     * sure to allow for the case where strchr is a macro. [Bug: 5089]
     *
     * We cannot if/else/endif the strchr arguments, it has to be the whole
     * function. On AIX this function is apparently a macro, and macros do
     * not allow preprocessor directives in their arguments.
     */

    if (
#if defined(PAREXT)
        strchr("noems", parity)
#else
        strchr("noe", parity)
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_MakeFileChannel(
    ClientData handle,		/* OS level handle. */
    int mode)			/* ORed combination of TCL_READABLE and
				 * TCL_WRITABLE to indicate file mode. */
{
    FileState *fsPtr;
    char channelName[16 + TCL_INTEGER_SPACE];
    int fd = PTR2INT(handle);
    const Tcl_ChannelType *channelTypePtr;
    struct sockaddr sockaddr;







|







1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_MakeFileChannel(
    ClientData handle,		/* OS level handle. */
    int mode)			/* OR'ed combination of TCL_READABLE and
				 * TCL_WRITABLE to indicate file mode. */
{
    FileState *fsPtr;
    char channelName[16 + TCL_INTEGER_SPACE];
    int fd = PTR2INT(handle);
    const Tcl_ChannelType *channelTypePtr;
    struct sockaddr sockaddr;

Changes to unix/tclUnixCompat.c.

734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
#endif /* NEED_COPYGRP */

/*
 *---------------------------------------------------------------------------
 *
 * CopyHostent --
 *
 *      Copies string fields of the hostnent structure to the private buffer,
 *      honouring the size of the buffer.
 *
 * Results:
 *      Number of bytes copied on success or -1 on error (errno = ERANGE)
 *
 * Side effects:
 *      None







|







734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
#endif /* NEED_COPYGRP */

/*
 *---------------------------------------------------------------------------
 *
 * CopyHostent --
 *
 *      Copies string fields of the hostent structure to the private buffer,
 *      honouring the size of the buffer.
 *
 * Results:
 *      Number of bytes copied on success or -1 on error (errno = ERANGE)
 *
 * Side effects:
 *      None

Changes to unix/tclUnixFCmd.c.

1
2
3
4
5
6
7
8
9
10
11
/*
 * tclUnixFCmd.c
 *
 *	This file implements the unix specific portion of file manipulation
 *	subcommands of the "file" command. All filename arguments should
 *	already be translated to native format.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.



|







1
2
3
4
5
6
7
8
9
10
11
/*
 * tclUnixFCmd.c
 *
 *	This file implements the Unix specific portion of file manipulation
 *	subcommands of the "file" command. All filename arguments should
 *	already be translated to native format.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
	return TCL_OK;
    }
    if (errno == ENOTEMPTY) {
	errno = EEXIST;
    }

    /*
     * IRIX returns EIO when you attept to move a directory into itself. We
     * just map EIO to EINVAL get the right message on SGI. Most platforms
     * don't return EIO except in really strange cases.
     */

    if (errno == EIO) {
	errno = EINVAL;
    }







|







346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
	return TCL_OK;
    }
    if (errno == ENOTEMPTY) {
	errno = EEXIST;
    }

    /*
     * IRIX returns EIO when you attempt to move a directory into itself. We
     * just map EIO to EINVAL get the right message on SGI. Most platforms
     * don't return EIO except in really strange cases.
     */

    if (errno == EIO) {
	errno = EINVAL;
    }
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
/*
 *---------------------------------------------------------------------------
 *
 * TclpObjCopyDirectory --
 *
 *	Recursively copies a directory. The target directory dst must not
 *	already exist. Note that this function does not merge two directory
 *	hierarchies, even if the target directory is an an empty directory.
 *
 * Results:
 *	If the directory was successfully copied, returns TCL_OK. Otherwise
 *	the return value is TCL_ERROR, errno is set to indicate the error, and
 *	the pathname of the file that caused the error is stored in errorPtr.
 *	See TclpObjCreateDirectory and TclpObjCopyFile for a description of
 *	possible values for errno.







|







736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
/*
 *---------------------------------------------------------------------------
 *
 * TclpObjCopyDirectory --
 *
 *	Recursively copies a directory. The target directory dst must not
 *	already exist. Note that this function does not merge two directory
 *	hierarchies, even if the target directory is an empty directory.
 *
 * Results:
 *	If the directory was successfully copied, returns TCL_OK. Otherwise
 *	the return value is TCL_ERROR, errno is set to indicate the error, and
 *	the pathname of the file that caused the error is stored in errorPtr.
 *	See TclpObjCreateDirectory and TclpObjCopyFile for a description of
 *	possible values for errno.

Changes to unix/tclUnixFile.c.

689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
 *	This function replaces the library version of getcwd().
 *
 * Results:
 *	The input and output are filesystem paths in native form. The result
 *	is either the given clientData, if the working directory hasn't
 *	changed, or a new clientData (owned by our caller), giving the new
 *	native path, or NULL if the current directory could not be determined.
 *	If NULL is returned, the caller can examine the standard posix error
 *	codes to determine the cause of the problem.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */







|







689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
 *	This function replaces the library version of getcwd().
 *
 * Results:
 *	The input and output are filesystem paths in native form. The result
 *	is either the given clientData, if the working directory hasn't
 *	changed, or a new clientData (owned by our caller), giving the new
 *	native path, or NULL if the current directory could not be determined.
 *	If NULL is returned, the caller can examine the standard Posix error
 *	codes to determine the cause of the problem.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Changes to unix/tclUnixInit.c.

475
476
477
478
479
480
481
482
483
484
485
486
487
488
489

    TclNewObj(pathPtr);

    /*
     * Look for the library relative to the TCL_LIBRARY env variable. If the
     * last dirname in the TCL_LIBRARY path does not match the last dirname in
     * the installLib variable, use the last dir name of installLib in
     * addition to the orginal TCL_LIBRARY path.
     */

    str = getenv("TCL_LIBRARY");			/* INTL: Native. */
    Tcl_ExternalToUtfDString(NULL, str, -1, &buffer);
    str = Tcl_DStringValue(&buffer);

    if ((str != NULL) && (str[0] != '\0')) {







|







475
476
477
478
479
480
481
482
483
484
485
486
487
488
489

    TclNewObj(pathPtr);

    /*
     * Look for the library relative to the TCL_LIBRARY env variable. If the
     * last dirname in the TCL_LIBRARY path does not match the last dirname in
     * the installLib variable, use the last dir name of installLib in
     * addition to the original TCL_LIBRARY path.
     */

    str = getenv("TCL_LIBRARY");			/* INTL: Native. */
    Tcl_ExternalToUtfDString(NULL, str, -1, &buffer);
    str = Tcl_DStringValue(&buffer);

    if ((str != NULL) && (str[0] != '\0')) {
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006

/*
 *----------------------------------------------------------------------
 *
 * TclpFindVariable --
 *
 *	Locate the entry in environ for a given name. On Unix this routine is
 *	case sensetive, on Windows this matches mixed case.
 *
 * Results:
 *	The return value is the index in environ of an entry with the name
 *	"name", or -1 if there is no such entry. The integer at *lengthPtr is
 *	filled in with the length of name (if a matching entry is found) or
 *	the length of the environ array (if no matching entry is found).
 *







|







992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006

/*
 *----------------------------------------------------------------------
 *
 * TclpFindVariable --
 *
 *	Locate the entry in environ for a given name. On Unix this routine is
 *	case sensitive, on Windows this matches mixed case.
 *
 * Results:
 *	The return value is the index in environ of an entry with the name
 *	"name", or -1 if there is no such entry. The integer at *lengthPtr is
 *	filled in with the length of name (if a matching entry is found) or
 *	the length of the environ array (if no matching entry is found).
 *

Changes to unix/tclUnixNotfy.c.

1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
	     * threads, which are invalid here, so setting it to NULL is not
	     * unreasonable.
	     */
	    waitingListPtr = NULL;

	    /*
	     * The tsdPtr from before the fork is copied as well.  But since
	     * we are paranoic, we don't trust its condvar and reset it.
	     */
#ifdef __CYGWIN__
	    DestroyWindow(tsdPtr->hwnd);
	    tsdPtr->hwnd = CreateWindowExW(NULL, NotfyClassName,
		    NotfyClassName, 0, 0, 0, 0, 0, NULL, NULL,
		    TclWinGetTclInstance(), NULL);
	    ResetEvent(tsdPtr->event);







|







1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
	     * threads, which are invalid here, so setting it to NULL is not
	     * unreasonable.
	     */
	    waitingListPtr = NULL;

	    /*
	     * The tsdPtr from before the fork is copied as well.  But since
	     * we are paranoiac, we don't trust its condvar and reset it.
	     */
#ifdef __CYGWIN__
	    DestroyWindow(tsdPtr->hwnd);
	    tsdPtr->hwnd = CreateWindowExW(NULL, NotfyClassName,
		    NotfyClassName, 0, 0, 0, 0, 0, NULL, NULL,
		    TclWinGetTclInstance(), NULL);
	    ResetEvent(tsdPtr->event);

Changes to unix/tclUnixPipe.c.

389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
				 * converted. */
    TclFile inputFile,		/* If non-NULL, gives the file to use as input
				 * for the child process. If inputFile file is
				 * not readable or is NULL, the child will
				 * receive no standard input. */
    TclFile outputFile,		/* If non-NULL, gives the file that receives
				 * output from the child process. If
				 * outputFile file is not writeable or is
				 * NULL, output from the child will be
				 * discarded. */
    TclFile errorFile,		/* If non-NULL, gives the file that receives
				 * errors from the child process. If errorFile
				 * file is not writeable or is NULL, errors
				 * from the child will be discarded. errorFile
				 * may be the same as outputFile. */
    Tcl_Pid *pidPtr)		/* If this function is successful, pidPtr is
				 * filled with the process id of the child
				 * process. */
{
    TclFile errPipeIn, errPipeOut;







|




|







389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
				 * converted. */
    TclFile inputFile,		/* If non-NULL, gives the file to use as input
				 * for the child process. If inputFile file is
				 * not readable or is NULL, the child will
				 * receive no standard input. */
    TclFile outputFile,		/* If non-NULL, gives the file that receives
				 * output from the child process. If
				 * outputFile file is not writable or is
				 * NULL, output from the child will be
				 * discarded. */
    TclFile errorFile,		/* If non-NULL, gives the file that receives
				 * errors from the child process. If errorFile
				 * file is not writable or is NULL, errors
				 * from the child will be discarded. errorFile
				 * may be the same as outputFile. */
    Tcl_Pid *pidPtr)		/* If this function is successful, pidPtr is
				 * filled with the process id of the child
				 * process. */
{
    TclFile errPipeIn, errPipeOut;

Changes to unix/tclUnixPort.h.

509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
#   define NFDBITS	NBBY*sizeof(fd_mask)
#endif /* NFDBITS */

#define MASK_SIZE	howmany(FD_SETSIZE, NFDBITS)

/*
 *---------------------------------------------------------------------------
 * Not all systems declare the errno variable in errno.h. so this file does it
 * explicitly. The list of system error messages also isn't generally declared
 * in a header file anywhere.
 *---------------------------------------------------------------------------
 */

#ifdef NO_ERRNO
extern int errno;







|







509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
#   define NFDBITS	NBBY*sizeof(fd_mask)
#endif /* NFDBITS */

#define MASK_SIZE	howmany(FD_SETSIZE, NFDBITS)

/*
 *---------------------------------------------------------------------------
 * Not all systems declare the errno variable in errno.h, so this file does it
 * explicitly. The list of system error messages also isn't generally declared
 * in a header file anywhere.
 *---------------------------------------------------------------------------
 */

#ifdef NO_ERRNO
extern int errno;

Changes to unix/tclUnixSock.c.

36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
    struct sockaddr sa;
    struct sockaddr_in sa4;
    struct sockaddr_in6 sa6;
    struct sockaddr_storage sas;
} address;

/*
 * This structure describes per-instance state of a tcp based channel.
 */

typedef struct TcpState TcpState;

typedef struct TcpFdList {
    TcpState *statePtr;
    int fd;
    struct TcpFdList *next;
} TcpFdList;

struct TcpState {
    Tcl_Channel channel;	/* Channel associated with this file. */
    TcpFdList fds;		/* The file descriptors of the sockets. */
    int flags;			/* ORed combination of the bitfields defined
				 * below. */
    int interest;		/* Event types of interest */

    /*
     * Only needed for server sockets
     */








|













|







36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
    struct sockaddr sa;
    struct sockaddr_in sa4;
    struct sockaddr_in6 sa6;
    struct sockaddr_storage sas;
} address;

/*
 * This structure describes per-instance state of a tcp-based channel.
 */

typedef struct TcpState TcpState;

typedef struct TcpFdList {
    TcpState *statePtr;
    int fd;
    struct TcpFdList *next;
} TcpFdList;

struct TcpState {
    Tcl_Channel channel;	/* Channel associated with this file. */
    TcpFdList fds;		/* The file descriptors of the sockets. */
    int flags;			/* OR'ed combination of the bitfields defined
				 * below. */
    int interest;		/* Event types of interest */

    /*
     * Only needed for server sockets
     */

77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
    int filehandlers;           /* Caches FileHandlers that get set up while
                                 * an async socket is not yet connected. */
    int connectError;           /* Cache SO_ERROR of async socket. */
    int cachedBlocking;         /* Cache blocking mode of async socket. */
};

/*
 * These bits may be ORed together into the "flags" field of a TcpState
 * structure.
 */

#define TCP_NONBLOCKING		(1<<0)	/* Socket with non-blocking I/O */
#define TCP_ASYNC_CONNECT	(1<<1)	/* Async connect in progress. */
#define TCP_ASYNC_PENDING	(1<<4)	/* TcpConnect was called to
					 * process an async connect. This







|







77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
    int filehandlers;           /* Caches FileHandlers that get set up while
                                 * an async socket is not yet connected. */
    int connectError;           /* Cache SO_ERROR of async socket. */
    int cachedBlocking;         /* Cache blocking mode of async socket. */
};

/*
 * These bits may be OR'ed together into the "flags" field of a TcpState
 * structure.
 */

#define TCP_NONBLOCKING		(1<<0)	/* Socket with non-blocking I/O */
#define TCP_ASYNC_CONNECT	(1<<1)	/* Async connect in progress. */
#define TCP_ASYNC_PENDING	(1<<4)	/* TcpConnect was called to
					 * process an async connect. This
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
/*
 * ----------------------------------------------------------------------
 *
 * WaitForConnect --
 *
 *	Check the state of an async connect process. If a connection attempt
 *	terminated, process it, which may finalize it or may start the next
 *	attempt. If a connect error occures, it is saved in
 *	statePtr->connectError to be reported by 'fconfigure -error'.
 *
 *	There are two modes of operation, defined by errorCodePtr:
 *	 *  non-NULL: Called by explicite read/write command. Blocks if the
 *	    socket is blocking.
 *	    May return two error codes:
 *	     *	EWOULDBLOCK: if connect is still in progress
 *	     *	ENOTCONN: if connect failed. This would be the error message
 *		of a rect or sendto syscall so this is emulated here.
 *	 *  NULL: Called by a backround operation. Do not block and do not
 *	    return any error code.
 *
 * Results:
 * 	0 if the connection has completed, -1 if still in progress or there is
 * 	an error.
 *
 * Side effects:







|



|




|
|







395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
/*
 * ----------------------------------------------------------------------
 *
 * WaitForConnect --
 *
 *	Check the state of an async connect process. If a connection attempt
 *	terminated, process it, which may finalize it or may start the next
 *	attempt. If a connect error occurs, it is saved in
 *	statePtr->connectError to be reported by 'fconfigure -error'.
 *
 *	There are two modes of operation, defined by errorCodePtr:
 *	 *  non-NULL: Called by explicit read/write command. Blocks if the
 *	    socket is blocking.
 *	    May return two error codes:
 *	     *	EWOULDBLOCK: if connect is still in progress
 *	     *	ENOTCONN: if connect failed. This would be the error message
 *		of a recv or sendto syscall so this is emulated here.
 *	 *  NULL: Called by a background operation. Do not block and do not
 *	    return any error code.
 *
 * Results:
 * 	0 if the connection has completed, -1 if still in progress or there is
 * 	an error.
 *
 * Side effects:
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451

    if (errorCodePtr != NULL && GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) {
	*errorCodePtr = ENOTCONN;
	return -1;
    }

    /*
     * Check if an async connect is running. If not return ok
     */

    if (!GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
	return 0;
    }

    if (errorCodePtr == NULL || GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) {







|







437
438
439
440
441
442
443
444
445
446
447
448
449
450
451

    if (errorCodePtr != NULL && GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) {
	*errorCodePtr = ENOTCONN;
	return -1;
    }

    /*
     * Check if an async connect is running. If not return ok.
     */

    if (!GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
	return 0;
    }

    if (errorCodePtr == NULL || GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) {
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089

	/*
	 * Whether it is a bug or feature or otherwise, it is a fact of life
	 * that on at least some Linux kernels select() fails to report that a
	 * socket file descriptor is writable when the other end of the socket
	 * is closed.  This is in contrast to the guarantees Tcl makes that
	 * its channels become writable and fire writable events on an error
	 * conditon.  This has caused a leak of file descriptors in a state of
	 * background flushing.  See Tcl ticket 1758a0b603.
	 *
	 * As a workaround, when our caller indicates an interest in writable
	 * notifications, we must tell the notifier built around select() that
	 * we are interested in the readable state of the file descriptor as
	 * well, as that is the only reliable means to get notified of error
	 * conditions.  Then it is the task of WrapNotify() above to untangle







|







1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089

	/*
	 * Whether it is a bug or feature or otherwise, it is a fact of life
	 * that on at least some Linux kernels select() fails to report that a
	 * socket file descriptor is writable when the other end of the socket
	 * is closed.  This is in contrast to the guarantees Tcl makes that
	 * its channels become writable and fire writable events on an error
	 * condition.  This has caused a leak of file descriptors in a state of
	 * background flushing.  See Tcl ticket 1758a0b603.
	 *
	 * As a workaround, when our caller indicates an interest in writable
	 * notifications, we must tell the notifier built around select() that
	 * we are interested in the readable state of the file descriptor as
	 * well, as that is the only reliable means to get notified of error
	 * conditions.  Then it is the task of WrapNotify() above to untangle
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
 *
 *----------------------------------------------------------------------
 */

void *
TclpMakeTcpClientChannelMode(
    void *sock,		/* The socket to wrap up into a channel. */
    int mode)			/* ORed combination of TCL_READABLE and
				 * TCL_WRITABLE to indicate file mode. */
{
    TcpState *statePtr;
    char channelName[SOCK_CHAN_LENGTH];

    statePtr = (TcpState *)ckalloc(sizeof(TcpState));
    memset(statePtr, 0, sizeof(TcpState));







|







1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
 *
 *----------------------------------------------------------------------
 */

void *
TclpMakeTcpClientChannelMode(
    void *sock,		/* The socket to wrap up into a channel. */
    int mode)			/* OR'ed combination of TCL_READABLE and
				 * TCL_WRITABLE to indicate file mode. */
{
    TcpState *statePtr;
    char channelName[SOCK_CHAN_LENGTH];

    statePtr = (TcpState *)ckalloc(sizeof(TcpState));
    memset(statePtr, 0, sizeof(TcpState));

Changes to unix/tclUnixTest.c.

720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
/*
 *---------------------------------------------------------------------------
 *
 * TestchmodCmd --
 *
 *	Implements the "testchmod" cmd.  Used when testing "file" command.
 *	The only attribute used by the Windows platform is the user write
 *	flag; if this is not set, the file is made read-only.  Otehrwise, the
 *	file is made read-write.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Changes permissions of specified files.







|







720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
/*
 *---------------------------------------------------------------------------
 *
 * TestchmodCmd --
 *
 *	Implements the "testchmod" cmd.  Used when testing "file" command.
 *	The only attribute used by the Windows platform is the user write
 *	flag; if this is not set, the file is made read-only.  Otherwise, the
 *	file is made read-write.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Changes permissions of specified files.

Changes to unix/tclXtNotify.c.

13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
#ifndef USE_TCL_STUBS
#   define USE_TCL_STUBS
#endif
#include <X11/Intrinsic.h>
#include "tclInt.h"

/*
 * This structure is used to keep track of the notifier info for a a
 * registered file.
 */

typedef struct FileHandler {
    int fd;
    int mask;			/* Mask of desired events: TCL_READABLE,
				 * etc. */







|







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
#ifndef USE_TCL_STUBS
#   define USE_TCL_STUBS
#endif
#include <X11/Intrinsic.h>
#include "tclInt.h"

/*
 * This structure is used to keep track of the notifier info for a
 * registered file.
 */

typedef struct FileHandler {
    int fd;
    int mask;			/* Mask of desired events: TCL_READABLE,
				 * etc. */

Changes to win/Makefile.in.

514
515
516
517
518
519
520
521
522
523
524
525
526
527
528

${TEST_EXE_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} tclTestMain.${OBJEXT}
	@$(RM) ${TEST_EXE_FILE}
	$(CC) $(CFLAGS) $(TCLTEST_OBJS) tclTestMain.$(OBJEXT) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
        tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
	$(COPY) tclsh.exe.manifest ${TEST_EXE_FILE}.manifest

# use pre-built zlib1.dll
${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE}
	@if test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win64-arm/zdll.libset" ; then \
		$(COPY) $(ZLIB_DIR)/win64-arm/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \
	elif test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.aset" ; then \
		$(COPY) $(ZLIB_DIR)/win64-arm/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \
	elif test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win32/zdll.libset" ; then \
		$(COPY) $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \







|







514
515
516
517
518
519
520
521
522
523
524
525
526
527
528

${TEST_EXE_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} tclTestMain.${OBJEXT}
	@$(RM) ${TEST_EXE_FILE}
	$(CC) $(CFLAGS) $(TCLTEST_OBJS) tclTestMain.$(OBJEXT) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
        tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
	$(COPY) tclsh.exe.manifest ${TEST_EXE_FILE}.manifest

# use prebuilt zlib1.dll
${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE}
	@if test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win64-arm/zdll.libset" ; then \
		$(COPY) $(ZLIB_DIR)/win64-arm/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \
	elif test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.aset" ; then \
		$(COPY) $(ZLIB_DIR)/win64-arm/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \
	elif test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win32/zdll.libset" ; then \
		$(COPY) $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \

Changes to win/coffbase.txt.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
;
; This file defines the virtual base addresses for the Dynamic Link Libraries
; that are part of the Tcl system.  The first token on a line is the key (or name
; of the DLL) and the second token is the virtual base address, in hexidecimal.
; The third token is the maximum size of the DLL image file, including symbols.
;
; Using a specified "prefered load address" should speed loading time by avoiding
; relocations (NT supported only).  It is assumed extension authors will contribute
; their modules to this grand-master list.  You can use the dumpbin utility with
; the /headers option to get the "size of image" data (already in hex).  If the
; maximum size is too small a linker warning will occur.  Modules can overlap when
; they're mutually exclusive.  This info is placed in the DLL's PE header by the
; linker with the `-base:@$(TCLDIR)\win\coffbase.txt,<key>` option.




|


|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
;
; This file defines the virtual base addresses for the Dynamic Link Libraries
; that are part of the Tcl system.  The first token on a line is the key (or name
; of the DLL) and the second token is the virtual base address, in hexadecimal.
; The third token is the maximum size of the DLL image file, including symbols.
;
; Using a specified "preferred load address" should speed loading time by avoiding
; relocations (NT supported only).  It is assumed extension authors will contribute
; their modules to this grand-master list.  You can use the dumpbin utility with
; the /headers option to get the "size of image" data (already in hex).  If the
; maximum size is too small a linker warning will occur.  Modules can overlap when
; they're mutually exclusive.  This info is placed in the DLL's PE header by the
; linker with the `-base:@$(TCLDIR)\win\coffbase.txt,<key>` option.

Changes to win/makefile.vc.

105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
#		set (ie: recent Platform SDK) then MACHINE is set from CPU.
#
#	TMP_DIR=<path>
#	OUT_DIR=<path>
#		Hooks to allow the intermediate and output directories to be
#		changed.  $(OUT_DIR) is assumed to be
#		$(BINROOT)\(Release|Debug) based on if symbols are requested.
#		$(TMP_DIR) will de $(OUT_DIR)\<buildtype> by default.
#
#	TESTPAT=<file>
#		Reads the tests requested to be run from this file.
#
# Examples:
#       c:\tcl_src\win\>nmake -f makefile.vc release
#       c:\tcl_src\win\>nmake -f makefile.vc test







|







105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
#		set (ie: recent Platform SDK) then MACHINE is set from CPU.
#
#	TMP_DIR=<path>
#	OUT_DIR=<path>
#		Hooks to allow the intermediate and output directories to be
#		changed.  $(OUT_DIR) is assumed to be
#		$(BINROOT)\(Release|Debug) based on if symbols are requested.
#		$(TMP_DIR) will be $(OUT_DIR)\<buildtype> by default.
#
#	TESTPAT=<file>
#		Reads the tests requested to be run from this file.
#
# Examples:
#       c:\tcl_src\win\>nmake -f makefile.vc release
#       c:\tcl_src\win\>nmake -f makefile.vc test

Changes to win/nmakehlp.c.

215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235

    ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES));
    sa.nLength = sizeof(SECURITY_ATTRIBUTES);
    sa.lpSecurityDescriptor = NULL;
    sa.bInheritHandle = FALSE;

    /*
     * Create a non-inheritible pipe.
     */

    CreatePipe(&Out.pipe, &h, &sa, 0);

    /*
     * Dupe the write side, make it inheritible, and close the original.
     */

    DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE,
	    DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);

    /*
     * Same as above, but for the error side.







|





|







215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235

    ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES));
    sa.nLength = sizeof(SECURITY_ATTRIBUTES);
    sa.lpSecurityDescriptor = NULL;
    sa.bInheritHandle = FALSE;

    /*
     * Create a non-inheritable pipe.
     */

    CreatePipe(&Out.pipe, &h, &sa, 0);

    /*
     * Dupe the write side, make it inheritable, and close the original.
     */

    DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE,
	    DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);

    /*
     * Same as above, but for the error side.
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
    /*
     * Create a non-inheritible pipe.
     */

    CreatePipe(&Out.pipe, &h, &sa, 0);

    /*
     * Dupe the write side, make it inheritible, and close the original.
     */

    DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE,
	    DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);

    /*
     * Same as above, but for the error side.







|







357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
    /*
     * Create a non-inheritible pipe.
     */

    CreatePipe(&Out.pipe, &h, &sa, 0);

    /*
     * Dupe the write side, make it inheritable, and close the original.
     */

    DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE,
	    DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);

    /*
     * Same as above, but for the error side.
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
    }
}

/*
 * SubstituteFile --
 *	As windows doesn't provide anything useful like sed and it's unreliable
 *	to use the tclsh you are building against (consider x-platform builds -
 *	eg compiling AMD64 target from IX86) we provide a simple substitution
 *	option here to handle autoconf style substitutions.
 *	The substitution file is whitespace and line delimited. The file should
 *	consist of lines matching the regular expression:
 *	  \s*\S+\s+\S*$
 *
 *	Usage is something like:
 *	  nmakehlp -S << $** > $@







|







589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
    }
}

/*
 * SubstituteFile --
 *	As windows doesn't provide anything useful like sed and it's unreliable
 *	to use the tclsh you are building against (consider x-platform builds -
 *	e.g. compiling AMD64 target from IX86) we provide a simple substitution
 *	option here to handle autoconf style substitutions.
 *	The substitution file is whitespace and line delimited. The file should
 *	consist of lines matching the regular expression:
 *	  \s*\S+\s+\S*$
 *
 *	Usage is something like:
 *	  nmakehlp -S << $** > $@
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
    list_item_t *substPtr = NULL;
    FILE *fp, *sp;

    fp = fopen(filename, "rt");
    if (fp != NULL) {

	/*
	 * Build a list of substutitions from the first filename
	 */

	sp = fopen(substitutions, "rt");
	if (sp != NULL) {
	    while (fgets(szBuffer, sizeof(szBuffer), sp) != NULL) {
		unsigned char *ks, *ke, *vs, *ve;
		ks = (unsigned char*)szBuffer;







|







615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
    list_item_t *substPtr = NULL;
    FILE *fp, *sp;

    fp = fopen(filename, "rt");
    if (fp != NULL) {

	/*
	 * Build a list of substitutions from the first filename
	 */

	sp = fopen(substitutions, "rt");
	if (sp != NULL) {
	    while (fgets(szBuffer, sizeof(szBuffer), sp) != NULL) {
		unsigned char *ks, *ke, *vs, *ve;
		ks = (unsigned char*)szBuffer;

Changes to win/rules.vc.

1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
# 12. Set up actual options to be passed to the compiler and linker
# Now we have all the information we need, set up the actual flags and
# options that we will pass to the compiler and linker. The main
# makefile should use these in combination with whatever other flags
# and switches are specific to it.
# The following macros are defined, names are for historical compatibility:
# OPTDEFINES - /Dxxx C macro flags based on user-specified OPTS
# COMPILERFLAGS - /Dxxx C macro flags independent of any configuration opttions
# crt - Compiler switch that selects the appropriate C runtime
# cdebug - Compiler switches related to debug AND optimizations
# cwarn - Compiler switches that set warning levels
# cflags - complete compiler switches (subsumes cdebug and cwarn)
# ldebug - Linker switches controlling debug information and optimization
# lflags - complete linker switches (subsumes ldebug) except subsystem type
# dlllflags - complete linker switches to build DLLs (subsumes lflags)







|







1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
# 12. Set up actual options to be passed to the compiler and linker
# Now we have all the information we need, set up the actual flags and
# options that we will pass to the compiler and linker. The main
# makefile should use these in combination with whatever other flags
# and switches are specific to it.
# The following macros are defined, names are for historical compatibility:
# OPTDEFINES - /Dxxx C macro flags based on user-specified OPTS
# COMPILERFLAGS - /Dxxx C macro flags independent of any configuration options
# crt - Compiler switch that selects the appropriate C runtime
# cdebug - Compiler switches related to debug AND optimizations
# cwarn - Compiler switches that set warning levels
# cflags - complete compiler switches (subsumes cdebug and cwarn)
# ldebug - Linker switches controlling debug information and optimization
# lflags - complete linker switches (subsumes ldebug) except subsystem type
# dlllflags - complete linker switches to build DLLs (subsumes lflags)

Changes to win/tcl.m4.

1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
#	extension can't assume that an executable Tcl shell exists at
#	build time.
#
# Arguments
#	none
#
# Results
#	Subst's the following values:
#		TCLSH_PROG
#------------------------------------------------------------------------

AC_DEFUN([SC_PROG_TCLSH], [
    AC_MSG_CHECKING([for tclsh])

    AC_CACHE_VAL(ac_cv_path_tclsh, [







|







1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
#	extension can't assume that an executable Tcl shell exists at
#	build time.
#
# Arguments
#	none
#
# Results
#	Substitutes the following values:
#		TCLSH_PROG
#------------------------------------------------------------------------

AC_DEFUN([SC_PROG_TCLSH], [
    AC_MSG_CHECKING([for tclsh])

    AC_CACHE_VAL(ac_cv_path_tclsh, [
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
#	when running tests from an extension build directory. It is not
#	correct to use the TCLSH_PROG in cases like this.
#
# Arguments
#	none
#
# Results
#	Subst's the following values:
#		BUILD_TCLSH
#------------------------------------------------------------------------

AC_DEFUN([SC_BUILD_TCLSH], [
    AC_MSG_CHECKING([for tclsh in Tcl build directory])
    BUILD_TCLSH=${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}\${EXESUFFIX}
    AC_MSG_RESULT($BUILD_TCLSH)







|







1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
#	when running tests from an extension build directory. It is not
#	correct to use the TCLSH_PROG in cases like this.
#
# Arguments
#	none
#
# Results
#	Substitutes the following values:
#		BUILD_TCLSH
#------------------------------------------------------------------------

AC_DEFUN([SC_BUILD_TCLSH], [
    AC_MSG_CHECKING([for tclsh in Tcl build directory])
    BUILD_TCLSH=${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}\${EXESUFFIX}
    AC_MSG_RESULT($BUILD_TCLSH)

Changes to win/tclWinChan.c.

931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
			TclGetString(pathPtr), "\": ",
			Tcl_PosixError(interp), NULL);
	    }
	    return NULL;
	}

	/*
	* For natively named Windows serial ports we are done.
	*/
	channel = TclWinOpenSerialChannel(handle, channelName,
		channelPermissions);

	return channel;
    }
    /*







|







931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
			TclGetString(pathPtr), "\": ",
			Tcl_PosixError(interp), NULL);
	    }
	    return NULL;
	}

	/*
	* For natively-named Windows serial ports we are done.
	*/
	channel = TclWinOpenSerialChannel(handle, channelName,
		channelPermissions);

	return channel;
    }
    /*
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_MakeFileChannel(
    ClientData rawHandle,	/* OS level handle */
    int mode)			/* ORed combination of TCL_READABLE and
				 * TCL_WRITABLE to indicate file mode. */
{
#if defined(HAVE_NO_SEH) && !defined(_WIN64) && !defined(__clang__)
    TCLEXCEPTION_REGISTRATION registration;
#endif
    char channelName[16 + TCL_INTEGER_SPACE];
    Tcl_Channel channel = NULL;







|







1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_MakeFileChannel(
    ClientData rawHandle,	/* OS level handle */
    int mode)			/* OR'ed combination of TCL_READABLE and
				 * TCL_WRITABLE to indicate file mode. */
{
#if defined(HAVE_NO_SEH) && !defined(_WIN64) && !defined(__clang__)
    TCLEXCEPTION_REGISTRATION registration;
#endif
    char channelName[16 + TCL_INTEGER_SPACE];
    Tcl_Channel channel = NULL;

Changes to win/tclWinConsole.c.

1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
    int action)
{
    ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;

    /*
     * We do not access firstConsolePtr in the thread structures. This is not
     * for all serials managed by the thread, but only those we are watching.
     * Removal of the filevent handlers before transfer thus takes care of
     * this structure.
     */

    Tcl_MutexLock(&consoleMutex);
    if (action == TCL_CHANNEL_THREAD_INSERT) {
	/*
	 * We can't copy the thread information from the channel when the







|







1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
    int action)
{
    ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;

    /*
     * We do not access firstConsolePtr in the thread structures. This is not
     * for all serials managed by the thread, but only those we are watching.
     * Removal of the fileevent handlers before transfer thus takes care of
     * this structure.
     */

    Tcl_MutexLock(&consoleMutex);
    if (action == TCL_CHANNEL_THREAD_INSERT) {
	/*
	 * We can't copy the thread information from the channel when the

Changes to win/tclWinDde.c.

864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
	}
	return ddeReturn;

#endif
    case XTYP_EXECUTE: {
	/*
	 * Execute this script. The results will be saved into a list object
	 * which will be retreived later. See ExecuteRemoteObject.
	 */

	Tcl_Obj *returnPackagePtr;
	char *string;

	for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
		&& (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {







|







864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
	}
	return ddeReturn;

#endif
    case XTYP_EXECUTE: {
	/*
	 * Execute this script. The results will be saved into a list object
	 * which will be retrieved later. See ExecuteRemoteObject.
	 */

	Tcl_Obj *returnPackagePtr;
	char *string;

	for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
		&& (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907

	utilString = (WCHAR *) DdeAccessData(hData, &dlen);
	string = (char *) utilString;
	if (!dlen) {
	    /* Empty binary array. */
	    ddeObjectPtr = Tcl_NewObj();
	} else if ((dlen & 1) || utilString[(dlen>>1)-1]) {
	    /* Cannot be unicode, so assume utf-8 */
	    if (!string[dlen-1]) {
		dlen--;
	    }
	    ddeObjectPtr = Tcl_NewStringObj(string, dlen);
	} else {
	    /* unicode */
	    Tcl_DString dsBuf;

	    Tcl_DStringInit(&dsBuf);
	    Tcl_WCharToUtfDString(utilString, (dlen>>1) - 1, &dsBuf);
	    ddeObjectPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
		    Tcl_DStringLength(&dsBuf));
	    Tcl_DStringFree(&dsBuf);







|





|







887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907

	utilString = (WCHAR *) DdeAccessData(hData, &dlen);
	string = (char *) utilString;
	if (!dlen) {
	    /* Empty binary array. */
	    ddeObjectPtr = Tcl_NewObj();
	} else if ((dlen & 1) || utilString[(dlen>>1)-1]) {
	    /* Cannot be Unicode, so assume utf-8 */
	    if (!string[dlen-1]) {
		dlen--;
	    }
	    ddeObjectPtr = Tcl_NewStringObj(string, dlen);
	} else {
	    /* Unicode */
	    Tcl_DString dsBuf;

	    Tcl_DStringInit(&dsBuf);
	    Tcl_WCharToUtfDString(utilString, (dlen>>1) - 1, &dsBuf);
	    ddeObjectPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
		    Tcl_DStringLength(&dsBuf));
	    Tcl_DStringFree(&dsBuf);

Changes to win/tclWinFCmd.c.

873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
/*
 *---------------------------------------------------------------------------
 *
 * TclpObjCopyDirectory --
 *
 *	Recursively copies a directory. The target directory dst must not
 *	already exist. Note that this function does not merge two directory
 *	hierarchies, even if the target directory is an an empty directory.
 *
 * Results:
 *	If the directory was successfully copied, returns TCL_OK. Otherwise
 *	the return value is TCL_ERROR, errno is set to indicate the error, and
 *	the pathname of the file that caused the error is stored in errorPtr.
 *	See TclpCreateDirectory and TclpCopyFile for a description of possible
 *	values for errno.







|







873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
/*
 *---------------------------------------------------------------------------
 *
 * TclpObjCopyDirectory --
 *
 *	Recursively copies a directory. The target directory dst must not
 *	already exist. Note that this function does not merge two directory
 *	hierarchies, even if the target directory is an empty directory.
 *
 * Results:
 *	If the directory was successfully copied, returns TCL_OK. Otherwise
 *	the return value is TCL_ERROR, errno is set to indicate the error, and
 *	the pathname of the file that caused the error is stored in errorPtr.
 *	See TclpCreateDirectory and TclpCopyFile for a description of possible
 *	values for errno.

Changes to win/tclWinFile.c.

1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
	    if (GetLastError() == ERROR_ACCESS_DENIED) {
		Tcl_SetErrno(EACCES);
		return -1;
	    }
	}

	/*
	 * We cannnot verify the access fast, check it below using security
	 * info.
	 */
    }

    /*
     * It looks as if the permissions are ok, but if we are on NT, 2000 or XP,
     * we have a more complex permissions structure so we try to check that.







|







1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
	    if (GetLastError() == ERROR_ACCESS_DENIED) {
		Tcl_SetErrno(EACCES);
		return -1;
	    }
	}

	/*
	 * We cannot verify the access fast, check it below using security
	 * info.
	 */
    }

    /*
     * It looks as if the permissions are ok, but if we are on NT, 2000 or XP,
     * we have a more complex permissions structure so we try to check that.
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810

	    goto accessError;
	}

	RevertToSelf();

	/*
	 * Setup desiredAccess according to the access priveleges we are
	 * checking.
	 */

	if (mode & R_OK) {
	    desiredAccess |= FILE_GENERIC_READ;
	}
	if (mode & W_OK) {







|







1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810

	    goto accessError;
	}

	RevertToSelf();

	/*
	 * Setup desiredAccess according to the access privileges we are
	 * checking.
	 */

	if (mode & R_OK) {
	    desiredAccess |= FILE_GENERIC_READ;
	}
	if (mode & W_OK) {
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
    /*
     * If we can use 'createFile' on this, then we can use the resulting
     * fileHandle to read more information (nlink, ino) than we can get from
     * other attributes reading APIs. If not, then we try to fall back on the
     * 'getFileAttributesExProc', and if that isn't available, then on even
     * simpler routines.
     *
     * Special consideration must be given to Windows hardcoded names like
     * CON, NULL, COM1, LPT1 etc. For these, we still need to do the
     * CreateFile as some may not exist (e.g. there is no CON in wish by
     * default). However the subsequent GetFileInformationByHandle will
     * fail. We do a WinIsReserved to see if it is one of the special names,
     * and if successful, mock up a BY_HANDLE_FILE_INFORMATION structure.
     */








|







2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
    /*
     * If we can use 'createFile' on this, then we can use the resulting
     * fileHandle to read more information (nlink, ino) than we can get from
     * other attributes reading APIs. If not, then we try to fall back on the
     * 'getFileAttributesExProc', and if that isn't available, then on even
     * simpler routines.
     *
     * Special consideration must be given to Windows hard-coded names like
     * CON, NULL, COM1, LPT1 etc. For these, we still need to do the
     * CreateFile as some may not exist (e.g. there is no CON in wish by
     * default). However the subsequent GetFileInformationByHandle will
     * fail. We do a WinIsReserved to see if it is one of the special names,
     * and if successful, mock up a BY_HANDLE_FILE_INFORMATION structure.
     */

2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
 *	This function replaces the library version of getcwd().
 *
 * Results:
 *	The input and output are filesystem paths in native form. The result
 *	is either the given clientData, if the working directory hasn't
 *	changed, or a new clientData (owned by our caller), giving the new
 *	native path, or NULL if the current directory could not be determined.
 *	If NULL is returned, the caller can examine the standard posix error
 *	codes to determine the cause of the problem.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */







|







2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
 *	This function replaces the library version of getcwd().
 *
 * Results:
 *	The input and output are filesystem paths in native form. The result
 *	is either the given clientData, if the working directory hasn't
 *	changed, or a new clientData (owned by our caller), giving the new
 *	native path, or NULL if the current directory could not be determined.
 *	If NULL is returned, the caller can examine the standard Posix error
 *	codes to determine the cause of the problem.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Changes to win/tclWinInit.c.

159
160
161
162
163
164
165
166
167
168
169
170
171
172
173

    snprintf(installLib, sizeof(installLib), "lib/tcl%s", TCL_VERSION);

    /*
     * Look for the library relative to the TCL_LIBRARY env variable. If the
     * last dirname in the TCL_LIBRARY path does not match the last dirname in
     * the installLib variable, use the last dir name of installLib in
     * addition to the orginal TCL_LIBRARY path.
     */

    AppendEnvironment(pathPtr, installLib);

    /*
     * Look for the library in its default location.
     */







|







159
160
161
162
163
164
165
166
167
168
169
170
171
172
173

    snprintf(installLib, sizeof(installLib), "lib/tcl%s", TCL_VERSION);

    /*
     * Look for the library relative to the TCL_LIBRARY env variable. If the
     * last dirname in the TCL_LIBRARY path does not match the last dirname in
     * the installLib variable, use the last dir name of installLib in
     * addition to the original TCL_LIBRARY path.
     */

    AppendEnvironment(pathPtr, installLib);

    /*
     * Look for the library in its default location.
     */
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
	}
    }
    if (shortlib == lib) {
	Tcl_Panic("no '/' character found in lib");
    }

    /*
     * The "L" preceeding the TCL_LIBRARY string is used to tell VC++ that
     * this is a unicode string.
     */

    GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH);
    WideCharToMultiByte(CP_UTF8, 0, wBuf, -1, buf, MAX_PATH * 3, NULL, NULL);

    if (buf[0] != '\0') {
	objPtr = Tcl_NewStringObj(buf, -1);







|
|







236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
	}
    }
    if (shortlib == lib) {
	Tcl_Panic("no '/' character found in lib");
    }

    /*
     * The "L" preceding the TCL_LIBRARY string is used to tell VC++ that
     * this is a Unicode string.
     */

    GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH);
    WideCharToMultiByte(CP_UTF8, 0, wBuf, -1, buf, MAX_PATH * 3, NULL, NULL);

    if (buf[0] != '\0') {
	objPtr = Tcl_NewStringObj(buf, -1);

Changes to win/tclWinNotify.c.

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"

/*
 * The follwing static indicates whether this module has been initialized.
 */

#define INTERVAL_TIMER	1	/* Handle of interval timer. */

#define WM_WAKEUP	WM_USER	/* Message that is send by
				 * Tcl_AlertNotifier. */
/*







|







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"

/*
 * The following static indicates whether this module has been initialized.
 */

#define INTERVAL_TIMER	1	/* Handle of interval timer. */

#define WM_WAKEUP	WM_USER	/* Message that is send by
				 * Tcl_AlertNotifier. */
/*

Changes to win/tclWinPipe.c.

918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
				 * arguments have not been converted. */
    TclFile inputFile,		/* If non-NULL, gives the file to use as input
				 * for the child process. If inputFile file is
				 * not readable or is NULL, the child will
				 * receive no standard input. */
    TclFile outputFile,		/* If non-NULL, gives the file that receives
				 * output from the child process. If
				 * outputFile file is not writeable or is
				 * NULL, output from the child will be
				 * discarded. */
    TclFile errorFile,		/* If non-NULL, gives the file that receives
				 * errors from the child process. If errorFile
				 * file is not writeable or is NULL, errors
				 * from the child will be discarded. errorFile
				 * may be the same as outputFile. */
    Tcl_Pid *pidPtr)		/* If this function is successful, pidPtr is
				 * filled with the process id of the child
				 * process. */
{
    int result, applType, createFlags;







|




|







918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
				 * arguments have not been converted. */
    TclFile inputFile,		/* If non-NULL, gives the file to use as input
				 * for the child process. If inputFile file is
				 * not readable or is NULL, the child will
				 * receive no standard input. */
    TclFile outputFile,		/* If non-NULL, gives the file that receives
				 * output from the child process. If
				 * outputFile file is not writable or is
				 * NULL, output from the child will be
				 * discarded. */
    TclFile errorFile,		/* If non-NULL, gives the file that receives
				 * errors from the child process. If errorFile
				 * file is not writable or is NULL, errors
				 * from the child will be discarded. errorFile
				 * may be the same as outputFile. */
    Tcl_Pid *pidPtr)		/* If this function is successful, pidPtr is
				 * filled with the process id of the child
				 * process. */
{
    int result, applType, createFlags;
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
    int action)
{
    PipeInfo *infoPtr = (PipeInfo *) instanceData;

    /*
     * We do not access firstPipePtr in the thread structures. This is not for
     * all pipes managed by the thread, but only those we are watching.
     * Removal of the filevent handlers before transfer thus takes care of
     * this structure.
     */

    Tcl_MutexLock(&pipeMutex);
    if (action == TCL_CHANNEL_THREAD_INSERT) {
	/*
	 * We can't copy the thread information from the channel when the







|







3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
    int action)
{
    PipeInfo *infoPtr = (PipeInfo *) instanceData;

    /*
     * We do not access firstPipePtr in the thread structures. This is not for
     * all pipes managed by the thread, but only those we are watching.
     * Removal of the fileevent handlers before transfer thus takes care of
     * this structure.
     */

    Tcl_MutexLock(&pipeMutex);
    if (action == TCL_CHANNEL_THREAD_INSERT) {
	/*
	 * We can't copy the thread information from the channel when the

Changes to win/tclWinReg.c.

769
770
771
772
773
774
775
776
777
778
779
780
781
782
783

    /*
     * Initialize a Dstring to maximum statically allocated size we could get
     * one more byte by avoiding Tcl_DStringSetLength() and just setting
     * length to TCL_DSTRING_STATIC_SIZE, but this should be safer if the
     * implementation of Dstrings changes.
     *
     * This allows short values to be read from the registy in one call.
     * Longer values need a second call with an expanded DString.
     */

    Tcl_DStringInit(&data);
    Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1);
    length = TCL_DSTRING_STATIC_SIZE/sizeof(WCHAR) - 1;








|







769
770
771
772
773
774
775
776
777
778
779
780
781
782
783

    /*
     * Initialize a Dstring to maximum statically allocated size we could get
     * one more byte by avoiding Tcl_DStringSetLength() and just setting
     * length to TCL_DSTRING_STATIC_SIZE, but this should be safer if the
     * implementation of Dstrings changes.
     *
     * This allows short values to be read from the registry in one call.
     * Longer values need a second call with an expanded DString.
     */

    Tcl_DStringInit(&data);
    Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1);
    length = TCL_DSTRING_STATIC_SIZE/sizeof(WCHAR) - 1;

863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
}

/*
 *----------------------------------------------------------------------
 *
 * GetValueNames --
 *
 *	This function enumerates the values of the a given key. If the
 *	optional pattern is supplied, then only value names that match the
 *	pattern will be returned.
 *
 * Results:
 *	Returns the list of value names in the result object of the
 *	interpreter, or an error message on failure.
 *







|







863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
}

/*
 *----------------------------------------------------------------------
 *
 * GetValueNames --
 *
 *	This function enumerates the values of the given key. If the
 *	optional pattern is supplied, then only value names that match the
 *	pattern will be returned.
 *
 * Results:
 *	Returns the list of value names in the result object of the
 *	interpreter, or an error message on failure.
 *
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
}

/*
 *----------------------------------------------------------------------
 *
 * OpenSubKey --
 *
 *	This function opens a given subkey of a root key on the specified
 *	host.
 *
 * Results:
 *	Returns the opened key in the keyPtr and a Windows error code as the
 *	return value.
 *
 * Side effects:







|







998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
}

/*
 *----------------------------------------------------------------------
 *
 * OpenSubKey --
 *
 *	Opens a given subkey of the given root key on the specified
 *	host.
 *
 * Results:
 *	Returns the opened key in the keyPtr and a Windows error code as the
 *	return value.
 *
 * Side effects:
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
}

/*
 *----------------------------------------------------------------------
 *
 * ParseKeyName --
 *
 *	This function parses a key name into the host, root, and subkey parts.
 *
 * Results:
 *	The pointers to the start of the host and subkey names are returned in
 *	the hostNamePtr and keyNamePtr variables. The specified root HKEY is
 *	returned in rootKeyPtr. Returns a standard Tcl result.
 *
 * Side effects:







|







1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
}

/*
 *----------------------------------------------------------------------
 *
 * ParseKeyName --
 *
 *	Parses a key name into the host, root, and subkey parts.
 *
 * Results:
 *	The pointers to the start of the host and subkey names are returned in
 *	the hostNamePtr and keyNamePtr variables. The specified root HKEY is
 *	returned in rootKeyPtr. Returns a standard Tcl result.
 *
 * Side effects:
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
}

/*
 *----------------------------------------------------------------------
 *
 * AppendSystemError --
 *
 *	This routine formats a Windows system error message and places it into
 *	the interpreter result.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.







|







1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
}

/*
 *----------------------------------------------------------------------
 *
 * AppendSystemError --
 *
 *	Formats a Windows system error message and places it into
 *	the interpreter result.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
}

/*
 *----------------------------------------------------------------------
 *
 * ConvertDWORD --
 *
 *	This function determines whether a DWORD needs to be byte swapped, and
 *	returns the appropriately swapped value.
 *
 * Results:
 *	Returns a converted DWORD.
 *
 * Side effects:
 *	None.







|







1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
}

/*
 *----------------------------------------------------------------------
 *
 * ConvertDWORD --
 *
 *	Determines whether a DWORD needs to be byte swapped, and
 *	returns the appropriately swapped value.
 *
 * Results:
 *	Returns a converted DWORD.
 *
 * Side effects:
 *	None.

Changes to win/tclWinSerial.c.

324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
}

/*
 *----------------------------------------------------------------------
 *
 * SerialBlockTime --
 *
 *	Wrapper to set Tcl's block time in msec
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Updates the maximum blocking time.
 *







|







324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
}

/*
 *----------------------------------------------------------------------
 *
 * SerialBlockTime --
 *
 *	Wrapper to set Tcl's block time in msec.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Updates the maximum blocking time.
 *
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
		}
	    } else {
		errno = *errorCode = EWOULDBLOCK;
		return -1;
	    }
	} else {
	    /*
	     * BLOCKING mode: Tcl trys to read a full buffer of 4 kBytes here.
	     */

	    if (cStat.cbInQue > 0) {
		if ((DWORD) bufSize > cStat.cbInQue) {
		    bufSize = cStat.cbInQue;
		}
	    } else {







|







898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
		}
	    } else {
		errno = *errorCode = EWOULDBLOCK;
		return -1;
	    }
	} else {
	    /*
	     * BLOCKING mode: Tcl tries to read a full buffer of 4 kBytes here.
	     */

	    if (cStat.cbInQue > 0) {
		if ((DWORD) bufSize > cStat.cbInQue) {
		    bufSize = cStat.cbInQue;
		}
	    } else {
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
{
    SerialInfo *infoPtr = (SerialInfo *) instanceData;
    DWORD bytesWritten, timeout;

    *errorCode = 0;

    /*
     * At EXIT Tcl trys to flush all open channels in blocking mode. We avoid
     * blocking output after ExitProc or CloseHandler(chan) has been called by
     * checking the corrresponding variables.
     */

    if (!initialized || TclInExit()) {
	return toWrite;
    }

    /*







|

|







967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
{
    SerialInfo *infoPtr = (SerialInfo *) instanceData;
    DWORD bytesWritten, timeout;

    *errorCode = 0;

    /*
     * At EXIT Tcl tries to flush all open channels in blocking mode. We avoid
     * blocking output after ExitProc or CloseHandler(chan) has been called by
     * checking the corresponding variables.
     */

    if (!initialized || TclInExit()) {
	return toWrite;
    }

    /*
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
    int action)
{
    SerialInfo *infoPtr = (SerialInfo *) instanceData;

    /*
     * We do not access firstSerialPtr in the thread structures. This is not
     * for all serials managed by the thread, but only those we are watching.
     * Removal of the filevent handlers before transfer thus takes care of
     * this structure.
     */

    Tcl_MutexLock(&serialMutex);
    if (action == TCL_CHANNEL_THREAD_INSERT) {
	/*
	 * We can't copy the thread information from the channel when the







|







2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
    int action)
{
    SerialInfo *infoPtr = (SerialInfo *) instanceData;

    /*
     * We do not access firstSerialPtr in the thread structures. This is not
     * for all serials managed by the thread, but only those we are watching.
     * Removal of the fileevent handlers before transfer thus takes care of
     * this structure.
     */

    Tcl_MutexLock(&serialMutex);
    if (action == TCL_CHANNEL_THREAD_INSERT) {
	/*
	 * We can't copy the thread information from the channel when the

Changes to win/tclWinSock.c.

117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
} address;

#ifndef IN6_ARE_ADDR_EQUAL
#define IN6_ARE_ADDR_EQUAL IN6_ADDR_EQUAL
#endif

/*
 * This structure describes per-instance state of a tcp based channel.
 */

typedef struct TcpState TcpState;

typedef struct TcpFdList {
    TcpState *statePtr;
    SOCKET fd;







|







117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
} address;

#ifndef IN6_ARE_ADDR_EQUAL
#define IN6_ARE_ADDR_EQUAL IN6_ADDR_EQUAL
#endif

/*
 * This structure describes per-instance state of a tcp-based channel.
 */

typedef struct TcpState TcpState;

typedef struct TcpFdList {
    TcpState *statePtr;
    SOCKET fd;
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
				 * This error is still a windows error code.
				 * Access must be protected by semaphore */
    struct TcpState *nextPtr;	/* The next socket on the per-thread socket
				 * list. */
};

/*
 * These bits may be ORed together into the "flags" field of a TcpState
 * structure.
 */

#define TCP_NONBLOCKING		(1<<0)	/* Socket with non-blocking I/O */
#define TCP_ASYNC_CONNECT	(1<<1)	/* Async connect in progress. */
#define SOCKET_EOF		(1<<2)	/* A zero read happened on the
					 * socket. */







|







173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
				 * This error is still a windows error code.
				 * Access must be protected by semaphore */
    struct TcpState *nextPtr;	/* The next socket on the per-thread socket
				 * list. */
};

/*
 * These bits may be OR'ed together into the "flags" field of a TcpState
 * structure.
 */

#define TCP_NONBLOCKING		(1<<0)	/* Socket with non-blocking I/O */
#define TCP_ASYNC_CONNECT	(1<<1)	/* Async connect in progress. */
#define SOCKET_EOF		(1<<2)	/* A zero read happened on the
					 * socket. */
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
 *
 *	There are two modes of operation, defined by errorCodePtr:
 *	 *  non-NULL: Called by explicite read/write command. Block if socket
 *	    is blocking.
 *	    May return two error codes:
 *	     *	EWOULDBLOCK: if connect is still in progress
 *	     *	ENOTCONN: if connect failed. This would be the error message
 *		of a rect or sendto syscall so this is emulated here.
 *	 *  Null: Called by a backround operation. Do not block and don't
 *	    return any error code.
 *
 * Results:
 * 	0 if the connection has completed, -1 if still in progress or there is
 * 	an error.
 *
 * Side effects:







|
|







569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
 *
 *	There are two modes of operation, defined by errorCodePtr:
 *	 *  non-NULL: Called by explicite read/write command. Block if socket
 *	    is blocking.
 *	    May return two error codes:
 *	     *	EWOULDBLOCK: if connect is still in progress
 *	     *	ENOTCONN: if connect failed. This would be the error message
 *		of a recv or sendto syscall so this is emulated here.
 *	 *  Null: Called by a background operation. Do not block and don't
 *	    return any error code.
 *
 * Results:
 * 	0 if the connection has completed, -1 if still in progress or there is
 * 	an error.
 *
 * Side effects:
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
	     * Consume the connect event.
	     */

	    CLEAR_BITS(statePtr->readyEvents, FD_CONNECT);

	    /*
	     * For blocking sockets and foreground processing, disable async
	     * connect as we continue now synchoneously.
	     */

	    if (errorCodePtr != NULL &&
		    !GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) {
		CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
	    }

	    /*
	     * Free list lock.
	     */

	    SetEvent(tsdPtr->socketListLock);

	    /*
	     * Continue connect. If switched to synchroneous connect, the
	     * connect is terminated.
	     */

	    result = TcpConnect(NULL, statePtr);

	    /*
	     * Restore event service mode.
	     */

	    (void) Tcl_SetServiceMode(oldMode);

	    /*
	     * Check for Succesfull connect or async connect restart
	     */

	    if (result == TCL_OK) {
		/*
		 * Check for async connect restart (not possible for
		 * foreground blocking operation)
		 */







|














|












|







643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
	     * Consume the connect event.
	     */

	    CLEAR_BITS(statePtr->readyEvents, FD_CONNECT);

	    /*
	     * For blocking sockets and foreground processing, disable async
	     * connect as we continue now synchronously.
	     */

	    if (errorCodePtr != NULL &&
		    !GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) {
		CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
	    }

	    /*
	     * Free list lock.
	     */

	    SetEvent(tsdPtr->socketListLock);

	    /*
	     * Continue connect. If switched to synchronous connect, the
	     * connect is terminated.
	     */

	    result = TcpConnect(NULL, statePtr);

	    /*
	     * Restore event service mode.
	     */

	    (void) Tcl_SetServiceMode(oldMode);

	    /*
	     * Check for Successful connect or async connect restart
	     */

	    if (result == TCL_OK) {
		/*
		 * Check for async connect restart (not possible for
		 * foreground blocking operation)
		 */
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
	    break;
	}

	error = WSAGetLastError();

	/*
	 * If an RST comes, then ignore the error and report an EOF just like
	 * on unix.
	 */

	if (error == WSAECONNRESET) {
	    SET_BITS(statePtr->flags, SOCKET_EOF);
	    bytesRead = 0;
	    break;
	}







|







842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
	    break;
	}

	error = WSAGetLastError();

	/*
	 * If an RST comes, then ignore the error and report an EOF just like
	 * on Unix.
	 */

	if (error == WSAECONNRESET) {
	    SET_BITS(statePtr->flags, SOCKET_EOF);
	    bytesRead = 0;
	    break;
	}
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
	}
	return TCL_ERROR;
    }

    /*
     * Go one step in async connect
     *
     * If any error is thrown save it as backround error to report eventually
     * below.
     */
    WaitForConnect(statePtr, NULL);

    sock = statePtr->sockets->fd;
    if (optionName != NULL) {
	len = strlen(optionName);







|







1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
	}
	return TCL_ERROR;
    }

    /*
     * Go one step in async connect
     *
     * If any error is thrown save it as background error to report eventually
     * below.
     */
    WaitForConnect(statePtr, NULL);

    sock = statePtr->sockets->fd;
    if (optionName != NULL) {
	len = strlen(optionName);
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
		    statePtr->addr->ai_addrlen);

	    error = WSAGetLastError();
	    TclWinConvertError(error);

	    if (async_connect && error == WSAEWOULDBLOCK) {
		/*
		 * Asynchroneous connect
		 *
		 * Remember that we jump back behind this next round
		 */

		SET_BITS(statePtr->flags, TCP_ASYNC_PENDING);
		return TCL_OK;








|







1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
		    statePtr->addr->ai_addrlen);

	    error = WSAGetLastError();
	    TclWinConvertError(error);

	    if (async_connect && error == WSAEWOULDBLOCK) {
		/*
		 * Asynchronous connect
		 *
		 * Remember that we jump back behind this next round
		 */

		SET_BITS(statePtr->flags, TCP_ASYNC_PENDING);
		return TCL_OK;

1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
     * Async connect terminated
     */

    CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT);

    if (Tcl_GetErrno() == 0) {
	/*
	 * Succesfully connected
	 *
	 * Set up the select mask for read/write events.
	 */

	statePtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE;

	/*







|







1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
     * Async connect terminated
     */

    CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT);

    if (Tcl_GetErrno() == 0) {
	/*
	 * Successfully connected
	 *
	 * Set up the select mask for read/write events.
	 */

	statePtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE;

	/*
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
	     * Free list lock.
	     */

	    SetEvent(tsdPtr->socketListLock);
	}

	/*
	 * Error message on synchroneous connect
	 */

	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "couldn't open socket: %s", Tcl_PosixError(interp)));
	}
	return TCL_ERROR;







|







1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
	     * Free list lock.
	     */

	    SetEvent(tsdPtr->socketListLock);
	}

	/*
	 * Error message on synchronous connect
	 */

	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "couldn't open socket: %s", Tcl_PosixError(interp)));
	}
	return TCL_ERROR;
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
	/*
	 * Get statePtr lock.
	 */

	WaitForSingleObject(tsdPtr->socketListLock, INFINITE);

	/*
	 * Check if event occured.
	 */

	event_found = GOT_BITS(statePtr->readyEvents, events);

	/*
	 * Free list lock.
	 */

	SetEvent(tsdPtr->socketListLock);

	/*
	 * Exit loop if event occured.
	 */

	if (event_found) {
	    break;
	}

	/*







|











|







3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
	/*
	 * Get statePtr lock.
	 */

	WaitForSingleObject(tsdPtr->socketListLock, INFINITE);

	/*
	 * Check if event occurred.
	 */

	event_found = GOT_BITS(statePtr->readyEvents, events);

	/*
	 * Free list lock.
	 */

	SetEvent(tsdPtr->socketListLock);

	/*
	 * Exit loop if event occurred.
	 */

	if (event_found) {
	    break;
	}

	/*
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
 *	interest in a socket event, and the event has occurred.
 *
 * Results:
 *	0 on success.
 *
 * Side effects:
 *	The flags for the given socket are updated to reflect the event that
 *	occured.
 *
 *----------------------------------------------------------------------
 */

static LRESULT CALLBACK
SocketProc(
    HWND hwnd,







|







3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
 *	interest in a socket event, and the event has occurred.
 *
 * Results:
 *	0 on success.
 *
 * Side effects:
 *	The flags for the given socket are updated to reflect the event that
 *	occurred.
 *
 *----------------------------------------------------------------------
 */

static LRESULT CALLBACK
SocketProc(
    HWND hwnd,
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
}

/*
 *----------------------------------------------------------------------
 *
 * FindFDInList --
 *
 *	Return true, if the given file descriptior is contained in the
 *	file descriptor list.
 *
 * Results:
 *	true if found.
 *
 * Side effects:
 *







|







3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
}

/*
 *----------------------------------------------------------------------
 *
 * FindFDInList --
 *
 *	Return true, if the given file descriptor is contained in the
 *	file descriptor list.
 *
 * Results:
 *	true if found.
 *
 * Side effects:
 *

Changes to win/tclWinThrd.c.

779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
     */

    if (timeout) {
	if (tsdPtr->flags & WIN_THREAD_RUNNING) {
	    timeout = 0;
	} else {
	    /*
	     * When dequeuing, we can leave the tsdPtr->nextPtr and
	     * tsdPtr->prevPtr with dangling pointers because they are
	     * reinitialilzed w/out reading them when the thread is enqueued
	     * later.
	     */

	    if (winCondPtr->firstPtr == tsdPtr) {
		winCondPtr->firstPtr = tsdPtr->nextPtr;
	    } else {
		tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;







|

|







779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
     */

    if (timeout) {
	if (tsdPtr->flags & WIN_THREAD_RUNNING) {
	    timeout = 0;
	} else {
	    /*
	     * When dequeueing, we can leave the tsdPtr->nextPtr and
	     * tsdPtr->prevPtr with dangling pointers because they are
	     * reinitialized w/out reading them when the thread is enqueued
	     * later.
	     */

	    if (winCondPtr->firstPtr == tsdPtr) {
		winCondPtr->firstPtr = tsdPtr->nextPtr;
	    } else {
		tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;

Changes to win/tclWinTime.c.

594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627

	/*
	 * If calibration cycle occurred after we get curCounter
	 */

	if (curCounter.QuadPart <= perfCounterLastCall) {
	    /*
	     * Calibrated file-time is saved from posix in 100-ns ticks
	     */

	    return fileTimeLastCall / 10;
	}

	/*
	 * If it appears to be more than 1.1 seconds since the last trip
	 * through the calibration loop, the performance counter may have
	 * jumped forward. (See MSDN Knowledge Base article Q274323 for a
	 * description of the hardware problem that makes this test
	 * necessary.) If the counter jumps, we don't want to use it directly.
	 * Instead, we must return system time. Eventually, the calibration
	 * loop should recover.
	 */

	if (curCounter.QuadPart - perfCounterLastCall <
		11 * curCounterFreq * timeInfo.calibrationInterv / 10
	) {
	    /* Calibrated file-time is saved from posix in 100-ns ticks */
	    return NativeCalc100NsTicks(fileTimeLastCall,
		perfCounterLastCall, curCounterFreq, curCounter.QuadPart) / 10;
	}
    }

    /*
     * High resolution timer is not available.







|


















|







594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627

	/*
	 * If calibration cycle occurred after we get curCounter
	 */

	if (curCounter.QuadPart <= perfCounterLastCall) {
	    /*
	     * Calibrated file-time is saved from Posix in 100-ns ticks
	     */

	    return fileTimeLastCall / 10;
	}

	/*
	 * If it appears to be more than 1.1 seconds since the last trip
	 * through the calibration loop, the performance counter may have
	 * jumped forward. (See MSDN Knowledge Base article Q274323 for a
	 * description of the hardware problem that makes this test
	 * necessary.) If the counter jumps, we don't want to use it directly.
	 * Instead, we must return system time. Eventually, the calibration
	 * loop should recover.
	 */

	if (curCounter.QuadPart - perfCounterLastCall <
		11 * curCounterFreq * timeInfo.calibrationInterv / 10
	) {
	    /* Calibrated file-time is saved from Posix in 100-ns ticks */
	    return NativeCalc100NsTicks(fileTimeLastCall,
		perfCounterLastCall, curCounterFreq, curCounter.QuadPart) / 10;
	}
    }

    /*
     * High resolution timer is not available.
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
	/*
	 * If we are in the valid range, let the C run-time library handle it.
	 * Otherwise we need to fake it. Note that this algorithm ignores
	 * daylight savings time before the epoch.
	 */

	/*
	 * Hm, Borland's localtime manages to return NULL under certain
	 * circumstances (e.g. wintime.test, test 1.2). Nobody tests for this,
	 * since 'localtime' isn't supposed to do this, possibly leading to
	 * crashes.
	 *
	 * Patch: We only call this function if we are at least one day into
	 * the epoch, else we handle it ourselves (like we do for times < 0).
	 * H. Giese, June 2003







|







750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
	/*
	 * If we are in the valid range, let the C run-time library handle it.
	 * Otherwise we need to fake it. Note that this algorithm ignores
	 * daylight savings time before the epoch.
	 */

	/*
	 * Hmm, Borland's localtime manages to return NULL under certain
	 * circumstances (e.g. wintime.test, test 1.2). Nobody tests for this,
	 * since 'localtime' isn't supposed to do this, possibly leading to
	 * crashes.
	 *
	 * Patch: We only call this function if we are at least one day into
	 * the epoch, else we handle it ourselves (like we do for times < 0).
	 * H. Giese, June 2003
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
     */

    GetSystemTimeAsFileTime(&curFileTime);
    QueryPerformanceCounter(&timeInfo.perfCounterLastCall);
    QueryPerformanceFrequency(&timeInfo.curCounterFreq);
    timeInfo.fileTimeLastCall.LowPart = curFileTime.dwLowDateTime;
    timeInfo.fileTimeLastCall.HighPart = curFileTime.dwHighDateTime;
    /* Calibrated file-time will be saved from posix in 100-ns ticks */
    timeInfo.fileTimeLastCall.QuadPart -= timeInfo.posixEpoch.QuadPart;

    ResetCounterSamples(timeInfo.fileTimeLastCall.QuadPart,
	    timeInfo.perfCounterLastCall.QuadPart,
	    timeInfo.curCounterFreq.QuadPart);

    /*







|







981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
     */

    GetSystemTimeAsFileTime(&curFileTime);
    QueryPerformanceCounter(&timeInfo.perfCounterLastCall);
    QueryPerformanceFrequency(&timeInfo.curCounterFreq);
    timeInfo.fileTimeLastCall.LowPart = curFileTime.dwLowDateTime;
    timeInfo.fileTimeLastCall.HighPart = curFileTime.dwHighDateTime;
    /* Calibrated file-time will be saved from Posix in 100-ns ticks */
    timeInfo.fileTimeLastCall.QuadPart -= timeInfo.posixEpoch.QuadPart;

    ResetCounterSamples(timeInfo.fileTimeLastCall.QuadPart,
	    timeInfo.perfCounterLastCall.QuadPart,
	    timeInfo.curCounterFreq.QuadPart);

    /*
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
    Tcl_WideInt vt1;		/* Tcl time one second from now. */
    Tcl_WideInt tdiff;		/* Difference between system clock and Tcl
				 * time. */
    Tcl_WideInt driftFreq;	/* Frequency needed to drift virtual time into
				 * step over 1 second. */

    /*
     * Sample performance counter and system time (from posix epoch).
     */

    GetSystemTimeAsFileTime(&curSysTime);
    curFileTime.LowPart = curSysTime.dwLowDateTime;
    curFileTime.HighPart = curSysTime.dwHighDateTime;
    curFileTime.QuadPart -= timeInfo.posixEpoch.QuadPart;
    /* If calibration still not needed (check for possible time switch) */
    if ( curFileTime.QuadPart > lastFileTime.QuadPart
      && curFileTime.QuadPart < lastFileTime.QuadPart +
      				    (timeInfo.calibrationInterv * 10000000)
    ) {
    	/* again in next one second */
	return;
    }
    QueryPerformanceCounter(&curPerfCounter);

    lastFileTime.QuadPart = curFileTime.QuadPart;

    /*
     * We devide by timeInfo.curCounterFreq.QuadPart in several places. That
     * value should always be positive on a correctly functioning system. But
     * it is good to be defensive about such matters. So if something goes
     * wrong and the value does goes to zero, we clear the
     * timeInfo.perfCounterAvailable in order to cause the calibration thread
     * to shut itself down, then return without additional processing.
     */








|



















|







1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
    Tcl_WideInt vt1;		/* Tcl time one second from now. */
    Tcl_WideInt tdiff;		/* Difference between system clock and Tcl
				 * time. */
    Tcl_WideInt driftFreq;	/* Frequency needed to drift virtual time into
				 * step over 1 second. */

    /*
     * Sample performance counter and system time (from Posix epoch).
     */

    GetSystemTimeAsFileTime(&curSysTime);
    curFileTime.LowPart = curSysTime.dwLowDateTime;
    curFileTime.HighPart = curSysTime.dwHighDateTime;
    curFileTime.QuadPart -= timeInfo.posixEpoch.QuadPart;
    /* If calibration still not needed (check for possible time switch) */
    if ( curFileTime.QuadPart > lastFileTime.QuadPart
      && curFileTime.QuadPart < lastFileTime.QuadPart +
      				    (timeInfo.calibrationInterv * 10000000)
    ) {
    	/* again in next one second */
	return;
    }
    QueryPerformanceCounter(&curPerfCounter);

    lastFileTime.QuadPart = curFileTime.QuadPart;

    /*
     * We divide by timeInfo.curCounterFreq.QuadPart in several places. That
     * value should always be positive on a correctly functioning system. But
     * it is good to be defensive about such matters. So if something goes
     * wrong and the value does goes to zero, we clear the
     * timeInfo.perfCounterAvailable in order to cause the calibration thread
     * to shut itself down, then return without additional processing.
     */