Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Merge pre-TIP 660 changes from trunk. |
|---|---|
| Timelines: | family | ancestors | descendants | both | novem |
| Files: | files | file ages | folders |
| SHA3-256: |
b1c433a972bf473ceb68c7800d975b0d |
| User & Date: | dgp 2023-04-21 16:49:36.504 |
Context
|
2023-04-24
| ||
| 14:39 | merge TIP 660 commit check-in: 8cab581c5a user: dgp tags: novem | |
|
2023-04-21
| ||
| 16:49 | Merge pre-TIP 660 changes from trunk. check-in: b1c433a972 user: dgp tags: novem | |
|
2023-04-18
| ||
| 22:35 | In DoReadChars() reset CHANNEL_ENCODING_ERROR instead of CHANNEL_BLOCKED. check-in: 883464ea32 user: pooryorick tags: trunk, main | |
|
2023-04-06
| ||
| 12:26 | merge trunk check-in: 2b792483a3 user: dgp tags: novem | |
Changes
Changes to ChangeLog.
| ︙ | ︙ | |||
1378 1379 1380 1381 1382 1383 1384 | 2012-04-28 Alexandre Ferrieux <ferrieux@users.sourceforge.net> * generic/tclIO.c: Properly close nonblocking channels even when not flushing them. 2012-05-03 Jan Nijtmans <nijtmans@users.sf.net> | | | 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 | 2012-04-28 Alexandre Ferrieux <ferrieux@users.sourceforge.net> * generic/tclIO.c: Properly close nonblocking channels even when not flushing them. 2012-05-03 Jan Nijtmans <nijtmans@users.sf.net> * 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 <dgp@users.sourceforge.net> * tests/socket.test: [Bug 3428754]: Test socket-14.2 tolerate [socket -async] connection that connects synchronously. |
| ︙ | ︙ | |||
5478 5479 5480 5481 5482 5483 5484 | checking for the exact error message. 2010-03-30 Andreas Kupries <andreask@activestate.com> * generic/tclIORChan.c (ReflectClose, ReflectInput, ReflectOutput, (ReflectSeekWide, ReflectWatch, ReflectBlock, ReflectSetOption, (ReflectGetOption, ForwardProc): [Bug 2978773]: Preserve | | | 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 <andreask@activestate.com> * 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 <dgp@users.sourceforge.net> * 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 | * generic/tclBinary.c: [Bug 2922555]: Handle completely invalid input * tests/binary.test: to the decode methods. 2009-12-28 Donal K. Fellows <dkf@users.sf.net> * unix/Makefile.in (trace-shell, trace-test): [FRQ 1083288]: Added | | | 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 <dkf@users.sf.net> * 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 | * tools/tclZIC.tcl * tools/tsdPerf.c 2009-11-17 Andreas Kupries <andreask@activestate.com> * 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 | | | 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 <andreask@activestate.com> * 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 <ferrieux@users.sourceforge.net> * 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 | 2009-10-20 Don Porter <dgp@users.sourceforge.net> * 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 | | | 7137 7138 7139 7140 7141 7142 7143 7144 7145 7146 7147 7148 7149 7150 7151 | 2009-10-20 Don Porter <dgp@users.sourceforge.net> * 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 <dgp@users.sourceforge.net> * 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 | customize SHLIB_VERSION on BSD-derived systems. Thanks to Stuart Cassoff for his help. * unix/configure: Autoconf 2.59 2009-01-19 David Gravereaux <davygrvy@pobox.com> * win/build.vc.bat: Improved tools detection and error message | | | 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 <davygrvy@pobox.com> * 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 | 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 | | | 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 | 2000-11-23 Donal K. Fellows <fellowsd@cs.man.ac.uk> * generic/tclCmdIL.c (Tcl_LsortObjCmd): Fixed memory leak from [Bug 119398] * library/init.tcl (unknown): Added specific level parameters to | | | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 | 2000-11-23 Donal K. Fellows <fellowsd@cs.man.ac.uk> * 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 <a.kupries@westend.com> 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 | * 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 | | | 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 <davygrvy@ajubasolutions.com> * 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 | * 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 <ericm@scriptics.com> | | | 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 <ericm@scriptics.com> * 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 <ericm@scriptics.com> * doc/package.n: Corrected information about [package forget] arguments [Bug: 5418]. |
| ︙ | ︙ | |||
1542 1543 1544 1545 1546 1547 1548 | 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 | | | 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 | 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 <welch@scriptics.com> * library/http2.1/http.tcl: More thrashing with the "server closes | | | 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 <welch@scriptics.com> * 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 <hobbs@scriptics.com> * 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 | * 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 | | | 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 <ericm@scriptics.com> * 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 | #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 | | | 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 <hobbs@scriptics.com> * 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 | 2002-12-16 David Gravereaux <davygrvy@pobox.com> * generic/tclPipe.c (TclCleanupChildren): * tests/winPipe.test: * win/tclWinPipe.c (Tcl_WaitPid): * win/tclWinTest.c: Gave Tcl_WaitPid the ability to return a Win32 | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | 2002-12-16 David Gravereaux <davygrvy@pobox.com> * 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 | * 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. | | | | | 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 <fellowsd@cs.man.ac.uk> * doc/concat.n: Documented the *real* behaviour of [concat]! 2002-06-30 Don Porter <dgp@users.sourceforge.net> * 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 | 2002-06-06 Daniel Steffen <das@users.sourceforge.net> * 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 | | | 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 | 2002-06-06 Daniel Steffen <das@users.sourceforge.net> * 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 <dgp@users.sourceforge.net> |
| ︙ | ︙ | |||
3679 3680 3681 3682 3683 3684 3685 | * 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 | | | 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 <fellowsd@cs.man.ac.uk> * 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 | * 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 | | | 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 | 2003-11-17 Don Porter <dgp@users.sourceforge.net> * 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 | | | 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 | 2003-11-17 Don Porter <dgp@users.sourceforge.net> * 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 | 2004-11-26 Donal K. Fellows <donal.k.fellows@man.ac.uk> * 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 | | | 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 | 2004-11-26 Donal K. Fellows <donal.k.fellows@man.ac.uk> * 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 <donal.k.fellows@man.ac.uk> * generic/tclProc.c (TclObjInterpProc): Make it so that only |
| ︙ | ︙ | |||
1971 1972 1973 1974 1975 1976 1977 | Mikhail Kolesnitchenko. [Patch 1018486] 2004-08-31 Vince Darley <vincentdarley@users.sourceforge.net> * 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 | | | 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 | Mikhail Kolesnitchenko. [Patch 1018486] 2004-08-31 Vince Darley <vincentdarley@users.sourceforge.net> * 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 <das@users.sourceforge.net> |
| ︙ | ︙ | |||
2273 2274 2275 2276 2277 2278 2279 | 2004-07-17 Vince Darley <vincentdarley@users.sourceforge.net> * generic/tclIOUtil.c: fix to rare 'cd' infinite loop in normalization with vfs [Bug 991420]. * tests/fileSystem.test: added test for above bug. | | | 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 | 2004-07-17 Vince Darley <vincentdarley@users.sourceforge.net> * 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 <jeffh@ActiveState.com> * 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 |
* 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
| | | 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 | 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 | | | 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 | 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 | | | 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 | 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 | | | 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 expression indicates an error. 2007-08-22 Miguel Sofer <msofer@users.sf.net> * generic/tclExecute.c (TEBC): disable the new shortcut to frequent INSTs for debug builds. REVERTED (collision with alternative fix) 2007-08-21 Don Porter <dgp@users.sourceforge.net> |
| ︙ | ︙ | |||
2823 2824 2825 2826 2827 2828 2829 | * generic/tclCmdMZ.c (STR_MAP): Replace ckalloc calls with TclStackAlloc calls. 2007-03-24 Zoran Vasiljevic <vasiljevic@users.sourceforge.net> * win/tclWinThrd.c: Thread exit handler marks the current thread as | | | | 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 <vasiljevic@users.sourceforge.net> * 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 <msofer@users.sf.net> * generic/tclBasic.c (DeleteInterpProc): pop the root frame pointer before deleting the global namespace [Bug 1658572] |
| ︙ | ︙ | |||
4934 4935 4936 4937 4938 4939 4940 | namespace creation faster. Plus selected other minor improvements to code quality. [Patch 1352382] 2006-08-10 Donal K. Fellows <donal.k.fellows@manchester.ac.uk> Misc patches to make code more efficient. [Bug 1530474] (afredd) * generic/*.c, macosx/tclMacOSXNotify.c, unix/tclUnixNotfy.c, | | | 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 <donal.k.fellows@manchester.ac.uk> 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 <dgp@users.sourceforge.net> |
| ︙ | ︙ | |||
5012 5013 5014 5015 5016 5017 5018 | * 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 <dgp@users.sourceforge.net> | | | 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 <dgp@users.sourceforge.net> * win/tclWinSock.c: Correct uninitialized Tcl_DString. Thanks to afredd. [Bug 1518166] 2006-07-21 Miguel Sofer <msofer@users.sf.net> * 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 | * 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 | | | 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 <msofer@users.sf.net> * generic/tclBasic.c: Fix the numLevels computations on * generic/tclInt.h: coroutine yield/resume * tests/unsupported.test: |
| ︙ | ︙ | |||
3248 3249 3250 3251 3252 3253 3254 | * 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 <dkf@users.sf.net> * doc/switch.n: Clarified documentation in respect of two-argument | | | 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 <dkf@users.sf.net> * 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 <dkf@users.sf.net> * generic/tcl.h, generic/tclThreadAlloc.c: Tidied up the declarations |
| ︙ | ︙ |
Changes to changes.
| ︙ | ︙ | |||
3024 3025 3026 3027 3028 3029 3030 |
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
| | | 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 |
- 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
| | | 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 | 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) | | | 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 |
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)
| | | 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 doc/Cancel.3.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | .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 | | | | 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 void *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.
| ︙ | ︙ | |||
65 66 67 68 69 70 71 | 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 | | | | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | 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.
| ︙ | ︙ | |||
42 43 44 45 46 47 48 | .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 | | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | .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 size_t 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 |
| ︙ | ︙ | |||
97 98 99 100 101 102 103 | (^Z) for all platforms. If you require a .QW ^Z in code for string comparison, you can use .QW \ex1A , which will be safely substituted by the Tcl interpreter into .QW ^Z . .PP | | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | (^Z) for all platforms. If you require a .QW ^Z in code for string comparison, you can use .QW \ex1A , 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. |
| ︙ | ︙ | |||
138 139 140 141 142 143 144 | It returns the result of the command and also modifies the interpreter result in the same way as \fBTcl_Eval\fR. The last argument to \fBTcl_VarEval\fR must be NULL to indicate the end of arguments. \fBTcl_VarEval\fR is now deprecated. .SH "FLAG BITS" .PP | | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | It returns the result of the command and also modifies the interpreter result in the same way as \fBTcl_Eval\fR. The last argument to \fBTcl_VarEval\fR must be NULL to indicate the end of arguments. \fBTcl_VarEval\fR is now 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.
| ︙ | ︙ | |||
229 230 231 232 233 234 235 | .AP int index in The index of the attribute in question. .AP Tcl_Obj *objPtr in The value to set in the operation. .AP Tcl_Obj **objPtrRef out Filled with a value containing the result of the operation. .AP Tcl_Obj *resultPtr out | | | 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 | .AP int index in The index of the attribute in question. .AP Tcl_Obj *objPtr in The value to set in the operation. .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. |
| ︙ | ︙ | |||
479 480 481 482 483 484 485 | .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 | | | 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 | .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 | \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 | | | 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/SetResult.3.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | .sp \fBTcl_TransferResult\fR(\fIsourceInterp, code, targetInterp\fR) .sp \fBTcl_AppendElement\fR(\fIinterp, element\fR) .SH ARGUMENTS .AS Tcl_FreeProc sourceInterp out .AP Tcl_Interp *interp out | | | < | | | | < | | | | < | < | < | < | < | < > | < < < < < < < < | | < < < | < | < < < | | < | | < < | < > | < | | < < < < < < | | | < | < < < < < | < < | | | < | | | | < < < | | > > < | | < | | < < < | | < < | | | < | | | < < < < < < < < < < | < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 58 59 60 61 62 63 64 65 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 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 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 142 143 |
.sp
\fBTcl_TransferResult\fR(\fIsourceInterp, code, targetInterp\fR)
.sp
\fBTcl_AppendElement\fR(\fIinterp, element\fR)
.SH ARGUMENTS
.AS Tcl_FreeProc sourceInterp out
.AP Tcl_Interp *interp out
The interpreter get or set the result for.
.AP Tcl_Obj *objPtr in
A value to set the result to.
.AP char *result in
The string value set the result to, or to append to the existing result.
.AP "const char" *element in
The string value to append as a list element
to the existing result of \fIinterp\fR.
.AP Tcl_FreeProc *freeProc in
Pointer to a procedure to call to release storage at
\fIresult\fR.
.AP va_list argList in
An argument list which must have been initialized using
\fBva_start\fR, and cleared using \fBva_end\fR.
.AP Tcl_Interp *sourceInterp in
The interpreter to transfer the result and return options from.
.AP Tcl_Interp *targetInterp in
The interpreter to transfer the result and return options to.
.AP int code in
Return code value that controls transfer of return options.
.BE
.SH DESCRIPTION
.PP
These procedures manipulate the result of an interpreter. Some procedures
provide a Tcl_Obj interface while others provide a string interface. For
example, \fBTcl_SetObjResult\fR accepts a Tcl_Obj and \fBTcl_SetResult\fR
accepts a char *. Similarly, \fBTcl_GetObjResult\fR produces a Tcl_Obj * and
\fBTcl_GetStringResult\fR produces a char *. The procedures can be mixed and
matched. For example, if \fBTcl_SetObjResult\fR is called to set the result to
a Tcl_Obj value, and then \fBTcl_GetStringResult\fR is called, it returns a
char * (but see caveats below).
.PP
\fBTcl_SetObjResult\fR sets \fIobjPtr\fR as the result for \fIinterp\fR,
replacing any existing result.
.PP
\fBTcl_GetObjResult\fR returns the result for \fIinterp\fR, without
incrementing its reference count.
.PP
\fBTcl_SetResult\fR sets \fIresult\fR as the result for \fIinterp\fR, replacing
any existing result, and calls \fIfreeProc\fR to free \fIresult\fR. See \fBTHE
TCL_FREEPROC ARGUMENT TO TCL_SETRESULT\fR below. If \fIresult\fR is
\fBNULL\fR, ignores \fIfreeProc\fR and sets the result for \fIinterp\fR to
point to the empty string.
.PP
\fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as a string, i.e.
the bytes of the Tcl_Obj for the result, which can be decoded using
\fBTcl_UtfToExternal\fR. This value is freed when its corresponding Tcl_Obj is
freed.Programmers are encouraged to use the newer Tcl_Obj API procedures, e.g.
to call \fBTcl_GetObjResult\fR instead.
.PP
\fBTcl_ResetResult\fR sets the empty string as the result for \fIinterp\fR and
clears the error state managed by \fBTcl_AddErrorInfo\fR
and \fBTcl_SetErrorCode\fR.
.PP
\fBTcl_AppendResult\fR builds up a result from smaller pieces, appending each
\fIresult\fR in order to the current result for \fIinterp\fR. It may be called
repeatedly as additional pieces of the result are produced, and manages the
storage for the \fIinterp\fR's result, allocating a larger result area if
necessary. It also manages conversion to and from the \fIresult\fR field of
the \fIinterp\fR to handle backward-compatibility with old-style extensions.
Any number of \fIresult\fR arguments may be passed in a single call; the last
argument in the list must be a NULL pointer.
.PP
\fBTcl_TransferResult\fR transfers interpreter state from \fIsourceInterp\fR to
\fItargetInterp\fR, both of which must have been created in the same thread,
resets the result in \fIsourceInterp\fR, and moves the return options
dictionary as controlled by the return code value \fIcode\fR in the same manner
as \fBTcl_GetReturnOptions\fR.
.PP
If \fIsourceInterp\fR and \fItargetInterp\fR are the same, nothing is done.
.SH "DEPRECATED INTERFACES"
.SS "OLD STRING PROCEDURES"
.PP
The following procedures are deprecated since they manipulate the Tcl result as
a string. Procedures such as \fBTcl_SetObjResult\fR can be significantly more
efficient.
.PP
\fBTcl_AppendElement\fR is like \fBTcl_AppendResult\fR, but it appends only one
piece, and also appends that piece as a list item.
\fBTcl_AppendElement\fR adds backslashes or braces as necessary to ensure that
\fIelement\fR is properly formatted as a list item. Under normal conditions,
\fBTcl_AppendElement\fR adds a space character to \fIinterp\fR's result just
before adding the new list element, so that the list elements in the result are
properly separated. However if the new list element is the first item in the
list or sublist (i.e. \fIinterp\fR's current result is empty, or consists of
the single character
.QW { ,
or ends in the characters
.QW " {" )
then no space is added.
.SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT"
.PP
\fIFreeProc\fR has the following type:
.PP
.CS
typedef void \fBTcl_FreeProc\fR(
char *\fIblockPtr\fR);
.CE
.PP
When \fIfreeProc\fR is called, \fIblockPtr\fR is the \fIresult\fR value passed
to \fBTcl_SetResult\fR.
.SH "SEE ALSO"
Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp,
Tcl_GetReturnOptions
.SH KEYWORDS
append, command, element, list, value, result, return value, interpreter
|
Changes to doc/SubstObj.3.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 | .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 | | | 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/chan.n.
| ︙ | ︙ | |||
120 121 122 123 124 125 126 | Sets the encoding of the channel. \fIname\fR is either one of the names returned by \fBencoding names\fR, or .QW \fBbinary\fR \&. Input is converted from the encoding into Unicode, and output is converted from Unicode to the encoding. .RS .PP | | < < < < < < < < | < < | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 | Sets the encoding of the channel. \fIname\fR is either one of the names returned by \fBencoding names\fR, or .QW \fBbinary\fR \&. Input is converted from the encoding into Unicode, and output is converted from Unicode to the encoding. .RS .PP \fBbinary\fR is an alias for \fBiso8859-1\fR. This alone is not sufficient for working with binary data. Use \fB\-translation binary\fR instead. .PP The encoding of a new channel is the value of \fBencoding system\fR, which returns the platform- and locale-dependent system encoding used to interface with the operating system, .RE .TP \fB\-eofchar\fR \fIchar\fR |
| ︙ | ︙ | |||
192 193 194 195 196 197 198 | translated into a line feed. For output, each line feed is translated into a platform-specific representation: For all Unix variants it is \fBlf\fR, and for all Windows variants it is \fBcrlf\fR, except that for sockets on all platforms it is \fBcrlf\fR for both input and output. .TP \fBbinary\fR . | | | | | > > > > > > > | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 | translated into a line feed. For output, each line feed is translated into a platform-specific representation: For all Unix variants it is \fBlf\fR, and for all Windows variants it is \fBcrlf\fR, except that for sockets on all platforms it is \fBcrlf\fR for both input and output. .TP \fBbinary\fR . Like \fBlf\fR, no end-of-line translation is performed, but in addition, sets \fB\-eofchar\fR to the empty string to disable it, sets \fB\-encoding\fR to \fBiso8859-1\fR, and sets \fB-profile\fR to \fBstrict\fR so the the channel is fully configured for binary input and output: Each byte read from the channel becomes the Unicode character having the same value as that byte, and each character written to the channel becomes a single byte in the output. This makes it possible to work seamlessly with binary data as long as each character in the data remains in the range of 0 to 255 so that there is no distinction between binary data and text. For example, A JPEG image can be read from a such a channel, manipulated, and then written back to such a channel. .TP \fBcr\fR . The end of a line is represented in the external data by a single carriage return character. For input, each carriage return is translated to a line feed, and for output each line feed character is translated to a carriage return. |
| ︙ | ︙ |
Changes to doc/info.n.
| ︙ | ︙ | |||
168 169 170 171 172 173 174 | .TP \fBeval\fR\0\0\0\0\0\0\0\0 . The body of a script provided to \fBeval\fR or \fBuplevel\fR. .TP \fBprecompiled\fR\0\0\0\0\0\0\0\0 . | | | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 | .TP \fBeval\fR\0\0\0\0\0\0\0\0 . The body of a script provided to \fBeval\fR or \fBuplevel\fR. .TP \fBprecompiled\fR\0\0\0\0\0\0\0\0 . A precompiled script (loadable by the package \fBtbcload\fR), and no further information is available. .RE .TP \fBline\fR . The line number of of the command inside its script. Not available for \fBprecompiled\fR commands. When the type is \fBsource\fR, the line number is |
| ︙ | ︙ |
Changes to doc/memory.n.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 | Tcl began, the current packets allocated (the current number of calls to \fBTcl_Alloc\fR not met by a corresponding call to \fBTcl_Free\fR), the current bytes allocated, and the maximum number of packets and bytes allocated. .TP \fBmemory init \fR[\fBon\fR|\fBoff\fR] . | | | 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 \fBTcl_Alloc\fR not met by a corresponding call to \fBTcl_Free\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 | 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. | | | 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 | 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 | | | 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 | \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 | | | 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 | 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 | | | | 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 |
victim->freechain = from->free;
from->free = victim;
}
/*
* changearctarget - flip an arc to have a different to state
*
| | | 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 | /* - 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. * | | | 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 | /* - 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. * | | | 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 | * 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 | | | 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 |
}
}
/*
- analyze - ascertain potentially-useful facts about an optimized NFA
^ static long analyze(struct nfa *);
*/
| | | 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.
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
struct state *next; /* chain for traversing all */
struct state *prev; /* back chain */
struct arcbatch oas; /* first arcbatch, avoid malloc in easy case */
size_t noas; /* number of arcs used in first arcbatch */
};
struct nfa {
| | | | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 |
struct state *next; /* chain for traversing all */
struct state *prev; /* back chain */
struct arcbatch oas; /* first arcbatch, avoid malloc in easy case */
size_t 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 */
size_t 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.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
void Tcl_DbCkfree(void *ptr, const char *file, int line)
}
declare 8 {
void *Tcl_DbCkrealloc(void *ptr, TCL_HASH_TYPE size,
const char *file, int line)
}
| | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
void Tcl_DbCkfree(void *ptr, const char *file, int line)
}
declare 8 {
void *Tcl_DbCkrealloc(void *ptr, TCL_HASH_TYPE 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 {
void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc,
void *clientData)
}
|
| ︙ | ︙ | |||
2626 2627 2628 2629 2630 2631 2632 |
# TIP 651
declare 685 {
Tcl_Obj *Tcl_DStringToObj(Tcl_DString *dsPtr)
}
# ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- #
| | | 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 |
# TIP 651
declare 685 {
Tcl_Obj *Tcl_DStringToObj(Tcl_DString *dsPtr)
}
# ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- #
declare 688 {
void TclUnusedStubEntry(void)
}
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.
|
| ︙ | ︙ |
Changes to generic/tcl.h.
| ︙ | ︙ | |||
267 268 269 270 271 272 273 274 275 276 277 278 279 | # define TCL_Z_MODIFIER "z" # elif defined(_WIN64) # define TCL_Z_MODIFIER TCL_LL_MODIFIER # else # define TCL_Z_MODIFIER "" # endif #endif /* !TCL_Z_MODIFIER */ #define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val))) #define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val))) #define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) #define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) #if TCL_MAJOR_VERSION < 9 | > > > > > > > > > > | > > | > > | | 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 |
# define TCL_Z_MODIFIER "z"
# elif defined(_WIN64)
# define TCL_Z_MODIFIER TCL_LL_MODIFIER
# else
# define TCL_Z_MODIFIER ""
# endif
#endif /* !TCL_Z_MODIFIER */
#ifndef TCL_T_MODIFIER
# if defined(__GNUC__) && !defined(_WIN32)
# define TCL_T_MODIFIER "t"
# elif defined(_WIN64)
# define TCL_T_MODIFIER TCL_LL_MODIFIER
# else
# define TCL_T_MODIFIER TCL_Z_MODIFIER
# endif
#endif /* !TCL_T_MODIFIER */
#define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val)))
#define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val)))
#define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val)))
#define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val)))
#if TCL_MAJOR_VERSION < 9
typedef int Tcl_Size;
# define TCL_SIZE_MODIFIER ""
# define TCL_SIZE_MAX INT_MAX
#else
typedef size_t Tcl_Size;
# define TCL_SIZE_MAX PTRDIFF_MAX
# define TCL_SIZE_MODIFIER TCL_T_MODIFIER
#endif /* TCL_MAJOR_VERSION */
#ifdef _WIN32
# if TCL_MAJOR_VERSION > 8 || defined(_WIN64) || defined(_USE_64BIT_TIME_T)
typedef struct __stat64 Tcl_StatBuf;
# elif defined(_USE_32BIT_TIME_T)
typedef struct _stati64 Tcl_StatBuf;
# else
|
| ︙ | ︙ | |||
411 412 413 414 415 416 417 | /* * Structures filled in by Tcl_RegExpInfo. Note that all offset values are * relative to the start of the match string, not the beginning of the entire * string. */ | < > > > > > > < < < < < < < < < < < < | < < > | 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 |
/*
* Structures filled in by Tcl_RegExpInfo. Note that all offset values are
* relative to the start of the match string, not the beginning of the entire
* string.
*/
typedef struct Tcl_RegExpIndices {
#if TCL_MAJOR_VERSION > 8
Tcl_Size start; /* Character offset of first character in
* match. */
Tcl_Size end; /* Character offset of first character after
* the match. */
#else
long start;
long end;
#endif
} Tcl_RegExpIndices;
typedef struct Tcl_RegExpInfo {
Tcl_Size nsubs; /* Number of subexpressions in the compiled
* expression. */
Tcl_RegExpIndices *matches; /* Array of nsubs match offset pairs. */
#if TCL_MAJOR_VERSION > 8
Tcl_Size extendStart; /* The offset at which a subsequent match
* might begin. */
#else
long extendStart;
long reserved; /* Reserved for later use. */
#endif
} Tcl_RegExpInfo;
/*
* Picky compilers complain if this typdef doesn't appear before the struct's
* reference in tclDecls.h.
*/
typedef Tcl_StatBuf *Tcl_Stat_;
|
| ︙ | ︙ | |||
1735 1736 1737 1738 1739 1740 1741 | * is described by a TCL_TOKEN_SUB_EXPR token * followed by the TCL_TOKEN_OPERATOR token for * the operator, then TCL_TOKEN_SUB_EXPR tokens * for the left then the right operands. * TCL_TOKEN_OPERATOR - The token describes one expression operator. * An operator might be the name of a math * function such as "abs". A TCL_TOKEN_OPERATOR | | | 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 |
* is described by a TCL_TOKEN_SUB_EXPR token
* followed by the TCL_TOKEN_OPERATOR token for
* the operator, then TCL_TOKEN_SUB_EXPR tokens
* for the left then the right operands.
* TCL_TOKEN_OPERATOR - The token describes one expression operator.
* An operator might be the name of a math
* function such as "abs". A TCL_TOKEN_OPERATOR
* token is always preceded by one
* TCL_TOKEN_SUB_EXPR token for the operator's
* subexpression, and is followed by zero or more
* TCL_TOKEN_SUB_EXPR tokens for the operator's
* operands. NumComponents is always 0.
* TCL_TOKEN_EXPAND_WORD - This token is just like TCL_TOKEN_WORD except
* that it marks a word that began with the
* literal character prefix "{*}". This word is
|
| ︙ | ︙ | |||
1975 1976 1977 1978 1979 1980 1981 | * (or perhaps 1 if we want to support a non-unicode enabled core). If > 3, * then Tcl_UniChar must be 4-bytes in size (UCS-4) (the default). If == 3, * then Tcl_UniChar must be 2-bytes in size (UTF-16). Since Tcl 9.0, UCS-4 * mode is the default and recommended mode. */ #ifndef TCL_UTF_MAX | | | | | | | 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 | * (or perhaps 1 if we want to support a non-unicode enabled core). If > 3, * then Tcl_UniChar must be 4-bytes in size (UCS-4) (the default). If == 3, * then Tcl_UniChar must be 2-bytes in size (UTF-16). Since Tcl 9.0, UCS-4 * mode is the default and recommended mode. */ #ifndef TCL_UTF_MAX # if TCL_MAJOR_VERSION > 8 # define TCL_UTF_MAX 4 # else # define TCL_UTF_MAX 3 # endif #endif /* * This represents a Unicode character. Any changes to this should also be * reflected in regcustom.h. */ |
| ︙ | ︙ |
Changes to generic/tclAlloc.c.
| ︙ | ︙ | |||
112 113 114 115 116 117 118 |
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
| | | 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.
*/
#if TCL_THREADS
static Tcl_Mutex *allocMutexPtr;
#endif
|
| ︙ | ︙ | |||
506 507 508 509 510 511 512 | * None. * *---------------------------------------------------------------------- */ void * TclpRealloc( | | | 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 |
* None.
*
*----------------------------------------------------------------------
*/
void *
TclpRealloc(
void *oldPtr, /* Pointer to alloc'ed block. */
size_t numBytes) /* New size of memory. */
{
int i;
union overhead *overPtr;
struct block *bigBlockPtr;
int expensive;
size_t maxSize;
|
| ︙ | ︙ | |||
605 606 607 608 609 610 611 |
}
memcpy(newPtr, oldPtr, numBytes);
TclpFree(oldPtr);
return newPtr;
}
/*
| | | 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 |
}
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.
| ︙ | ︙ | |||
1027 1028 1029 1030 1031 1032 1033 |
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
| | | 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 |
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.
*/
|
| ︙ | ︙ | |||
2205 2206 2207 2208 2209 2210 2211 |
"hidden command named \"%s\" already exists",
hiddenCmdToken));
Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", NULL);
return TCL_ERROR;
}
/*
| | | | | 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 |
"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++;
}
|
| ︙ | ︙ | |||
2334 2335 2336 2337 2338 2339 2340 |
* 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) {
/*
| | | 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 |
* 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;
|
| ︙ | ︙ | |||
2440 2441 2442 2443 2444 2445 2446 | * 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 | | | 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 | * 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 |
| ︙ | ︙ | |||
3927 3928 3929 3930 3931 3932 3933 | * 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: | | | 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 |
* 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(
void *clientData, /* Interp to cancel the script in progress. */
|
| ︙ | ︙ | |||
4850 4851 4852 4853 4854 4855 4856 |
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
| | | 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 |
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.
*/
TclListObjGetElementsM(NULL, currNsPtr->unknownHandlerPtr,
&handlerObjc, &handlerObjv);
newObjc = objc + handlerObjc;
newObjv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc);
|
| ︙ | ︙ | |||
5145 5146 5147 5148 5149 5150 5151 |
* TCL_EVAL_GLOBAL is currently supported. */
size_t 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
| | | 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 |
* TCL_EVAL_GLOBAL is currently supported. */
size_t 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
|
| ︙ | ︙ | |||
5711 5712 5713 5714 5715 5716 5717 |
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
| | | | 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 |
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);
|
| ︙ | ︙ |
Changes to generic/tclBinary.c.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | * special conditions in the parsing of a format specifier. */ #define BINARY_ALL ((size_t)-1) /* Use all elements in the argument. */ #define BINARY_NOCOUNT ((size_t)-2) /* No count was specified in format. */ /* | | | | 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 | * special conditions in the parsing of a format specifier. */ #define BINARY_ALL ((size_t)-1) /* Use all elements in the argument. */ #define BINARY_NOCOUNT ((size_t)-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 |
| ︙ | ︙ | |||
374 375 376 377 378 379 380 381 382 383 384 385 386 387 |
if (numBytesPtr != NULL) {
*numBytesPtr = baPtr->used;
}
return baPtr->bytes;
}
unsigned char *
TclGetBytesFromObj(
Tcl_Interp *interp, /* For error reporting */
Tcl_Obj *objPtr, /* Value to extract from */
int *numBytesPtr) /* If non-NULL, write the number of bytes
* in the array here */
{
| > | 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 |
if (numBytesPtr != NULL) {
*numBytesPtr = baPtr->used;
}
return baPtr->bytes;
}
#if !defined(TCL_NO_DEPRECATED)
unsigned char *
TclGetBytesFromObj(
Tcl_Interp *interp, /* For error reporting */
Tcl_Obj *objPtr, /* Value to extract from */
int *numBytesPtr) /* If non-NULL, write the number of bytes
* in the array here */
{
|
| ︙ | ︙ | |||
401 402 403 404 405 406 407 408 409 410 411 412 413 414 |
return NULL;
} else {
*numBytesPtr = (int) numBytes;
}
}
return bytes;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetByteArrayLength --
*
* This procedure changes the length of the byte array for this object.
| > | 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 |
return NULL;
} else {
*numBytesPtr = (int) numBytes;
}
}
return bytes;
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_SetByteArrayLength --
*
* This procedure changes the length of the byte array for this object.
|
| ︙ | ︙ | |||
1043 1044 1045 1046 1047 1048 1049 |
length = offset;
}
if (length == 0) {
return TCL_OK;
}
/*
| | | 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 |
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);
|
| ︙ | ︙ | |||
1804 1805 1806 1807 1808 1809 1810 | /* *---------------------------------------------------------------------- * * 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. | | | 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 | /* *---------------------------------------------------------------------- * * 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/tclCmdIL.c.
| ︙ | ︙ | |||
61 62 63 64 65 66 67 |
*/
typedef struct {
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
| | | 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 |
*/
typedef struct {
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
|
| ︙ | ︙ | |||
4890 4891 4892 4893 4894 4895 4896 |
if (indices || group) {
elementArray[i].payload.index = idx;
} else {
elementArray[i].payload.objPtr = listObjPtrs[idx];
}
/*
| | | 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 |
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);
|
| ︙ | ︙ | |||
5208 5209 5210 5211 5212 5213 5214 | * * SortCompare -- * * This procedure is invoked by MergeLists to determine the proper * ordering between two elements. * * Results: | | | 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 | * * 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. * |
| ︙ | ︙ | |||
5410 5411 5412 5413 5414 5415 5416 |
if ((*left != '\0') && (*right != '\0')) {
left += TclUtfToUCS4(left, &uniLeft);
right += TclUtfToUCS4(right, &uniRight);
/*
* Convert both chars to lower for the comparison, because
| | | 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 |
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 = Tcl_UniCharToLower(uniLeft);
uniRightLower = Tcl_UniCharToLower(uniRight);
} else {
|
| ︙ | ︙ |
Changes to generic/tclCmdMZ.c.
| ︙ | ︙ | |||
423 424 425 426 427 428 429 |
/*
* 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
| | | 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;
|
| ︙ | ︙ | |||
1235 1236 1237 1238 1239 1240 1241 |
Tcl_DeleteHashTable(&charReuseTable);
} else if (splitCharLen == 1) {
const char *p;
/*
* Handle the special case of splitting on a single character. This is
| | | 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 |
Tcl_DeleteHashTable(&charReuseTable);
} else if (splitCharLen == 1) {
const 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,*splitChars)) != NULL) {
objPtr = Tcl_NewStringObj(stringPtr, p - stringPtr);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
stringPtr = p + 1;
|
| ︙ | ︙ | |||
1585 1586 1587 1588 1589 1590 1591 |
}
}
}
/*
* 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,
| | | 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 |
}
}
}
/*
* 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.
|
| ︙ | ︙ | |||
2125 2126 2127 2128 2129 2130 2131 |
}
} else {
Tcl_UniChar **mapStrings;
size_t *mapLens;
int *u2lc = 0;
/*
| | | 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 |
}
} else {
Tcl_UniChar **mapStrings;
size_t *mapLens;
int *u2lc = 0;
/*
* 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 = (Tcl_UniChar **)TclStackAlloc(interp, mapElemc*sizeof(Tcl_UniChar *)*2);
mapLens = (size_t *)TclStackAlloc(interp, mapElemc * sizeof(size_t) * 2);
|
| ︙ | ︙ | |||
2174 2175 2176 2177 2178 2179 2180 | /* * Adjust len to be full length of matched string. */ ustring1 = p - 1; /* | | | 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 | /* * 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.
| ︙ | ︙ | |||
226 227 228 229 230 231 232 | } /* *---------------------------------------------------------------------- * * TclCompileArray*Cmd -- * | | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 | } /* *---------------------------------------------------------------------- * * 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 |
| ︙ | ︙ | |||
631 632 633 634 635 636 637 |
* 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
| | | 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 |
* 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);
|
| ︙ | ︙ | |||
979 980 981 982 983 984 985 | } /* *---------------------------------------------------------------------- * * TclCompileDict*Cmd -- * | | | 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 | } /* *---------------------------------------------------------------------- * * 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 |
| ︙ | ︙ | |||
1686 1687 1688 1689 1690 1691 1692 |
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
| | | 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 |
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);
|
| ︙ | ︙ | |||
1858 1859 1860 1861 1862 1863 1864 |
*/
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,
| | | 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 |
*/
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);
|
| ︙ | ︙ | |||
1904 1905 1906 1907 1908 1909 1910 |
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i, dictVarIndex;
/*
* There must be at least two argument after the command. And we impose an
| | | 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 |
{
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 ((int)parsePtr->numWords<4 || (int)parsePtr->numWords>100) {
return TCL_ERROR;
}
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsGR.c.
| ︙ | ︙ | |||
412 413 414 415 416 417 418 |
*/
for (j = jumpEndFixupArray.next; j > 0; j--) {
jumpIndex = (j - 1); /* i.e. process the closest jump first. */
if (TclFixupForwardJumpToHere(envPtr,
jumpEndFixupArray.fixup + jumpIndex, 127)) {
/*
| | | 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 |
*/
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 |
if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) {
goto notCompilable;
}
Tcl_DecrRefCount(objPtr);
/*
| | | | 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);
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsSZ.c.
| ︙ | ︙ | |||
2378 2379 2380 2381 2382 2383 2384 |
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
| | | 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 |
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 = (JumptableInfo *)Tcl_Alloc(sizeof(JumptableInfo));
Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
|
| ︙ | ︙ |
Changes to generic/tclCompExpr.c.
| ︙ | ︙ | |||
92 93 94 95 96 97 98 | * * 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 | | | 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 | /* 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. */ | | | 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. */ #define COMMENT 6 /* Comment. Lasts to end of line or end of |
| ︙ | ︙ | |||
572 573 574 575 576 577 578 |
* 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
| | | 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 |
* 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. */
size_t scanned = 0; /* Capture number of byte scanned by parsing
* routines. */
int lastParsed; /* Stores info about what the lexeme parsed
|
| ︙ | ︙ | |||
1908 1909 1910 1911 1912 1913 1914 | * 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: | | | 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 |
* 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 size_t
ParseLexeme(
const char *start, /* Start of lexeme to parse. */
|
| ︙ | ︙ |
Changes to generic/tclCompile.c.
| ︙ | ︙ | |||
2033 2034 2035 2036 2037 2038 2039 |
int *clNext = envPtr->clNext;
int cmdIdx = envPtr->numCommands;
int startCodeOffset = envPtr->codeNext - envPtr->codeStart;
int depth = TclGetStackDepth(envPtr);
assert ((int)parsePtr->numWords > 0);
| | | 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 |
int *clNext = envPtr->clNext;
int cmdIdx = envPtr->numCommands;
int startCodeOffset = envPtr->codeNext - envPtr->codeStart;
int depth = TclGetStackDepth(envPtr);
assert ((int)parsePtr->numWords > 0);
/* Precompile */
TclNewObj(cmdObj);
envPtr->numCommands++;
EnterCmdStartData(envPtr, cmdIdx,
parsePtr->commandStart - envPtr->source, startCodeOffset);
/*
|
| ︙ | ︙ | |||
2405 2406 2407 2408 2409 2410 2411 |
#define NUM_STATIC_POS 20
int isLiteral, maxNumCL, numCL;
int *clPosition = NULL;
int depth = TclGetStackDepth(envPtr);
int count = count1;
/*
| | | | 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 |
#define NUM_STATIC_POS 20
int isLiteral, maxNumCL, numCL;
int *clPosition = NULL;
int depth = TclGetStackDepth(envPtr);
int count = count1;
/*
* If this is actually a literal, handle continuation lines by
* preallocating a small table to store the locations of any continuation
* lines found in this literal. The table is extended if needed.
*
* Note: In contrast with the analagous code in 'TclSubstTokens()' the
* 'adjust' variable seems unneeded here. The code which merges
* continuation line information of multiple words which concat'd at
* runtime also seems unneeded. 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.
|
| ︙ | ︙ |
Changes to generic/tclCompile.h.
| ︙ | ︙ | |||
440 441 442 443 444 445 446 |
* code when new namespace resolution rules
* are put into effect. */
Tcl_Size 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.
| | | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 |
* code when new namespace resolution rules
* are put into effect. */
Tcl_Size 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.
| ︙ | ︙ | |||
177 178 179 180 181 182 183 | * * QueryConfigObjCmd -- * * Implementation of "::<package>::pkgconfig", the command to query * configuration information embedded into a library. * * Results: | | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 | * * QueryConfigObjCmd -- * * Implementation of "::<package>::pkgconfig", the command to query * configuration information embedded into a library. * * Results: * A standard Tcl result. * * Side effects: * See the manual for what this command does. * *---------------------------------------------------------------------- */ |
| ︙ | ︙ |
Changes to generic/tclDate.c.
| ︙ | ︙ | |||
2421 2422 2423 2424 2425 2426 2427 |
{ "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
| | | 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 |
{ "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/tclDecls.h.
| ︙ | ︙ | |||
1845 1846 1847 1848 1849 1850 1851 | TCLAPI Tcl_Size Tcl_GetEncodingNulLength(Tcl_Encoding encoding); /* 684 */ TCLAPI int Tcl_GetWideUIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 685 */ TCLAPI Tcl_Obj * Tcl_DStringToObj(Tcl_DString *dsPtr); /* Slot 686 is reserved */ | > | | 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 |
TCLAPI Tcl_Size Tcl_GetEncodingNulLength(Tcl_Encoding encoding);
/* 684 */
TCLAPI int Tcl_GetWideUIntFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr);
/* 685 */
TCLAPI Tcl_Obj * Tcl_DStringToObj(Tcl_DString *dsPtr);
/* Slot 686 is reserved */
/* Slot 687 is reserved */
/* 688 */
TCLAPI void TclUnusedStubEntry(void);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
const struct TclIntStubs *tclIntStubs;
const struct TclIntPlatStubs *tclIntPlatStubs;
const struct TclOOStubs *tclOOStubs;
|
| ︙ | ︙ | |||
2547 2548 2549 2550 2551 2552 2553 |
int (*tcl_GetNumberFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void **clientDataPtr, int *typePtr); /* 680 */
int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, size_t numBytes, void **clientDataPtr, int *typePtr); /* 681 */
int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */
Tcl_Size (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */
int (*tcl_GetWideUIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 684 */
Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 685 */
void (*reserved686)(void);
| > | | 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 |
int (*tcl_GetNumberFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void **clientDataPtr, int *typePtr); /* 680 */
int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, size_t numBytes, void **clientDataPtr, int *typePtr); /* 681 */
int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */
Tcl_Size (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */
int (*tcl_GetWideUIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 684 */
Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 685 */
void (*reserved686)(void);
void (*reserved687)(void);
void (*tclUnusedStubEntry) (void); /* 688 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ | |||
3872 3873 3874 3875 3876 3877 3878 3879 | #define Tcl_GetEncodingNulLength \ (tclStubsPtr->tcl_GetEncodingNulLength) /* 683 */ #define Tcl_GetWideUIntFromObj \ (tclStubsPtr->tcl_GetWideUIntFromObj) /* 684 */ #define Tcl_DStringToObj \ (tclStubsPtr->tcl_DStringToObj) /* 685 */ /* Slot 686 is reserved */ #define TclUnusedStubEntry \ | > | | 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 | #define Tcl_GetEncodingNulLength \ (tclStubsPtr->tcl_GetEncodingNulLength) /* 683 */ #define Tcl_GetWideUIntFromObj \ (tclStubsPtr->tcl_GetWideUIntFromObj) /* 684 */ #define Tcl_DStringToObj \ (tclStubsPtr->tcl_DStringToObj) /* 685 */ /* Slot 686 is reserved */ /* Slot 687 is reserved */ #define TclUnusedStubEntry \ (tclStubsPtr->tclUnusedStubEntry) /* 688 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #undef TclUnusedStubEntry |
| ︙ | ︙ | |||
4004 4005 4006 4007 4008 4009 4010 | #undef Tcl_GetString #undef Tcl_GetUnicode #define Tcl_GetString(objPtr) \ Tcl_GetStringFromObj(objPtr, (Tcl_Size *)NULL) #define Tcl_GetUnicode(objPtr) \ Tcl_GetUnicodeFromObj(objPtr, (Tcl_Size *)NULL) | > | > > > < < > | | | | > > > > > > > > > < < < < < < < < | 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 | #undef Tcl_GetString #undef Tcl_GetUnicode #define Tcl_GetString(objPtr) \ Tcl_GetStringFromObj(objPtr, (Tcl_Size *)NULL) #define Tcl_GetUnicode(objPtr) \ Tcl_GetUnicodeFromObj(objPtr, (Tcl_Size *)NULL) #if TCL_MAJOR_VERSION < 9 || !defined(TCL_NO_DEPRECATED) # undef Tcl_GetBytesFromObj # undef Tcl_GetStringFromObj # undef Tcl_GetUnicodeFromObj #endif #undef Tcl_GetIndexFromObjStruct #undef Tcl_GetBooleanFromObj #undef Tcl_GetBoolean #undef TclGetByteArrayFromObj #undef Tcl_GetByteArrayFromObj #if defined(USE_TCL_STUBS) # if TCL_MAJOR_VERSION < 9 || !defined(TCL_NO_DEPRECATED) # define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(void *)(sizePtr))) # define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)(void *)(sizePtr))) # define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetUnicodeFromObj(objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (size_t *)(void *)(sizePtr))) # endif #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), \ (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ ((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \ Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr))) #define Tcl_GetBoolean(interp, src, boolPtr) \ ((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? tclStubsPtr->tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \ Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr))) #if TCL_MAJOR_VERSION > 8 #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (size_t *)(void *)(sizePtr))) #else #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetByteArrayFromObj(objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (size_t *)(void *)(sizePtr))) #endif #else #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? \ TclGetBytesFromObj(interp, objPtr, (int *)(void *)(sizePtr)) : \ (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), \ |
| ︙ | ︙ | |||
4183 4184 4185 4186 4187 4188 4189 | : (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToChar16DString) # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ ? (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToUniChar \ : (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToChar16) # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ ? (Tcl_Size (*)(wchar_t *))Tcl_UniCharLen \ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len) | | | 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 | : (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToChar16DString) # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ ? (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToUniChar \ : (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToChar16) # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ ? (Tcl_Size (*)(wchar_t *))Tcl_UniCharLen \ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len) #if !defined(BUILD_tcl) && !defined(TCL_NO_DEPRECATED) # define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(int) \ ? TclListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr)) \ : (Tcl_ListObjGetElements)((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr))) # define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) == sizeof(int) \ ? TclListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr)) \ : (Tcl_ListObjLength)((interp), (listPtr), (size_t *)(void *)(lengthPtr))) # define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) == sizeof(int) \ |
| ︙ | ︙ |
Changes to generic/tclDictObj.c.
| ︙ | ︙ | |||
765 766 767 768 769 770 771 | * 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), | | | 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 | * 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( |
| ︙ | ︙ | |||
858 859 860 861 862 863 864 | } /* *---------------------------------------------------------------------- * * InvalidateDictChain -- * | | | 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 | } /* *---------------------------------------------------------------------- * * 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: |
| ︙ | ︙ | |||
1184 1185 1186 1187 1188 1189 1190 |
* written into when there are no further
* values in the dictionary, or a 0
* otherwise. */
{
ChainEntry *cPtr;
/*
| | | 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 |
* 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) {
*donePtr = 1;
return;
}
|
| ︙ | ︙ | |||
3670 3671 3672 3673 3674 3675 3676 |
} else {
allocdict = 0;
}
if (pathc > 0) {
/*
* Want to get to the dictionary which we will update; need to do
| | | | | 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 |
} 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.
| ︙ | ︙ | |||
606 607 608 609 610 611 612 |
type.encodingName = "utf-8";
type.toUtfProc = UtfToUtfProc;
type.fromUtfProc = UtfToUtfProc;
type.freeProc = NULL;
type.nullSize = 1;
type.clientData = INT2PTR(ENCODING_UTF);
Tcl_CreateEncoding(&type);
| | | | | | | | 606 607 608 609 610 611 612 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 657 658 659 660 661 662 663 |
type.encodingName = "utf-8";
type.toUtfProc = UtfToUtfProc;
type.fromUtfProc = UtfToUtfProc;
type.freeProc = NULL;
type.nullSize = 1;
type.clientData = INT2PTR(ENCODING_UTF);
Tcl_CreateEncoding(&type);
type.clientData = NULL;
type.encodingName = "cesu-8";
Tcl_CreateEncoding(&type);
type.toUtfProc = Utf16ToUtfProc;
type.fromUtfProc = UtfToUcs2Proc;
type.freeProc = NULL;
type.nullSize = 2;
type.encodingName = "ucs-2le";
type.clientData = INT2PTR(TCL_ENCODING_LE);
Tcl_CreateEncoding(&type);
type.encodingName = "ucs-2be";
type.clientData = NULL;
Tcl_CreateEncoding(&type);
type.encodingName = "ucs-2";
type.clientData = INT2PTR(leFlags);
Tcl_CreateEncoding(&type);
type.toUtfProc = Utf32ToUtfProc;
type.fromUtfProc = UtfToUtf32Proc;
type.freeProc = NULL;
type.nullSize = 4;
type.encodingName = "utf-32le";
type.clientData = INT2PTR(TCL_ENCODING_LE);
Tcl_CreateEncoding(&type);
type.encodingName = "utf-32be";
type.clientData = NULL;
Tcl_CreateEncoding(&type);
type.encodingName = "utf-32";
type.clientData = INT2PTR(leFlags);
Tcl_CreateEncoding(&type);
type.toUtfProc = Utf16ToUtfProc;
type.fromUtfProc = UtfToUtf16Proc;
type.freeProc = NULL;
type.nullSize = 2;
type.encodingName = "utf-16le";
type.clientData = INT2PTR(TCL_ENCODING_LE);
Tcl_CreateEncoding(&type);
type.encodingName = "utf-16be";
type.clientData = NULL;
Tcl_CreateEncoding(&type);
type.encodingName = "utf-16";
type.clientData = INT2PTR(leFlags);
Tcl_CreateEncoding(&type);
#ifndef TCL_NO_DEPRECATED
type.encodingName = "unicode";
Tcl_CreateEncoding(&type);
#endif
|
| ︙ | ︙ | |||
3475 3476 3477 3478 3479 3480 3481 |
ch = UNICODE_REPLACE_CHAR;
} else {
ch = (Tcl_UniChar)byte;
}
}
/*
| | | 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 |
ch = UNICODE_REPLACE_CHAR;
} else {
ch = (Tcl_UniChar)byte;
}
}
/*
* Special case for 1-byte Utf chars for speed.
*/
if ((unsigned)ch - 1 < 0x7F) {
*dst++ = (char) ch;
} else {
dst += Tcl_UniCharToUtf(ch, dst);
}
|
| ︙ | ︙ |
Changes to generic/tclEnsemble.c.
| ︙ | ︙ | |||
1888 1889 1890 1891 1892 1893 1894 |
* not be the same length as the number of arguments to this ensemble
* command, and then handing it to the main command-lookup engine. In
* theory, the command could be looked up right here using the namespace in
* which it is guaranteed to exist,
*
* ((Q: That's not true if the -map option is used, is it?))
*
| | | 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 |
* not be the same length as the number of arguments to this ensemble
* command, and then handing it to the main command-lookup engine. In
* theory, the command could be looked up right here using the namespace in
* which it is guaranteed to exist,
*
* ((Q: That's not true if the -map option is used, is it?))
*
* but don't do that because caching of the command object should help.
*/
{
Tcl_Obj *copyPtr; /* The list of words to dispatch on.
* Will be freed by the dispatch engine. */
Tcl_Obj **copyObjv;
size_t copyObjc, prefixObjc;
|
| ︙ | ︙ |
Changes to generic/tclEnv.c.
| ︙ | ︙ | |||
398 399 400 401 402 403 404 |
char *value;
if (assignment == NULL) {
return 0;
}
/*
| | | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 |
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, TCL_INDEX_NONE, &nameString);
value = (char *)strchr(name, '=');
if ((value != NULL) && (value != name)) {
|
| ︙ | ︙ |
Changes to generic/tclEvent.c.
| ︙ | ︙ | |||
585 586 587 588 589 590 591 | /* *---------------------------------------------------------------------- * * BgErrorDeleteProc -- * * This function is associated with the "tclBgError" assoc data for an * interpreter; it is invoked when the interpreter is deleted in order to | | | 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 | /* *---------------------------------------------------------------------- * * 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. |
| ︙ | ︙ | |||
1118 1119 1120 1121 1122 1123 1124 |
{
if (inExit != 0) {
Tcl_Panic("Tcl_InitSubsystems called while exiting");
}
if (subsystemsInitialized == 0) {
/*
| | | 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 |
{
if (inExit != 0) {
Tcl_Panic("Tcl_InitSubsystems 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.
| ︙ | ︙ | |||
1630 1631 1632 1633 1634 1635 1636 | * 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 | | | 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 | * 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 |
| ︙ | ︙ | |||
1728 1729 1730 1731 1732 1733 1734 | } /* *---------------------------------------------------------------------- * * TclIncrObj -- * | | | 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 | } /* *---------------------------------------------------------------------- * * 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). |
| ︙ | ︙ | |||
3459 3460 3461 3462 3463 3464 3465 |
/*
* End of INST_STORE and related instructions.
* -----------------------------------------------------------------
* Start of INST_INCR instructions.
*
* WARNING: more 'goto' here than your doctor recommended! The different
| | | 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 |
/*
* 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;
|
| ︙ | ︙ | |||
5252 5253 5254 5255 5256 5257 5258 |
case INST_STR_INDEX:
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
TRACE(("\"%.20s\" %.20s => ", O2S(valuePtr), O2S(value2Ptr)));
/*
| | | 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 |
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.
*/
slength = Tcl_GetCharLength(valuePtr);
DECACHE_STACK_INFO();
if (TclGetIntForIndexM(interp, value2Ptr, slength-1, &index)!=TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
|
| ︙ | ︙ | |||
7058 7059 7060 7061 7062 7063 7064 |
PUSH_OBJECT(valuePtr);
PUSH_OBJECT(keyPtr);
}
TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done));
/*
| | | 7058 7059 7060 7061 7062 7063 7064 7065 7066 7067 7068 7069 7070 7071 7072 |
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.
| ︙ | ︙ | |||
1208 1209 1210 1211 1212 1213 1214 |
* 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
| | | 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 |
* 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);
|
| ︙ | ︙ | |||
1529 1530 1531 1532 1533 1534 1535 |
if (objc < 1 || objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?template?");
return TCL_ERROR;
}
if (objc > 1) {
| | | 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 |
if (objc < 1 || objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?template?");
return TCL_ERROR;
}
if (objc > 1) {
Tcl_Size length;
Tcl_Obj *templateObj = objv[1];
const char *string = Tcl_GetStringFromObj(templateObj, &length);
const int onWindows = (tclPlatform == TCL_PLATFORM_WINDOWS);
/*
* Treat an empty string as if it wasn't there.
*/
|
| ︙ | ︙ |
Changes to generic/tclFileName.c.
| ︙ | ︙ | |||
92 93 94 95 96 97 98 | * * 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 | | | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 | * * 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. * *---------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
1718 1719 1720 1721 1722 1723 1724 |
}
}
/*
* 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
| | | 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 |
}
}
/*
* 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.
| ︙ | ︙ | |||
965 966 967 968 969 970 971 | * an interpreter is deleted, via the AssocData cleanup mechanism. * * Results: * None. * * Side effects: * Deletes the hash table of channels. May close channels. May flush | | | 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 | * 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( |
| ︙ | ︙ | |||
998 999 1000 1001 1002 1003 1004 |
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;
/*
| | | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 |
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) {
|
| ︙ | ︙ | |||
1417 1418 1419 1420 1421 1422 1423 |
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
| | | 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 |
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. */
|
| ︙ | ︙ | |||
1500 1501 1502 1503 1504 1505 1506 |
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
| | | 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 |
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. */
TCL_UNUSED(int) /*flags*/)
{
ChannelState *statePtr;
ResolvedChanName *resPtr = NULL;
Tcl_Channel chan;
|
| ︙ | ︙ | |||
1671 1672 1673 1674 1675 1676 1677 |
* Note the strange bit of protection taking place here. If the system
* encoding name is reported back as "binary", something weird is
* happening. Tcl provides no "binary" encoding, so someone else has
* provided one. We ignore it so as not to interfere with the "magic"
* interpretation that Tcl_Channels give to the "-encoding binary" option.
*/
| < < | < | 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 |
* Note the strange bit of protection taking place here. If the system
* encoding name is reported back as "binary", something weird is
* happening. Tcl provides no "binary" encoding, so someone else has
* provided one. We ignore it so as not to interfere with the "magic"
* interpretation that Tcl_Channels give to the "-encoding binary" option.
*/
name = Tcl_GetEncodingName(NULL);
statePtr->encoding = Tcl_GetEncoding(NULL, name);
statePtr->inputEncodingState = NULL;
statePtr->inputEncodingFlags = TCL_ENCODING_START;
CHANNEL_PROFILE_SET(statePtr->inputEncodingFlags,
TCL_ENCODING_PROFILE_DEFAULT);
statePtr->outputEncodingState = NULL;
statePtr->outputEncodingFlags = TCL_ENCODING_START;
CHANNEL_PROFILE_SET(statePtr->outputEncodingFlags,
|
| ︙ | ︙ | |||
1912 1913 1914 1915 1916 1917 1918 |
* 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
| | | 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 |
* 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.
|
| ︙ | ︙ | |||
2021 2022 2023 2024 2025 2026 2027 | * 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: | | | 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 | * 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( |
| ︙ | ︙ | |||
2044 2045 2046 2047 2048 2049 2050 |
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
if (chanPtr->downChanPtr != NULL) {
/*
| | | 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 |
* 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
|
| ︙ | ︙ | |||
2588 2589 2590 2591 2592 2593 2594 |
if (mustDiscard) {
ReleaseChannelBuffer(bufPtr);
return;
}
/*
| | | | 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 |
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) != statePtr->bufSize + BUFFER_PADDING) {
ReleaseChannelBuffer(bufPtr);
return;
}
|
| ︙ | ︙ | |||
2749 2750 2751 2752 2753 2754 2755 |
int wroteSome = 0; /* Set to one if any data was written to the
* driver. */
int bufExists;
/*
* 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
| | | 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 |
int wroteSome = 0; /* Set to one if any data was written to the
* driver. */
int bufExists;
/*
* 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;
}
|
| ︙ | ︙ | |||
2864 2865 2866 2867 2868 2869 2870 |
/*
* Decide whether to report the error upwards or defer it.
*/
if (calledFromAsyncFlush) {
/*
* TIP #219, Tcl Channel Reflection API.
| | | | 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 |
/*
* 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;
|
| ︙ | ︙ | |||
3210 3211 3212 3213 3214 3215 3216 | * 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 | | | | 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 |
* 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
|
| ︙ | ︙ | |||
3325 3326 3327 3328 3329 3330 3331 | * * 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 | | | | | 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 |
*
* 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
|
| ︙ | ︙ | |||
3476 3477 3478 3479 3480 3481 3482 |
/*
* When the channel has an escape sequence driven encoding such as
* iso2022, the terminated escape sequence must write to the buffer.
*/
stickyError = 0;
| | > | 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 |
/*
* When the channel has an escape sequence driven encoding such as
* iso2022, the terminated escape sequence must write to the buffer.
*/
stickyError = 0;
if (GotFlag(statePtr, TCL_WRITABLE)
&& (statePtr->encoding != GetBinaryEncoding())
&& !(statePtr->outputEncodingFlags & TCL_ENCODING_START)) {
int code = CheckChannelErrors(statePtr, TCL_WRITABLE);
if (code == 0) {
statePtr->outputEncodingFlags |= TCL_ENCODING_END;
code = WriteChars(chanPtr, "", 0);
statePtr->outputEncodingFlags &= ~TCL_ENCODING_END;
|
| ︙ | ︙ | |||
3738 3739 3740 3741 3742 3743 3744 | * 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. | | | 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 | * 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. * *---------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
4180 4181 4182 4183 4184 4185 4186 |
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
| | | 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 |
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);
}
|
| ︙ | ︙ | |||
4265 4266 4267 4268 4269 4270 4271 |
/*
* Note original code always called WriteChars even if srcLen 0
* so we will too.
*/
do {
int chunkSize = srcLen > INT_MAX ? INT_MAX : srcLen;
int written;
| < < < | < | 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 |
/*
* Note original code always called WriteChars even if srcLen 0
* so we will too.
*/
do {
int chunkSize = srcLen > INT_MAX ? INT_MAX : srcLen;
int written;
written = WriteChars(chanPtr, src, chunkSize);
if (written < 0) {
return TCL_INDEX_NONE;
}
totalWritten += written;
srcLen -= chunkSize;
} while (srcLen);
return totalWritten;
|
| ︙ | ︙ | |||
4507 4508 4509 4510 4511 4512 4513 |
if (FlushChannel(NULL, chanPtr, 0) != 0) {
return -1;
}
flushed += statePtr->bufSize;
/*
* We just flushed. So if we have needNlFlush set to record that
| | | 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 |
if (FlushChannel(NULL, chanPtr, 0) != 0) {
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.
*/
|
| ︙ | ︙ | |||
4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 |
Tcl_Size oldLength;
Tcl_Encoding encoding;
char *dst, *dstEnd, *eol, *eof;
Tcl_EncodingState oldState;
if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
UpdateInterest(chanPtr);
Tcl_SetErrno(EILSEQ);
return TCL_INDEX_NONE;
}
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
return TCL_INDEX_NONE;
}
| > | 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 |
Tcl_Size oldLength;
Tcl_Encoding encoding;
char *dst, *dstEnd, *eol, *eof;
Tcl_EncodingState oldState;
if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
UpdateInterest(chanPtr);
ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR);
Tcl_SetErrno(EILSEQ);
return TCL_INDEX_NONE;
}
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
return TCL_INDEX_NONE;
}
|
| ︙ | ︙ | |||
4647 4648 4649 4650 4651 4652 4653 |
/*
* A binary version of Tcl_GetsObj. This could also handle encodings that
* are ascii-7 pure (iso8859, utf-8, ...) with a final encoding conversion
* done on objPtr.
*/
| | | 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 |
/*
* A binary version of Tcl_GetsObj. This could also handle encodings that
* are ascii-7 pure (iso8859, utf-8, ...) with a final encoding conversion
* done on objPtr.
*/
if (statePtr->encoding == GetBinaryEncoding()
&& ((statePtr->inputTranslation == TCL_TRANSLATE_LF)
|| (statePtr->inputTranslation == TCL_TRANSLATE_CR))
&& Tcl_GetByteArrayFromObj(objPtr, (size_t *)NULL) != NULL) {
return TclGetsObjBinary(chan, objPtr);
}
/*
|
| ︙ | ︙ | |||
4677 4678 4679 4680 4681 4682 4683 |
oldFlags = statePtr->inputEncodingFlags;
oldState = statePtr->inputEncodingState;
oldRemoved = BUFFER_PADDING;
if (bufPtr != NULL) {
oldRemoved = bufPtr->nextRemoved;
}
| < < < < < < < < < | 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 |
oldFlags = statePtr->inputEncodingFlags;
oldState = statePtr->inputEncodingState;
oldRemoved = BUFFER_PADDING;
if (bufPtr != NULL) {
oldRemoved = bufPtr->nextRemoved;
}
/*
* Object used by FilterInputBytes to keep track of how much data has been
* consumed from the channel buffers.
*/
gs.objPtr = objPtr;
gs.dstPtr = &dst;
|
| ︙ | ︙ | |||
4761 4762 4763 4764 4765 4766 4767 |
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
| | | 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 |
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) {
Tcl_Size offset;
if (eol != eof) {
|
| ︙ | ︙ | |||
4883 4884 4885 4886 4887 4888 4889 |
goto done;
}
goto gotEOL;
} else if (gs.bytesWrote == 0
&& GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
&& !GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
/* Set eol to the position that caused the encoding error, and then
| | | | 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 |
goto done;
}
goto gotEOL;
} else if (gs.bytesWrote == 0
&& GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
&& !GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
/* Set eol to the position that caused the encoding error, and then
* continue to gotEOL, which stores the data that was decoded
* without error to objPtr. This allows the caller to do something
* useful with the data decoded so far, and also results in the
* position of the file being the first byte that was not
* successfully decoded, allowing further processing at exactly that
* point, if desired.
*/
eol = dstEnd;
goto gotEOL;
}
dst = dstEnd;
}
|
| ︙ | ︙ | |||
5008 5009 5010 5011 5012 5013 5014 |
if (chanPtr != statePtr->topChanPtr) {
TclChannelRelease((Tcl_Channel)chanPtr);
chanPtr = statePtr->topChanPtr;
TclChannelPreserve((Tcl_Channel)chanPtr);
}
UpdateInterest(chanPtr);
TclChannelRelease((Tcl_Channel)chanPtr);
| | | > | 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 |
if (chanPtr != statePtr->topChanPtr) {
TclChannelRelease((Tcl_Channel)chanPtr);
chanPtr = statePtr->topChanPtr;
TclChannelPreserve((Tcl_Channel)chanPtr);
}
UpdateInterest(chanPtr);
TclChannelRelease((Tcl_Channel)chanPtr);
if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR) && gs.bytesWrote == 0) {
bufPtr->nextRemoved = oldRemoved;
Tcl_SetErrno(EILSEQ);
copiedTotal = -1;
}
ResetFlag(statePtr, CHANNEL_ENCODING_ERROR);
return copiedTotal;
}
/*
*---------------------------------------------------------------------------
*
* TclGetsObjBinary --
|
| ︙ | ︙ | |||
5232 5233 5234 5235 5236 5237 5238 |
bufPtr->nextRemoved += rawLen + skip;
/*
* Convert the buffer if there was an encoding.
* XXX - unimplemented.
*/
| | | 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 |
bufPtr->nextRemoved += rawLen + skip;
/*
* Convert the buffer if there was an encoding.
* XXX - unimplemented.
*/
if (statePtr->encoding != GetBinaryEncoding()) {
}
/*
* Recycle all the emptied buffers.
*/
CommonGetsCleanup(chanPtr);
|
| ︙ | ︙ | |||
5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 |
result = Tcl_ExternalToUtf(NULL, gsPtr->encoding, raw, rawLen,
statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE,
&statePtr->inputEncodingState, dst, spaceLeft, &gsPtr->rawRead,
&gsPtr->bytesWrote, &gsPtr->charsWrote);
if (result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) {
SetFlag(statePtr, CHANNEL_ENCODING_ERROR);
result = TCL_OK;
}
/*
* Make sure that if we go through 'gets', that we reset the
* TCL_ENCODING_START flag still. [Bug #523988]
*/
| > > | 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 |
result = Tcl_ExternalToUtf(NULL, gsPtr->encoding, raw, rawLen,
statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE,
&statePtr->inputEncodingState, dst, spaceLeft, &gsPtr->rawRead,
&gsPtr->bytesWrote, &gsPtr->charsWrote);
if (result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) {
SetFlag(statePtr, CHANNEL_ENCODING_ERROR);
ResetFlag(statePtr, CHANNEL_STICKY_EOF);
ResetFlag(statePtr, CHANNEL_EOF);
result = TCL_OK;
}
/*
* Make sure that if we go through 'gets', that we reset the
* TCL_ENCODING_START flag still. [Bug #523988]
*/
|
| ︙ | ︙ | |||
5801 5802 5803 5804 5805 5806 5807 |
}
RecycleBuffer(chanPtr->state, bufPtr, 0);
}
}
/*
* Go to the driver only if we got nothing from pushback. Have to do it
| | | 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 |
}
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;
}
|
| ︙ | ︙ | |||
5947 5948 5949 5950 5951 5952 5953 |
Tcl_Size copied;
int result;
Tcl_Encoding encoding = statePtr->encoding;
int binaryMode;
#define UTF_EXPANSION_FACTOR 1024
int factor = UTF_EXPANSION_FACTOR;
| < < < < < < < < < < < < < < < < < < < < < < < < < < > | 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 |
Tcl_Size copied;
int result;
Tcl_Encoding encoding = statePtr->encoding;
int binaryMode;
#define UTF_EXPANSION_FACTOR 1024
int factor = UTF_EXPANSION_FACTOR;
if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR);
/* TODO: We don't need this call? */
UpdateInterest(chanPtr);
Tcl_SetErrno(EILSEQ);
return -1;
}
/*
* Early out when next read will see eofchar.
|
| ︙ | ︙ | |||
6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 |
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
TclChannelPreserve((Tcl_Channel)chanPtr);
/*
* Must clear the BLOCKED|EOF flags here since we check before reading.
*/
if (GotFlag(statePtr, CHANNEL_EOF)) {
statePtr->inputEncodingFlags |= TCL_ENCODING_START;
| > > > > > > > > > > > > > > > > | 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 |
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
TclChannelPreserve((Tcl_Channel)chanPtr);
binaryMode = (encoding == GetBinaryEncoding())
&& (statePtr->inputTranslation == TCL_TRANSLATE_LF)
&& (statePtr->inEofChar == '\0');
if (appendFlag) {
if (binaryMode && (NULL == Tcl_GetByteArrayFromObj(objPtr, (size_t *)NULL))) {
binaryMode = 0;
}
} else {
if (binaryMode) {
Tcl_SetByteArrayLength(objPtr, 0);
} else {
Tcl_SetObjLength(objPtr, 0);
}
}
/*
* Must clear the BLOCKED|EOF flags here since we check before reading.
*/
if (GotFlag(statePtr, CHANNEL_EOF)) {
statePtr->inputEncodingFlags |= TCL_ENCODING_START;
|
| ︙ | ︙ | |||
6059 6060 6061 6062 6063 6064 6065 | * then CHANNEL_ENCODING_ERROR was caused by data that occurred * after the EOF character was encountered, so it doesn't count as * a real error. */ if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR) && !GotFlag(statePtr, CHANNEL_STICKY_EOF) | | < < < < | 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 |
* then CHANNEL_ENCODING_ERROR was caused by data that occurred
* after the EOF character was encountered, so it doesn't count as
* a real error.
*/
if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
&& !GotFlag(statePtr, CHANNEL_STICKY_EOF)
&& (!GotFlag(statePtr, CHANNEL_NONBLOCKING))) {
goto finish;
}
}
if (copiedNow < 0) {
if (GotFlag(statePtr, CHANNEL_EOF)) {
break;
|
| ︙ | ︙ | |||
6108 6109 6110 6111 6112 6113 6114 |
*/
if (toRead == 0) {
ResetFlag(statePtr, CHANNEL_BLOCKED);
}
/*
| | | 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 |
*/
if (toRead == 0) {
ResetFlag(statePtr, CHANNEL_BLOCKED);
}
/*
* Regenerate chanPtr in case it was changed due to
* self-modifying reflected transforms.
*/
if (chanPtr != statePtr->topChanPtr) {
TclChannelRelease((Tcl_Channel)chanPtr);
chanPtr = statePtr->topChanPtr;
TclChannelPreserve((Tcl_Channel)chanPtr);
|
| ︙ | ︙ | |||
6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 |
assert(!GotFlag(statePtr, CHANNEL_EOF)
|| GotFlag(statePtr, CHANNEL_STICKY_EOF)
|| GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
|| Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
== (CHANNEL_EOF|CHANNEL_BLOCKED)));
UpdateInterest(chanPtr);
if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
&& (!copied || !GotFlag(statePtr, CHANNEL_NONBLOCKING))) {
Tcl_SetErrno(EILSEQ);
copied = -1;
}
TclChannelRelease((Tcl_Channel)chanPtr);
return copied;
}
| > > > > > > > | 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 |
assert(!GotFlag(statePtr, CHANNEL_EOF)
|| GotFlag(statePtr, CHANNEL_STICKY_EOF)
|| GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
|| Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
== (CHANNEL_EOF|CHANNEL_BLOCKED)));
UpdateInterest(chanPtr);
/* This must comes after UpdateInterest(), which may set errno */
if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
&& (!copied || !GotFlag(statePtr, CHANNEL_NONBLOCKING))) {
/* Channel either is blocking or is nonblocking with no data
* succesfully red before the error. Return an error so that callers
* like [read] can also return an error.
*/
ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR);
Tcl_SetErrno(EILSEQ);
copied = -1;
}
TclChannelRelease((Tcl_Channel)chanPtr);
return copied;
}
|
| ︙ | ︙ | |||
6229 6230 6231 6232 6233 6234 6235 |
int charsToRead, /* Maximum number of characters to store, or
* TCL_INDEX_NONE 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
| | | < | 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 |
int charsToRead, /* Maximum number of characters to store, or
* TCL_INDEX_NONE 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
* UTF-8. On output, contains another guess
* based on the data seen so far. */
{
Tcl_Encoding encoding = statePtr->encoding;
Tcl_EncodingState savedState = statePtr->inputEncodingState;
ChannelBuffer *bufPtr = statePtr->inQueueHead;
int savedIEFlags = statePtr->inputEncodingFlags;
int savedFlags = statePtr->flags;
char *dst, *src = RemovePoint(bufPtr);
Tcl_Size numBytes;
int srcLen = BytesLeft(bufPtr);
|
| ︙ | ︙ | |||
6324 6325 6326 6327 6328 6329 6330 | assert(bufPtr->nextPtr == NULL || BytesLeft(bufPtr->nextPtr) == 0 || (statePtr->inputEncodingFlags & TCL_ENCODING_END) == 0); code = Tcl_ExternalToUtf(NULL, encoding, src, srcLen, flags, &statePtr->inputEncodingState, dst, dstLimit, &srcRead, &dstDecoded, &numChars); | | > > > > > | 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 |
assert(bufPtr->nextPtr == NULL || BytesLeft(bufPtr->nextPtr) == 0
|| (statePtr->inputEncodingFlags & TCL_ENCODING_END) == 0);
code = Tcl_ExternalToUtf(NULL, encoding, src, srcLen,
flags, &statePtr->inputEncodingState,
dst, dstLimit, &srcRead, &dstDecoded, &numChars);
if (code == TCL_CONVERT_UNKNOWN || code == TCL_CONVERT_SYNTAX
|| (
code == TCL_CONVERT_MULTIBYTE
&& GotFlag(statePtr, CHANNEL_EOF
))
) {
SetFlag(statePtr, CHANNEL_ENCODING_ERROR);
code = TCL_OK;
}
/*
* Perform the translation transformation in place. Read no more than
* the dstDecoded bytes the encoding transformation actually produced.
|
| ︙ | ︙ | |||
7412 7413 7414 7415 7416 7417 7418 |
Tcl_SetErrno(EINVAL);
return TCL_ERROR;
}
/*
* Seek first to force a total flush of all pending buffers and ditch any
| | | 7399 7400 7401 7402 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 |
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) == -1) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
7472 7473 7474 7475 7476 7477 7478 |
if (statePtr->unreportedError != 0) {
Tcl_SetErrno(statePtr->unreportedError);
statePtr->unreportedError = 0;
/*
* TIP #219, Tcl Channel Reflection API.
| | | 7459 7460 7461 7462 7463 7464 7465 7466 7467 7468 7469 7470 7471 7472 7473 |
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;
|
| ︙ | ︙ | |||
7610 7611 7612 7613 7614 7615 7616 |
for (bytesBuffered = 0, bufPtr = statePtr->inQueueHead; bufPtr != NULL;
bufPtr = bufPtr->nextPtr) {
bytesBuffered += BytesLeft(bufPtr);
}
/*
| | | 7597 7598 7599 7600 7601 7602 7603 7604 7605 7606 7607 7608 7609 7610 7611 |
for (bytesBuffered = 0, bufPtr = statePtr->inQueueHead; bufPtr != NULL;
bufPtr = bufPtr->nextPtr) {
bytesBuffered += BytesLeft(bufPtr);
}
/*
* Remember the bytes in the topmost pushback area.
*/
for (bufPtr = statePtr->topChanPtr->inQueueHead; bufPtr != NULL;
bufPtr = bufPtr->nextPtr) {
bytesBuffered += BytesLeft(bufPtr);
}
|
| ︙ | ︙ | |||
7800 7801 7802 7803 7804 7805 7806 | * * Results: * TCL_ERROR. * * Side effects: * An error message is generated in interp's result object to indicate | | | 7787 7788 7789 7790 7791 7792 7793 7794 7795 7796 7797 7798 7799 7800 7801 | * * 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. |
| ︙ | ︙ | |||
7967 7968 7969 7970 7971 7972 7973 |
return TCL_OK;
}
}
if (len == 0 || HaveOpt(2, "-encoding")) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-encoding");
}
| < < < | | < | 7954 7955 7956 7957 7958 7959 7960 7961 7962 7963 7964 7965 7966 7967 7968 7969 |
return TCL_OK;
}
}
if (len == 0 || HaveOpt(2, "-encoding")) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-encoding");
}
Tcl_DStringAppendElement(dsPtr,
Tcl_GetEncodingName(statePtr->encoding));
if (len > 0) {
return TCL_OK;
}
}
if (len == 0 || HaveOpt(2, "-eofchar")) {
char buf[4] = "";
if (len == 0) {
|
| ︙ | ︙ | |||
8192 8193 8194 8195 8196 8197 8198 |
Tcl_SetChannelBufferSize(chan, newBufferSize);
return TCL_OK;
} else if (HaveOpt(2, "-encoding")) {
Tcl_Encoding encoding;
int profile;
if ((newValue[0] == '\0') || (strcmp(newValue, "binary") == 0)) {
| | > > > > > > | | 8175 8176 8177 8178 8179 8180 8181 8182 8183 8184 8185 8186 8187 8188 8189 8190 8191 8192 8193 8194 8195 8196 8197 8198 8199 8200 8201 8202 8203 8204 8205 8206 8207 8208 |
Tcl_SetChannelBufferSize(chan, newBufferSize);
return TCL_OK;
} else if (HaveOpt(2, "-encoding")) {
Tcl_Encoding encoding;
int profile;
if ((newValue[0] == '\0') || (strcmp(newValue, "binary") == 0)) {
encoding = Tcl_GetEncoding(NULL, "iso8859-1");
CHANNEL_PROFILE_SET(statePtr->inputEncodingFlags
,CHANNEL_PROFILE_GET(statePtr->inputEncodingFlags)
|TCL_ENCODING_PROFILE_STRICT);
CHANNEL_PROFILE_SET(statePtr->outputEncodingFlags
,CHANNEL_PROFILE_GET(statePtr->outputEncodingFlags)
|TCL_ENCODING_PROFILE_STRICT);
} else {
encoding = Tcl_GetEncoding(interp, newValue);
if (encoding == NULL) {
return TCL_ERROR;
}
}
/*
* When the channel has an escape sequence driven encoding such as
* iso2022, the terminated escape sequence must write to the buffer.
*/
if ((statePtr->encoding != GetBinaryEncoding())
&& !(statePtr->outputEncodingFlags & TCL_ENCODING_START)
&& (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
statePtr->outputEncodingFlags |= TCL_ENCODING_END;
WriteChars(chanPtr, "", 0);
}
Tcl_FreeEncoding(statePtr->encoding);
statePtr->encoding = encoding;
|
| ︙ | ︙ | |||
8300 8301 8302 8303 8304 8305 8306 |
translation = statePtr->inputTranslation;
} else if (strcmp(readMode, "auto") == 0) {
translation = TCL_TRANSLATE_AUTO;
} else if (strcmp(readMode, "binary") == 0) {
translation = TCL_TRANSLATE_LF;
statePtr->inEofChar = 0;
Tcl_FreeEncoding(statePtr->encoding);
| | > > > > > > | 8289 8290 8291 8292 8293 8294 8295 8296 8297 8298 8299 8300 8301 8302 8303 8304 8305 8306 8307 8308 8309 |
translation = statePtr->inputTranslation;
} else if (strcmp(readMode, "auto") == 0) {
translation = TCL_TRANSLATE_AUTO;
} else if (strcmp(readMode, "binary") == 0) {
translation = TCL_TRANSLATE_LF;
statePtr->inEofChar = 0;
Tcl_FreeEncoding(statePtr->encoding);
statePtr->encoding = Tcl_GetEncoding(NULL, "iso8859-1");
CHANNEL_PROFILE_SET(statePtr->inputEncodingFlags
,CHANNEL_PROFILE_GET(statePtr->inputEncodingFlags)
|TCL_ENCODING_PROFILE_STRICT);
CHANNEL_PROFILE_SET(statePtr->outputEncodingFlags
,CHANNEL_PROFILE_GET(statePtr->outputEncodingFlags)
|TCL_ENCODING_PROFILE_STRICT);
} else if (strcmp(readMode, "lf") == 0) {
translation = TCL_TRANSLATE_LF;
} else if (strcmp(readMode, "cr") == 0) {
translation = TCL_TRANSLATE_CR;
} else if (strcmp(readMode, "crlf") == 0) {
translation = TCL_TRANSLATE_CRLF;
} else if (strcmp(readMode, "platform") == 0) {
|
| ︙ | ︙ | |||
8349 8350 8351 8352 8353 8354 8355 |
statePtr->outputTranslation = TCL_TRANSLATE_CRLF;
} else {
statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
}
} else if (strcmp(writeMode, "binary") == 0) {
statePtr->outputTranslation = TCL_TRANSLATE_LF;
Tcl_FreeEncoding(statePtr->encoding);
| | > > > > > > | 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 8354 8355 8356 8357 8358 8359 8360 8361 8362 8363 8364 |
statePtr->outputTranslation = TCL_TRANSLATE_CRLF;
} else {
statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
}
} else if (strcmp(writeMode, "binary") == 0) {
statePtr->outputTranslation = TCL_TRANSLATE_LF;
Tcl_FreeEncoding(statePtr->encoding);
statePtr->encoding = Tcl_GetEncoding(NULL, "iso8859-1");
CHANNEL_PROFILE_SET(statePtr->inputEncodingFlags
,CHANNEL_PROFILE_GET(statePtr->inputEncodingFlags)
|TCL_ENCODING_PROFILE_STRICT);
CHANNEL_PROFILE_SET(statePtr->outputEncodingFlags
,CHANNEL_PROFILE_GET(statePtr->outputEncodingFlags)
|TCL_ENCODING_PROFILE_STRICT);
} else if (strcmp(writeMode, "lf") == 0) {
statePtr->outputTranslation = TCL_TRANSLATE_LF;
} else if (strcmp(writeMode, "cr") == 0) {
statePtr->outputTranslation = TCL_TRANSLATE_CR;
} else if (strcmp(writeMode, "crlf") == 0) {
statePtr->outputTranslation = TCL_TRANSLATE_CRLF;
} else if (strcmp(writeMode, "platform") == 0) {
|
| ︙ | ︙ | |||
10267 10268 10269 10270 10271 10272 10273 |
long long toRead)
{
return inStatePtr->inEofChar == '\0' /* No eofChar to stop input */
&& inStatePtr->inputTranslation == TCL_TRANSLATE_LF
&& outStatePtr->outputTranslation == TCL_TRANSLATE_LF
&& (
(
| < | < < | < | 10268 10269 10270 10271 10272 10273 10274 10275 10276 10277 10278 10279 10280 10281 10282 10283 10284 |
long long toRead)
{
return inStatePtr->inEofChar == '\0' /* No eofChar to stop input */
&& inStatePtr->inputTranslation == TCL_TRANSLATE_LF
&& outStatePtr->outputTranslation == TCL_TRANSLATE_LF
&& (
(
inStatePtr->encoding == GetBinaryEncoding()
&&
outStatePtr->encoding == GetBinaryEncoding()
)
||
(
toRead == -1
&& inStatePtr->encoding == outStatePtr->encoding
&& CHANNEL_PROFILE_GET(inStatePtr->inputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8
&& CHANNEL_PROFILE_GET(outStatePtr->inputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8
|
| ︙ | ︙ | |||
11153 11154 11155 11156 11157 11158 11159 |
/*
* Process the caught message.
*
* Syntax = (option value)... ?message?
*
* Bad message syntax causes a panic, because the other side uses
| | | 11150 11151 11152 11153 11154 11155 11156 11157 11158 11159 11160 11161 11162 11163 11164 |
/*
* 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 = TclListObjGetElementsM(NULL, msg, &lc, &lv);
if (res != TCL_OK) {
Tcl_Panic("Tcl_SetChannelError: bad syntax of message");
}
|
| ︙ | ︙ | |||
11222 11223 11224 11225 11226 11227 11228 |
if (newcode >= 0) {
lcn += 2;
}
lvn = (Tcl_Obj **)Tcl_Alloc(lcn * sizeof(Tcl_Obj *));
/*
| | | | 11219 11220 11221 11222 11223 11224 11225 11226 11227 11228 11229 11230 11231 11232 11233 11234 |
if (newcode >= 0) {
lcn += 2;
}
lvn = (Tcl_Obj **)Tcl_Alloc(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 |
* will be put in the buffer. */
Tcl_Size nextRemoved; /* Position of next byte to be removed from
* the buffer. */
Tcl_Size bufLength; /* How big is the buffer? */
struct ChannelBuffer *nextPtr;
/* Next buffer in chain. */
char buf[TCLFLEXARRAY]; /* Placeholder for real buffer. The real
| | | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
* will be put in the buffer. */
Tcl_Size nextRemoved; /* Position of next byte to be removed from
* the buffer. */
Tcl_Size 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 offsetof(ChannelBuffer, buf)
/*
|
| ︙ | ︙ | |||
125 126 127 128 129 130 131 |
* 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. */
| | | 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. */
|
| ︙ | ︙ | |||
207 208 209 210 211 212 213 |
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
| | | | 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 233 234 235 236 |
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'. */
size_t epoch; /* Used to test validity of stored channelname
* lookup results. */
int maxPerms; /* TIP #220: Max access privileges
* the channel was created with. */
} 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.
| ︙ | ︙ | |||
426 427 428 429 430 431 432 |
TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
return TCL_ERROR;
}
}
TclNewObj(resultPtr);
| < > < < | 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 |
TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
return TCL_ERROR;
}
}
TclNewObj(resultPtr);
TclChannelPreserve(chan);
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
if (charactersRead == TCL_IO_FAILURE) {
Tcl_DecrRefCount(resultPtr);
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area and
* put them into the regular interpreter result. Fall back to the
* regular message if nothing was found in the bypass.
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error reading \"%s\": %s",
TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
TclChannelRelease(chan);
return TCL_ERROR;
}
/*
* If requested, remove the last newline in the channel if at EOF.
*/
if ((charactersRead > 0) && (newline != 0)) {
const char *result;
size_t length;
result = Tcl_GetStringFromObj(resultPtr, &length);
if (result[length - 1] == '\n') {
Tcl_SetObjLength(resultPtr, length - 1);
}
}
Tcl_SetObjResult(interp, resultPtr);
TclChannelRelease(chan);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SeekObjCmd --
|
| ︙ | ︙ | |||
1005 1006 1007 1008 1009 1010 1011 | * 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 | | | 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 |
* 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.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FblockedObjCmd(
TCL_UNUSED(void *),
|
| ︙ | ︙ |
Changes to generic/tclIOGT.c.
| ︙ | ︙ | |||
397 398 399 400 401 402 403 |
}
Tcl_IncrRefCount(command);
Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, TCL_INDEX_NONE));
/*
* Use a byte-array to prevent the misinterpretation of binary data coming
| | | | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 |
}
Tcl_IncrRefCount(command);
Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, TCL_INDEX_NONE));
/*
* 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;
|
| ︙ | ︙ | |||
569 570 571 572 573 574 575 |
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
| | | 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 |
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);
}
|
| ︙ | ︙ | |||
1011 1012 1013 1014 1015 1016 1017 |
void *instanceData, /* Channel to watch. */
int mask) /* Events of interest. */
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
Tcl_Channel downChan;
/*
| | | 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 |
void *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
|
| ︙ | ︙ | |||
1118 1119 1120 1121 1122 1123 1124 |
*----------------------------------------------------------------------
*/
static int
TransformNotifyProc(
void *clientData, /* The state of the notified
* transformation. */
| | | | 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 |
*----------------------------------------------------------------------
*/
static int
TransformNotifyProc(
void *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
|
| ︙ | ︙ | |||
1213 1214 1215 1216 1217 1218 1219 | /* *---------------------------------------------------------------------- * * ResultInit -- * * Initializes the specified buffer structure. The structure will contain | | | 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 | /* *---------------------------------------------------------------------- * * 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 | /* * 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. * | | | 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 © 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" |
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
/*
* 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.
*
| | | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 |
/*
* 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.
*
* A timer is used here as well in order to ensure at least on pass through
* the event loop when a channel becomes ready. See issues 67a5eabbd3d1 and
* ef28eb1f1516.
*/
} 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.
|
| ︙ | ︙ | |||
883 884 885 886 887 888 889 |
* (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.
*
| | | | 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 |
* (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);
/*
|
| ︙ | ︙ | |||
1059 1060 1061 1062 1063 1064 1065 |
/*
* Process the caught message.
*
* Syntax = (option value)... ?message?
*
* Bad syntax causes a panic. This is OK because the other side uses
| | | 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 |
/*
* 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 (TclListObjGetElementsM(interp, msgObj, &lc, &lv) != TCL_OK) {
Tcl_Panic("TclChanCaughtErrorBypass: Bad syntax of caught result");
}
if (interp == NULL) {
|
| ︙ | ︙ | |||
1150 1151 1152 1153 1154 1155 1156 | * * ReflectClose -- * * This function is invoked when the channel is closed, to delete the * driver-specific instance data. * * Results: | | | 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 | * * 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. * *---------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
1714 1715 1716 1717 1718 1719 1720 | * * ReflectBlock -- * * This function is invoked to tell the channel which blocking behaviour * is required of it. * * Results: | | | 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 | * * 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. * *---------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
2281 2282 2283 2284 2285 2286 2287 | * reflected channel. * * Results: * A Tcl_Obj containing the string of the new channel handle. The * refcount of the returned object is -- zero --. * * Side effects: | | | 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 | * 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) |
| ︙ | ︙ | |||
2335 2336 2337 2338 2339 2340 2341 | /* *---------------------------------------------------------------------- * * InvokeTclMethod -- * * This function is used to invoke the Tcl level of a reflected channel. | | | 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 | /* *---------------------------------------------------------------------- * * 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: |
| ︙ | ︙ | |||
2363 2364 2365 2366 2367 2368 2369 |
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 */
| | | | 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 |
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.
*/
|
| ︙ | ︙ | |||
2583 2584 2585 2586 2587 2588 2589 | * an interpreter is deleted, via the AssocData cleanup mechanism. * * Results: * None. * * Side effects: * Deletes the hash table of channels. May close channels. May flush | | | 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 | * 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.
| ︙ | ︙ | |||
630 631 632 633 634 635 636 |
TclGetString(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
| | | 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 |
TclGetString(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;
}
|
| ︙ | ︙ | |||
862 863 864 865 866 867 868 | * * ReflectClose -- * * This function is invoked when the channel is closed, to delete the * driver specific instance data. * * Results: | | | 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 | * * 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. * *---------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
981 982 983 984 985 986 987 |
return EINVAL;
}
return EOK;
}
#endif /* TCL_THREADS */
/*
| | | 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 |
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);
}
|
| ︙ | ︙ | |||
1445 1446 1447 1448 1449 1450 1451 | * * ReflectBlock -- * * This function is invoked to tell the channel which blocking behaviour * is required of it. * * Results: | | | 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 | * * 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. * *---------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
1532 1533 1534 1535 1536 1537 1538 |
*----------------------------------------------------------------------
*/
static int
ReflectGetOption(
void *clientData, /* Channel to query */
Tcl_Interp *interp, /* Interpreter to leave error messages in */
| | | 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 |
*----------------------------------------------------------------------
*/
static int
ReflectGetOption(
void *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
|
| ︙ | ︙ | |||
1587 1588 1589 1590 1591 1592 1593 |
int direction,
void **handlePtr)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
/*
* Transformations have no handle of their own. As such we simply query
| | | 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 |
int direction,
void **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.
*/
|
| ︙ | ︙ | |||
1621 1622 1623 1624 1625 1626 1627 |
ReflectNotify(
void *clientData,
int mask)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
/*
| | | 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 |
ReflectNotify(
void *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).
*/
|
| ︙ | ︙ | |||
1883 1884 1885 1886 1887 1888 1889 | /* *---------------------------------------------------------------------- * * InvokeTclMethod -- * * This function is used to invoke the Tcl level of a reflected channel. | | | 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 | /* *---------------------------------------------------------------------- * * 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: |
| ︙ | ︙ | |||
1915 1916 1917 1918 1919 1920 1921 |
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 */
| | | | 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 |
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.
*/
|
| ︙ | ︙ | |||
1940 1941 1942 1943 1944 1945 1946 |
* 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.
*/
/*
| | | 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 |
* 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;
|
| ︙ | ︙ | |||
1967 1968 1969 1970 1971 1972 1973 |
if (argTwoObj) {
rtPtr->argv[cmdc] = argTwoObj;
cmdc++;
}
}
/*
| | | 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 |
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);
|
| ︙ | ︙ | |||
2869 2870 2871 2872 2873 2874 2875 | /* *---------------------------------------------------------------------- * * ResultInit -- * * Initializes the specified buffer structure. The structure will contain | | | 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 | /* *---------------------------------------------------------------------- * * 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.
| ︙ | ︙ | |||
289 290 291 292 293 294 295 | } # undef OUT_OF_RANGE # undef OUT_OF_URANGE #endif /* !TCL_WIDE_INT_IS_LONG */ /* | | | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 | } # 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; |
| ︙ | ︙ | |||
1299 1300 1301 1302 1303 1304 1305 | * Stores the resulting pathname in pathPtr and returns the offset of the * last byte processed in pathPtr. * * Side effects: * None (beyond the memory allocation for the result). * * Special notes: | | | 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 | * Stores the resulting pathname in pathPtr and returns the offset of the * last byte processed in pathPtr. * * Side effects: * None (beyond the memory allocation for the result). * * Special notes: * If the filesystem-specific normalizePathProcs can reintroduce ../, ./ * components into the pathname, this function does not return the correct * result. This may be possible with symbolic links on unix. * * *--------------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
2059 2060 2061 2062 2063 2064 2065 | /* *---------------------------------------------------------------------- * * Tcl_FSStat -- * Calls 'statProc' of the filesystem corresponding to pathPtr. * | | < | 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 | /* *---------------------------------------------------------------------- * * Tcl_FSStat -- * Calls 'statProc' of the filesystem corresponding to pathPtr. * * Replaces the standard library "stat" routine. * * Results: * See stat documentation. * * Side effects: * See stat documentation. * |
| ︙ | ︙ |
Changes to generic/tclIndexObj.c.
| ︙ | ︙ | |||
110 111 112 113 114 115 116 |
Tcl_Size objc, t;
int result;
Tcl_Obj **objv;
const char **tablePtr;
/*
* Use Tcl_GetIndexFromObjStruct to do the work to avoid duplicating most
| | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 |
Tcl_Size objc, t;
int result;
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 = TclListObjGetElementsM(interp, tableObjPtr, &objc, &objv);
if (result != TCL_OK) {
return result;
}
|
| ︙ | ︙ |
Changes to generic/tclInt.h.
| ︙ | ︙ | |||
218 219 220 221 222 223 224 | *---------------------------------------------------------------- */ typedef struct Tcl_Ensemble Tcl_Ensemble; typedef struct NamespacePathEntry NamespacePathEntry; /* | | | | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 |
*----------------------------------------------------------------
*/
typedef struct Tcl_Ensemble Tcl_Ensemble;
typedef struct NamespacePathEntry NamespacePathEntry;
/*
* Special hashtable for variables: This is just a Tcl_HashTable with nsPtr
* and arrayPtr fields added at the end so that variables can find their
* namespace and possibly containing array without having to copy a pointer in
* their struct by accessing them via their hPtr->tablePtr.
*/
typedef struct TclVarHashTable {
Tcl_HashTable table;
struct Namespace *nsPtr;
#if TCL_MAJOR_VERSION > 8
struct Var *arrayPtr;
|
| ︙ | ︙ | |||
475 476 477 478 479 480 481 |
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. */
| | | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 |
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
|
| ︙ | ︙ | |||
502 503 504 505 506 507 508 | * 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 | | | 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 |
* 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. */
Tcl_Size 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. */
|
| ︙ | ︙ | |||
646 647 648 649 650 651 652 |
* 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
| | | | | | | 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 686 687 688 689 |
* 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
|
| ︙ | ︙ | |||
1313 1314 1315 1316 1317 1318 1319 |
Tcl_Size pc; /* Instruction pointer of a command in
* ExtCmdLoc.loc[.] */
Tcl_Size 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. */
| | | | 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 |
Tcl_Size pc; /* Instruction pointer of a command in
* ExtCmdLoc.loc[.] */
Tcl_Size 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)
|
| ︙ | ︙ | |||
5191 5192 5193 5194 5195 5196 5197 | * Other externals. */ MODULE_SCOPE size_t TclEnvEpoch; /* Epoch of the tcl environment * (if changed with tcl-env). */ #endif /* _TCLINT */ | | | 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 | * 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/tclInterp.c.
| ︙ | ︙ | |||
193 194 195 196 197 198 199 |
* 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
| | | 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
|
| ︙ | ︙ | |||
3321 3322 3323 3324 3325 3326 3327 |
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);
/*
| | | 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 |
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_UnsetVar2(interp, "tclDefaultLibrary", NULL, TCL_GLOBAL_ONLY);
Tcl_UnsetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY);
Tcl_UnsetVar2(interp, "tcl_pkgPath", NULL, TCL_GLOBAL_ONLY);
|
| ︙ | ︙ | |||
4285 4286 4287 4288 4289 4290 4291 | * interpreter through this mechanism (though as many interpreters may be * limited as the programmer chooses overall). * * Results: * None. * * Side effects: | | | 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 | * 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.
| ︙ | ︙ | |||
818 819 820 821 822 823 824 |
}
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
| | | 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 |
}
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.
| ︙ | ︙ | |||
1873 1874 1875 1876 1877 1878 1879 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendElement -- * | | < < < | > | > > > > > | | | < | > > | < | | | | 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 |
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjAppendElement --
*
* Like 'Tcl_ListObjAppendList', but Appends a single value to a list.
*
* Value
*
* TCL_OK
*
* 'objPtr' is appended to the elements of 'listPtr'.
*
* TCL_ERROR
*
* listPtr does not refer to a list object and the object can not be
* 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
Tcl_ListObjAppendElement(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *toObj, /* List object to append elemObj to. */
|
| ︙ | ︙ | |||
1912 1913 1914 1915 1916 1917 1918 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjIndex -- * | | | < < < | > | > | > | | | > > > | | | > | | 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 |
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjIndex --
*
* Retrieve a pointer to the element of 'listPtr' at 'index'. The index
* of the first element is 0.
*
* Value
*
* TCL_OK
*
* A pointer to the element at 'index' is stored in 'objPtrPtr'. If
* '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.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjIndex(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listObj, /* List object to index into. */
|
| ︙ | ︙ | |||
2774 2775 2776 2777 2778 2779 2780 |
*/
return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
}
LIST_ASSERT_TYPE(indexListCopy);
ListObjGetElements(indexListCopy, indexCount, indices);
/*
| | | 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 |
*/
return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
}
LIST_ASSERT_TYPE(indexListCopy);
ListObjGetElements(indexListCopy, indexCount, indices);
/*
* Let TclLsetFlat perform the actual lset operation.
*/
retValueObj = TclLsetFlat(interp, listObj, indexCount, indices, valueObj);
Tcl_DecrRefCount(indexListCopy);
return retValueObj;
}
|
| ︙ | ︙ | |||
3403 3404 3405 3406 3407 3408 3409 | } /* *---------------------------------------------------------------------- * * UpdateStringOfList -- * | | > | | | < < | | | < | 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 |
}
/*
*----------------------------------------------------------------------
*
* 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.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfList(
Tcl_Obj *listObj) /* List object with string rep to update. */
{
|
| ︙ | ︙ |
Changes to generic/tclLiteral.c.
| ︙ | ︙ | |||
396 397 398 399 400 401 402 |
* array. */
size_t length, /* Number of bytes in the string. If -1, 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
| | | 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 |
* array. */
size_t length, /* Number of bytes in the string. If -1, 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 = (CompileEnv *)ePtr;
Interp *iPtr = envPtr->iPtr;
LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *globalPtr, *localPtr;
Tcl_Obj *objPtr;
|
| ︙ | ︙ | |||
439 440 441 442 443 444 445 |
return objIndex;
}
}
/*
* The literal is new to this CompileEnv. If it is a command name, avoid
| | | 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 |
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/tclNamesp.c.
| ︙ | ︙ | |||
4209 4210 4211 4212 4213 4214 4215 | * * Results: * nothing * * Side effects: * Increments the command reference epoch in each namespace whose path * includes the given namespace. This causes any cached resolved names | | | 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 | * * 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( |
| ︙ | ︙ | |||
4282 4283 4284 4285 4286 4287 4288 |
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 == ':')) {
| | | 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 |
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;
|
| ︙ | ︙ | |||
4561 4562 4563 4564 4565 4566 4567 | * 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 | | | 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 | * 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.
| ︙ | ︙ | |||
1023 1024 1025 1026 1027 1028 1029 |
}
}
if (flags & TCL_DONT_WAIT) {
break;
}
/*
| | | | | | | | 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 |
}
}
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.
| ︙ | ︙ | |||
1130 1131 1132 1133 1134 1135 1136 |
*/
return;
}
/*
* One rule for the teardown routines is that if an object is in the
| | | 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 |
*/
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!
|
| ︙ | ︙ | |||
1183 1184 1185 1186 1187 1188 1189 |
* still exists) because otherwise its pointer to the object points into
* freed memory.
*/
if (((Command *) oPtr->command)->flags && CMD_DYING) {
/*
* Something has already started the command deletion process. We can
| | | 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 |
* still exists) because otherwise its pointer to the object points into
* freed memory.
*/
if (((Command *) oPtr->command)->flags && CMD_DYING) {
/*
* 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.
| ︙ | ︙ | |||
1492 1493 1494 1495 1496 1497 1498 |
flags|BUILDING_MIXINS, NULL);
AddSimpleChainToCallContext(&obj, NULL, 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
| | | 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 |
flags|BUILDING_MIXINS, NULL);
AddSimpleChainToCallContext(&obj, NULL, 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, NULL, fPtr->unknownMethodNameObj,
&cb, NULL, BUILDING_MIXINS, NULL);
AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj,
&cb, NULL, 0, NULL);
|
| ︙ | ︙ |
Changes to generic/tclOOMethod.c.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 | #endif #include "tclInt.h" #include "tclOOInt.h" #include "tclCompile.h" /* * Structure used to help delay computing names of objects or classes for | | | 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 |
* The structure defined below is used in this file only.
*/
typedef struct {
Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj
* generated by a call to the function
* TclSubstTokens() from a literal text
| | | 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 {
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 |
* 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 {
| | | | 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
|
| ︙ | ︙ | |||
342 343 344 345 346 347 348 |
* pointer is invalid. */
size_t refCount; /* Reference count: 1 for each cmdName object
* that has a pointer to this ResolvedCmdName
* structure as its internal rep. This
* structure can be freed when refCount
* becomes zero. */
} ResolvedCmdName;
| | | | 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 |
* pointer is invalid. */
size_t refCount; /* Reference count: 1 for each cmdName object
* that has a pointer to this ResolvedCmdName
* structure as its internal rep. This
* structure can be freed when refCount
* becomes zero. */
} ResolvedCmdName;
#ifdef TCL_MEM_DEBUG
/*
* Filler matches the value used for filling freed memory in tclCkalloc.
* On 32-bit systems, the ref counts do not cross 0x7fffffff. On 64-bit
* implementations, ref counts will never reach this value (unless explicitly
* incremented without actual references!)
*/
#define FREEDREFCOUNTFILLER \
(sizeof(objPtr->refCount) == 4 ? 0xe8e8e8e8 : 0xe8e8e8e8e8e8e8e8)
|
| ︙ | ︙ | |||
565 566 567 568 569 570 571 | * 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 | | | 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 | * 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 |
| ︙ | ︙ | |||
1376 1377 1378 1379 1380 1381 1382 |
/*
* 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
| | | 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 |
/*
* 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;
|
| ︙ | ︙ | |||
1467 1468 1469 1470 1471 1472 1473 |
/*
* 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
| | | 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 |
/*
* 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;
|
| ︙ | ︙ | |||
1661 1662 1663 1664 1665 1666 1667 | * Side effects: * May call the object's updateStringProc to update the string * representation from the internal representation. * *---------------------------------------------------------------------- */ | | | 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 |
* Side effects:
* May call the object's updateStringProc to update the string
* representation from the internal representation.
*
*----------------------------------------------------------------------
*/
#if !defined(TCL_NO_DEPRECATED)
char *
TclGetStringFromObj(
Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
* be returned. */
int *lengthPtr) /* If non-NULL, the location where the string
* rep's byte array length should * be stored.
* If NULL, no length is stored. */
|
| ︙ | ︙ | |||
1698 1699 1700 1701 1702 1703 1704 |
"failed to create a valid string rep",
objPtr->typePtr->name);
}
}
if (lengthPtr != NULL) {
if (objPtr->length > INT_MAX) {
Tcl_Panic("Tcl_GetStringFromObj with 'int' lengthPtr"
| | > | 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 |
"failed to create a valid string rep",
objPtr->typePtr->name);
}
}
if (lengthPtr != NULL) {
if (objPtr->length > INT_MAX) {
Tcl_Panic("Tcl_GetStringFromObj with 'int' lengthPtr"
" cannot handle such long strings. Please use 'size_t'");
}
*lengthPtr = (int)objPtr->length;
}
return objPtr->bytes;
}
#endif /* !defined(TCL_NO_DEPRECATED) */
#undef Tcl_GetStringFromObj
char *
Tcl_GetStringFromObj(
Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
* be returned. */
size_t *lengthPtr) /* If non-NULL, the location where the string
|
| ︙ | ︙ | |||
3441 3442 3443 3444 3445 3446 3447 | * 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 | | | 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 | * 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.
| ︙ | ︙ | |||
62 63 64 65 66 67 68 | * Side effects: * The process dies, entering the debugger if possible. * *---------------------------------------------------------------------- */ /* | | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
* Side effects:
* The process dies, entering the debugger if possible.
*
*----------------------------------------------------------------------
*/
/*
* 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.
| ︙ | ︙ | |||
777 778 779 780 781 782 783 | * None. * *---------------------------------------------------------------------- */ int TclParseBackslash( | | | 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 |
* None.
*
*----------------------------------------------------------------------
*/
int
TclParseBackslash(
const char *src, /* Points to the backslash character of a
* backslash sequence. */
size_t numBytes, /* Max number of bytes to scan. */
size_t *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 4 bytes will be written there. */
|
| ︙ | ︙ | |||
2155 2156 2157 2158 2159 2160 2161 |
* 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.
*/
/*
| | | | | 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 |
* 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.
| ︙ | ︙ | |||
812 813 814 815 816 817 818 |
}
Tcl_Obj *
TclJoinPath(
size_t elements, /* Number of elements to use */
Tcl_Obj * const objv[], /* Path elements to join */
int forceRelative) /* If non-zero, assume all more paths are
| | | 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 |
}
Tcl_Obj *
TclJoinPath(
size_t elements, /* Number of elements to use */
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;
size_t i;
const Tcl_Filesystem *fsPtr = NULL;
if (elements == 0) {
TclNewObj(res);
|
| ︙ | ︙ | |||
866 867 868 869 870 871 872 | * the base itself is just fine! */ return elt; } /* | | | 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 | * 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.
| ︙ | ︙ | |||
411 412 413 414 415 416 417 |
* 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
| | | 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 |
* 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
|
| ︙ | ︙ | |||
486 487 488 489 490 491 492 |
/*
* 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
| | | 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 |
/*
* 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 = TCL_INDEX_NONE;
|
| ︙ | ︙ |
Changes to generic/tclPkg.c.
| ︙ | ︙ | |||
1740 1741 1742 1743 1744 1745 1746 |
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
| | | 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 |
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
|
| ︙ | ︙ | |||
2194 2195 2196 2197 2198 2199 2200 |
Tcl_Free(min);
Tcl_Free(buf);
return satisfied;
}
/*
* We have both min and max, and generate their internal reps. When
| | | 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 |
Tcl_Free(min);
Tcl_Free(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/tclResult.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
/*
* tclResult.c --
*
* This file contains code to manage the interpreter result.
*
* Copyright © 1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
/*
* Indices of the standard return options dictionary keys.
*/
enum returnKeys {
KEY_CODE, KEY_ERRORCODE, KEY_ERRORINFO, KEY_ERRORLINE,
| > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
/*
* tclResult.c --
*
* This file contains code to manage the interpreter result.
*
* Copyright © 1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include <assert.h>
/*
* Indices of the standard return options dictionary keys.
*/
enum returnKeys {
KEY_CODE, KEY_ERRORCODE, KEY_ERRORINFO, KEY_ERRORLINE,
|
| ︙ | ︙ | |||
207 208 209 210 211 212 213 |
Tcl_Free(statePtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetObjResult --
| < | | < | > | | < | < | > > > > | | | < < < < | < | 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 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 |
Tcl_Free(statePtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetObjResult --
* Makes objPtr the interpreter's result value.
*
* Results:
* None.
*
* Side effects:
* Stores objPtr interp->objResultPtr, increments its reference count, and
* decrements the reference count of any existing interp->objResultPtr.
*
* The string result is reset.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetObjResult(
Tcl_Interp *interp, /* Interpreter to set the result for. */
Tcl_Obj *objPtr) /* The value to set as the result. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *oldObjResult = iPtr->objResultPtr;
if (objPtr == oldObjResult) {
/* This should be impossible */
assert(objPtr->refCount != 0);
return;
} else {
iPtr->objResultPtr = objPtr;
Tcl_IncrRefCount(objPtr);
TclDecrRefCount(oldObjResult);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetObjResult --
*
|
| ︙ | ︙ |
Changes to generic/tclStrToD.c.
| ︙ | ︙ | |||
1747 1748 1749 1750 1751 1752 1753 |
((Tcl_WideInt)significand / pow10vals[-exponent]);
goto returnValue;
}
}
}
/*
| | | 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 |
((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.
*/
if (mp_init_u64(&significandBig, significand) != MP_OKAY) {
return 0.0;
}
retval = MakeHighPrecisionDouble(0, &significandBig, numSigDigs,
|
| ︙ | ︙ | |||
2049 2050 2051 2052 2053 2054 2055 |
return approxResult;
}
}
/*
* Compute twoMd as 2*M*d, where d is the exact value.
* This is done by multiplying by 5**(M5+exponent) and then multiplying
| | | 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 |
return approxResult;
}
}
/*
* 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.
*/
if (mp_init_copy(&twoMd, exactSignificand) != MP_OKAY) {
mp_clear(&twoMv);
return approxResult;
}
for (i = 0; (i <= 8); ++i) {
|
| ︙ | ︙ | |||
2278 2279 2280 2281 2282 2283 2284 | } /* *---------------------------------------------------------------------- * * RequiredPrecision -- * | | | 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 | } /* *---------------------------------------------------------------------- * * 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.
| ︙ | ︙ | |||
133 134 135 136 137 138 139 |
static void
GrowStringBuffer(
Tcl_Obj *objPtr,
size_t needed,
int flag)
{
/*
| | | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 |
static void
GrowStringBuffer(
Tcl_Obj *objPtr,
size_t 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 |
static void
GrowUnicodeBuffer(
Tcl_Obj *objPtr,
size_t needed)
{
/*
| | | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 |
static void
GrowUnicodeBuffer(
Tcl_Obj *objPtr,
size_t needed)
{
/*
* Preconditions:
* objPtr->typePtr == &tclStringType
* needed > stringPtr->maxChars
*/
String *ptr = NULL, *stringPtr = GET_STRING(objPtr);
size_t attempt;
|
| ︙ | ︙ | |||
386 387 388 389 390 391 392 | *---------------------------------------------------------------------- * * Tcl_GetCharLength -- * * Get the length of the Unicode string from the Tcl object. * * Results: | | | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 | *---------------------------------------------------------------------- * * 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. * *---------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
555 556 557 558 559 560 561 |
* from. */
size_t index) /* Get the index'th Unicode character. */
{
String *stringPtr;
int ch;
/*
| | | 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 |
* from. */
size_t index) /* Get the index'th Unicode character. */
{
String *stringPtr;
int ch;
/*
* 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)) {
size_t length = 0;
unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
if (index >= length) {
|
| ︙ | ︙ | |||
623 624 625 626 627 628 629 |
Tcl_Obj *objPtr, /* The object to get the Unicode charater
* from. */
size_t index) /* Get the index'th Unicode character. */
{
int ch = 0;
/*
| | | | 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 |
Tcl_Obj *objPtr, /* The object to get the Unicode charater
* from. */
size_t index) /* Get the index'th Unicode character. */
{
int ch = 0;
/*
* Optimize the ByteArray case: N need need to convert to a string to
* perform the indexing operation.
*/
if (TclIsPureByteArray(objPtr)) {
size_t length = 0;
unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
if (index >= length) {
return -1;
|
| ︙ | ︙ | |||
668 669 670 671 672 673 674 675 676 | * Side effects: * Converts the object to have the String internal rep. * *---------------------------------------------------------------------- */ #undef Tcl_GetUnicodeFromObj Tcl_UniChar * TclGetUnicodeFromObj( | > | | | > | 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 |
* Side effects:
* Converts the object to have the String internal rep.
*
*----------------------------------------------------------------------
*/
#undef Tcl_GetUnicodeFromObj
#if !defined(TCL_NO_DEPRECATED)
Tcl_UniChar *
TclGetUnicodeFromObj(
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);
if (stringPtr->hasUnicode == 0) {
FillUnicodeRep(objPtr);
stringPtr = GET_STRING(objPtr);
}
if (lengthPtr != NULL) {
if (stringPtr->numChars > INT_MAX) {
Tcl_Panic("Tcl_GetUnicodeFromObj with 'int' lengthPtr"
" cannot handle such long strings. Please use 'size_t'");
}
*lengthPtr = (int)stringPtr->numChars;
}
return stringPtr->unicode;
}
#endif /* !defined(TCL_NO_DEPRECATED) */
Tcl_UniChar *
Tcl_GetUnicodeFromObj(
Tcl_Obj *objPtr, /* The object to find the unicode string
* for. */
size_t *lengthPtr) /* If non-NULL, the location where the string
* rep's unichar length should be stored. If
|
| ︙ | ︙ | |||
933 934 935 936 937 938 939 | } /* *---------------------------------------------------------------------- * * Tcl_SetObjLength -- * | | < | | | | | < > | | 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 |
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetObjLength --
*
* Changes the length of the string representation of objPtr.
*
* Results:
* None.
*
* Side effects:
* If the size of objPtr's string representation is greater than length, a
* new terminating null byte is stored in objPtr->bytes at length, and
* bytes at positions past length have no meaning. If the length of the
* string representation is greater than length, the storage space is
* reallocated to length+1.
*
* The object's internal representation is changed to &tclStringType.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetObjLength(
Tcl_Obj *objPtr, /* Pointer to object. This object must not
|
| ︙ | ︙ | |||
992 993 994 995 996 997 998 | stringPtr->allocated = length; } objPtr->length = length; objPtr->bytes[length] = 0; /* | | | | 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 |
stringPtr->allocated = length;
}
objPtr->length = length;
objPtr->bytes[length] = 0;
/*
* Invalidate the Unicode data.
*/
stringPtr->numChars = TCL_INDEX_NONE;
stringPtr->hasUnicode = 0;
} else {
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;
/*
|
| ︙ | ︙ | |||
1089 1090 1091 1092 1093 1094 1095 | stringPtr->allocated = length; } objPtr->length = length; objPtr->bytes[length] = 0; /* | | | | | 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 |
stringPtr->allocated = length;
}
objPtr->length = length;
objPtr->bytes[length] = 0;
/*
* Invalidate the Unicode data.
*/
stringPtr->numChars = TCL_INDEX_NONE;
stringPtr->hasUnicode = 0;
} else {
/*
* Changing length of pure Unicode string.
*/
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;
/*
|
| ︙ | ︙ | |||
1143 1144 1145 1146 1147 1148 1149 |
*
*---------------------------------------------------------------------------
*/
void
Tcl_SetUnicodeObj(
Tcl_Obj *objPtr, /* The object to set the string of. */
| | | | 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 |
*
*---------------------------------------------------------------------------
*/
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. */
size_t numChars) /* Number of characters in the Unicode
* string. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj");
}
TclFreeInternalRep(objPtr);
SetUnicodeObj(objPtr, unicode, numChars);
|
| ︙ | ︙ | |||
1172 1173 1174 1175 1176 1177 1178 |
}
return numChars;
}
static void
SetUnicodeObj(
Tcl_Obj *objPtr, /* The object to set the string of. */
| | | < | 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 |
}
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. */
size_t numChars) /* Number of characters in unicode. */
{
String *stringPtr;
if (numChars == TCL_INDEX_NONE) {
numChars = UnicodeLength(unicode);
}
|
| ︙ | ︙ | |||
1347 1348 1349 1350 1351 1352 1353 |
*
*----------------------------------------------------------------------
*/
void
Tcl_AppendUnicodeToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
| | | | 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 |
*
*----------------------------------------------------------------------
*/
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. */
size_t length) /* Number of chars in unicode. */
{
String *stringPtr;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj");
}
|
| ︙ | ︙ | |||
1417 1418 1419 1420 1421 1422 1423 |
*/
if (appendObjPtr->bytes == &tclEmptyString) {
return;
}
/*
| | | 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 |
*/
if (appendObjPtr->bytes == &tclEmptyString) {
return;
}
/*
* Handle append of one ByteArray object to another as a special case.
* Note that we only do this when the objects are pure so that the
* bytearray faithfully represent the true value; Otherwise appending the
* byte arrays together could lose information;
*/
if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString)
&& TclIsPureByteArray(appendObjPtr)) {
|
| ︙ | ︙ | |||
1534 1535 1536 1537 1538 1539 1540 | } /* *---------------------------------------------------------------------- * * AppendUnicodeToUnicodeRep -- * | | | | 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 | } /* *---------------------------------------------------------------------- * * 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. * |
| ︙ | ︙ | |||
1566 1567 1568 1569 1570 1571 1572 |
return;
}
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
/*
| | | | | 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 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 |
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;
if (numChars > stringPtr->maxChars) {
size_t index = TCL_INDEX_NONE;
/*
* 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) {
index = unicode - stringPtr->unicode;
}
GrowUnicodeBuffer(objPtr, numChars);
stringPtr = GET_STRING(objPtr);
/*
* Relocate Unicode if needed; see above.
*/
if (index != TCL_INDEX_NONE) {
unicode = stringPtr->unicode + index;
}
}
|
| ︙ | ︙ | |||
1638 1639 1640 1641 1642 1643 1644 |
*----------------------------------------------------------------------
*/
static void
AppendUnicodeToUtfRep(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const Tcl_UniChar *unicode, /* String to convert to UTF. */
| | | 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 |
*----------------------------------------------------------------------
*/
static void
AppendUnicodeToUtfRep(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const Tcl_UniChar *unicode, /* String to convert to UTF. */
size_t numChars) /* Number of chars of unicode to convert. */
{
String *stringPtr = GET_STRING(objPtr);
numChars = ExtendStringRepWithUnicode(objPtr, unicode, numChars);
if (stringPtr->numChars != TCL_INDEX_NONE) {
stringPtr->numChars += numChars;
|
| ︙ | ︙ | |||
3907 3908 3909 3910 3911 3912 3913 |
Tcl_UniChar *from = Tcl_GetUnicode(objPtr);
stringPtr = GET_STRING(objPtr);
Tcl_UniChar *src = from + stringPtr->numChars;
Tcl_UniChar *to;
if (!inPlace || Tcl_IsShared(objPtr)) {
/*
| | | | 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 |
Tcl_UniChar *from = Tcl_GetUnicode(objPtr);
stringPtr = GET_STRING(objPtr);
Tcl_UniChar *src = from + stringPtr->numChars;
Tcl_UniChar *to;
if (!inPlace || 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);
stringPtr = GET_STRING(objPtr);
while (--src >= from) {
|
| ︙ | ︙ | |||
4313 4314 4315 4316 4317 4318 4319 | * Create an internal representation of type "String" for an object. * * Results: * This operation always succeeds and returns TCL_OK. * * Side effects: * Any old internal representation for objPtr is freed and the internal | | | 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 |
* Create an internal representation of type "String" for an object.
*
* Results:
* This operation always succeeds and returns TCL_OK.
*
* Side effects:
* Any old internal representation for objPtr is freed and the internal
* representation is set to &tclStringType.
*
*----------------------------------------------------------------------
*/
static int
SetStringFromAny(
TCL_UNUSED(Tcl_Interp *),
|
| ︙ | ︙ | |||
4360 4361 4362 4363 4364 4365 4366 | * Update the string representation for an object whose internal * representation is "String". * * Results: * None. * * Side effects: | | | 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 | * 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( |
| ︙ | ︙ | |||
4397 4398 4399 4400 4401 4402 4403 |
static size_t
ExtendStringRepWithUnicode(
Tcl_Obj *objPtr,
const Tcl_UniChar *unicode,
size_t numChars)
{
/*
| | | 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 |
static size_t
ExtendStringRepWithUnicode(
Tcl_Obj *objPtr,
const Tcl_UniChar *unicode,
size_t numChars)
{
/*
* Precondition: this is the "string" Tcl_ObjType.
*/
size_t i, origLength, size = 0;
char *dst;
String *stringPtr = GET_STRING(objPtr);
if (numChars == TCL_INDEX_NONE) {
|
| ︙ | ︙ |
Changes to generic/tclStringRep.h.
| ︙ | ︙ | |||
56 57 58 59 60 61 62 |
* calculated. Any other means that there is a valid
* Unicode rep, or that the number of UTF bytes ==
* the number of chars. */
Tcl_Size allocated; /* The amount of space actually allocated for
* the UTF string (minus 1 byte for the
* termination char). */
Tcl_Size maxChars; /* Max number of chars that can fit in the
| | | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 |
* calculated. Any other means that there is a valid
* Unicode rep, or that the number of UTF bytes ==
* the number of chars. */
Tcl_Size allocated; /* The amount of space actually allocated for
* the UTF string (minus 1 byte for the
* termination char). */
Tcl_Size 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/tclStubInit.c.
| ︙ | ︙ | |||
80 81 82 83 84 85 86 | #define TclStaticLibrary Tcl_StaticLibrary #undef Tcl_UniCharToUtfDString #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar #undef Tcl_UniCharLen #undef TclObjInterpProc #if !defined(_WIN32) && !defined(__CYGWIN__) | | | > > > > > > > > | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 | #define TclStaticLibrary Tcl_StaticLibrary #undef Tcl_UniCharToUtfDString #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar #undef Tcl_UniCharLen #undef TclObjInterpProc #if !defined(_WIN32) && !defined(__CYGWIN__) # undef Tcl_WinConvertError # define Tcl_WinConvertError 0 #endif #if defined(TCL_NO_DEPRECATED) # undef TclGetStringFromObj # undef TclGetBytesFromObj # undef TclGetUnicodeFromObj # define TclGetStringFromObj 0 # define TclGetBytesFromObj 0 # define TclGetUnicodeFromObj 0 #endif #undef Tcl_Close #define Tcl_Close 0 #undef TclGetByteArrayFromObj #define TclGetByteArrayFromObj 0 #undef Tcl_GetByteArrayFromObj #define Tcl_GetByteArrayFromObj 0 |
| ︙ | ︙ | |||
107 108 109 110 111 112 113 114 115 116 117 118 119 120 |
# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, size_t))(void *)uniCodePanic
#endif
#define TclUtfCharComplete Tcl_UtfCharComplete
#define TclUtfNext Tcl_UtfNext
#define TclUtfPrev Tcl_UtfPrev
int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
int *objcPtr, Tcl_Obj ***objvPtr) {
size_t n = TCL_INDEX_NONE;
int result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr);
if (objcPtr) {
if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) {
if (interp) {
| > > > > > > > > > | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 |
# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, size_t))(void *)uniCodePanic
#endif
#define TclUtfCharComplete Tcl_UtfCharComplete
#define TclUtfNext Tcl_UtfNext
#define TclUtfPrev Tcl_UtfPrev
#if defined(TCL_NO_DEPRECATED)
# define TclListObjGetElements 0
# define TclListObjLength 0
# define TclDictObjSize 0
# define TclSplitList 0
# define TclSplitPath 0
# define TclFSSplitPath 0
# define TclParseArgsObjv 0
#else /* !defined(TCL_NO_DEPRECATED) */
int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
int *objcPtr, Tcl_Obj ***objvPtr) {
size_t n = TCL_INDEX_NONE;
int result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr);
if (objcPtr) {
if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) {
if (interp) {
|
| ︙ | ︙ | |||
200 201 202 203 204 205 206 207 208 209 210 211 212 213 |
const Tcl_ArgvInfo *argTable, int *objcPtr, Tcl_Obj *const *objv,
Tcl_Obj ***remObjv) {
size_t n = (*objcPtr < 0) ? TCL_INDEX_NONE: (size_t)*objcPtr ;
int result = Tcl_ParseArgsObjv(interp, argTable, &n, objv, remObjv);
*objcPtr = (int)n;
return result;
}
#define TclBN_mp_add mp_add
#define TclBN_mp_add_d mp_add_d
#define TclBN_mp_and mp_and
#define TclBN_mp_clamp mp_clamp
#define TclBN_mp_clear mp_clear
#define TclBN_mp_clear_multi mp_clear_multi
| > | 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 |
const Tcl_ArgvInfo *argTable, int *objcPtr, Tcl_Obj *const *objv,
Tcl_Obj ***remObjv) {
size_t n = (*objcPtr < 0) ? TCL_INDEX_NONE: (size_t)*objcPtr ;
int result = Tcl_ParseArgsObjv(interp, argTable, &n, objv, remObjv);
*objcPtr = (int)n;
return result;
}
#endif /* !defined(TCL_NO_DEPRECATED) */
#define TclBN_mp_add mp_add
#define TclBN_mp_add_d mp_add_d
#define TclBN_mp_and mp_and
#define TclBN_mp_clamp mp_clamp
#define TclBN_mp_clear mp_clear
#define TclBN_mp_clear_multi mp_clear_multi
|
| ︙ | ︙ | |||
1499 1500 1501 1502 1503 1504 1505 |
Tcl_GetNumberFromObj, /* 680 */
Tcl_GetNumber, /* 681 */
Tcl_RemoveChannelMode, /* 682 */
Tcl_GetEncodingNulLength, /* 683 */
Tcl_GetWideUIntFromObj, /* 684 */
Tcl_DStringToObj, /* 685 */
0, /* 686 */
| > | | 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 |
Tcl_GetNumberFromObj, /* 680 */
Tcl_GetNumber, /* 681 */
Tcl_RemoveChannelMode, /* 682 */
Tcl_GetEncodingNulLength, /* 683 */
Tcl_GetWideUIntFromObj, /* 684 */
Tcl_DStringToObj, /* 685 */
0, /* 686 */
0, /* 687 */
TclUnusedStubEntry, /* 688 */
};
/* !END!: Do not edit above this line. */
|
Changes to generic/tclTest.c.
| ︙ | ︙ | |||
2024 2025 2026 2027 2028 2029 2030 |
const unsigned char *bytes;
unsigned char *bufPtr;
int srcRead, dstLen, dstWrote, dstChars;
Tcl_Obj *srcReadVar, *dstWroteVar, *dstCharsVar;
int result;
int flags;
Tcl_Obj **flagObjs;
| | | | 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 |
const unsigned char *bytes;
unsigned char *bufPtr;
int srcRead, dstLen, dstWrote, dstChars;
Tcl_Obj *srcReadVar, *dstWroteVar, *dstCharsVar;
int result;
int flags;
Tcl_Obj **flagObjs;
Tcl_Size nflags;
static const struct {
const char *flagKey;
int flag;
} flagMap[] = {
{"start", TCL_ENCODING_START},
{"end", TCL_ENCODING_END},
{"stoponerror", TCL_ENCODING_STOPONERROR},
{"noterminate", TCL_ENCODING_NO_TERMINATE},
{"charlimit", TCL_ENCODING_CHAR_LIMIT},
{"profiletcl8", TCL_ENCODING_PROFILE_TCL8},
{"profilestrict", TCL_ENCODING_PROFILE_STRICT},
{"profilereplace", TCL_ENCODING_PROFILE_REPLACE},
{NULL, 0}
};
Tcl_Size i;
Tcl_WideInt wide;
if (objc < 7 || objc > 10) {
Tcl_WrongNumArgs(interp,
2,
objv,
"encoding srcbytes flags state dstlen ?srcreadvar? ?dstwrotevar? ?dstcharsvar?");
|
| ︙ | ︙ | |||
2414 2415 2416 2417 2418 2419 2420 |
static int
TestevalexObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | > | 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 |
static int
TestevalexObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int flags;
Tcl_Size length;
const char *script;
flags = 0;
if (objc == 3) {
const char *global = Tcl_GetString(objv[2]);
if (strcmp(global, "global") != 0) {
Tcl_AppendResult(interp, "bad value \"", global,
|
| ︙ | ︙ | |||
3053 3054 3055 3056 3057 3058 3059 | /* *---------------------------------------------------------------------- * * TestgetplatformCmd -- * * This procedure implements the "testgetplatform" command. It is | | | 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 | /* *---------------------------------------------------------------------- * * 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. * |
| ︙ | ︙ | |||
3652 3653 3654 3655 3656 3657 3658 |
static int LinkTypes[] = {
TCL_LINK_CHAR, TCL_LINK_UCHAR,
TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_INT, TCL_LINK_UINT,
TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_WIDE_INT, TCL_LINK_WIDE_UINT,
TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS,
TCL_LINK_BINARY
};
| | > | 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 |
static int LinkTypes[] = {
TCL_LINK_CHAR, TCL_LINK_UCHAR,
TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_INT, TCL_LINK_UINT,
TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_WIDE_INT, TCL_LINK_WIDE_UINT,
TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS,
TCL_LINK_BINARY
};
int typeIndex, readonly, i, size;
Tcl_Size length;
char *name, *arg;
Tcl_WideInt addr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option args");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3997 3998 3999 4000 4001 4002 4003 |
TestparserObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
| > | | 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 |
TestparserObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
Tcl_Size dummy;
int length;
Tcl_Parse parse;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "script length");
return TCL_ERROR;
}
script = Tcl_GetStringFromObj(objv[1], &dummy);
|
| ︙ | ︙ | |||
4053 4054 4055 4056 4057 4058 4059 |
TestexprparserObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
| > | | 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 |
TestexprparserObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
Tcl_Size dummy;
int length;
Tcl_Parse parse;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "expr length");
return TCL_ERROR;
}
script = Tcl_GetStringFromObj(objv[1], &dummy);
|
| ︙ | ︙ | |||
4242 4243 4244 4245 4246 4247 4248 |
TestparsevarnameObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
| | > | 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 |
TestparsevarnameObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
int length, append;
Tcl_Size dummy;
Tcl_Parse parse;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "script length append");
return TCL_ERROR;
}
script = Tcl_GetStringFromObj(objv[1], &dummy);
|
| ︙ | ︙ | |||
4375 4376 4377 4378 4379 4380 4381 |
static int
TestregexpObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 |
static int
TestregexpObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, indices, match, about;
Tcl_Size stringLength, ii;
int hasxflags, cflags, eflags;
Tcl_RegExp regExpr;
const char *string;
Tcl_Obj *objPtr;
Tcl_RegExpInfo info;
static const char *const options[] = {
"-indices", "-nocase", "-about", "-expanded",
|
| ︙ | ︙ | |||
4814 4815 4816 4817 4818 4819 4820 | * This procedure implements the "teststaticlibrary" command. * It is used to test the procedure Tcl_StaticLibrary. * * Results: * A standard Tcl result. * * Side effects: | | | 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 | * This procedure implements the "teststaticlibrary" command. * It is used to test the procedure Tcl_StaticLibrary. * * 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 TeststaticlibraryCmd( |
| ︙ | ︙ | |||
5529 5530 5531 5532 5533 5534 5535 |
static int
TeststringbytesObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
| | | 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 |
static int
TeststringbytesObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Size n;
const unsigned char *p;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
return TCL_ERROR;
}
p = (const unsigned char *)Tcl_GetStringFromObj(objv[1], &n);
|
| ︙ | ︙ | |||
7265 7266 7267 7268 7269 7270 7271 |
* (native) directory.
*/
static Tcl_Obj *
SimpleRedirect(
Tcl_Obj *pathPtr) /* Name of file to copy. */
{
| | | 7270 7271 7272 7273 7274 7275 7276 7277 7278 7279 7280 7281 7282 7283 7284 |
* (native) directory.
*/
static Tcl_Obj *
SimpleRedirect(
Tcl_Obj *pathPtr) /* Name of file to copy. */
{
Tcl_Size len;
const char *str;
Tcl_Obj *origPtr;
/*
* We assume the same name in the current directory is ok.
*/
|
| ︙ | ︙ | |||
7855 7856 7857 7858 7859 7860 7861 | /* *---------------------------------------------------------------------- * * TestconcatobjCmd -- * * This procedure implements the "testconcatobj" command. It is used * to test that Tcl_ConcatObj does indeed return a fresh Tcl_Obj in all | | | 7860 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 | /* *---------------------------------------------------------------------- * * 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.
| ︙ | ︙ | |||
895 896 897 898 899 900 901 |
LISTOBJ_GETELEMENTSMEMCHECK,
} cmdIndex;
Tcl_Size varIndex; /* Variable number converted to binary */
Tcl_Size first; /* First index in the list */
Tcl_Size count; /* Count of elements in a list */
Tcl_Obj **varPtr;
| | | 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 |
LISTOBJ_GETELEMENTSMEMCHECK,
} cmdIndex;
Tcl_Size varIndex; /* Variable number converted to binary */
Tcl_Size first; /* First index in the list */
Tcl_Size count; /* Count of elements in a list */
Tcl_Obj **varPtr;
Tcl_Size i, len;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg...?");
return TCL_ERROR;
}
varPtr = GetVarPtr(interp);
if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
|
| ︙ | ︙ |
Changes to generic/tclThreadAlloc.c.
| ︙ | ︙ | |||
933 934 935 936 937 938 939 |
Cache *cachePtr,
int bucket)
{
Block *blockPtr;
size_t n;
/*
| | | 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 |
Cache *cachePtr,
int bucket)
{
Block *blockPtr;
size_t 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 | } /* *---------------------------------------------------------------------- * * TclRememberJoinableThread -- * | | | | 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.
| ︙ | ︙ | |||
268 269 270 271 272 273 274 |
} else {
result = NULL;
}
return ThreadCancel(interp, (Tcl_ThreadId) INT2PTR(id), result, flags);
}
case THREAD_CREATE: {
const char *script;
| | > | 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 |
} else {
result = NULL;
}
return ThreadCancel(interp, (Tcl_ThreadId) INT2PTR(id), result, flags);
}
case THREAD_CREATE: {
const char *script;
int joinable;
Tcl_Size len;
if (objc == 2) {
/*
* Neither joinable nor special script
*/
joinable = 0;
|
| ︙ | ︙ | |||
818 819 820 821 822 823 824 |
if (!found) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp, "invalid thread id", NULL);
return TCL_ERROR;
}
/*
| | | 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 |
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.
| ︙ | ︙ | |||
265 266 267 268 269 270 271 |
}
#ifndef TCL_REMOVE_OBSOLETE_TRACES
case TRACE_OLD_VARIABLE:
case TRACE_OLD_VDELETE: {
Tcl_Obj *copyObjv[6];
Tcl_Obj *opsList;
| | > | 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 |
}
#ifndef TCL_REMOVE_OBSOLETE_TRACES
case TRACE_OLD_VARIABLE:
case TRACE_OLD_VDELETE: {
Tcl_Obj *copyObjv[6];
Tcl_Obj *opsList;
int code;
Tcl_Size numFlags;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
return TCL_ERROR;
}
TclNewObj(opsList);
|
| ︙ | ︙ | |||
1100 1101 1102 1103 1104 1105 1106 | * 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 | | | 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 | * 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( |
| ︙ | ︙ | |||
2924 2925 2926 2927 2928 2929 2930 |
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. */
| | | 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 |
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. */
void *clientData) /* Arbitrary argument to pass to proc. */
{
VarTrace *tracePtr;
VarTrace *prevPtr, *nextPtr;
Var *varPtr, *arrayPtr;
Interp *iPtr = (Interp *) interp;
ActiveVarTrace *activePtr;
|
| ︙ | ︙ | |||
3052 3053 3054 3055 3056 3057 3058 |
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. */
| | | 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 |
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. */
void *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;
|
| ︙ | ︙ | |||
3110 3111 3112 3113 3114 3115 3116 | * actions. * * Results: * A standard Tcl return value. * * Side effects: * A trace is set up on the variable given by part1 and part2, such that | | | 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 | * 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 |
| ︙ | ︙ | |||
3163 3164 3165 3166 3167 3168 3169 | * actions. * * Results: * A standard Tcl return value. * * Side effects: * A trace is set up on the variable given by part1 and part2, such that | | | 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 | * 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.
| ︙ | ︙ | |||
1984 1985 1986 1987 1988 1989 1990 |
*----------------------------------------------------------------------
*/
int
TclUniCharNcasecmp(
const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */
const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
| | | 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 |
*----------------------------------------------------------------------
*/
int
TclUniCharNcasecmp(
const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */
const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
size_t 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.
| ︙ | ︙ | |||
1234 1235 1236 1237 1238 1239 1240 |
#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
| | | 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 |
#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++;
}
|
| ︙ | ︙ | |||
2002 2003 2004 2005 2006 2007 2008 |
}
slow:
/*
* Something cannot be determined to be safe, so build the concatenation
* the slow way, using the string representations.
*
| | | 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 |
}
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 = Tcl_GetStringFromObj(objv[i], &elemLength);
bytesNeeded += elemLength;
}
|
| ︙ | ︙ |
Changes to generic/tclVar.c.
| ︙ | ︙ | |||
627 628 629 630 631 632 633 |
goto donePart1;
}
}
goto doneParsing;
}
/*
| | | 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 |
goto donePart1;
}
}
goto doneParsing;
}
/*
* If part1Ptr is a parsedVarNameType, retrieve the preparsed parts.
*/
ParsedGetInternalRep(part1Ptr, parsed, arrayPtr, elem);
if (parsed && arrayPtr) {
if (part2Ptr != NULL) {
/*
* ERROR: part1Ptr is already an array element, cannot specify
|
| ︙ | ︙ | |||
788 789 790 791 792 793 794 | * * 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 | | | 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 | * * 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.
| ︙ | ︙ | |||
1734 1735 1736 1737 1738 1739 1740 |
}
if (e != Z_OK) {
goto error;
}
/*
| | | 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 |
}
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.
| ︙ | ︙ | |||
176 177 178 179 180 181 182 |
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]
}
}
| | | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 |
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 {
|
| ︙ | ︙ | |||
376 377 378 379 380 381 382 | # 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 | | | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 |
# 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 {} {
|
| ︙ | ︙ | |||
629 630 631 632 633 634 635 |
} 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
| | | 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 |
} 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
}
}
}
|
| ︙ | ︙ | |||
684 685 686 687 688 689 690 |
catch {
set name [dict get [lrange $args 1 end] -command]
if {![string match ::* $name]} {
set name ::[join [lreverse $contextStack] ::]$name
}
regsub -all ::+ $name :: name
}
| | | 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 |
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 | # Parameters: # locale -- Desired locale # # Results: # Returns the locale that was previously current. # # Side effects: | | | 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 | # # ParseStarDate -- # # Parses a StarDate # # Parameters: # year - Year from the Roddenberry epoch | | | 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 | # Parameters: # None. # # Results: # Returns the system time zone. # # Side effects: | | | 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 |
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
| | | 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 |
} else {
set i $event
}
if {$i <= $history(oldest)} {
return -code error "event \"$event\" is too far in the past"
}
if {$i > $history(nextid)} {
| | | 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.
| ︙ | ︙ | |||
3318 3319 3320 3321 3322 3323 3324 | # # Garbage collect the state associated with a transaction # # Arguments # token The token returned from http::geturl # # Side Effects | | | 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 |
#
# 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 {}
}
|
| ︙ | ︙ | |||
3346 3347 3348 3349 3350 3351 3352 |
unset state
}
return
}
# http::Connect
#
| | | 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 |
unset state
}
return
}
# 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
|
| ︙ | ︙ | |||
4453 4454 4455 4456 4457 4458 4459 | # http::CopyDone # # fcopy completion callback # # Arguments # token The token returned from http::geturl | | | 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 |
# 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
|
| ︙ | ︙ |
Changes to library/init.tcl.
| ︙ | ︙ | |||
136 137 138 139 140 141 142 |
# Some machines do not have exec. Also, on all
# platforms, safe interpreters do not have exec.
set auto_noexec 1
}
| | | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 |
# 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.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 |
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
| | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
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.
|
| ︙ | ︙ | |||
207 208 209 210 211 212 213 214 215 216 217 218 219 220 | # msgcat::mcn -- # # Find the translation for the given string based on the current # locale setting. Check the passed namespace first, then look in each # parent namespace until the source is found. If additional args are # specified, use the format command to work them into the translated # string. # If no catalog item is found, mcunknown is called in the caller frame # and its result is returned. # # Arguments: # ns Package namespace of the translation # src The string to translate. # args Args to pass to the format command | > | 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 | # msgcat::mcn -- # # Find the translation for the given string based on the current # locale setting. Check the passed namespace first, then look in each # parent namespace until the source is found. If additional args are # specified, use the format command to work them into the translated # string. # # If no catalog item is found, mcunknown is called in the caller frame # and its result is returned. # # Arguments: # ns Package namespace of the translation # src The string to translate. # args Args to pass to the format command |
| ︙ | ︙ | |||
680 681 682 683 684 685 686 | # unset Clear option. return "". # # Available options are: # # mcfolder # The message catalog folder of the package. # This is automatically set by mcload. | | | 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 | # 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. |
| ︙ | ︙ |
Changes to library/opt/optparse.tcl.
| ︙ | ︙ | |||
71 72 73 74 75 76 77 |
# Array storing the parsed descriptions
variable OptDesc
array set OptDesc {}
# Next potentially free key id (numeric)
variable OptDescN 0
# Inside algorithm/mechanism description:
| | | 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 | # 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 | | | | 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 |
variable OptDesc
if {![info exists OptDesc($descKey)]} {
return -code error "Unknown option description key \"$descKey\""
}
set OptDesc($descKey)
}
| | | 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 |
set item [lindex $descriptions $adress]
if {[OptIsPrg $item]} {
return [OptCurAddr $item $start]
} else {
return $start
}
}
| | | | | | | | 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 |
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
| | | 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 | # 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 | | | 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 |
| ︙ | ︙ | |||
205 206 207 208 209 210 211 |
}
}
}
proc tclPkgUnknown args {}
package unknown tclPkgUnknown
# Stub out the unknown command so package can call into each other
| | | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 |
}
}
}
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} {}
|
| ︙ | ︙ | |||
732 733 734 735 736 737 738 |
error [format $err(valueMissing) "-version"]
}
if {!([llength $opts(-source)] || [llength $opts(-load)])} {
error $err(noLoadOrSource)
}
| | | 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 |
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 |
upvar 1 $vv v
set libclist [lsort [glob -nocomplain -directory $base libc*]]
if {![llength $libclist]} { return 0 }
set libc [lindex $libclist 0]
| | | 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 |
proc ::platform::shell::generic {shell} {
# Argument is the path to a tcl shell.
CHECK $shell
LOCATE base out
set code {}
| | | 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 |
proc ::platform::shell::identify {shell} {
# Argument is the path to a tcl shell.
CHECK $shell
LOCATE base out
set code {}
| | | 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 |
return
}
proc ::platform::shell::LOCATE {bv ov} {
upvar 1 $bv base $ov out
# Locate the platform package for injection into the specified
| | | | 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.
| ︙ | ︙ | |||
190 191 192 193 194 195 196 |
-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
| | | 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 |
-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 ?)\
|
| ︙ | ︙ | |||
245 246 247 248 249 250 251 |
set nested [InterpNested]
} else {
set nested $state(nestedok)
}
if {![::tcl::OptProcArgGiven -deleteHook]} {
set deleteHook $state(cleanupHook)
}
| | | | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 |
set nested [InterpNested]
} else {
set nested $state(nestedok)
}
if {![::tcl::OptProcArgGiven -deleteHook]} {
set deleteHook $state(cleanupHook)
}
# Now reconfigure
set withAutoPath [::tcl::OptProcArgGiven -autoPath]
InterpSetConfig $child $accessPath $statics $nested $deleteHook $autoPath $withAutoPath
# auto_reset the child (to completely sync the new access_path) tests safe-9.8 safe-9.9
if {$doreset} {
if {[catch {::interp eval $child {auto_reset}} msg]} {
Log $child "auto_reset failed: $msg"
} else {
Log $child "successful auto_reset" NOTICE
}
|
| ︙ | ︙ | |||
371 372 373 374 375 376 377 | 0 [info library]] Log $child "tcl_libray was not in first in auto_path,\ moved it to front of child's access_path" NOTICE } set raw_auto_path $access_path | | | 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 |
0 [info library]]
Log $child "tcl_libray was not in first in auto_path,\
moved it to front of child's access_path" NOTICE
}
set raw_auto_path $access_path
# 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]
} else {
set raw_auto_path $autoPath
}
|
| ︙ | ︙ | |||
689 690 691 692 693 694 695 |
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
| | | 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 |
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
|
| ︙ | ︙ | |||
723 724 725 726 727 728 729 |
::interp delete $child
Log $child "Deleted" NOTICE
}
return
}
| | | 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 |
::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 |
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
| | | | 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 |
# 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
| | | 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 |
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
| | | 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 |
# 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
| | | 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 | # (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 | | | | 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 |
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
| | | 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 |
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
}
| | | 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 | } ##################################################################### # tcltest::Debug* -- # # Internal helper procedures to write out debug information | | | 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. |
| ︙ | ︙ | |||
1785 1786 1787 1788 1789 1790 1791 |
#
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
| | | 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 |
#
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 ""
|
| ︙ | ︙ | |||
1892 1893 1894 1895 1896 1897 1898 |
# 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].
| | | 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 |
# 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.
#
|
| ︙ | ︙ | |||
1923 1924 1925 1926 1927 1928 1929 |
}
set TestNames($name) [info script]
}
FillFilesExisted
incr testLevel
| | | 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 |
}
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
|
| ︙ | ︙ | |||
2522 2523 2524 2525 2526 2527 2528 |
}
# Call the cleanup hook
cleanupTestsHook
# Remove files and directories created by the makeFile and
# makeDirectory procedures. Record the names of files in
| | | 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 |
}
# 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}
|
| ︙ | ︙ | |||
3480 3481 3482 3483 3484 3485 3486 |
return 1
}
return 0
}
# Initialize the constraints and set up command line arguments
namespace eval tcltest {
| | | | 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 |
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 | # [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 | | | | 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 | # 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'. # | | | | | 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 | # 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. | | | | 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 | # # Arguments # None # # Results # None. # | | | 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]]
|
| ︙ | ︙ | |||
354 355 356 357 358 359 360 | # # Arguments # paths - List of 'root' paths to derive search paths from. # # Results # No result. # | | | 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 |
#
# 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 | # 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 © 1996 Sun Microsystems, Inc. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | # 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 © 1996 Sun Microsystems, Inc. # Copyright © 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 word characters. See bug [f1253530cdd8]. Will # probably be removed in Tcl 9. |
| ︙ | ︙ |
Changes to libtommath/changes.txt.
| ︙ | ︙ | |||
408 409 410 411 412 413 414 |
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
| | | 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 | ######################################################################################################## # # Makefile wrapper to build tcl on Mac OS X in a way compatible with the tk/macosx Xcode buildsystem | | | 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 <das@users.sourceforge.net> # # 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 |
--prefix="${PREFIX}" --bindir="${BINDIR}" --libdir="${LIBDIR}" \
--mandir="${MANDIR}" --enable-framework --enable-dtrace --disable-zipfs \
${CONFIGURE_ARGS} ${EXTRA_CONFIGURE_ARGS}; else ./config.status; fi
build-${PROJECT}: ${objdir}/Makefile
${DO_MAKE}
ifeq (${INSTALL_BUILD},)
| | | 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
--prefix="${PREFIX}" --bindir="${BINDIR}" --libdir="${LIBDIR}" \
--mandir="${MANDIR}" --enable-framework --enable-dtrace --disable-zipfs \
${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.
| ︙ | ︙ | |||
488 489 490 491 492 493 494 | * 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 | | | 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 | * 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.
| ︙ | ︙ | |||
1346 1347 1348 1349 1350 1351 1352 | * TclpWaitForEvent -- * * 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: | | | 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 | * TclpWaitForEvent -- * * 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 | # 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 | | | 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.
| ︙ | ︙ | |||
3568 3569 3570 3571 3572 3573 3574 |
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
| | | 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 |
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
|
| ︙ | ︙ | |||
5306 5307 5308 5309 5310 5311 5312 |
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 D {1 {bad value for -eofchar: must be non-NUL ASCII character}}}
| > | | > | 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 |
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 D {1 {bad value for -eofchar: must be non-NUL ASCII character}}}
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
|
| ︙ | ︙ | |||
6864 6865 6866 6867 6868 6869 6870 |
chan puts -nonewline $out [chan read $in]
chan close $in
chan close $out
list [file size $path(kyrillic.txt)] \
[file size $path(utf8-fcopy.txt)] \
[file size $path(utf8-rp.txt)]
} {3 5 5}
| | < | > | 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 |
chan puts -nonewline $out [chan read $in]
chan close $in
chan close $out
list [file size $path(kyrillic.txt)] \
[file size $path(utf8-fcopy.txt)] \
[file size $path(utf8-rp.txt)]
} {3 5 5}
test chan-io-52.10 {TclCopyChannel & encodings} -constraints {fcopy} -body {
set in [open $path(kyrillic.txt) r]
set out [open $path(utf8-fcopy.txt) w]
chan configure $in -encoding koi8-r -translation lf
# -translation binary is also -encoding binary
chan configure $out -translation binary
chan copy $in $out
chan close $in
chan close $out
file size $path(utf8-fcopy.txt)
} -returnCodes 1 -match glob -result {error writing "*":\
invalid or incomplete multibyte or wide character}
test chan-io-52.11 {TclCopyChannel & encodings} -setup {
set f [open $path(utf8-fcopy.txt) w]
fconfigure $f -encoding utf-8 -translation lf
puts $f АА
close $f
} -constraints {fcopy} -body {
set in [open $path(utf8-fcopy.txt) r]
|
| ︙ | ︙ | |||
7609 7610 7611 7612 7613 7614 7615 |
#chan seek $f 0 current
#lappend res [chan read $f; chan tell $f]
} -cleanup {
chan close $f
removeFile eofchar
} -result {77 = 23431}
| | | 7611 7612 7613 7614 7615 7616 7617 7618 7619 7620 7621 7622 7623 7624 7625 |
#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.
| ︙ | ︙ | |||
36039 36040 36041 36042 36043 36044 36045 |
unset oldTZ
} else {
unset env(TZ)
}
} \
-result {-0500}
| | | 36039 36040 36041 36042 36043 36044 36045 36046 36047 36048 36049 36050 36051 36052 36053 |
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.
| ︙ | ︙ | |||
1720 1721 1722 1723 1724 1725 1726 |
} -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
| | | 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 |
} -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]} -setup {
set filename [makeFile "" foo.text]
} -body {
list [file atime $filename 3155760000] [file atime $filename]
} -cleanup {
removeFile $filename
} -result {3155760000 3155760000}
|
| ︙ | ︙ | |||
2126 2127 2128 2129 2130 2131 2132 |
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
| | | 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 |
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.
| ︙ | ︙ | |||
51 52 53 54 55 56 57 |
} -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
| | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
} -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 0
pwd
} -returnCodes error -cleanup {
cd $cwd
file delete -force $foodir
|
| ︙ | ︙ |
Changes to tests/compile.test.
| ︙ | ︙ | |||
516 517 518 519 520 521 522 |
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
| | | 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 |
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.
| ︙ | ︙ | |||
1105 1106 1107 1108 1109 1110 1111 |
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 {{} {
| | | 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 |
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/encoding.test.
| ︙ | ︙ | |||
461 462 463 464 465 466 467 |
binary scan $y H* z
list [string length $y] $z
} {2 cfbf}
test encoding-15.25 {UtfToUtfProc CESU-8} {
encoding convertfrom cesu-8 \x00
} \x00
test encoding-15.26 {UtfToUtfProc CESU-8} {
| | | 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 |
binary scan $y H* z
list [string length $y] $z
} {2 cfbf}
test encoding-15.25 {UtfToUtfProc CESU-8} {
encoding convertfrom cesu-8 \x00
} \x00
test encoding-15.26 {UtfToUtfProc CESU-8} {
encoding convertfrom -profile tcl8 cesu-8 \xC0\x80
} \x00
test encoding-15.27 {UtfToUtfProc -profile strict CESU-8} {
encoding convertfrom -profile strict cesu-8 \x00
} \x00
test encoding-15.28 {UtfToUtfProc -profile strict CESU-8} -body {
encoding convertfrom -profile strict cesu-8 \xC0\x80
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'}
|
| ︙ | ︙ | |||
488 489 490 491 492 493 494 |
list $val [format %x [scan $val %c]]
} -result "乎 4e4e"
test encoding-16.2 {Utf16ToUtfProc} -body {
set val [encoding convertfrom utf-16 "\xD8\xD8\xDC\xDC"]
list $val [format %x [scan $val %c]]
} -result "\U460DC 460dc"
test encoding-16.3 {Utf16ToUtfProc} -body {
| | | | | | | | | | | | 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 |
list $val [format %x [scan $val %c]]
} -result "乎 4e4e"
test encoding-16.2 {Utf16ToUtfProc} -body {
set val [encoding convertfrom utf-16 "\xD8\xD8\xDC\xDC"]
list $val [format %x [scan $val %c]]
} -result "\U460DC 460dc"
test encoding-16.3 {Utf16ToUtfProc} -body {
set val [encoding convertfrom -profile tcl8 utf-16 "\xDC\xDC"]
list $val [format %x [scan $val %c]]
} -result "\uDCDC dcdc"
test encoding-16.4 {Ucs2ToUtfProc} -body {
set val [encoding convertfrom ucs-2 NN]
list $val [format %x [scan $val %c]]
} -result "乎 4e4e"
test encoding-16.5 {Ucs2ToUtfProc} -body {
set val [encoding convertfrom ucs-2 "\xD8\xD8\xDC\xDC"]
list $val [format %x [scan $val %c]]
} -result "\U460DC 460dc"
test encoding-16.6 {Utf32ToUtfProc} -body {
set val [encoding convertfrom -profile strict utf-32le NN\0\0]
list $val [format %x [scan $val %c]]
} -result "乎 4e4e"
test encoding-16.7 {Utf32ToUtfProc} -body {
set val [encoding convertfrom -profile strict utf-32be \0\0NN]
list $val [format %x [scan $val %c]]
} -result "乎 4e4e"
test encoding-16.8 {Utf32ToUtfProc} -body {
set val [encoding convertfrom -profile tcl8 utf-32 \x41\x00\x00\x41]
list $val [format %x [scan $val %c]]
} -result "\uFFFD fffd"
test encoding-16.9 {Utf32ToUtfProc} -constraints utf32 -body {
encoding convertfrom -profile tcl8 utf-32le \x00\xD8\x00\x00
} -result \uD800
test encoding-16.10 {Utf32ToUtfProc} -body {
encoding convertfrom -profile tcl8 utf-32le \x00\xDC\x00\x00
} -result \uDC00
test encoding-16.11 {Utf32ToUtfProc} -body {
encoding convertfrom -profile tcl8 utf-32le \x00\xD8\x00\x00\x00\xDC\x00\x00
} -result \uD800\uDC00
test encoding-16.12 {Utf32ToUtfProc} -constraints utf32 -body {
encoding convertfrom -profile tcl8 utf-32le \x00\xDC\x00\x00\x00\xD8\x00\x00
} -result \uDC00\uD800
test encoding-16.13 {Utf16ToUtfProc} -body {
encoding convertfrom -profile tcl8 utf-16le \x00\xD8
} -result \uD800
test encoding-16.14 {Utf16ToUtfProc} -body {
encoding convertfrom -profile tcl8 utf-16le \x00\xDC
} -result \uDC00
test encoding-16.15 {Utf16ToUtfProc} -body {
encoding convertfrom utf-16le \x00\xD8\x00\xDC
} -result \U010000
test encoding-16.16 {Utf16ToUtfProc} -body {
encoding convertfrom -profile tcl8 utf-16le \x00\xDC\x00\xD8
} -result \uDC00\uD800
test encoding-16.17 {Utf32ToUtfProc} -body {
list [encoding convertfrom -profile strict -failindex idx utf-32le \x41\x00\x00\x00\x00\xD8\x00\x00\x42\x00\x00\x00] [set idx]
} -result {A 4}
test encoding-16.18 {
Utf16ToUtfProc, Tcl_UniCharToUtf, surrogate pairs in utf-16
|
| ︙ | ︙ | |||
559 560 561 562 563 564 565 |
}
}
}
return done
} [namespace current]]
} -result done
test encoding-16.19 {Utf16ToUtfProc, bug [d19fe0a5b]} -body {
| | | | | | | | | 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 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 |
}
}
}
return done
} [namespace current]]
} -result done
test encoding-16.19 {Utf16ToUtfProc, bug [d19fe0a5b]} -body {
encoding convertfrom -profile tcl8 utf-16 "\x41\x41\x41"
} -result \u4141\uFFFD
test encoding-16.20 {Utf16ToUtfProc, bug [d19fe0a5b]} -constraints deprecated -body {
encoding convertfrom utf-16 "\xD8\xD8"
} -result \uD8D8
test encoding-16.21 {Utf32ToUtfProc, bug [d19fe0a5b]} -body {
encoding convertfrom -profile tcl8 utf-32 "\x00\x00\x00\x00\x41\x41"
} -result \x00\uFFFD
test encoding-16.22 {Utf16ToUtfProc, strict, bug [db7a085bd9]} -body {
encoding convertfrom -profile strict utf-16le \x00\xD8
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\x00'}
test encoding-16.23 {Utf16ToUtfProc, strict, bug [db7a085bd9]} -body {
encoding convertfrom -profile strict utf-16le \x00\xDC
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\x00'}
test encoding-16.24 {Utf32ToUtfProc} -body {
encoding convertfrom -profile tcl8 utf-32 "\xFF\xFF\xFF\xFF"
} -result \uFFFD
test encoding-16.25 {Utf32ToUtfProc} -body {
encoding convertfrom -profile tcl8 utf-32 "\x01\x00\x00\x01"
} -result \uFFFD
test encoding-17.1 {UtfToUtf16Proc} -body {
encoding convertto utf-16 "\U460DC"
} -result "\xD8\xD8\xDC\xDC"
test encoding-17.2 {UtfToUcs2Proc} -body {
encoding convertfrom utf-16 \xD8\xD8\xDC\xDC
} -result "\U460DC"
test encoding-17.3 {UtfToUtf16Proc} -body {
encoding convertto -profile tcl8 utf-16be "\uDCDC"
} -result "\xDC\xDC"
test encoding-17.4 {UtfToUtf16Proc} -body {
encoding convertto -profile tcl8 utf-16le "\uD8D8"
} -result "\xD8\xD8"
test encoding-17.5 {UtfToUtf32Proc} -body {
encoding convertto utf-32le "\U460DC"
} -result "\xDC\x60\x04\x00"
test encoding-17.6 {UtfToUtf32Proc} -body {
encoding convertto utf-32be "\U460DC"
} -result "\x00\x04\x60\xDC"
test encoding-17.7 {UtfToUtf16Proc} -body {
encoding convertto -profile strict utf-16be "\uDCDC"
} -returnCodes error -result {unexpected character at index 0: 'U+00DCDC'}
test encoding-17.8 {UtfToUtf16Proc} -body {
encoding convertto -profile strict utf-16le "\uD8D8"
|
| ︙ | ︙ | |||
618 619 620 621 622 623 624 |
encoding convertfrom -profile strict utf-32le "\x00\xD8\x00\x00"
} -returnCodes error -result {unexpected byte sequence starting at index 0: '\x00'}
test encoding-17.12 {Utf32ToUtfProc} -body {
encoding convertfrom -profile strict utf-32le "\x00\xDC\x00\x00"
} -returnCodes error -result {unexpected byte sequence starting at index 0: '\x00'}
test encoding-18.1 {TableToUtfProc on invalid input} -body {
| | | | | | 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 657 658 659 660 |
encoding convertfrom -profile strict utf-32le "\x00\xD8\x00\x00"
} -returnCodes error -result {unexpected byte sequence starting at index 0: '\x00'}
test encoding-17.12 {Utf32ToUtfProc} -body {
encoding convertfrom -profile strict utf-32le "\x00\xDC\x00\x00"
} -returnCodes error -result {unexpected byte sequence starting at index 0: '\x00'}
test encoding-18.1 {TableToUtfProc on invalid input} -body {
list [catch {encoding convertto -profile tcl8 jis0208 \\} res] $res
} -result {0 !)}
test encoding-18.2 {TableToUtfProc on invalid input with -profile strict} -body {
list [catch {encoding convertto -profile strict jis0208 \\} res] $res
} -result {1 {unexpected character at index 0: 'U+00005C'}}
test encoding-18.3 {TableToUtfProc on invalid input with -profile strict -failindex} -body {
list [catch {encoding convertto -profile strict -failindex pos jis0208 \\} res] $res $pos
} -result {0 {} 0}
test encoding-18.4 {TableToUtfProc on invalid input with -failindex -profile strict} -body {
list [catch {encoding convertto -failindex pos -profile strict jis0208 \\} res] $res $pos
} -result {0 {} 0}
test encoding-18.5 {TableToUtfProc on invalid input with -failindex} -body {
list [catch {encoding convertto -profile tcl8 -failindex pos jis0208 \\} res] $res $pos
} -result {0 !) -1}
test encoding-18.6 {TableToUtfProc on invalid input with -profile tcl8} -body {
list [catch {encoding convertto -profile tcl8 jis0208 \\} res] $res
} -result {0 !)}
test encoding-19.1 {TableFromUtfProc} -body {
encoding convertfrom -profile tcl8 ascii AÁ
} -result AÁ
test encoding-19.2 {TableFromUtfProc} -body {
encoding convertfrom -profile tcl8 ascii AÁ
} -result AÁ
test encoding-19.3 {TableFromUtfProc} -body {
encoding convertfrom -profile strict ascii AÁ
} -returnCodes 1 -result {unexpected byte sequence starting at index 1: '\xC1'}
test encoding-19.4 {TableFromUtfProc} -body {
list [encoding convertfrom -profile tcl8 -failindex idx ascii AÁ] [set idx]
} -result [list A\xC1 -1]
test encoding-19.5 {TableFromUtfProc} -body {
list [encoding convertfrom -failindex idx -profile strict ascii A\xC1] [set idx]
} -result {A 1}
test encoding-19.6 {TableFromUtfProc} -body {
list [encoding convertfrom -failindex idx -profile strict ascii AÁB] [set idx]
} -result {A 1}
|
| ︙ | ︙ | |||
795 796 797 798 799 800 801 |
test encoding-24.13 {Parse valid or invalid utf-8} -body {
encoding convertfrom -profile strict utf-8 "\xC1\xBF"
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC1'}
test encoding-24.14 {Parse valid or invalid utf-8} {
string length [encoding convertfrom utf-8 "\xC2\x80"]
} 1
test encoding-24.15 {Parse valid or invalid utf-8} -body {
| | | 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 |
test encoding-24.13 {Parse valid or invalid utf-8} -body {
encoding convertfrom -profile strict utf-8 "\xC1\xBF"
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC1'}
test encoding-24.14 {Parse valid or invalid utf-8} {
string length [encoding convertfrom utf-8 "\xC2\x80"]
} 1
test encoding-24.15 {Parse valid or invalid utf-8} -body {
encoding convertfrom -profile tcl8 utf-8 "Z\xE0\x80"
} -result Z\xE0\u20AC
test encoding-24.16 {Parse valid or invalid utf-8} -constraints testbytestring -body {
encoding convertto utf-8 [testbytestring "Z\u4343\x80"]
} -returnCodes 1 -result {expected byte sequence but character 1 was '䍃' (U+004343)}
test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body {
encoding convertto utf-8 [testbytestring "Z\xE0\x80"]
} -result "Z\xC3\xA0\xE2\x82\xAC"
|
| ︙ | ︙ | |||
858 859 860 861 862 863 864 |
test encoding-24.33 {Try to generate noncharacter with -profile strict} -body {
encoding convertto -profile strict utf-8 \uFFFF
} -result \xEF\xBF\xBF
test encoding-24.34 {Try to generate invalid utf-8 with -profile tcl8} -body {
encoding convertto -profile tcl8 utf-8 \uFFFF
} -result \xEF\xBF\xBF
test encoding-24.35 {Parse invalid utf-8} -constraints utf32 -body {
| | | 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 |
test encoding-24.33 {Try to generate noncharacter with -profile strict} -body {
encoding convertto -profile strict utf-8 \uFFFF
} -result \xEF\xBF\xBF
test encoding-24.34 {Try to generate invalid utf-8 with -profile tcl8} -body {
encoding convertto -profile tcl8 utf-8 \uFFFF
} -result \xEF\xBF\xBF
test encoding-24.35 {Parse invalid utf-8} -constraints utf32 -body {
encoding convertfrom -profile tcl8 utf-8 \xED\xA0\x80
} -result \uD800
test encoding-24.36 {Parse invalid utf-8 with -profile strict} -body {
encoding convertfrom -profile strict utf-8 \xED\xA0\x80
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xED'}
test encoding-24.37 {Parse invalid utf-8 with -profile tcl8} -body {
encoding convertfrom -profile tcl8 utf-8 \xED\xA0\x80
} -result \uD800
|
| ︙ | ︙ |
Changes to tests/env.test.
| ︙ | ︙ | |||
217 218 219 220 221 222 223 |
getenv
} -cleanup { cleanup1
} -result {NAME1=test string
NAME2=more
XYZZY=garbage}
test env-2.5 {different encoding (wide chars)} -constraints {win exec} -setup {
| | | | 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 |
} -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
| | | 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 |
} -result {a 1}
test env-5.4 {corner cases - unset the env array} -setup {
setup1
interp create i
} -body {
| | | 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 |
} finally {
throw BAR baz
}
}
list $em [dict get $opts -errorcode]
} {bar FOO}
| | | 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 |
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]
| | | | 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.
| ︙ | ︙ | |||
423 424 425 426 427 428 429 |
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
| | | 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 |
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 |
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
| | | 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/fCmd.test.
| ︙ | ︙ | |||
83 84 85 86 87 88 89 |
testConstraint notContinuousIntegration [expr {![info exists ::env(CI)]}]
testConstraint fileSharing 0
testConstraint notFileSharing 1
testConstraint linkFile 1
testConstraint linkDirectory 1
| | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 |
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 {
|
| ︙ | ︙ | |||
879 880 881 882 883 884 885 |
createfile -force
file delete -force -force -- -- -force
glob -- -- -force
} -result {}
test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \
-constraints {unix notRoot knownBug tildeexpansion} -body {
| | | 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 |
createfile -force
file delete -force -force -- -- -force
glob -- -- -force
} -result {}
test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \
-constraints {unix notRoot knownBug tildeexpansion} -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 == ~} \
|
| ︙ | ︙ | |||
979 980 981 982 983 984 985 |
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 exists}} 1 1 0 0}
test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup {
cleanup
} -constraints {notRoot testchmod notNetworkFilesystem} -body {
| | | 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 |
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 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
|
| ︙ | ︙ | |||
2533 2534 2535 2536 2537 2538 2539 |
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
| | | 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 |
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.
| ︙ | ︙ | |||
1343 1344 1345 1346 1347 1348 1349 |
# 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...
| | | 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 |
# 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} {
# ~xxx no longer expanded so errors about unknown users should not occur
list [catch {glob -nocomplain ~wontexist ~blahxyz ~} res1] $res1 \
[catch {glob -nocomplain ~ ~blahxyz ~wontexist} res2] $res2
} {0 {} 0 {}}
|
| ︙ | ︙ |
Changes to tests/fileSystem.test.
| ︙ | ︙ | |||
293 294 295 296 297 298 299 |
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]} {
| | | 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 |
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 |
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 {} \
| | | 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 | ts written for earlier releases should work on these new releases as well. Obtaining The Releases Binary Releases | | | 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 procedures in file # tkIndexObj.c, which implement indexed table lookups. The tests here are # organized in the standard fashion for Tcl tests. # # Copyright © 1997 Sun Microsystems, Inc. # Copyright © 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 |
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)]} {
| | | 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.
| ︙ | ︙ | |||
1616 1617 1618 1619 1620 1621 1622 |
} 160
test io-12.9 {ReadChars: multibyte chars split} -body {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f [string repeat a 9]\xC2
close $f
set f [open $path(test1)]
| | | 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 |
} 160
test io-12.9 {ReadChars: multibyte chars split} -body {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f [string repeat a 9]\xC2
close $f
set f [open $path(test1)]
fconfigure $f -encoding utf-8 -profile tcl8 -buffersize 10
set in [read $f]
close $f
scan [string index $in end] %c
} -cleanup {
catch {close $f}
} -result 194
test io-12.10 {ReadChars: multibyte chars split} -body {
|
| ︙ | ︙ | |||
3894 3895 3896 3897 3898 3899 3900 |
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
| | | 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 |
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
|
| ︙ | ︙ | |||
5851 5852 5853 5854 5855 5856 5857 |
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
} -result {O D {1 {bad value for -eofchar: must be non-NUL ASCII character}}}
test io-39.23 {Tcl_GetChannelOption, server socket is not readable or
| | | 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 |
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
} -result {O D {1 {bad value for -eofchar: must be non-NUL ASCII character}}}
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
|
| ︙ | ︙ | |||
7496 7497 7498 7499 7500 7501 7502 |
close $in
close $out
list [file size $path(kyrillic.txt)] \
[file size $path(utf8-fcopy.txt)] \
[file size $path(utf8-rp.txt)]
} {3 5 5}
| | < < < | > | 7496 7497 7498 7499 7500 7501 7502 7503 7504 7505 7506 7507 7508 7509 7510 7511 7512 7513 7514 7515 7516 7517 7518 7519 7520 7521 7522 7523 7524 |
close $in
close $out
list [file size $path(kyrillic.txt)] \
[file size $path(utf8-fcopy.txt)] \
[file size $path(utf8-rp.txt)]
} {3 5 5}
test io-52.10 {TclCopyChannel & encodings} -constraints fcopy -body {
set in [open $path(kyrillic.txt) r]
set out [open $path(utf8-fcopy.txt) w]
fconfigure $in -encoding koi8-r -translation lf
# -translation binary is also -encoding binary
fconfigure $out -translation binary
fcopy $in $out
close $in
close $out
file size $path(utf8-fcopy.txt)
} -returnCodes 1 -match glob -result {error writing "*":\
invalid or incomplete multibyte or wide character}
test io-52.11 {TclCopyChannel & encodings} -setup {
set out [open $path(utf8-fcopy.txt) w]
fconfigure $out -encoding utf-8 -translation lf -profile strict
puts $out АА
close $out
} -constraints {fcopy} -body {
set in [open $path(utf8-fcopy.txt) r]
|
| ︙ | ︙ | |||
8370 8371 8372 8373 8374 8375 8376 |
set out [open $outFile wb]
chan copy $in $out
} -cleanup {
catch {close $in}
catch {close $out}
removeFile out
rename driver {}
| | | 8368 8369 8370 8371 8372 8373 8374 8375 8376 8377 8378 8379 8380 8381 8382 |
set out [open $outFile wb]
chan copy $in $out
} -cleanup {
catch {close $in}
catch {close $out}
removeFile out
rename driver {}
} -result {error reading "rc*": *} -returnCodes error -match glob
test io-53.14 {TclCopyChannel: write error reporting} -setup {
proc driver {cmd args} {
variable buffer
variable index
set chan [lindex $args 0]
switch -- $cmd {
initialize {
|
| ︙ | ︙ | |||
8837 8838 8839 8840 8841 8842 8843 |
close $f
set res
} -cleanup {
removeFile eofchar
} -result {77 = 23431}
| | | 8835 8836 8837 8838 8839 8840 8841 8842 8843 8844 8845 8846 8847 8848 8849 |
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]
|
| ︙ | ︙ | |||
9169 9170 9171 9172 9173 9174 9175 |
read [teststringobj get 2]
} -cleanup {
interp delete child
testobj freeallvars
removeFile io-74.1
} -returnCodes error -match glob -result {can not find channel named "*"}
| | | 9167 9168 9169 9170 9171 9172 9173 9174 9175 9176 9177 9178 9179 9180 9181 |
read [teststringobj get 2]
} -cleanup {
interp delete child
testobj freeallvars
removeFile io-74.1
} -returnCodes error -match glob -result {can not find channel named "*"}
test io-75.1 {multibyte encoding error read results in raw bytes (-profile tcl8)} -setup {
set fn [makeFile {} io-75.1]
set f [open $fn w+]
fconfigure $f -encoding binary
# In UTF-8, a byte 0xCx starts a multibyte sequence and must be followed
# by a byte > 0x7F. This is violated to get an invalid sequence.
puts -nonewline $f A\xC0\x40
flush $f
|
| ︙ | ︙ | |||
9260 9261 9262 9263 9264 9265 9266 |
binary scan $d H* hd
set hd
} -cleanup {
close $f
removeFile io-75.5
} -result 4181
| | | | > | > > | > | > | > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | < < | > > > > > > > > | | > > > | > | > | > > > > | > > > > > | | > > | > > > > | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 9258 9259 9260 9261 9262 9263 9264 9265 9266 9267 9268 9269 9270 9271 9272 9273 9274 9275 9276 9277 9278 9279 9280 9281 9282 9283 9284 9285 9286 9287 9288 9289 9290 9291 9292 9293 9294 9295 9296 9297 9298 9299 9300 9301 9302 9303 9304 9305 9306 9307 9308 9309 9310 9311 9312 9313 9314 9315 9316 9317 9318 9319 9320 9321 9322 9323 9324 9325 9326 9327 9328 9329 9330 9331 9332 9333 9334 9335 9336 9337 9338 9339 9340 9341 9342 9343 9344 9345 9346 9347 9348 9349 9350 9351 9352 9353 9354 9355 9356 9357 9358 9359 9360 9361 9362 9363 9364 9365 9366 9367 9368 9369 9370 9371 9372 9373 9374 9375 9376 9377 9378 9379 9380 9381 9382 9383 9384 9385 9386 9387 9388 9389 9390 9391 9392 9393 9394 9395 9396 9397 9398 9399 9400 9401 9402 9403 9404 9405 9406 9407 9408 9409 9410 9411 9412 9413 9414 9415 9416 9417 9418 9419 9420 9421 9422 9423 9424 9425 9426 9427 9428 9429 9430 9431 9432 9433 9434 9435 9436 9437 9438 9439 9440 9441 9442 9443 9444 9445 9446 9447 9448 9449 9450 9451 9452 9453 9454 9455 9456 9457 9458 9459 9460 9461 9462 9463 9464 9465 9466 9467 9468 9469 9470 9471 9472 9473 9474 9475 9476 9477 9478 9479 9480 9481 9482 9483 9484 9485 9486 9487 9488 9489 9490 9491 9492 9493 9494 9495 9496 9497 9498 9499 9500 9501 9502 9503 9504 9505 9506 9507 9508 9509 9510 9511 9512 9513 9514 9515 9516 9517 9518 9519 9520 9521 9522 9523 9524 9525 9526 9527 9528 9529 9530 9531 9532 9533 9534 9535 9536 9537 9538 9539 9540 9541 9542 9543 9544 9545 9546 9547 9548 9549 9550 9551 9552 9553 9554 9555 9556 9557 9558 9559 9560 9561 9562 9563 |
binary scan $d H* hd
set hd
} -cleanup {
close $f
removeFile io-75.5
} -result 4181
test io-75.6 {invalid utf-8 encoding, gets is not ignored (-profile strict)} -setup {
set fn [makeFile {} io-75.6]
set f [open $fn w+]
fconfigure $f -encoding binary
# \x81 is an incomplete byte sequence in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar {} \
-translation lf -profile strict
} -body {
gets $f
} -cleanup {
close $f
removeFile io-75.6
} -match glob -returnCodes 1 -result {error reading "file*":\
invalid or incomplete multibyte or wide character}
test io-75.7 {
invalid utf-8 encoding gets is not ignored (-profile strict)
} -setup {
set fn [makeFile {} io-75.7]
set f [open $fn w+]
fconfigure $f -encoding binary
# \x81 is invalid in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf \
-profile strict
} -body {
read $f
} -cleanup {
close $f
removeFile io-75.7
} -match glob -returnCodes 1 -result {error reading "file*":\
invalid or incomplete multibyte or wide character}
test io-75.8 {invalid utf-8 encoding eof handling (-profile strict)} -setup {
set fn [makeFile {} io-75.8]
set f [open $fn w+]
fconfigure $f -encoding binary
# \x81 is invalid in utf-8, but since \x1A comes first, -eofchar takes
# precedence.
puts -nonewline $f A\x1A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \
-translation lf -profile strict
} -body {
set d [read $f]
binary scan $d H* hd
lappend hd [eof $f]
lappend hd [read $f]
close $f
set hd
} -cleanup {
removeFile io-75.8
} -result {41 1 {}}
test io-75.8.eoflater {invalid utf-8 encoding eof handling (-profile strict)} -setup {
set res {}
set fn [makeFile {} io-75.8]
set f [open $fn w+]
# This also configures the channel encoding profile as strict.
fconfigure $f -encoding binary
# \x81 is invalid in utf-8. -eofchar is not detected, because it comes later.
puts -nonewline $f A\x81\x81\x1A
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \
-translation lf -profile strict
} -body {
set status [catch {read $f} cres copts]
lappend res $status
lappend res [eof $f]
chan configure $f -encoding iso8859-1
lappend res [read $f 1]
chan configure $f -encoding utf-8
catch {read $f 1} cres
lappend res $cres
close $f
set res
} -cleanup {
removeFile io-75.8
} -match glob -result "1 0 \x81 {error reading \"*\":\
invalid or incomplete multibyte or wide character}"
test io-strict-multibyte-eof {
incomplete utf-8 sequence immediately prior to eof character
See issue 25cdcb7e8fb381fb
} -setup {
set res {}
set chan [file tempfile];
fconfigure $chan -encoding binary
puts -nonewline $chan \x81\x1A
flush $chan
seek $chan 0
chan configure $chan -encoding utf-8 -profile strict
} -body {
set status [catch {read $chan 1} cres]
lappend res $status $cres
} -cleanup {
close $chan
unset res
} -match glob -result {1 {error reading "*":\
invalid or incomplete multibyte or wide character}}
test io-75.9 {unrepresentable character write passes and is replaced by ?} -setup {
set fn [makeFile {} io-75.9]
set f [open $fn w+]
fconfigure $f -encoding iso8859-1 -profile strict
} -body {
catch {puts -nonewline $f "A\u2022"} msg
flush $f
seek $f 0
list [read $f] $msg
} -cleanup {
close $f
removeFile io-75.9
} -match glob -result [list {A} {error writing "*":\
invalid or incomplete multibyte or wide character}]
test io-75.10 {
incomplete multibyte encoding read is not ignored because "binary" sets
profile to strict
} -setup {
set res {}
set fn [makeFile {} io-75.10]
set f [open $fn w+]
fconfigure $f -encoding binary
puts -nonewline $f A\xC0
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none
} -body {
catch {read $f} errmsg
lappend res $errmsg
seek $f 0
chan configure $f -profile tcl8
set d [read $f]
binary scan $d H* hd
lappend res $hd
return $res
} -cleanup {
close $f
removeFile io-75.10
unset result
} -match glob -result {{error reading "file*":\
invalid or incomplete multibyte or wide character} 41c0}
# The current result returns the orphan byte as byte.
# This may be expected due to special utf-8 handling.
# As utf-8 has a special treatment in multi-byte decoding, also test another
# one.
test io-75.11 {shiftjis encoding error read results in raw bytes} -setup {
set fn [makeFile {} io-75.11]
set f [open $fn w+]
fconfigure $f -encoding binary
# In shiftjis, \x81 starts a two-byte sequence.
# But 2nd byte \xFF is not allowed
puts -nonewline $f A\x81\xFFA
flush $f
seek $f 0
fconfigure $f -encoding shiftjis -blocking 0 -eofchar {} -translation lf \
-profile strict
} -body {
set d [read $f]
binary scan $d H* hd
lappend hd [catch {set d [read $f]} msg]
lappend hd $msg
} -cleanup {
close $f
removeFile io-75.11
} -match glob -result {41 1 {error reading "file*":\
invalid or incomplete multibyte or wide character}}
test io-75.12 {
invalid utf-8 encoding read is not ignored because setting the encoding to
"binary" also set the profile to strict
} -setup {
set res {}
set fn [makeFile {} io-75.12]
set f [open $fn w+]
fconfigure $f -encoding binary
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf
} -body {
catch {read $f} errmsg
lappend res $errmsg
chan configure $f -profile tcl8
seek $f 0
set d [read $f]
binary scan $d H* hd
lappend res $hd
return $res
} -cleanup {
close $f
removeFile io-75.12
unset res
} -match glob -result {{error reading "file*":\
invalid or incomplete multibyte or wide character} 4181}
test io-75.13 {
In nonblocking mode when there is an encoding error the data that has been
successfully read so far is returned first and then the error is returned
on the next call to [read].
} -setup {
set fn [makeFile {} io-75.13]
set f [open $fn w+]
fconfigure $f -encoding binary
# \x81 is invalid in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -blocking 0 -eofchar {} -translation lf \
-profile strict
} -body {
set d [read $f]
binary scan $d H* hd
lappend hd [catch {read $f} msg]
lappend hd $msg
} -cleanup {
close $f
removeFile io-75.13
} -match glob -result {41 1 {error reading "file*":\
invalid or incomplete multibyte or wide character}}
test io-75.14 {
[gets] succesfully returns lines prior to error
invalid utf-8 encoding [gets] continues in non-strict mode after error
} -setup {
set chan [file tempfile]
fconfigure $chan -encoding binary
# \xc0\n is an invalid utf-8 sequence
puts -nonewline $chan a\nb\nc\xc0\nd\n
flush $chan
seek $chan 0
fconfigure $chan -encoding utf-8 -buffering none -eofchar {} \
-translation auto -profile strict
} -body {
lappend res [gets $chan]
lappend res [gets $chan]
set status [catch {gets $chan} cres copts]
lappend res $status $cres
chan configure $chan -profile tcl8
lappend res [gets $chan]
lappend res [gets $chan]
close $chan
return $res
} -match glob -result {a b 1 {error reading "*":\
invalid or incomplete multibyte or wide character} cÀ d}
test io-75.15 {
invalid utf-8 encoding strict
gets does not hang
gets succeeds for the first two lines
} -setup {
set res {}
set chan [file tempfile]
fconfigure $chan -encoding binary
# \xc0\x40 is an invalid utf-8 sequence
puts $chan hello\nAB\nCD\xc0\x40EF\nGHI
seek $chan 0
} -body {
#Now try to read it with [gets]
fconfigure $chan -encoding utf-8 -profile strict
lappend res [gets $chan]
lappend res [gets $chan]
set status [catch {gets $chan} cres copts]
lappend res $status $cres
set status [catch {gets $chan} cres copts]
lappend res $status $cres
chan configure $chan -translation binary
set data [read $chan 4]
foreach char [split $data {}] {
scan $char %c ord
lappend res [format %x $ord]
}
fconfigure $chan -encoding utf-8 -profile strict -translation auto
lappend res [gets $chan]
lappend res [gets $chan]
return $res
} -cleanup {
close $chan
} -match glob -result {hello AB 1 {error reading "*": invalid or incomplete multibyte or wide character}\
1 {error reading "*": invalid or incomplete multibyte or wide character} 43 44 c0 40 EF GHI}
# ### ### ### ######### ######### #########
test io-76.0 {channel modes} -setup {
set datafile [makeFile {some characters} dummy]
|
| ︙ | ︙ | |||
9458 9459 9460 9461 9462 9463 9464 |
set datafile [makeFile {some characters} dummy]
set f [open $datafile r]
} -constraints testchannel -body {
testchannel mremove-rd $f
} -returnCodes error -cleanup {
close $f
removeFile dummy
| | > | > | 9604 9605 9606 9607 9608 9609 9610 9611 9612 9613 9614 9615 9616 9617 9618 9619 9620 9621 9622 9623 9624 9625 9626 9627 9628 9629 9630 9631 9632 9633 9634 9635 9636 9637 9638 9639 9640 9641 |
set datafile [makeFile {some characters} dummy]
set f [open $datafile r]
} -constraints testchannel -body {
testchannel mremove-rd $f
} -returnCodes error -cleanup {
close $f
removeFile dummy
} -match glob -result {Tcl_RemoveChannelMode error:\
Bad mode, would make channel inacessible. Channel: "*"}
test io-76.5 {channel mode dropping} -setup {
set datafile [makeFile {some characters} dummy]
set f [open $datafile w]
} -constraints testchannel -body {
testchannel mremove-rd $f
list [testchannel mode $f] [testchannel maxmode $f]
} -cleanup {
close $f
removeFile dummy
} -result {{{} write} {{} write}}
test io-76.6 {channel mode dropping} -setup {
set datafile [makeFile {some characters} dummy]
set f [open $datafile w]
} -constraints testchannel -body {
testchannel mremove-wr $f
} -returnCodes error -cleanup {
close $f
removeFile dummy
} -match glob -result {Tcl_RemoveChannelMode error:\
Bad mode, would make channel inacessible. Channel: "*"}
test io-76.7 {channel mode dropping} -setup {
set datafile [makeFile {some characters} dummy]
set f [open $datafile r+]
} -constraints testchannel -body {
testchannel mremove-rd $f
list [testchannel mode $f] [testchannel maxmode $f]
|
| ︙ | ︙ | |||
9512 9513 9514 9515 9516 9517 9518 |
set f [open $datafile r+]
} -constraints testchannel -body {
testchannel mremove-wr $f
testchannel mremove-rd $f
} -returnCodes error -cleanup {
close $f
removeFile dummy
| | > | > | 9660 9661 9662 9663 9664 9665 9666 9667 9668 9669 9670 9671 9672 9673 9674 9675 9676 9677 9678 9679 9680 9681 9682 9683 9684 9685 9686 9687 9688 9689 9690 |
set f [open $datafile r+]
} -constraints testchannel -body {
testchannel mremove-wr $f
testchannel mremove-rd $f
} -returnCodes error -cleanup {
close $f
removeFile dummy
} -match glob -result {Tcl_RemoveChannelMode error:\
Bad mode, would make channel inacessible. Channel: "*"}
test io-76.10 {channel mode dropping} -setup {
set datafile [makeFile {some characters} dummy]
set f [open $datafile r+]
} -constraints testchannel -body {
testchannel mremove-rd $f
testchannel mremove-wr $f
} -returnCodes error -cleanup {
close $f
removeFile dummy
} -match glob -result {Tcl_RemoveChannelMode error:\
Bad mode, would make channel inacessible. Channel: "*"}
# cleanup
foreach file [list fooBar longfile script script2 output test1 pipe my_script \
test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] {
removeFile $file
}
cleanupTests
}
namespace delete ::tcl::test::io
return
|
Changes to tests/ioCmd.test.
| ︙ | ︙ | |||
262 263 264 265 266 267 268 |
} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation binary -buffering none -buffersize 4040 \
-eofchar {} -encoding binary -profile tcl8
fconfigure $f1
} -cleanup {
catch {close $f1}
| | | 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 |
} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation binary -buffering none -buffersize 4040 \
-eofchar {} -encoding binary -profile tcl8
fconfigure $f1
} -cleanup {
catch {close $f1}
} -result {-blocking 1 -buffering none -buffersize 4040 -encoding iso8859-1 -eofchar {} -profile tcl8 -translation lf}
test iocmd-8.10 {fconfigure command} -returnCodes error -body {
fconfigure a b
} -result {can not find channel named "a"}
set path(fconfigure.dummy) [makeFile {} fconfigure.dummy]
test iocmd-8.11 {fconfigure command} -body {
set chan [open $path(fconfigure.dummy) r]
fconfigure $chan -froboz blarfo
|
| ︙ | ︙ | |||
492 493 494 495 496 497 498 499 500 501 502 503 504 505 |
set f [open $path(test1) r]
fconfigure $f -translation binary
set result [string length [read $f]]
close $f
set result
} 5
test iocmd-12.11 {POSIX open access modes: BINARY} -body {
set f [open $path(test1) {WRONLY BINARY TRUNC}]
puts $f Ɉ ;# throws an exception
} -cleanup {
close $f
} -returnCodes 1 -match glob -result {error writing "*": invalid or incomplete multibyte or wide character}
test iocmd-12.12 {POSIX open access modes: BINARY} {
set f [open $path(test1) {WRONLY BINARY TRUNC}]
| > | 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 |
set f [open $path(test1) r]
fconfigure $f -translation binary
set result [string length [read $f]]
close $f
set result
} 5
test iocmd-12.11 {POSIX open access modes: BINARY} -body {
after 100
set f [open $path(test1) {WRONLY BINARY TRUNC}]
puts $f Ɉ ;# throws an exception
} -cleanup {
close $f
} -returnCodes 1 -match glob -result {error writing "*": invalid or incomplete multibyte or wide character}
test iocmd-12.12 {POSIX open access modes: BINARY} {
set f [open $path(test1) {WRONLY BINARY TRUNC}]
|
| ︙ | ︙ | |||
684 685 686 687 688 689 690 |
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 *}
# --- --- --- --------- --------- ---------
| | | 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 |
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
|
| ︙ | ︙ | |||
1053 1054 1055 1056 1057 1058 1059 |
}
set c [chan create {r w} foo]
note [read $c 10]
close $c
rename foo {}
set res
} -result {{read rc* 4096} {read rc* 4096} snarfsnarf}
| | | 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 |
}
set c [chan create {r w} foo]
note [read $c 10]
close $c
rename foo {}
set res
} -result {{read rc* 4096} {read rc* 4096} snarfsnarf}
test iocmd-23.2 {chan read, bad data return, too much} -match glob -body {
set res {}
proc foo {args} {
oninit; onfinal; track
return [string repeat snarf 1000]
}
set c [chan create {r w} foo]
note [catch {read $c 2} msg]; note $msg
|
| ︙ | ︙ | |||
2364 2365 2366 2367 2368 2369 2370 |
note [read $c 10]
close $c
notes
} c]
rename foo {}
set res
} -constraints {testchannel thread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf}
| | | 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 |
note [read $c 10]
close $c
notes
} c]
rename foo {}
set res
} -constraints {testchannel thread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf}
test iocmd.tf-23.2 {chan read, bad data return, too much} -match glob -body {
set res {}
proc foo {args} {
oninit; onfinal; track
return [string repeat snarf 1000]
}
set c [chan create {r w} foo]
notes [inthread $c {
|
| ︙ | ︙ |
Changes to tests/ioTrans.test.
| ︙ | ︙ | |||
110 111 112 113 114 115 116 |
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*}
# --- --- --- --------- --------- ---------
| | | 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 | # ## 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. | | | 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 |
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
| | | 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 |
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".
#
| | | 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 |
# 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.
| | | 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.
| ︙ | ︙ | |||
1051 1052 1053 1054 1055 1056 1057 |
}
set bgerrorsaved [interp bgerror {}]
interp bgerror {} [namespace code callbackproc]
variable locale
if {![info exist locale]} { set locale [mclocale] }
| | | | | | 1051 1052 1053 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 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 |
}
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 |
}
}
oo::class create C {
superclass A B
variable result
constructor {p q r} {
lappend result ==C== p=$p,q=$q,r=$r
| | | 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 |
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
| | | 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 } {
|
| ︙ | ︙ | |||
650 651 652 653 654 655 656 |
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]
| | | 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 |
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 | # 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 © 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. | | | 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 © 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 | # 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 | | | 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.
| ︙ | ︙ | |||
93 94 95 96 97 98 99 |
set listOut {}
foreach element $listIn {
lappend listOut [string map $map $element]
}
lsort $listOut
}
| | | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 |
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}
testConstraint AutoSyncDefined 1
# high level general test
test safe-stock-7.1 {tests that everything works at high level with conventional AutoPathSync, use pkg opt} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
|
| ︙ | ︙ |
Changes to tests/safe.test.
| ︙ | ︙ | |||
52 53 54 55 56 57 58 |
set listOut {}
foreach element $listIn {
lappend listOut [string map $map $element]
}
lsort $listOut
}
| | | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
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 - tcl::test - but it might be absent if we're in standard tclsh)
testConstraint tcl::test [expr {![catch {package require tcl::test}]}]
testConstraint AutoSyncDefined 1
|
| ︙ | ︙ |
Changes to tests/scan.test.
| ︙ | ︙ | |||
504 505 506 507 508 509 510 |
} -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 {} {}}
#
| | | 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 |
} -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.
| ︙ | ︙ | |||
123 124 125 126 127 128 129 |
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
| | | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 |
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}]
|
| ︙ | ︙ | |||
1860 1861 1862 1863 1864 1865 1866 |
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]}]} {
| | | 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 |
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
}
}
|
| ︙ | ︙ | |||
1894 1895 1896 1897 1898 1899 1900 |
}} $fd]
};#
thread::detach $fd
thread::send -async $::parent [list transf_parent $fd {*}$args]
}
iteration first
}
| | | 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 |
}} $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
|
| ︙ | ︙ | |||
2443 2444 2445 2446 2447 2448 2449 |
test socket-14.13 {testing writable event when quick failure} \
-constraints {socket win supported_inet notWine} \
-body {
# Test for bug 336441ed59 where a quick background fail was ignored
# Test only for windows as socket -async 255.255.255.255 fails
| | | 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 |
test socket-14.13 {testing writable event when quick failure} \
-constraints {socket win supported_inet notWine} \
-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 2000 {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.
| ︙ | ︙ | |||
311 312 313 314 315 316 317 |
string length $x
list [testobj objtype $x] [testobj objtype $y] [append x $y] \
[set y] [testobj objtype $x] [testobj objtype $y]
} "string int abc\xEF\xBF\xAEghi9 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
| | | 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 |
string length $x
list [testobj objtype $x] [testobj objtype $y] [append x $y] \
[set y] [testobj objtype $x] [testobj objtype $y]
} "string int abc\xEF\xBF\xAEghi9 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\xFCb\xE5c\xEF
set len [string length $y]
append x $y
string length $x
set q {}
|
| ︙ | ︙ | |||
404 405 406 407 408 409 410 |
list [string length $a] [string length $a]
} {6 6}
test stringObj-13.4 {Tcl_GetCharLength with mixed width chars} testobj {
string length "\xAE"
} 1
test stringObj-13.5 {Tcl_GetCharLength with mixed width chars} testobj {
# string length "○○"
| | | | 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 |
list [string length $a] [string length $a]
} {6 6}
test stringObj-13.4 {Tcl_GetCharLength with mixed width chars} testobj {
string length "\xAE"
} 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 "\xEF\xBF\xAE\xEF\xBF\xAE"
} 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 "\xEFa\xBFb\xAEc\xEF\xBFd\xAE"
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 |
-body {
child msg $a -tmpdir $tdiaf
return $msg
}
-result {*not a directory*}
-match glob
}
| | | | | | | | | | | | 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 591 |
-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
|
| ︙ | ︙ | |||
717 718 719 720 721 722 723 |
}
# clean up from directory testing
switch -- $::tcl_platform(platform) {
unix {
file attributes $notReadableDir -permissions 0o777
| | | | | | 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 |
}
# 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 |
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]
| | | 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 |
permcheck unixFCmd-17.11 --x--x--x 0o111
permcheck unixFCmd-17.12 {0 a+rwx} {00000 0o777}
file delete -force -- foo.test
test unixFCmd-18.1 {Unix pwd} -constraints {unix notRoot nonPortable} -setup {
set cd [pwd]
} -body {
| | | 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} {00000 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 0
pwd
} -returnCodes error -cleanup {
|
| ︙ | ︙ |
Changes to tests/unixForkEvent.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
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
| | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
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.
| ︙ | ︙ | |||
150 151 152 153 154 155 156 |
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"
| | | | | 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 |
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 notWine} -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.
| ︙ | ︙ | |||
119 120 121 122 123 124 125 | 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 | | | 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 |
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 notInCIenv} -body {
|
| ︙ | ︙ |
Changes to tests/zlib.test.
| ︙ | ︙ | |||
288 289 290 291 292 293 294 |
set fd [open $file wb]
} -constraints zlib -body {
list [fconfigure $fd] [zlib push compress $fd; fconfigure $fd] \
[chan pop $fd; fconfigure $fd]
} -cleanup {
catch {close $fd}
removeFile $file
| | | | 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 |
set fd [open $file wb]
} -constraints zlib -body {
list [fconfigure $fd] [zlib push compress $fd; fconfigure $fd] \
[chan pop $fd; fconfigure $fd]
} -cleanup {
catch {close $fd}
removeFile $file
} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding iso8859-1 -eofchar {} -profile strict -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding iso8859-1 -eofchar {} -profile strict -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding iso8859-1 -eofchar {} -profile strict -translation lf}}
test zlib-8.7 {transformation and fconfigure} -setup {
set file [makeFile {} test.gz]
set fd [open $file wb]
} -constraints zlib -body {
list [fconfigure $fd] [zlib push gzip $fd; fconfigure $fd] \
[chan pop $fd; fconfigure $fd]
} -cleanup {
catch {close $fd}
removeFile $file
} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding iso8859-1 -eofchar {} -profile strict -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding iso8859-1 -eofchar {} -profile strict -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding iso8859-1 -eofchar {} -profile strict -translation lf}}
# Input is headers from fetching SPDY draft
# Dictionary is that which is proposed _in_ SPDY draft
set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n"
set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl"
test zlib-8.8 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
} -constraints zlib -body {
|
| ︙ | ︙ |
Changes to tools/mkdepend.tcl.
| ︙ | ︙ | |||
248 249 250 251 252 253 254 | } # addSearchPath -- # # Adds a new set of path and replacement string to the global list. # # Arguments: | | | 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 |
proc readInputListFile {objectListFile} {
global srcFileList srcPathList source_extensions
set f [open $objectListFile r]
set fl [read $f]
close $f
| | | 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/regexpTestLib.tcl.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 |
close $fileId
return $i
}
#
# strings with embedded @'s are truncated
| | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
close $fileId
return $i
}
#
# strings with embedded @'s are truncated
# unpreceded @'s are replaced by {}
#
proc removeAts {ls} {
set len [llength $ls]
set newLs {}
foreach item $ls {
regsub @.* $item "" newItem
lappend newLs $newItem
|
| ︙ | ︙ |
Changes to unix/install-sh.
| ︙ | ︙ | |||
325 326 327 328 329 330 331 | 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 | | | 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/tclAppInit.c.
| ︙ | ︙ | |||
87 88 89 90 91 92 93 |
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
#elif (TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6) && (!defined(_WIN32) || defined(UNICODE))
/* New in Tcl 8.7. This doesn't work on Windows without UNICODE */
TclZipfs_AppHook(&argc, &argv);
#endif
| | | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 |
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
#elif (TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6) && (!defined(_WIN32) || defined(UNICODE))
/* New in Tcl 8.7. This doesn't work on Windows without UNICODE */
TclZipfs_AppHook(&argc, &argv);
#endif
Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);
return 0; /* Needed only to prevent compiler warning. */
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppInit --
|
| ︙ | ︙ |
Changes to unix/tclUnixChan.c.
| ︙ | ︙ | |||
1460 1461 1462 1463 1464 1465 1466 |
/*
* 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
| | | 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 |
/*
* 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)
|
| ︙ | ︙ | |||
1710 1711 1712 1713 1714 1715 1716 |
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_MakeFileChannel(
void *handle, /* OS level handle. */
| | | 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 |
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_MakeFileChannel(
void *handle, /* OS level handle. */
int mode) /* OR'ed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
TtyState *fsPtr;
char channelName[16 + TCL_INTEGER_SPACE];
int fd = PTR2INT(handle);
const Tcl_ChannelType *channelTypePtr;
struct stat buf;
|
| ︙ | ︙ |
Changes to unix/tclUnixCompat.c.
| ︙ | ︙ | |||
730 731 732 733 734 735 736 | #endif /* NEED_COPYGRP */ /* *--------------------------------------------------------------------------- * * CopyHostent -- * | | | 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 | #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 | /* * 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 © 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. |
| ︙ | ︙ | |||
339 340 341 342 343 344 345 |
return TCL_OK;
}
if (errno == ENOTEMPTY) {
errno = EEXIST;
}
/*
| | | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 |
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;
}
|
| ︙ | ︙ | |||
729 730 731 732 733 734 735 | /* *--------------------------------------------------------------------------- * * TclpObjCopyDirectory -- * * Recursively copies a directory. The target directory dst must not * already exist. Note that this function does not merge two directory | | | 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 | /* *--------------------------------------------------------------------------- * * 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.
| ︙ | ︙ | |||
696 697 698 699 700 701 702 | * 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. | | | 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 | * 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.
| ︙ | ︙ | |||
465 466 467 468 469 470 471 |
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
| | | 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 |
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_ExternalToUtfDStringEx(NULL, NULL, str, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_TCL8, &buffer, NULL);
str = Tcl_DStringValue(&buffer);
if ((str != NULL) && (str[0] != '\0')) {
|
| ︙ | ︙ | |||
994 995 996 997 998 999 1000 | /* *---------------------------------------------------------------------- * * TclpFindVariable -- * * Locate the entry in environ for a given name. On Unix this routine is | | | 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 | /* *---------------------------------------------------------------------- * * 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 TCL_INDEX_NONE 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.
| ︙ | ︙ | |||
435 436 437 438 439 440 441 | * 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 | | | 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 | * 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, className, className, 0, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL); ResetEvent(tsdPtr->event); |
| ︙ | ︙ |
Changes to unix/tclUnixPipe.c.
| ︙ | ︙ | |||
389 390 391 392 393 394 395 |
* 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
| | | | 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.
| ︙ | ︙ | |||
497 498 499 500 501 502 503 | # define NFDBITS NBBY*sizeof(fd_mask) #endif /* NFDBITS */ #define MASK_SIZE howmany(FD_SETSIZE, NFDBITS) /* *--------------------------------------------------------------------------- | | | 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 | # 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.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 |
struct sockaddr sa;
struct sockaddr_in sa4;
struct sockaddr_in6 sa6;
struct sockaddr_storage sas;
} address;
/*
| | | | 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. */
int flags; /* OR'ed combination of the bitfields defined
* below. */
TcpFdList fds; /* The file descriptors of the sockets. */
int interest; /* Event types of interest */
/*
* Only needed for server sockets
*/
|
| ︙ | ︙ | |||
78 79 80 81 82 83 84 |
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. */
};
/*
| | | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 |
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
|
| ︙ | ︙ | |||
382 383 384 385 386 387 388 | /* * ---------------------------------------------------------------------- * * 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 | | | | | | 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 | /* * ---------------------------------------------------------------------- * * 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: |
| ︙ | ︙ | |||
424 425 426 427 428 429 430 |
if (errorCodePtr != NULL && GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) {
*errorCodePtr = ENOTCONN;
return -1;
}
/*
| | | 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 |
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;
}
/*
|
| ︙ | ︙ | |||
1197 1198 1199 1200 1201 1202 1203 | /* * 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 | | | 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 | /* * 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 |
| ︙ | ︙ | |||
1597 1598 1599 1600 1601 1602 1603 |
*
*----------------------------------------------------------------------
*/
void *
TclpMakeTcpClientChannelMode(
void *sock, /* The socket to wrap up into a channel. */
| | | 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 |
*
*----------------------------------------------------------------------
*/
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 *)Tcl_Alloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
|
| ︙ | ︙ |
Changes to unix/tclUnixTest.c.
| ︙ | ︙ | |||
590 591 592 593 594 595 596 | /* *--------------------------------------------------------------------------- * * TestchmodCmd -- * * Implements the "testchmod" cmd. Used when testing "file" command. * The only attribute used by the Windows platform is the user write | | | 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 | /* *--------------------------------------------------------------------------- * * 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 | #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include <X11/Intrinsic.h> #include "tclInt.h" /* | | | 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.
| ︙ | ︙ | |||
607 608 609 610 611 612 613 |
${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
| | | 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 |
${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}; \
|
| ︙ | ︙ | |||
695 696 697 698 699 700 701 702 703 704 705 706 707 708 |
-DCFG_RUNTIME_INCDIR="\"$(includedir_native)\"" \
-DCFG_RUNTIME_DOCDIR="\"$(mandir_native)\"" \
-DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \
-DBUILD_tcl \
@DEPARG@ $(CC_OBJNAME)
tclEvent.${OBJEXT}: tclEvent.c tclUuid.h
$(TOP_DIR)/manifest.uuid:
printf "git-" >$(TOP_DIR)/manifest.uuid
(cd $(TOP_DIR); git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid || \
(printf "svn-r" >$(TOP_DIR)/manifest.uuid ; \
svn info --show-item last-changed-revision >>$(TOP_DIR)/manifest.uuid) || \
printf "unknown" >$(TOP_DIR)/manifest.uuid)
| > > | 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 |
-DCFG_RUNTIME_INCDIR="\"$(includedir_native)\"" \
-DCFG_RUNTIME_DOCDIR="\"$(mandir_native)\"" \
-DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \
-DBUILD_tcl \
@DEPARG@ $(CC_OBJNAME)
tclEvent.${OBJEXT}: tclEvent.c tclUuid.h
tclTest.${OBJEXT}: tclTest.c tclUuid.h
$(TOP_DIR)/manifest.uuid:
printf "git-" >$(TOP_DIR)/manifest.uuid
(cd $(TOP_DIR); git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid || \
(printf "svn-r" >$(TOP_DIR)/manifest.uuid ; \
svn info --show-item last-changed-revision >>$(TOP_DIR)/manifest.uuid) || \
printf "unknown" >$(TOP_DIR)/manifest.uuid)
|
| ︙ | ︙ |
Changes to win/makefile.vc.
| ︙ | ︙ | |||
106 107 108 109 110 111 112 | # 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. | | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 | # 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.
| ︙ | ︙ | |||
206 207 208 209 210 211 212 |
ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES));
sa.nLength = sizeof(SECURITY_ATTRIBUTES);
sa.lpSecurityDescriptor = NULL;
sa.bInheritHandle = FALSE;
/*
| | | | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 |
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.
|
| ︙ | ︙ | |||
348 349 350 351 352 353 354 |
/*
* Create a non-inheritible pipe.
*/
CreatePipe(&Out.pipe, &h, &sa, 0);
/*
| | | 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 |
/*
* 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.
|
| ︙ | ︙ | |||
580 581 582 583 584 585 586 |
}
}
/*
* 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 -
| | | 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 |
}
}
/*
* 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 << $** > $@
|
| ︙ | ︙ | |||
606 607 608 609 610 611 612 |
list_item_t *substPtr = NULL;
FILE *fp, *sp;
fp = fopen(filename, "rt");
if (fp != NULL) {
/*
| | | 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 |
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.
| ︙ | ︙ | |||
1365 1366 1367 1368 1369 1370 1371 | # 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 | | | 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 | # 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.
| ︙ | ︙ | |||
1040 1041 1042 1043 1044 1045 1046 | # extension can't assume that an executable Tcl shell exists at # build time. # # Arguments # none # # Results | | | 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 |
# 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, [
|
| ︙ | ︙ | |||
1086 1087 1088 1089 1090 1091 1092 | # when running tests from an extension build directory. It is not # correct to use the TCLSH_PROG in cases like this. # # Arguments # none # # Results | | | 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 |
# 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/tclAppInit.c.
| ︙ | ︙ | |||
137 138 139 140 141 142 143 |
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
#elif (TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6) && (!defined(_WIN32) || defined(UNICODE))
/* New in Tcl 8.7. This doesn't work on Windows without UNICODE */
TclZipfs_AppHook(&argc, &argv);
#endif
| | | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 |
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
#elif (TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6) && (!defined(_WIN32) || defined(UNICODE))
/* New in Tcl 8.7. This doesn't work on Windows without UNICODE */
TclZipfs_AppHook(&argc, &argv);
#endif
Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);
return 0; /* Needed only to prevent compiler warning. */
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppInit --
|
| ︙ | ︙ |
Changes to win/tclWinChan.c.
| ︙ | ︙ | |||
848 849 850 851 852 853 854 | "couldn't open serial \"%s\": %s", TclGetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } /* | | | 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 |
"couldn't open serial \"%s\": %s",
TclGetString(pathPtr), Tcl_PosixError(interp)));
}
return NULL;
}
/*
* For natively-named Windows serial ports we are done.
*/
channel = TclWinOpenSerialChannel(handle, channelName,
channelPermissions);
return channel;
}
|
| ︙ | ︙ | |||
988 989 990 991 992 993 994 |
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_MakeFileChannel(
void *rawHandle, /* OS level handle */
| | | 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 |
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_MakeFileChannel(
void *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/tclWinDde.c.
| ︙ | ︙ | |||
314 315 316 317 318 319 320 |
* incoming Dde eval's */
{
int suffix, offset;
RegisteredInterp *riPtr, *prevPtr;
Tcl_DString dString;
const WCHAR *actualName;
Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL;
| > | | 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 |
* incoming Dde eval's */
{
int suffix, offset;
RegisteredInterp *riPtr, *prevPtr;
Tcl_DString dString;
const WCHAR *actualName;
Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL;
Tcl_Size n, srvCount = 0;
int lastSuffix, r = TCL_OK;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* See if the application is already registered; if so, remove its current
* name from the registry. The deletion of the command will take care of
* disposing of this entry.
*/
|
| ︙ | ︙ | |||
866 867 868 869 870 871 872 |
}
return ddeReturn;
#endif
case XTYP_EXECUTE: {
/*
* Execute this script. The results will be saved into a list object
| | | 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 |
}
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) {
|
| ︙ | ︙ | |||
889 890 891 892 893 894 895 |
utilString = (WCHAR *) DdeAccessData(hData, &dlen);
string = (char *) utilString;
if (!dlen) {
/* Empty binary array. */
ddeObjectPtr = Tcl_NewObj();
} else if ((dlen & 1) || utilString[(dlen>>1)-1]) {
| | | | 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 |
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.
| ︙ | ︙ | |||
875 876 877 878 879 880 881 | /* *--------------------------------------------------------------------------- * * TclpObjCopyDirectory -- * * Recursively copies a directory. The target directory dst must not * already exist. Note that this function does not merge two directory | | | 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 | /* *--------------------------------------------------------------------------- * * 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.
| ︙ | ︙ | |||
1656 1657 1658 1659 1660 1661 1662 |
if (GetLastError() == ERROR_ACCESS_DENIED) {
Tcl_SetErrno(EACCES);
return -1;
}
}
/*
| | | 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 |
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.
|
| ︙ | ︙ | |||
1776 1777 1778 1779 1780 1781 1782 | goto accessError; } RevertToSelf(); /* | | | 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 |
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) {
|
| ︙ | ︙ | |||
2033 2034 2035 2036 2037 2038 2039 |
/*
* 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.
*
| | | 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 |
/*
* 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.
*/
|
| ︙ | ︙ | |||
2324 2325 2326 2327 2328 2329 2330 | * 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. | | | 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 | * 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.
| ︙ | ︙ | |||
143 144 145 146 147 148 149 |
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
| | | 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 |
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.
*/
|
| ︙ | ︙ | |||
221 222 223 224 225 226 227 |
}
}
if (shortlib == lib) {
Tcl_Panic("no '/' character found in lib");
}
/*
| | | | 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 |
}
}
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, TCL_INDEX_NONE);
|
| ︙ | ︙ |
Changes to win/tclWinNotify.c.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" /* | | | 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.
| ︙ | ︙ | |||
919 920 921 922 923 924 925 |
* 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
| | | | 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 |
* 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;
|
| ︙ | ︙ | |||
3134 3135 3136 3137 3138 3139 3140 |
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.
| | | 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 |
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.
| ︙ | ︙ | |||
778 779 780 781 782 783 784 |
/*
* 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.
*
| | | 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 |
/*
* 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;
|
| ︙ | ︙ | |||
872 873 874 875 876 877 878 | } /* *---------------------------------------------------------------------- * * GetValueNames -- * | | | 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 | } /* *---------------------------------------------------------------------- * * 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. * |
| ︙ | ︙ | |||
1008 1009 1010 1011 1012 1013 1014 | } /* *---------------------------------------------------------------------- * * OpenSubKey -- * | | | 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 | } /* *---------------------------------------------------------------------- * * 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: |
| ︙ | ︙ | |||
1093 1094 1095 1096 1097 1098 1099 | } /* *---------------------------------------------------------------------- * * ParseKeyName -- * | | | 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 | } /* *---------------------------------------------------------------------- * * 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: |
| ︙ | ︙ | |||
1325 1326 1327 1328 1329 1330 1331 |
}
value = ConvertDWORD((DWORD) type, (DWORD) value);
result = RegSetValueExW(key, (WCHAR *) valueName, 0,
(DWORD) type, (BYTE *) &value, sizeof(DWORD));
} else if (type == REG_MULTI_SZ) {
Tcl_DString data, buf;
| | | 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 |
}
value = ConvertDWORD((DWORD) type, (DWORD) value);
result = RegSetValueExW(key, (WCHAR *) valueName, 0,
(DWORD) type, (BYTE *) &value, sizeof(DWORD));
} else if (type == REG_MULTI_SZ) {
Tcl_DString data, buf;
Tcl_Size objc, i;
Tcl_Obj **objv;
if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {
RegCloseKey(key);
Tcl_DStringFree(&nameBuf);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1472 1473 1474 1475 1476 1477 1478 | } /* *---------------------------------------------------------------------- * * AppendSystemError -- * | | | 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 | } /* *---------------------------------------------------------------------- * * AppendSystemError -- * * Formats a Windows system error message and places it into * the interpreter result. * * Results: * None. * * Side effects: * None. |
| ︙ | ︙ | |||
1545 1546 1547 1548 1549 1550 1551 | } /* *---------------------------------------------------------------------- * * ConvertDWORD -- * | | | 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 | } /* *---------------------------------------------------------------------- * * 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.
| ︙ | ︙ | |||
331 332 333 334 335 336 337 | } /* *---------------------------------------------------------------------- * * SerialBlockTime -- * | | | 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 | } /* *---------------------------------------------------------------------- * * SerialBlockTime -- * * Wrapper to set Tcl's block time in msec. * * Results: * None. * * Side effects: * Updates the maximum blocking time. * |
| ︙ | ︙ | |||
900 901 902 903 904 905 906 |
}
} else {
errno = *errorCode = EWOULDBLOCK;
return -1;
}
} else {
/*
| | | 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 |
}
} 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 {
|
| ︙ | ︙ | |||
969 970 971 972 973 974 975 |
{
SerialInfo *infoPtr = (SerialInfo *) instanceData;
DWORD bytesWritten, timeout;
*errorCode = 0;
/*
| | | | 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 |
{
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;
}
/*
|
| ︙ | ︙ | |||
2278 2279 2280 2281 2282 2283 2284 |
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.
| | | 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 |
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.
| ︙ | ︙ | |||
101 102 103 104 105 106 107 | } address; #ifndef IN6_ARE_ADDR_EQUAL #define IN6_ARE_ADDR_EQUAL IN6_ADDR_EQUAL #endif /* | | | 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 |
} 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;
|
| ︙ | ︙ | |||
157 158 159 160 161 162 163 |
* 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. */
};
/*
| | | 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 |
* 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. */
|
| ︙ | ︙ | |||
545 546 547 548 549 550 551 | * * 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 | | | | 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 | * * 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: |
| ︙ | ︙ | |||
634 635 636 637 638 639 640 | * Consume the connect event. */ CLEAR_BITS(statePtr->readyEvents, FD_CONNECT); /* * For blocking sockets and foreground processing, disable async | | | | | 634 635 636 637 638 639 640 641 642 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 |
* 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)
*/
|
| ︙ | ︙ | |||
822 823 824 825 826 827 828 | break; } error = WSAGetLastError(); /* * If an RST comes, then ignore the error and report an EOF just like | | | 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 |
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;
}
|
| ︙ | ︙ | |||
1219 1220 1221 1222 1223 1224 1225 |
size_t len = 0;
int reverseDNS = 0;
#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS"
/*
* Go one step in async connect
*
| | | 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 |
size_t len = 0;
int reverseDNS = 0;
#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS"
/*
* Go one step in async connect
*
* If any error is thrown save it as background error to report eventually
* below.
*/
if (!GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE)) {
WaitForConnect(statePtr, NULL);
}
|
| ︙ | ︙ | |||
1766 1767 1768 1769 1770 1771 1772 |
statePtr->addr->ai_addrlen);
error = WSAGetLastError();
Tcl_WinConvertError(error);
if (async_connect && error == WSAEWOULDBLOCK) {
/*
| | | 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 |
statePtr->addr->ai_addrlen);
error = WSAGetLastError();
Tcl_WinConvertError(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;
|
| ︙ | ︙ | |||
1835 1836 1837 1838 1839 1840 1841 |
* Async connect terminated
*/
CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
if (Tcl_GetErrno() == 0) {
/*
| | | 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 |
* 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;
/*
|
| ︙ | ︙ | |||
1894 1895 1896 1897 1898 1899 1900 | * Free list lock. */ SetEvent(tsdPtr->socketListLock); } /* | | | 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 |
* 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;
|
| ︙ | ︙ | |||
2929 2930 2931 2932 2933 2934 2935 | /* * Get statePtr lock. */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); /* | | | | 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 |
/*
* 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;
}
/*
|
| ︙ | ︙ | |||
3046 3047 3048 3049 3050 3051 3052 | * 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 | | | 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 |
* 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,
|
| ︙ | ︙ | |||
3196 3197 3198 3199 3200 3201 3202 | } /* *---------------------------------------------------------------------- * * FindFDInList -- * | | | 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 | } /* *---------------------------------------------------------------------- * * 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.
| ︙ | ︙ | |||
773 774 775 776 777 778 779 |
*/
if (timeout) {
if (tsdPtr->flags & WIN_THREAD_RUNNING) {
timeout = 0;
} else {
/*
| | | | 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 |
*/
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.
| ︙ | ︙ | |||
618 619 620 621 622 623 624 |
/*
* If calibration cycle occurred after we get curCounter
*/
if (curCounter.QuadPart <= perfCounterLastCall) {
/*
| | | | 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 |
/*
* 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;
}
}
|
| ︙ | ︙ | |||
778 779 780 781 782 783 784 |
GetSystemTimeAsFileTime(&curFileTime);
QueryPerformanceCounter(&timeInfo.perfCounterLastCall);
QueryPerformanceFrequency(&timeInfo.curCounterFreq);
timeInfo.fileTimeLastCall.LowPart = curFileTime.dwLowDateTime;
timeInfo.fileTimeLastCall.HighPart = curFileTime.dwHighDateTime;
/*
| | | 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 |
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);
|
| ︙ | ︙ | |||
853 854 855 856 857 858 859 |
long long vt1; /* Tcl time one second from now. */
long long tdiff; /* Difference between system clock and Tcl
* time. */
long long driftFreq; /* Frequency needed to drift virtual time into
* step over 1 second. */
/*
| | | 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 |
long long vt1; /* Tcl time one second from now. */
long long tdiff; /* Difference between system clock and Tcl
* time. */
long long 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;
|
| ︙ | ︙ | |||
878 879 880 881 882 883 884 |
return;
}
QueryPerformanceCounter(&curPerfCounter);
lastFileTime.QuadPart = curFileTime.QuadPart;
/*
| | | 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 |
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.
*/
|
| ︙ | ︙ |