Compare commits

...
292 Commits
Author SHA1 Message Date
pooryorick 674dc6d84e Merge trunk-encoding-defaultstrict [c499122331]. 2023-06-18 21:30:00 +00:00
pooryorick f85eb13554 Merge trunk [7dc0ea8ca5]. 2023-06-12 10:19:50 +00:00
pooryorick 50eb79b797 Merge trunk [19e22d9bc5]. 2023-06-11 21:31:59 +00:00
pooryorick dd66ab423e Merge trunk [402ff62239]. 2023-06-11 20:21:28 +00:00
pooryorick 7600da9e6c Merge trunk [07d84ca4b3]. 2023-06-11 19:53:08 +00:00
pooryorick a1300ad826 Merge trunk [3389fba412]. 2023-06-11 19:41:42 +00:00
pooryorick fea0c84f2f Merge trunk [9d2e82fe49]. 2023-06-11 13:10:31 +00:00
pooryorick 25fb9a6a54 Merge trunk [b06ffa0e0e]. 2023-06-11 08:55:29 +00:00
pooryorick baf1eb36e4 Merge trunk [66350977dd]. 2023-06-11 08:07:01 +00:00
pooryorick 6c22f6b730 Merge trunk [20891426a8]. 2023-06-11 07:29:27 +00:00
pooryorick 2071be71b1 Merge trunk [874005b119] 2023-06-11 05:06:54 +00:00
apnadkarni 9cf727affb Tests for invalidly encoded file names and env (TIP 671 motivation) 2023-06-11 02:34:35 +00:00
pointsman 5140d2419c Merge 8.7 2023-06-04 22:58:07 +00:00
pointsman d716e3bd57 Merge 8.6 2023-06-04 22:56:45 +00:00
pointsman 02f302c8cf Fixed a new test added by [72f78b60851]. The test as it was repeated just the previous one. Now it shows what was fixed. Removed development comment. 2023-06-04 22:54:59 +00:00
jan.nijtmans 9ef860c58c Merge 8.7 2023-06-03 20:03:28 +00:00
jan.nijtmans 702bb9ab89 Merge 8.6 2023-06-03 19:59:48 +00:00
jan.nijtmans a7e21b7c56 Fix [af3ebc5fafe0097c]: clock scan and clock add bugs in error cases / with abbreviated options 2023-06-03 19:51:21 +00:00
jan.nijtmans 6b77d746e1 Merge 8.7 2023-06-02 22:12:10 +00:00
jan.nijtmans 7e152743be In TclAttemptInitStringRep(): Don't do a memcpy if attemptckalloc() fails 2023-06-02 22:05:03 +00:00
dkf 0513ad381a More library(n) docs 2023-06-02 15:12:26 +00:00
jan.nijtmans b37dff78c1 Merge 8.7 2023-06-02 14:02:19 +00:00
jan.nijtmans 103eb015c0 Merge 8.7 2023-06-02 13:59:26 +00:00
dgp 73519e9804 silence compiler warning 2023-06-02 13:46:50 +00:00
jan.nijtmans 2867ac2637 New (internal) macro TclAttemptInitStringRep() 2023-06-02 12:00:02 +00:00
jan.nijtmans 3d0413417d Merge 8.7 2023-06-01 21:04:48 +00:00
jan.nijtmans 56d50aec7c Fix [9921778646]: something is wrong in core-8-branch 2023-06-01 20:58:00 +00:00
dkf b1ee2de573 Added some examples to library(n) 2023-06-01 14:37:44 +00:00
jan.nijtmans 5d5b5a4242 merge-mark 2023-05-31 14:13:19 +00:00
jan.nijtmans c8ff4cae81 Use TclDuplicatePureObj() in stead of TclListObjCopy() where appropriate. Backported from 9.0 2023-05-31 14:12:12 +00:00
jan.nijtmans 6104a20928 Merge 8.7 2023-05-31 07:49:17 +00:00
jan.nijtmans b87d0095dc Document hoe Tcl_ReadChars() behaves in "-profile strict" mode when an encoding error happens. 2023-05-31 07:45:52 +00:00
jan.nijtmans 4632c037e3 Merge 8.7 2023-05-31 07:20:18 +00:00
jan.nijtmans 28c9edc49b Fix [c243e7a85e]: TIP #603 implementation broken on Windows 2023-05-31 07:16:04 +00:00
jan.nijtmans 614c8b3360 Let's see if this helps 2023-05-30 21:31:11 +00:00
dkf a4f289d5b5 More typo fixes 2023-05-30 13:57:09 +00:00
jan.nijtmans 75bdb75689 Merge 8.7 2023-05-30 12:22:20 +00:00
jan.nijtmans 13f6f72bb7 Backport IO-related changes from Tcl 9.0. Needed for preparation of TIP #653 2023-05-30 11:25:13 +00:00
jan.nijtmans af838a5d52 Merge 8.7 2023-05-29 19:41:08 +00:00
jan.nijtmans 8091425c93 int -> Tcl_Size, for full Tcl 9 support 2023-05-29 16:27:28 +00:00
dkf 4c03aeaadd Fix typo and outdated comment 2023-05-29 10:49:45 +00:00
fvogel 69ae2a0f03 merge 8.7 2023-05-28 10:39:40 +00:00
fvogel 7988b3f1b6 Fix errors when building the html man page for configurable.n (TIP #558) 2023-05-28 10:38:13 +00:00
fvogel 827a1d3802 Fix errors when building the html man page for configurable.n 2023-05-28 10:37:31 +00:00
jan.nijtmans 0657f97bc5 Eliminate some clang warnings. Only use "testbigdata" if sizeof(Tcl_Size) == sizeof(Tcl_WideInt) 2023-05-25 15:10:55 +00:00
dkf 6598d2eeae TIP 603: Get 'stat' Information of Open Files 2023-05-24 16:04:46 +00:00
dkf 29225e440c merge core-8-branch 2023-05-24 16:02:24 +00:00
jan.nijtmans 231fd112f9 Merge 8.7 2023-05-24 15:29:11 +00:00
jan.nijtmans 70a3d08fc4 Fix regular expression in previous commit 2023-05-24 15:22:00 +00:00
jan.nijtmans c7771a763e Enhance html generation, so it can handle the "©" copy-sign as well 2023-05-24 15:18:05 +00:00
jan.nijtmans 6c1bdd15d6 More size protection for winDde 2023-05-24 15:16:14 +00:00
jan.nijtmans 9a6a7030e8 Remove TCL_SIZE_SMAX, not used anywhere. Some more variable which should have been Tcl_Size 2023-05-24 10:31:56 +00:00
jan.nijtmans 633171eda9 Merge 8.7 2023-05-23 16:15:10 +00:00
jan.nijtmans 2acd355f8d Give Tcl_CreateThread a TCL_HASH_TYPE (unsigned) stackSize parameter 2023-05-23 16:03:29 +00:00
pointsman 73ff912a1f Proposed fix for [af3ebc5fafe0]. 2023-05-22 12:17:44 +00:00
jan.nijtmans b9722ec356 Merge 8.7 2023-05-22 10:13:42 +00:00
dkf f3f254e8ba Small documentation corrections 2023-05-22 07:48:43 +00:00
jan.nijtmans f1e62884ba Merge 8.7 2023-05-21 23:00:20 +00:00
jan.nijtmans e18d096bd7 Unbreak windows symbols build. More int -> Tcl_Size backported from 9.0 2023-05-21 21:19:22 +00:00
griffin 54a1d7e517 Fix test to be stable. 2023-05-21 20:42:14 +00:00
griffin c6cce703b5 Add cleanup to lseq tests. Fix assertion. 2023-05-20 23:24:54 +00:00
apnadkarni f19e2665d3 Fix [c9663296fd]. Also refactor memory reallocation. 2023-05-20 16:39:50 +00:00
pooryorick a7c911213a Merge trunk [b60a8ec69f]. 2023-05-20 16:02:09 +00:00
apnadkarni 96d441c29a Minor refactor to combine alloc/realloc 2023-05-20 15:40:17 +00:00
jan.nijtmans 72dfeb60e2 merge-mark 2023-05-20 10:34:14 +00:00
jan.nijtmans b27acbe84f More int/Tcl_Size backport 2023-05-20 10:07:19 +00:00
apnadkarni 1b8701ee3d Merge trunk 2023-05-19 23:07:13 +00:00
apnadkarni 83d22bd1f6 Fix int/Tcl_Size pointer errors 2023-05-19 22:18:51 +00:00
apnadkarni 861c6c226a Fix build - ckalloc/ckfree not in Tcl 9 2023-05-19 21:31:18 +00:00
jan.nijtmans b0bd6fc251 Merge 8.7 2023-05-19 19:50:31 +00:00
jan.nijtmans 6643ceb141 int -> Tcl_Size and other (internal) signature improvements. Most of them backported from 9.0 2023-05-19 19:47:18 +00:00
apnadkarni 16a75f3cbf More refactoring into common code 2023-05-19 16:47:58 +00:00
dkf ed8816500e Improve the synopsis of the transchan manpage so it helps users a bit 2023-05-19 14:15:18 +00:00
dkf 5ef48eba53 Improve the synopsis of the refchan manpage so it helps users a bit 2023-05-19 13:35:19 +00:00
dkf ee48919fcc Merge 8.7 2023-05-19 12:56:28 +00:00
pooryorick b359029baa Merge trunk [c405bdd1f0]. 2023-05-19 12:08:53 +00:00
dkf d6a3425ec6 TIP 558: Basic Configure Support for TclOO 2023-05-19 12:06:05 +00:00
dkf b0f19e41f2 merge core-8-branch 2023-05-19 12:02:49 +00:00
pooryorick c447bf4370 Merge trunk [402ff62239]. 2023-05-19 12:02:13 +00:00
pooryorick 00dd4a5b56 Improve TclDuplicatePureObj(), remove unnecessary increment/decrement pairs, and add more error checking. 2023-05-17 12:44:46 +00:00
pooryorick ac555b905c New functions: TclUndoRefCount() and TclDictGetSize(). 2023-05-17 12:26:11 +00:00
pooryorick 5990382222 Fix for [5ee01098824881b5], lseq list conversion results in attempt to access
freed memory.
2023-05-17 12:09:27 +00:00
jan.nijtmans c7e670b85f Merge 8.7 2023-05-17 07:33:33 +00:00
jan.nijtmans 86e88cf233 Remove dead code 2023-05-17 07:30:54 +00:00
jan.nijtmans e47cbdc798 Merge 8.6 2023-05-16 16:31:53 +00:00
jan.nijtmans a5297cf7c3 Some more nmakehlp.c tweaks 2023-05-16 16:30:07 +00:00
jan.nijtmans 32ffe00c48 Merge 8.6 2023-05-16 10:26:48 +00:00
jan.nijtmans 8f8a3bc1c0 Only use _snprintf on older MSVC compilers. ZeroMemory -> memset 2023-05-16 10:19:41 +00:00
pooryorick a038d4aad3 Fix memory leaks and remove unnecessary reference count bounce. 2023-05-16 09:33:12 +00:00
jan.nijtmans 17c92b0a7a Merge 8.7 2023-05-16 06:25:19 +00:00
jan.nijtmans 4eb91b8e5b Remove some more references to removed ChangeLog 2023-05-16 06:07:51 +00:00
jan.nijtmans ebcc04616c More int -> Tcl_Size (in tclInt.h) 2023-05-16 06:05:22 +00:00
pooryorick 50dde26caf New function, TclDuplicatePureObj(), doesn't duplicate the string
representation when duplicating an object, unless necessary.  Remove
TclListObjCopy() in favor of TclDuplicatePureObj(), allowing internal
representation to change after the copy rather than before.
2023-05-16 05:25:31 +00:00
apnadkarni 6fa73194d5 Refactor couple more reallocations 2023-05-15 23:08:17 +00:00
pooryorick 49c4458a25 Add Tcl_DecrRefCount() missing from [4b1a20629e]. 2023-05-15 20:49:43 +00:00
apnadkarni 02563b1911 Refactor allocation in Tcl_DStringAppendElement 2023-05-15 20:23:05 +00:00
dgp 54e89ec231 merge 8.7 2023-05-15 17:37:21 +00:00
dgp 8074bcec5e TIP 663 implementation 2023-05-15 17:17:43 +00:00
jan.nijtmans 4db805463e Backport test improvements from 9.0 2023-05-15 15:45:57 +00:00
jan.nijtmans 45dd8baf76 No need to init string rep, if we throw away the object immediately 2023-05-15 15:44:34 +00:00
jan.nijtmans f6f92fd671 Merge 8.7 2023-05-15 11:52:39 +00:00
jan.nijtmans f2f41b4b85 Merge 8.6 2023-05-15 11:45:42 +00:00
jan.nijtmans db43c8cbed One more ckalloc -> attemptckalloc (in compat/waitpid.c), since we can handle the error. 2023-05-15 11:43:15 +00:00
jan.nijtmans 062f4d0529 ckalloc -> attemptckalloc (since return-value is checked). Fix bug in unix/dltest/pkgooa.c, where last NULL-argument was missing 2023-05-15 11:15:28 +00:00
pooryorick 48d6b3d84c Rename TclRelaxRefCount() to TclUndoRefCount(). 2023-05-14 08:21:50 +00:00
pooryorick aafa141509 Add TclRelaxRefCount, and also try to take the fast path more often in byte-compiled [lindex]. 2023-05-13 10:59:32 +00:00
pooryorick d6ed36f134 In tclExecute.c call DECACHE_STACK_INFO() before calling TclLindexList(). 2023-05-12 23:20:26 +00:00
jan.nijtmans 14d2bc5415 Merge 8.7 2023-05-12 08:57:00 +00:00
jan.nijtmans 36cebb89fe Use 'attempt'-functions for libtommath, when built into Tcl 2023-05-11 22:20:17 +00:00
pooryorick c8c0db5f21 Merge trunk [05eeae5d67] and resolve conflicts. 2023-05-11 21:47:17 +00:00
pooryorick c29132ab84 ptrdiff_t to Tcl_Size in tclListObj.c 2023-05-11 20:59:18 +00:00
pooryorick edbf195dff Add TclRelaxRefCount and TclObjGetScalar, and use them to try to take the fast path more often in byte-compiled [lindex].
See: [https://github.com/tcltk/tcl/actions/runs/4956385513] for build failure
2023-05-11 20:25:49 +00:00
pooryorick 4fa1fa29ae Fix failing valgrind suppression for load.test 2023-05-11 17:17:18 +00:00
pooryorick 6fbc88e2a0 Silence valgrind "still reachable" report in cmdAH.test 2023-05-11 17:07:39 +00:00
jan.nijtmans 87ff0e4ee2 put back pragma voor MSVC warning, accidently removed in previous commit 2023-05-11 15:39:30 +00:00
jan.nijtmans 847fdd28f7 Restore warning-free compilation with C++ compiler 2023-05-11 15:30:18 +00:00
pooryorick 01e71bb26c Fix Valgind report of still reachable blocks in aaa_exit.test and other test
files.
2023-05-11 13:08:59 +00:00
jan.nijtmans ce00b07d6b disable on-purpose compiler warning (MSVC) for testcase 2023-05-11 06:31:49 +00:00
apnadkarni 363a6cc4cd Refactor allocation strategy in Tcl_DStringAppend 2023-05-10 21:32:16 +00:00
jan.nijtmans 180af1f9a5 Merge 8.7 2023-05-10 20:53:49 +00:00
jan.nijtmans c03808607b Backport various changes from 9.0 branch 2023-05-10 19:39:20 +00:00
dgp 6c604517d7 TIP 663 implementation 2023-05-10 18:28:30 +00:00
apnadkarni 6802927d5c Merge trunk 2023-05-10 17:25:47 +00:00
jan.nijtmans c0c0164a71 Merge 8.6 2023-05-10 12:28:06 +00:00
jan.nijtmans 284a501487 Backport: docs: function does not "return an error", it returns TCL_ERROR, indicating an error occured 2023-05-10 12:09:07 +00:00
bch 909827f9ee docs: function does not "return an error", it returns TCL_ERROR, indicating an error occured 2023-05-09 22:36:38 +00:00
apnadkarni d0ba759e2c Merge trunk 2023-05-05 12:36:45 +00:00
apnadkarni 5940356ced Change reallocation growth to 1.5. 2023-05-05 09:17:17 +00:00
apnadkarni 92dd14e77c Refactor reallocation in preparation for experimentation with different growth factors 2023-05-04 17:52:06 +00:00
apnadkarni 8a45e47c4c Merge trunk 2023-05-04 05:12:11 +00:00
pooryorick 6da79937df remove "forceUniChar" from TclStringCat() since it isn't used anymore. 2023-05-03 16:26:27 +00:00
apnadkarni 688c125ec3 Fix bug-c9663296fd (in progress) 2023-05-03 13:18:05 +00:00
pooryorick 66c0809095 Merge [842b3b3949]. 2023-05-03 11:31:30 +00:00
pooryorick 5f690c8fae Fix issue [b3628609ad73a105], by allowing TclStringCat to assume that each Tcl_Obj.bytes value is complete, i.e. concatenating such values does not change the interpretatin of any byte in any of the concatenated values. 2023-05-02 19:58:06 +00:00
pooryorick c811b1d642 Merge trunk [480bcbe193]. 2023-05-02 19:51:21 +00:00
pooryorick 50c851a04b Remove "deprecated" constraint in test suite. 2023-05-02 19:42:25 +00:00
pooryorick e1051201ce Merge trunk [6964e7e16a]. 2023-05-02 15:51:01 +00:00
pooryorick 410ffcdefa Fix issue [b3628609ad73a105], by allowing TclStringCat to assume that each
Tcl_Obj.bytes value is complete, i.e. concatenating such values does not change
the interpretatin of any byte in any of the concatenated values.
2023-05-02 12:47:10 +00:00
dkf fea912c676 Remove IDE guff 2023-05-01 15:08:08 +00:00
dkf 7555420166 Add doc comments, fix a typo in a manpage 2023-05-01 14:07:59 +00:00
dkf 10c71dc8b9 Use modern copyright symbol, in line with rest of code 2023-05-01 13:31:30 +00:00
dkf 530e4b3bb9 Merge 8.7 2023-05-01 13:22:24 +00:00
pooryorick 09dd330c44 Merge trunk [95cb1987c8]. 2023-05-01 09:46:41 +00:00
pooryorick 3458214e46 Delete related to TCL_BUILD_FOR and all code related to it. 2023-04-30 19:30:36 +00:00
pooryorick 0987bb4b63 Remove all code that is conditioned on TCL_MAJOR_VERSION. 2023-04-30 18:36:31 +00:00
pooryorick 64a0be31b9 Remove all code related to TCL_NO_DEPRECATED, and some related to TCL_MAJOR_VERSION. 2023-04-28 23:57:14 +00:00
pooryorick 2098e71e79 Remove TclUtfToUCS4(), TclUniCharToUCS4(), and TclUCS4Prev(). 2023-04-28 19:19:30 +00:00
pooryorick 4a24561f0b Remove all code related to TCL_UTF_MAX=3. 2023-04-28 17:34:24 +00:00
pooryorick df1dd156ed Merge trunk. 2023-04-28 12:20:52 +00:00
pooryorick 1a819d1063 Merge trunk. 2023-04-28 09:03:14 +00:00
pooryorick 6ee4d2b394 Merge trunk. 2023-04-24 00:08:18 +00:00
pooryorick 26c9f5e773 merge trunk [f867f44c9c]. 2023-04-23 11:48:15 +00:00
pooryorick 466e7c47c6 Set the encoding profile to strict in Tcl_FSEvalFileEx(). This is independent
of TIP 657:  A script to be evaluated must be properly encoded in any case.
2023-04-23 11:39:10 +00:00
pooryorick 37dceb3922 Merge trunk-encodingdefaultstrict [31278b27ed]. 2023-04-19 17:39:48 +00:00
pooryorick 0c2d0f0ab7 Merge trunk [08fc7dfb36]. 2023-04-19 17:05:58 +00:00
pooryorick 2fb58dc372 Merge trunk [c2d903f6ed]: apn-bigdata-tests. 2023-04-19 16:41:13 +00:00
pooryorick 2c78daa2b0 Fossil merge [1842599320]: TIP 660 accepted. 2023-04-19 12:20:25 +00:00
pooryorick 02c0281379 Merge trunk [883464ea32]. 2023-04-19 12:15:51 +00:00
pooryorick e736d151a0 Merge trunk-encodingdefaultstrict [d325b41eb8] 2023-04-19 12:11:55 +00:00
pooryorick dcb3b835e4 Merge trunk [1ef347e31d]. 2023-04-19 11:28:22 +00:00
pooryorick e027188168 Merge trunk [5995ca9b6c]. 2023-04-19 11:19:06 +00:00
pooryorick c4c090889c Merge trunk [f9c8bbde44]. 2023-04-19 07:43:57 +00:00
pooryorick 01570cabab Merge trunk [433637e689]. 2023-04-19 07:17:28 +00:00
pooryorick 182b7f85f6 Merge trunk [67baae2829]. 2023-04-18 23:57:32 +00:00
pooryorick e1b3b51a8f Merge trunk [32d5cdd8d0]. 2023-04-18 23:25:24 +00:00
pooryorick 23dd40e1a2 Merge trunk [8dba618fe6]. 2023-04-18 23:24:14 +00:00
pooryorick 9af2fb9efe Merge trunk [f9a80c2c9e]. 2023-04-18 23:22:43 +00:00
pooryorick 1a7bbea40c Merge trunk [4fc1f701cc] and resolve conflicts. 2023-04-18 22:56:24 +00:00
pooryorick aec3f90f4d Merge trunk [0d197907c6]. 2023-04-18 15:32:02 +00:00
pooryorick 198dbe0117 Merge trunk [e7fcdb7611]. 2023-04-18 13:24:40 +00:00
pooryorick 19eccf461d Merge trunk [cbaf88e90a]: Fix iocmd-12.11 testcase. 2023-04-18 13:16:54 +00:00
pooryorick ca96bc096f Merge trunk [a9fc905623] and resolve conflicts and test failures. 2023-04-18 13:05:39 +00:00
pooryorick 034957707a Merge trunk [79cd3ac351]. 2023-04-18 12:24:06 +00:00
pooryorick ce003df1ca Merge trunk [78beedf7e2] and resolve conflicts. 2023-04-18 12:12:41 +00:00
pooryorick 63e2ca9905 Merge trunk [c8983a2a94] and resolve conflicts. 2023-04-18 11:39:12 +00:00
pooryorick 9512351bc5 Merge trunk [48829d9671]: Fix [d7fd37ebd9]: handling leftover prefix in table
encoding.
2023-04-18 10:29:28 +00:00
pooryorick ce353e21ed Merge trunk [1253dd0211]:` Fix http11 test hang caused by trailing brace in
previous commit.
2023-04-18 08:07:56 +00:00
pooryorick fb61224892 Merge trunk [20cad126cd]: Don't let httpd11 depend on the system encoding any
more: All text files are now stored in utf-8.
2023-04-18 08:02:49 +00:00
pooryorick f10942c112 Merge trunk [b10e2b66a9], Tcl TIP 656 manpages. 2023-04-18 07:43:31 +00:00
pooryorick 62e806dc83 Merge trunk [49a4c8f8fb], "TIP 656 accepted", and resolve conflicts. 2023-04-17 21:33:41 +00:00
pooryorick 9831556bf7 Merge trunk [31788d9a4b] and resolve conflicts. 2023-04-17 13:30:36 +00:00
pooryorick 9586d2f54c Merge trunk [1997f71246]. 2023-04-17 11:31:50 +00:00
pooryorick 800f0a1edf Merge trunk [498ef65f88] and resolve conflicts. 2023-04-17 10:58:50 +00:00
pooryorick 304ca9a172 Merge trunk [91094999d0], resolve conflicts, and make Tcl_UtfToExternalDString
strict regarding encoding errors.
2023-04-16 18:30:54 +00:00
pooryorick d7fdb20ed5 Merge trunk [f868c40053] and resolve conflicts. 2023-04-16 17:07:15 +00:00
pooryorick 6e4c20e3a6 Merge trunk [32c5b5172b]. 2023-04-16 16:58:43 +00:00
pooryorick 704627190d Merge trunk [69fba9fb6b]: Fix [4bea02e811]: encoding convertfrom -strict
ascii \x7f generates exception Many other encodings had the same problem, and
also the reverse happened: encodings which should throw an exception with
-strict but didn't (within range 0x80-0x9F).
2023-04-16 16:40:37 +00:00
pooryorick a8075a956d Merge trunk [355a5e4733] and resolve conflicts and test failures. 2023-04-16 16:23:26 +00:00
pooryorick ab1a8089de Merge trunk [f64a19cf62] and resolve conflicts. 2023-04-16 14:05:13 +00:00
pooryorick 9c35850e30 Merge trunk [7b54fc6784]: Fix for [885c86a9a0]: convertfrom utf8 breaks for 4
byte utf encodings.
2023-04-16 13:48:59 +00:00
pooryorick 55bb2e9be3 Merge trunk [fc029613d5]. 2023-04-16 13:31:53 +00:00
pooryorick 0033456148 Merge trunk [e90924bb13]: test encoding-16.17. 2023-04-16 13:23:38 +00:00
pooryorick ce60562f86 Merge trunk [de933019a109d3d6]: Fix for [bd1a60eb9c]: convertfrom utf-8 strict
mode allows surrogates in input sequence.
2023-04-16 13:20:58 +00:00
pooryorick aad734db91 Merge trunk [2d036d968c] and resolve issues. 2023-04-16 08:29:10 +00:00
pooryorick c1ebc6273f Merge trunk [f118b6370b]. 2023-04-15 23:50:38 +00:00
pooryorick e08e3fbc09 Merge trunk [f9cdaa50ad]: First part of fix for [4a7397e0b3]. Not complete yet. 2023-04-15 22:52:02 +00:00
pooryorick ae955d6d24 merge trunk [77c37636f0]: DoReadChars() and Tcl_SetObjLength(). 2023-04-13 06:52:16 +00:00
pooryorick 756913ce13 Merge trunk [d65da06a77]: Correct spelling errors in comments and
documentation, but also a non-comment corections in history.tcl and
tcltest.test.
2023-04-12 14:44:08 +00:00
pooryorick 21fec5d3d1 Merge trunk [b921949acd]: More int -> Tcl_Size, so (theoretically) longer
lists could be handled. Thanks, Rolf!
2023-04-12 14:43:18 +00:00
pooryorick 72557b402d Merge trunk [9c60558723]: int -> Tcl_Size for tclWinDde.c/tclWinReg.c, so it
could (theoretically) handle larger lists in Tcl 9.
2023-04-12 14:42:10 +00:00
pooryorick a1d4fac3d8 Merge trunk [e825ea06803d4a61]: Editorial fix in Tcl_Panic() message. 2023-04-12 14:41:04 +00:00
pooryorick 3e3ef5f0be Merge trunk [b66d50b4d4]: Merge bug-[fa3d9fd818fa0072]. 2023-04-07 21:07:42 +00:00
pooryorick c70c765bc7 Merge trunk [c53063d69b]: TIP 602 - update manpages. 2023-04-07 20:26:47 +00:00
pooryorick a67d7e8610 Merge trunk [e1baa8ec4a]: Make sure that infoPtr->validMask only contains
TCL_READABLE|TCL_WRITABLE|TCL_EXCEPTION, no other flags.
2023-04-07 20:25:31 +00:00
pooryorick 2b4d8d160a Merge trunk [b27eacb7fc]: Fix [6390566ecd]: Testcase
cmdAH-4.3.13.00DC0000.tail.utf-32.tcl8.a fails sometimes.
2023-04-07 19:42:05 +00:00
pooryorick 3504682d15 Merge trunk [d29e69a635a0dc81]: TIP #628 addendum (various fixes to improve
handling of 8.7 <-> 9.0 header differences).
2023-04-07 18:43:26 +00:00
pooryorick 065cc78833 Merge trunk. 2023-04-04 18:56:27 +00:00
pooryorick 32aba95cdd Merge trunk. 2023-04-04 18:53:00 +00:00
pooryorick 15dbbaf497 Merge trunk [dc1e0b5f9a]: Minor fix in winConsole.test. 2023-04-04 14:11:05 +00:00
pooryorick f52fe2c0c0 Merge trunk [cbaf88e90a]: Fix iocmd-12.11 testcase. 2023-04-04 14:10:00 +00:00
pooryorick fc1e6cc187 Merge trunk [a9fc9056236f5775] : Fix [fa128568a5]: EOVERFLOW does not
necessarily mean "file too big". Synchronize many error-messages with what
Linux gives nowadays.
2023-04-04 14:08:38 +00:00
pooryorick dff9e4fbb2 Merge trunk [f8864b9541d149d2]: Merge 8.7. POSIX errors update and minizip fix. 2023-04-04 13:57:32 +00:00
pooryorick 92aeea296b Merge trunk [0569b8782f] : Remove unneeded parts from test in fileName.test. 2023-03-28 17:54:13 +00:00
pooryorick 42bbf78a33 Merge trunk [92ee031f32]: Make the documentation of [encoding] more concise
and readable.
2023-03-28 17:52:31 +00:00
pooryorick 04ef72b73b Merge trunk [4ebee22ffd]: Update reference-counting advice for Tcl_ObjSetVar2 and friends. 2023-03-28 17:51:26 +00:00
pooryorick e47a1c3779 Merge trunk [f8927d772b]: Avoid msvc "illegal indirection" error. 2023-03-28 16:32:57 +00:00
pooryorick ce09232ac7 Merge trunk [aa1a1096ac]: Fix memory leak in Tcl_JoinObjCmd(). 2023-03-28 16:32:01 +00:00
pooryorick 0a3bf031ac Merge trunk [79cd3ac351]: Update to tzdata 2023b. 2023-03-28 16:31:20 +00:00
pooryorick e78c831950 Merge trunk [7d005e0860]: Fix for [6d4e9d1af5bf5b7d]: Memory leak:
SetFsPathFromAny, assisted by the global literal table, causes a Tcl_Obj to
reference itself.
2023-03-28 16:30:24 +00:00
pooryorick e284637f4c Merge trunk [bb1378370e]: Fix [68417a8bb3]: No result/LF printed for 64-bit
integer type check.
2023-03-28 16:29:25 +00:00
pooryorick 97195d18a9 Merge trunk [6301de2138]: Fix various typos. 2023-03-28 16:27:57 +00:00
pooryorick 99af05cca8 Merge trunk [b29771bb5f]: Fix duplicate test name. 2023-03-28 16:25:38 +00:00
pooryorick 29a34b9b95 Merge trunk [5075be4f0b]: Add valgrind_each to Makefile.in. 2023-03-28 16:24:43 +00:00
pooryorick 30b1f27305 Merge trunk [82107b50c20baa70]: More TCL_INDEX_NONE. 2023-03-28 07:03:14 +00:00
pooryorick b2687dde17 Merge trunk [f25757b233]: Remove knownProfileBug constraint: this is already
fixed.
2023-03-28 06:51:54 +00:00
pooryorick a0ec63efa5 One missing int -> Tcl_Size change 2023-03-27 22:42:33 +00:00
pooryorick e1fca6fb5d Merge trunk [f4cf3c36b4] : Fix [0265750233]: invalid read in cmdAH-4.3.13.C1.solo.utf-8.tcl8 2023-03-27 22:36:04 +00:00
pooryorick 0fcfcc0f88 Merge trunk f8d60e395f: Move (TCL_ENCODING_PROFILE_MASK|GET|SET) from tcl.h to tclIO.h, since those are not public. Some formatting. 2023-03-24 13:27:08 +00:00
pooryorick 1852320cca Merge trunk e1cfef6bfd: Code cleanup: use more *SURROGATE() macros. 2023-03-24 13:25:14 +00:00
pooryorick 79e893e6f2 Merge trunk a9d278979e: Fix longIs64Bit->has64BitLengths else test will not run on 64-bit
Wind.
2023-03-24 13:20:27 +00:00
pooryorick 4232bc484d Merge trunk: Remove unneeded Tcl_IncrRefCount and TclDecrRefCount.
TclPtrSetVarIdx takes ownership of newValuePtr if its refCount is 0, and either
stores or frees it.
2023-03-24 13:19:44 +00:00
pooryorick af2c18d5ea Merge trunk 78beedf7e2: Fix [1bedc53c8c]: synchronous [read] with
-strictencoding does not produce an error on invalid input.
2023-03-24 13:18:51 +00:00
pooryorick fadb579028 Merge trunk c8983a2a94: Fix [154ed7ce56]: Tcl 9: [gets] on -strictencoding 1 configured
channel.
2023-03-24 13:16:26 +00:00
pooryorick ed01d27700 Merge trunk 037b767147: Missing backslashes in macro def. 2023-03-24 13:14:07 +00:00
pooryorick 09b9930667 Merge trunk dd8e66c296: More TclNewIndexObj() usages (for values between -1 and
SIZE_MAX-1).
2023-03-24 13:13:23 +00:00
pooryorick 657095d29a Merge trunk d89991c58b Fix [bdcb5126c0]: Failed assertion in test chan-io-7.3. 2023-03-23 21:38:14 +00:00
pooryorick 05277ab690 Merge trunk 15c9067453: Add longIs64bit constraint to lseq-4.4 (because this
isn't expected to work on 32-bit platforms). Remove some unused constraints.
2023-03-23 21:35:30 +00:00
pooryorick 333b4efa28 Merge trunk 1e23dd4876: Fix [5ae5ffc3f4]: Problem with -failindex on 32-bit platform. 2023-03-23 21:33:03 +00:00
pooryorick adbdca59a9 Merge trunk 1253dd0211: Fix http11 test hang caused by trailing brace in
previous commit.
2023-03-23 21:24:02 +00:00
pooryorick 2918f547d8 Merge trunk 20cad126cd: Don't let httpd11 depend on the system encoding any
more: All text files are now stored in utf-8.
2023-03-23 21:17:33 +00:00
pooryorick c52403ad33 Test TableFromUtfProc() with strict handling of encoding errors. 2023-01-25 19:56:57 +00:00
pooryorick 2b343d0207 Merge trunk. 2023-01-25 00:34:51 +00:00
pooryorick 5363b1f11f Rename [encoding convert*] option "-nocomplain"/"-ignore" to "-pass", and
"-nocomplainencoding"/"-encodingignore" to "-encodingpass".
2023-01-23 21:32:43 +00:00
pooryorick b49efc9ae0 Rename [encoding convert*] option "-nocomplain"/"-ignore" to "-pass", and
"-nocomplainencoding"/"-encodingignore" to  "-encodingpass"
2023-01-23 20:41:47 +00:00
pooryorick 7fe77d7ff8 Per TIP 601, the default behaviour of [encoding convert..] is to require valid input. 2023-01-23 13:53:51 +00:00
pooryorick f54d9a7c69 A branch for fixing TIP 346/601 issues, and other issues related to Unicode
encoding, while retaining the default of not raising an error when invalid data
for the encoding occurs.
2023-01-23 10:48:17 +00:00
pooryorick 9832ae4232 Fix issue with new options parsing in EncodingConvertfromObjCmd
EncodingConverttoObjCmd.
2023-01-22 11:45:56 +00:00
pooryorick 388bc52075 Merge trunk and resolve conflicts, including changing option processing for
EncodingConverttoObjCmd() and EncodingConvertfromObjCmd().
2023-01-20 00:19:38 +00:00
pooryorick 2c039a780e Add tests to verify the default behaviour for encoding errors. 2023-01-12 09:03:40 +00:00
pooryorick 5c70426f61 For [read] and [gets] encoding errors, used "-result read" in return options
dictionary instead of just "-result".
2023-01-08 00:01:50 +00:00
pooryorick d2fa0702bc Fix for [154ed7ce56], Tcl 9: [gets] on -strictencoding 1 configured channel. 2023-01-02 21:07:02 +00:00
pooryorick 530d3a7f83 Merge py-b8f575aa23. 2022-12-31 00:44:04 +00:00
pooryorick f98272ec1e Strict encoding conformance everywhere by default. Full test suite passes. 2022-12-29 18:11:24 +00:00
pooryorick ba64c646ee Unify TCL_ENCODING_STRICT and TCL_ENCODING_NOCOMPLAIN, and make strict encoding
conformance the default everywhere.
2022-12-28 23:35:24 +00:00
jan.nijtmans 528b7b7168 Merge 8.7 2022-09-28 14:08:05 +00:00
jan.nijtmans 0fbdd463cb Merge 8.7 2022-09-27 13:39:16 +00:00
jan.nijtmans dd1dc3c6e8 Merge 8.7 2022-09-26 19:26:11 +00:00
jan.nijtmans 4a3c559932 rebase to latest 8.7 2022-09-22 12:50:32 +00:00
jan.nijtmans cc185b1d76 eliminate some compiler warnings 2022-09-19 11:50:31 +00:00
jan.nijtmans 2ef45b0593 rebase to 8.7 2022-09-19 11:14:50 +00:00
jan.nijtmans b6ce0622a6 Merge 8.7 2021-11-01 16:28:15 +00:00
dkf 136b650bda Added a basic portable test of [fconfigure -stat] 2021-07-13 19:53:38 +00:00
dkf 65b685deca Added documentation 2021-07-13 19:38:37 +00:00
jan.nijtmans 0865a0b6b0 Merge 8.7. Fix fstat() call in tclUnixChan.c, in case Tcl_StatBuf == struct stat64. 2021-06-29 15:02:53 +00:00
jan.nijtmans 79260bd695 Make tclWinChan.c compile again, fixing obvious implementation problems. Not tested if it actually works. 2021-06-29 08:54:19 +00:00
jan.nijtmans 1a062775d2 Fix iocmd-8.4 testcase 2021-06-28 12:32:35 +00:00
dkf a855be143c merge core-8-branch 2021-06-27 11:26:36 +00:00
dkf 5e07595538 First attempt at Windows implementation.
I don't develop on that platform, so this is extra dodgy!
2021-06-19 20:19:49 +00:00
dkf 5ed49bbc61 Added in missing field 2021-06-19 15:57:41 +00:00
dkf fa0c0e6134 Start of implementing TIP 603: chan configure -stat 2021-06-19 14:59:05 +00:00
jan.nijtmans f3b329dd28 Merge 8.7 2021-01-06 11:52:16 +00:00
dkf 496cff3ee1 merge core-8-branch 2021-01-05 20:41:27 +00:00
dkf 0f93742804 merge core-8-branch 2020-12-06 18:24:00 +00:00
dkf 7dd7fe1b6c merge core-8-branch 2020-02-26 16:56:53 +00:00
dkf bfcd8d392a merge core-8-branch 2020-02-22 12:35:05 +00:00
dkf 004c1e1c8e Less contorted code 2020-02-22 12:31:11 +00:00
dkf 99145db40b There are subtle cases where an append-if-new operation is really useful for a slot. 2020-02-15 10:28:01 +00:00
jan.nijtmans 2569d6f81c Merge 8.7 2020-02-12 13:24:16 +00:00
dkf dafa1487f9 caching is one of the two hard things in CS (along with naming and off-by-one-errors) 2020-02-07 09:21:08 +00:00
dkf 743e0e4e1a Move the TIP 558 tests into their own file 2020-01-01 16:57:08 +00:00
dkf 8249e877df More error cases 2020-01-01 16:46:55 +00:00
dkf b308bd97e6 Check for another tricky edge case 2020-01-01 16:01:36 +00:00
dkf ae24dd87fa merge core-8-branch 2019-12-31 23:27:01 +00:00
dkf 995eed36fd Better error messages when a property has the wrong kind for the type of access desired 2019-12-31 23:25:58 +00:00
dkf c4f94adb46 Other list-returning [info class] subcommands are plurals, so change property -> properties 2019-12-31 22:58:01 +00:00
dkf d4b3d3a460 Added docs 2019-12-31 14:56:32 +00:00
dkf 6eb109c913 Even more tests, this time of the return-code semantics of property getters and setters. 2019-12-30 15:35:51 +00:00
dkf edb3a561eb merge core-8-branch 2019-12-30 10:13:25 +00:00
dkf c15b6135d5 More tests, more fixes 2019-12-30 10:12:16 +00:00
dkf a7a226fc49 Property definitions now work on instances. 2019-12-29 13:23:47 +00:00
dkf 76c3874ad8 Starting to do the testing. 2019-12-28 21:55:56 +00:00
dkf c0eed541eb Implementation of properties for TclOO 2019-12-28 13:24:59 +00:00
136 changed files with 5627 additions and 47087 deletions
-2
View File
@@ -15,8 +15,6 @@ jobs:
matrix:
cfgopt:
- ""
- "CFLAGS=-DTCL_UTF_MAX=3"
- "CFLAGS=-DTCL_NO_DEPRECATED=1"
- "--disable-shared"
- "--enable-symbols"
- "--enable-symbols=mem"
-2
View File
@@ -60,8 +60,6 @@ jobs:
matrix:
cfgopt:
- ""
- "CFLAGS=-DTCL_UTF_MAX=3"
- "CFLAGS=-DTCL_NO_DEPRECATED=1"
- "--disable-shared"
- "--enable-symbols"
- "--enable-symbols=mem"
-36
View File
@@ -20,20 +20,12 @@ jobs:
compiler: gcc
env:
- BUILD_DIR=unix
- name: "Linux/GCC/Shared: UTF_MAX=3"
os: linux
dist: focal
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT="CFLAGS=-DTCL_UTF_MAX=3"
- name: "Linux/GCC/Shared: NO_DEPRECATED"
os: linux
dist: focal
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1"
- name: "Linux/GCC/Static"
os: linux
dist: focal
@@ -301,20 +293,6 @@ jobs:
- touch generic/tclStubInit.c generic/tclOOStubInit.c generic/tclOOScript.h
- choco install -y make zip
- cd ${BUILD_DIR}
- name: "Windows/GCC/Shared: UTF_MAX=3"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit CFLAGS=-DTCL_UTF_MAX=3"
before_install: *makepreinst
- name: "Windows/GCC/Shared: NO_DEPRECATED"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit CFLAGS=-DTCL_NO_DEPRECATED=1"
before_install: *makepreinst
- name: "Windows/GCC/Static"
os: windows
compiler: gcc
@@ -343,20 +321,6 @@ jobs:
env:
- BUILD_DIR=win
before_install: *makepreinst
- name: "Windows/GCC-x86/Shared: UTF_MAX=3"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="CFLAGS=-DTCL_UTF_MAX=3"
before_install: *makepreinst
- name: "Windows/GCC-x86/Shared: NO_DEPRECATED"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1"
before_install: *makepreinst
- name: "Windows/GCC-x86/Static"
os: windows
compiler: gcc
-8856
View File
File diff suppressed because it is too large Load Diff
-2634
View File
File diff suppressed because it is too large Load Diff
-2539
View File
File diff suppressed because it is too large Load Diff
-3629
View File
File diff suppressed because it is too large Load Diff
-4741
View File
File diff suppressed because it is too large Load Diff
-3349
View File
File diff suppressed because it is too large Load Diff
-4619
View File
File diff suppressed because it is too large Load Diff
-3822
View File
File diff suppressed because it is too large Load Diff
-5921
View File
File diff suppressed because it is too large Load Diff
-3796
View File
File diff suppressed because it is too large Load Diff
+44 -48
View File
@@ -4650,7 +4650,7 @@ threading may still cause problems on AIX. (hobbs)
9/21/99 (bug fix) fixed bug when setting array in non-existent
namespace. [Bug: 2613] (hobbs)
--- Released 8.2.1, October 04, 1999 --- See ChangeLog for details ---
--- Released 8.2.1, October 04, 1999
10/30/99 (feature enhancement) new regexp engine from Henry Spencer
was patched in - should greatly reduce stack space usage. (spencer)
@@ -4680,7 +4680,7 @@ when indexing into one (test case string-5.16) [Bug: 2871] (hobbs)
10/30/99 (bug fix) fixes for mac UTF filename handling (ingham)
--- Released 8.2.2, November 04, 1999 --- See ChangeLog for details ---
--- Released 8.2.2, November 04, 1999
11/19/99 (feature enhancement) bug fixes for http package as well as
patch required by TLS (SSL) extension that adds http::(un)register
@@ -4705,7 +4705,7 @@ atexit handlers.
12/07/99 (bug fix) fixes for 'expr + {[incr]}' and 'expr + {[error]}'
cases (different causes).
--- Released 8.2.3, December 16, 1999 --- See ChangeLog for details ---
--- Released 8.2.3, December 16, 1999
1999-09-14 (feature enhancement) added -start switch to regexp and regsub.
@@ -4762,7 +4762,7 @@ ExitThread to _endthreadex to prevent 4K mem leak (gravereaux)
1999-12-21 (bug fix) changed thread ids to longs (for 64bit systems)
--- Released 8.3b1, December 22, 1999 --- See ChangeLog for details ---
--- Released 8.3b1, December 22, 1999
2000-01-10 (feature enhancement) clock scan now supports the common
ISO 8601 date/time formats. See docs for details. (melski)
@@ -4788,7 +4788,7 @@ symbolicly (like chmod) in [file attributes $file -permissions ...] (schoebel)
2000-01-13 (bug fix) fixed lsort -dictionary problem when sorting
characters between 'Z' and 'a' (flawed upper/lower comparison logic) (melski)
--- Released 8.3b2, January 13, 2000 --- See ChangeLog for details ---
--- Released 8.3b2, January 13, 2000
2000-01-14 (feature enhancement) clock format %Q added, clock scan updated
@@ -4827,7 +4827,7 @@ mac panic from an error when closing an async socket (steffen, ingham)
2000-02-10 (feature enhancement) improved error reporting for failed
loads on Windows (dejong, hobbs)
--- Released 8.3.0, February 10, 2000 --- See ChangeLog for details ---
--- Released 8.3.0, February 10, 2000
2000-03 (bug fixes, feature enhancement) overhaul of http package for
proper handling of async callbacks (new options), version is now at 2.3
@@ -4870,7 +4870,7 @@ tclLoadDyld.c dl type. (sanchez)
2000-04-24 (bug fix) fixed hang in threaded Unix case when backgrounded
exec process was running (dejong)
--- Released 8.3.1, April 26, 2000 --- See ChangeLog for details ---
--- Released 8.3.1, April 26, 2000
2000-04-26 (doc fix) updated/added documentation for many API's and
commands (melski)
@@ -4920,7 +4920,7 @@ pattern matching for [array names] (gazetta)
2000-05-31 (feature enhancement) added -nocomplain and -- flags to
[unset] to allow for silent unset operation (hobbs)
--- Released 8.4a1, June 6, 2000 --- See ChangeLog for details ---
--- Released 8.4a1, June 6, 2000
2000-05-29 (bug fix) corrected resource cleanup in http error cases.
Improved handling of error cases in http. (tamhankar)
@@ -4959,7 +4959,7 @@ sections. (english)
2000-08-07 (bug fix) new man pages memory.n, TCL_MEM_DEBUG.3, Init.3 and
DumpActiveMemory.3. (melski)
--- Released 8.3.2, August 9, 2000 --- See ChangeLog for details ---
--- Released 8.3.2, August 9, 2000
2000-06 thru 2000-11 (build improvements) Added support for mingw (gcc on
Windows), AIX-5 and Win64 builds (dejong, hobbs)
@@ -5018,7 +5018,7 @@ environment (gravereaux)
2000-11-03 (new feature) Tcl_SetMainLoop enables defining an event loop for
tclsh. This enables Tk as a truly loadable package. (hobbs)
--- Released 8.4a2, November 3, 2000 --- See ChangeLog for details ---
--- Released 8.4a2, November 3, 2000
2000-09-27 (bug fix) fixed a bug introduced by a partial fix in 8.3.2 that
didn't set nonBlocking correctly when resetting the flags for the write
@@ -5076,7 +5076,7 @@ Update of READMEs.
Corrected IRIX-5* configure (english). Added support for AIX-5 (hobbs).
Added support for Win64 (hobbs).
--- Released 8.3.3, April 6, 2001 --- See ChangeLog for details ---
--- Released 8.3.3, April 6, 2001
2000-11-23 (new feature)[TIP 7] higher resolution timer on Windows (kenny)
@@ -5150,7 +5150,7 @@ system. This includes the addition of 'file normalize', 'file system',
* corrected several minor errors noted by Purify (hobbs)
--- Released 8.4a3, August 6, 2001 --- See ChangeLog for details ---
--- Released 8.4a3, August 6, 2001
2001-06-27 (bug fix)[217987] corrected backslash substitution of non-ASCII
characters. (hobbs, riefenstahl)
@@ -5256,7 +5256,7 @@ bundles to standard .dylib dynamic libraries like on other unices.
2001-10-18 (bug fix) corrected off-by-one-day error in clock scan with
relative months and years during swing hours. (lavana)
--- Released 8.3.4, October 19, 2001 --- See ChangeLog for details ---
--- Released 8.3.4, October 19, 2001
2001-08-21 (bug fix)[219184] overagressive compilation of [catch] (sofer)
@@ -5282,8 +5282,6 @@ compiles to 0 bytecodes (sofer)
2001-09-13 (new feature)[TIP 56] Tcl_EvalTokensStandard API (sofer)
2001-09-13 (new feature) Old ChangeLog entries => ChangeLog.1999 (hobbs)
2001-09-17 (new feature) compiling with TCL_COMPILE_DEBUG now required to
enable all compile and execution tracing (sofer)
*** POTENTIAL INCOMPATIBILITY ***
@@ -5368,8 +5366,6 @@ of the Host: header value
2002-01-25 (new feature)[496733] socket options -eofchar and -translation
return read-only values (dejong)
2002-01-28 (new feature) Old ChangeLog entries => ChangeLog.20900 (hobbs)
2002-01-28 (performance enhancement) bytecompiled [regexp] for trivial cases
that amount to string matching. Also -nocase and --. (hobbs)
@@ -5394,7 +5390,7 @@ errored out. (kupries, sofer)
2002-02-15 (new feature)[TIP 72] support for 64-bit integer values on
32-bit platforms and ability to work with >2GiB files. Extends many
commands. See ChangeLog and TIP for details.
commands. See TIP for details.
*** POTENTIAL INCOMPATIBILITY ***
2002-02-22 (bug fix)[476537] Fix panic when loading shared library without
@@ -5435,7 +5431,7 @@ of prior Tcl releases. Others will need to be reconciled.
related to the handling of iso2022 text and finalization of escape-based
encodings. (taguchi, takahashi, hobbs)
--- Released 8.4a4, March 5, 2002 --- See ChangeLog for details ---
--- Released 8.4a4, March 5, 2002
2002-03-06 (new feature)[TIP 80] expanded [lsearch] options (wilkason, fellows)
@@ -5545,7 +5541,7 @@ options to configure (max)
2002-07-03 (bug fix)[577015] [catch] catches even compile errors (sofer)
--- Released 8.4b1, July 5, 2002 --- See ChangeLog for details ---
--- Released 8.4b1, July 5, 2002
2002-07-08 (bug fix) restored compatibility of [viewFile] in tcltest (porter)
@@ -5583,7 +5579,7 @@ options to configure (max)
Many internal bugs fixed.
Considerable cleanup of the test suite.
--- Released 8.4b2, August 9, 2002 --- See ChangeLog for details ---
--- Released 8.4b2, August 9, 2002
2002-08-20 (new feature) --enable-memdebug configure option (kupries)
@@ -5598,7 +5594,7 @@ Considerable cleanup of the test suite.
2002-09-02 (platfrom support) 64-bit compile on HP-11 (martin)
--- Released 8.4.0, September 10, 2002 --- See ChangeLog for details ---
--- Released 8.4.0, September 10, 2002
2002-09-18 (platform support) Updated support for compiling with Cygwin and
either mingw or gcc. (khan, howell, dejong)
@@ -5661,7 +5657,7 @@ dirs to tcl_pkgPath: @executable_path/../Frameworks and
@executable_path/../PrivateFrameworks (if they exist), as well as the dirs
in DYLD_FRAMEWORK_PATH (if set). (steffen)
--- Released 8.4.1, October 22, 2002 --- See ChangeLog for details ---
--- Released 8.4.1, October 22, 2002
2002-10-28 (bug fix)[627660] [package unknown] chaining for platform specifics
@@ -5754,7 +5750,7 @@ packages in multiple interps.
2003-02-27 (bug fix)[694232] stop [lsearch -start 0 {} x] segfault
--- Released 8.4.2, March 3, 2003 --- See ChangeLog for details ---
--- Released 8.4.2, March 3, 2003
2003-03-06 (bug fix)[699042] Correct case-insensitive unicode string
comparison in Tcl_UniCharNcasecmp
@@ -5836,7 +5832,7 @@ encoding for the original. Most uses of gb2312 really mean euc-cn.
2003-05-14 (bug fix)[736421] Corrected another putenv() copy behavior
problem when compiling on Windows and using Microsoft's runtime.
--- Released 8.4.3, May 20, 2003 --- See ChangeLog for details ---
--- Released 8.4.3, May 20, 2003
2003-05-23 (bug fix)[726018] reverted internals change to the
'cmdName' Tcl_ObjType that broke several extensions (TclBlend, e4graph...)
@@ -5877,7 +5873,7 @@ Improved documentation, new tests, and some code cleanup.
[655300, 720634, 735364, 748700, 756112, 756744, 756951, 758488, 760768,
763312, 769895, 771539, 771840, 771947, 771949, 772333]
--- Released 8.4.4, July 22, 2003 --- See ChangeLog for details ---
--- Released 8.4.4, July 22, 2003
2003-07-23 (bug fix)[775976] fix registry compilation for VC7.
@@ -5923,7 +5919,7 @@ asked for writable events by the generic layer.
2003-11-17 (bug fix)[230589, 504785, 505048, 703709, 840258] fixes to
various odd regexp "can't happen" bugs.
--- Released 8.4.5, November 20, 2003 --- See ChangeLog for details ---
--- Released 8.4.5, November 20, 2003
2003-12-02 (bug fix)[851747] object sharing fix in [binary scan]
@@ -5960,7 +5956,7 @@ various odd regexp "can't happen" bugs.
2004-03-01 (platform support)[218561] Allow 64-bit configure on IRIX64-6.5*
--- Released 8.4.6, March 1, 2004 --- See ChangeLog for details ---
--- Released 8.4.6, March 1, 2004
Changes to 8.5a1 include all changes to the 8.4 line through 8.4.6,
plus the following, which focuses on the high-level feature changes
@@ -6046,7 +6042,7 @@ in this changeset (new minor version) rather than bug fixes:
* [TIP #157] leading {expand} syntax on words to cause argument expansion.
This is a safer/cleaner alternative to the use of 'eval'.
--- Released 8.5a1, March 3, 2004 --- See ChangeLog for details ---
--- Released 8.5a1, March 3, 2004
2004-03-04 (new feature) registry package is [unload]able (thoyts)
=> registry 1.1.4
@@ -6070,7 +6066,7 @@ each command/interp validity before executing. (sofer)
2004-04-06 (clean up) refactored Tcl header file #include order. Might
create need for changes in extensions that #include private headers.
Changed source code files should work with older Tcl as well. See ChangeLog.
Changed source code files should work with older Tcl as well.
*** POTENTIAL INCOMPATIBILITY ***
2004-04-07 (bug fix)[920667] install into any Unicode path on Win (hobbs)
@@ -6346,7 +6342,7 @@ Doc improvements [759545,926590,935853,1017072,1018486,1022527,1027849,
1032243,1047928,1048005,1058446,1062647,1065732,1073334,etc.]
Test suite expansion [1036649,1001997,etc.]
--- Released 8.5a2, December 7, 2004 --- See ChangeLog for details ---
--- Released 8.5a2, December 7, 2004
2004-12-13 (bug fix)[1083082] encoding memory leaks (ade,porter)
@@ -6490,7 +6486,7 @@ Can support [load] from memory as well (steffen)
Documentation improvements [1075433,1085127,1117017,1124160,1149605,etc.]
--- Released 8.5a3, June 4, 2005 --- See ChangeLog for details ---
--- Released 8.5a3, June 4, 2005
2005-06-06 (bug fix)[1213678] Windows/gcc: crash in stack.test (kenny)
@@ -6741,7 +6737,7 @@ removed (steffen)
Documentation improvements [1211078,1190891,1292427,1277503,1104682,1359183,
1415725,666770]
--- Released 8.5a4, April 27, 2006 --- See ChangeLog for details ---
--- Released 8.5a4, April 27, 2006
2006-05-04 (bug fix)[1480509] srand() accept wide input (porter,afredd)
@@ -6837,7 +6833,7 @@ URL validity checking against RFC 2986 (hobbs)
2006-10-13 (platform support) get stack size on Darwin (steffen)
--- Released 8.5a5, October 20, 2006 --- See ChangeLog for details ---
--- Released 8.5a5, October 20, 2006
2006-10-20 (configure change) Added autodetection for OS-supplied timezone
files (max)
@@ -6919,7 +6915,7 @@ upvar and namespace upvar (sofer)
2007-04-23 (bug fix) fts_open() crash on 64bit Darwin 8 or earlier (steffen)
--- Released 8.5a6, April 25, 2007 --- See ChangeLog for details ---
--- Released 8.5a6, April 25, 2007
2007-04-30 (bug fix)[1705778] many valgrind-detected leaks corrected
@@ -7022,7 +7018,7 @@ project for Xcode 3.0 (steffen)
(bug fix)[1066755] Several stack efficiency efforts increases recursion limit
on Windows to be larger than the default [interp recursionlimit] value
--- Released 8.5b1, September 26, 2007 --- See ChangeLog for details ---
--- Released 8.5b1, September 26, 2007
2007-10-02 (bug fix)[1806422] proper [tcl::tm::path] autoload (porter)
@@ -7034,7 +7030,7 @@ on Windows to be larger than the default [interp recursionlimit] value
2007-10-25 (bug fix)[1726873] intermittent crash in threads (vasiljevic)
--- Released 8.5b2, October 26, 2007 --- See ChangeLog for details ---
--- Released 8.5b2, October 26, 2007
2007-10-27 (bug fix)[1821159] fixed broken compile on x86_64 (sofer)
@@ -7070,7 +7066,7 @@ on Windows to be larger than the default [interp recursionlimit] value
Many significant documentation improvements (fellows, sofer)
--- Released 8.5b3, November 19, 2007 --- See ChangeLog for details ---
--- Released 8.5b3, November 19, 2007
2007-11-20 (enhancement) string rep of dict has stable order (fellows)
@@ -7104,7 +7100,7 @@ over-consumption of resources (drewry,lane,ormandy,fellows)
Several documentation and release notes improvements
--- Released 8.5.0, December 20, 2007 --- See ChangeLog for details ---
--- Released 8.5.0, December 20, 2007
2007-12-23 (bug fix)[1857126] restore backref support to regexps (hobbs)
@@ -7126,7 +7122,7 @@ Several documentation and release notes improvements
Several documentation and release notes improvements
--- Released 8.5.1, February 5, 2008 --- See ChangeLog for details ---
--- Released 8.5.1, February 5, 2008
2008-02-06 (enhancement) [clock format] performance (kenny)
@@ -7187,7 +7183,7 @@ variables without "." added to customization hooks (kupries)
2008-03-27 clock tzdata updated to Olson's tzdata2008b (kenny)
--- Released 8.5.2, March 28, 2008 --- See ChangeLog for details ---
--- Released 8.5.2, March 28, 2008
2008-03-30 (bug fix)[1783544] more robust TclIsNaN() (kenny,teterin)
@@ -7242,7 +7238,7 @@ variables without "." added to customization hooks (kupries)
2008-06-25 (bug fix)[1999119] Support TM packages in Safe Base (kupries)
--- Released 8.6a1, June 25, 2008 --- See ChangeLog for details ---
--- Released 8.6a1, June 25, 2008
2008-06-29 (bug fix)[2004480] plug memory leaks (ade,porter,steffen)
@@ -7295,7 +7291,7 @@ in a deleted interp. (porter)
2008-08-21 (bug fix)[2065115] Restored ***= regexp functioning (hobbs,porter)
--- Released 8.6a2, August 25, 2008 --- See ChangeLog for details ---
--- Released 8.6a2, August 25, 2008
2008-08-29 (bug fix)[2082299] Install TclOO header files (fellows)
@@ -7376,7 +7372,7 @@ Tcl_FSFileAttrStringsProc prototype. (nijtmans)
2008-10-10 (bug fix)[2155658] crash in oo method export (fellows)
--- Released 8.6a3, October 10, 2008 --- See ChangeLog for details ---
--- Released 8.6a3, October 10, 2008
2008-10-13 (bug fix) Fix ability to join threads on 64-bit Windows (thoyts)
@@ -7446,7 +7442,7 @@ evaluation in extensions (sofer,kenny)
2008-12-18 (bug fix)[2444274] panic in long commands from {*} (goth,porter)
--- Released 8.6b1, December 19, 2008 --- See ChangeLog for details ---
--- Released 8.6b1, December 19, 2008
2008-12-27 [TIP 234] Tcl_Zlib* interface revisions (fellows)
*** INCOMPATIBILITY with interface of 8.6b1 ***
@@ -7954,7 +7950,7 @@ memory with buffer backup (ferrieux)
Many more Tcl built-in command errors now set an -errorcode.
--- Released 8.6b2, August 8, 2011 --- See ChangeLog for details ---
--- Released 8.6b2, August 8, 2011
2011-07-02 (bug fix)[3349507] correct double(1[string repeat 0 23]) (kenny)
@@ -8115,7 +8111,7 @@ Many revisions to better support a Cygwin environment (nijtmans)
Dropped support for OS X versions less than 10.4 (Tiger) (fellows)
--- Released 8.6b3, September 18, 2012 --- See ChangeLog for details ---
--- Released 8.6b3, September 18, 2012
2012-09-20 (enhancement) full Unicode support (nijtmans)
=> dde 1.4.0
@@ -8162,7 +8158,7 @@ Dropped support for OS X versions less than 10.4 (Tiger) (fellows)
2012-12-13 (bug fix) crash: [zlib gunzip $data -header noSuchNs::var] (porter)
--- Released 8.6.0, December 20, 2012 --- See ChangeLog for details ---
--- Released 8.6.0, December 20, 2012
2012-12-22 (bug fix)[3598150] DString to Tcl_Obj memleak (afredd)
+1 -2
View File
@@ -28,9 +28,8 @@ opendir(
if ((fd = open(myname, 0, 0)) == -1) {
return NULL;
}
dirp = (DIR *) Tcl_Alloc(sizeof(DIR));
dirp = (DIR *) Tcl_AttemptAlloc(sizeof(DIR));
if (dirp == NULL) {
/* unreachable? */
close(fd);
return NULL;
}
+5 -1
View File
@@ -156,7 +156,11 @@ waitpid(
goto waitAgain;
}
}
waitPtr = (WaitInfo *) Tcl_Alloc(sizeof(WaitInfo));
waitPtr = (WaitInfo *) Tcl_AttemptAlloc(sizeof(WaitInfo));
if (!waitPtr) {
errno = ENOMEM;
return -1;
}
waitPtr->pid = result;
waitPtr->status = status;
waitPtr->nextPtr = deadList;
+1 -1
View File
@@ -133,7 +133,7 @@ is true.
.PP
\fBTcl_Import\fR imports commands matching a pattern into a
namespace. Note that the pattern must include the name of the
namespace to import from. This function returns an error if
namespace to import from. This function returns TCL_ERROR if
an attempt to import a command over an existing command is made,
unless the \fIallowOverwrite\fR flag has been set.
.PP
+7 -5
View File
@@ -406,8 +406,10 @@ to UTF-8 based on the channel's encoding and storing the produced data in
\fIreadObjPtr\fR's string representation. The return value of
\fBTcl_ReadChars\fR is the number of characters, up to \fIcharsToRead\fR,
that were stored in \fIreadObjPtr\fR. If an error occurs while reading, the
return value is -1 and \fBTcl_ReadChars\fR records a POSIX error code that
can be retrieved with \fBTcl_GetErrno\fR.
return value is -1 and \fBTcl_ReadChars\fR records a POSIX error
code that can be retrieved with \fBTcl_GetErrno\fR. If an encoding error happens
while the channel is in blocking mode with -profile strict, the characters
retrieved until the encoding error happened will be stored in \fIreadObjPtr\fR.
.PP
Setting \fIcharsToRead\fR to -1 will cause the command to read
all characters currently available (non-blocking) or everything until
@@ -416,9 +418,9 @@ eof (blocking mode).
The return value may be smaller than the value to read, indicating that less
data than requested was available. This is called a \fIshort read\fR. In
blocking mode, this can only happen on an end-of-file. In nonblocking mode,
a short read can also occur if there is not enough input currently
available: \fBTcl_ReadChars\fR returns a short count rather than waiting
for more data.
a short read can also occur if an encoding error is encountered (with -profile
strict) or if there is not enough input currently available:
\fBTcl_ReadChars\fR returns a short count rather than waiting for more data.
.PP
If the channel is in blocking mode, a return value of zero indicates an
end-of-file condition. If the channel is in nonblocking mode, a return
+1 -1
View File
@@ -188,7 +188,7 @@ is used to initialize the compression engine rather than leaving it to create
it on the fly from the data being compressed. Setting a compression dictionary
allows for more efficient compression in the case where the start of the data
is highly regular, but it does require both the compressor and the
decompressor to agreee on the value to use. Compression dictionaries are only
decompressor to agree on the value to use. Compression dictionaries are only
fully supported for zlib-format data; on compression, they must be set before
any data is sent in with \fBTcl_ZlibStreamPut\fR, and on decompression they
should be set when \fBTcl_ZlibStreamGet\fR produces an \fBerror\fR with its
+1 -1
View File
@@ -69,7 +69,7 @@ This procedure will act as the \fBmain()\fR of the newly created
thread. The specified \fIclientData\fR will be its sole argument.
.AP void *clientData in
Arbitrary information. Passed as sole argument to the \fIproc\fR.
.AP int stackSize in
.AP size_t stackSize in
The size of the stack given to the new thread.
.AP int flags in
Bitmask containing flags allowing the caller to modify behavior of
+16 -3
View File
@@ -55,7 +55,9 @@ channel is flushed in the background before finally being closed.
.PP
\fBchan close\fR may return an error if an error occurs while flushing
output. If a process in a command pipeline created by \fBopen\fR returns an
error, \fBchan close\fR generates an error in the same manner as \fBexec\fR.
error (either by returning a non-zero exit code or writing to its standard
error file descriptor), \fBchan close\fR generates an error in the same
manner as \fBexec\fR.
.PP
Closing one side of a socket or command pipeline may lead to the shutdown() or
close() of the underlying system resource, leading to a reaction from whatever
@@ -70,6 +72,17 @@ description of channel sharing.
.PP
When the last interpreter sharing a channel is destroyed, the channel is
switched to blocking mode and fully flushed and then closed.
.PP
Channels are automatically closed when an interpreter is destroyed and
when the process exits.
From 8.6 on (TIP#398), nonblocking channels are no longer switched to
blocking mode when exiting; this guarantees a timely exit even when the
peer or a communication channel is stalled. To ensure proper flushing of
stalled nonblocking channels on exit, one must now either (a) actively
switch them back to blocking or (b) use the environment variable
\fBTCL_FLUSH_NONBLOCKING_ON_EXIT\fR, which when set and not equal to
.QW \fB0\fR
restores the previous behavior.
.RE
.TP
\fBchan configure \fIchannelName\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?...
@@ -348,8 +361,8 @@ first words of a command that provides the interface for a \fBrefchan\fR.
\fBImode\fR is a list of one or more of the strings
.QW \fBread\fR
or
.QW \fBwrite\fR
, indicating whether the channel is a read channel, a write channel, or both.
.QW \fBwrite\fR ,
indicating whether the channel is a read channel, a write channel, or both.
It is an error if the handler does not support the chosen mode.
.PP
The handler is called as needed from the global namespace at the top level, and
+15 -6
View File
@@ -12,11 +12,12 @@
.SH NAME
close \- Close an open channel
.SH SYNOPSIS
\fBclose \fIchannelId\fR ?r(ead)|w(rite)?
\fBclose \fIchannelId\fR ?\fBr\fR(\fBead\fR)|\fBw\fR(\fBrite\fR)?
.BE
.SH DESCRIPTION
.PP
Closes or half-closes the channel given by \fIchannelId\fR.
Closes or half-closes the channel given by \fIchannelId\fR. \fBchan close\fR
is another name for this command.
.PP
\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
@@ -49,12 +50,20 @@ When the last interpreter in which the channel is registered invokes
.PP
Channels are automatically closed when an interpreter is destroyed and
when the process exits.
From 8.6 on (TIP#398), nonblocking channels are no longer switched to blocking mode when exiting; this guarantees a timely exit even when the peer or a communication channel is stalled. To ensure proper flushing of stalled nonblocking channels on exit, one must now either (a) actively switch them back to blocking or (b) use the environment variable TCL_FLUSH_NONBLOCKING_ON_EXIT, which when set and not equal to "0" restores the previous behavior.
From 8.6 on (TIP#398), nonblocking channels are no longer switched to
blocking mode when exiting; this guarantees a timely exit even when the
peer or a communication channel is stalled. To ensure proper flushing of
stalled nonblocking channels on exit, one must now either (a) actively
switch them back to blocking or (b) use the environment variable
\fBTCL_FLUSH_NONBLOCKING_ON_EXIT\fR, which when set and not equal to
.QW \fB0\fR
restores the previous behavior.
.PP
The command returns an empty string, and may generate an error if
an error occurs while flushing output. If a command in a command
pipeline created with \fBopen\fR returns an error, \fBclose\fR
generates an error (similar to the \fBexec\fR command.)
pipeline created with \fBopen\fR returns an error (either by returning a
non-zero exit code or writing to its standard error file descriptor),
\fBclose\fR generates an error (similar to the \fBexec\fR command.)
.PP
The two-argument form is a
.QW "half-close" :
@@ -95,7 +104,7 @@ proc withOpenFile {filename channelVar script} {
}
.CE
.SH "SEE ALSO"
file(n), open(n), socket(n), eof(n), Tcl_StandardChannels(3)
chan(n), file(n), open(n), socket(n), eof(n), Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, channel, close, nonblocking, half-close
'\" Local Variables:
+333
View File
@@ -0,0 +1,333 @@
'\"
'\" Copyright © 2019 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH configurable n 0.4 TclOO "TclOO Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
oo::configurable, configure, property \- class that makes configurable classes and objects, and supports making configurable properties
.SH SYNOPSIS
.nf
package require TclOO
\fBoo::configurable create \fIclass\fR ?\fIdefinitionScript\fR?
\fBoo::define \fIclass\fB {\fR
\fBproperty \fIpropName\fR ?\fIoptions...\fR? ?\fIpropName\fR ?\fIoptions...\fR?...?
\fB}\fR
\fBoo::objdefine \fIobject\fB {\fR
\fBproperty \fIpropName\fR ?\fIoptions...\fR? ?\fIpropName\fR ?\fIoptions...\fR?...?
\fB}\fR
\fIobjectName \fBconfigure\fR
\fIobjectName \fBconfigure\fR \fI\-prop\fR
\fIobjectName \fBconfigure\fR \fI\-prop value\fR ?\fI\-prop value\fR...
.fi
.SH "CLASS HIERARCHY"
.nf
\fBoo::object\fR
\(-> \fBoo::class\fR
\(-> \fBoo::configurable\fR
\fBoo::object\fR
\(-> \fBoo::class\fR
\(-> \fBoo::configurablesupport::configurable\fR
.fi
.BE
.SH DESCRIPTION
.PP
Configurable objects are objects that support being configured with a
\fBconfigure\fR method. Each of the configurable entities of the object is
known as a property of the object. Properties may be defined on classes or
instances; when configuring an object, any of the properties defined by its
classes (direct or indirect) or by the instance itself may be configured.
.PP
The \fBoo::configurable\fR metaclass installs basic support for making
configurable objects into a class. This consists of making a \fBproperty\fR
definition command available in definition scripts for the class and instances
(e.g., from the class's constructor, within \fBoo::define\fR and within
\fBoo::objdefine\fR) and making a \fBconfigure\fR method available within the
instances.
.SS "CONFIGURE METHOD"
.PP
The behavior of the \fBconfigure\fR method is modelled after the
\fBfconfigure\fR/\fBchan configure\fR command.
.PP
If passed no additional arguments, the \fBconfigure\fR method returns an
alphabetically sorted dictionary of all \fIreadable\fR and \fIread-write\fR
properties and their current values.
.PP
If passed a single additional argument, that argument to the \fBconfigure\fR
method must be the name of a property to read (or an unambiguous prefix
thereof); its value is returned.
.PP
Otherwise, if passed an even number of arguments then each pair of arguments
specifies a property name (or an unambiguous prefix thereof) and the value to
set it to. The properties will be set in the order specified, including
duplicates. If the setting of any property fails, the overall \fBconfigure\fR
method fails, the preceding pairs (if any) will continue to have been applied,
and the succeeding pairs (if any) will be not applied. On success, the result
of the \fBconfigure\fR method in this mode operation will be an empty string.
.SS "PROPERTY DEFINITIONS"
.PP
When a class has been manufactured by the \fBoo::configurable\fR metaclass (or
one of its subclasses), it gains an extra definition, \fBproperty\fR. The
\fBproperty\fR definition defines one or more properties that will be exposed
by the class's instances.
.PP
The \fBproperty\fR command takes the name of a property to define first,
\fIwithout a leading hyphen\fR, followed by a number of option-value pairs
that modify the basic behavior of the property. This can then be followed by
an arbitrary number of other property definitions. The supported options are:
.TP
\fB\-get \fIgetterScript\fR
.
This defines the implementation of how to read from the property; the
\fIgetterScript\fR will become the body of a method (taking no arguments)
defined on the class, if the kind of the property is such that the property
can be read from. The method will be named
\fB<ReadProp-\fIpropertyName\fB>\fR, and will default to being a simple read
of the instance variable with the same name as the property (e.g.,
.QW "\fBproperty\fR xyz"
will result in a method
.QW <ReadProp-xyz>
being created).
.TP
\fB\-kind \fIpropertyKind\fR
.
This defines what sort of property is being created. The \fIpropertyKind\fR
must be exactly one of \fBreadable\fR, \fBwritable\fR, or \fBreadwrite\fR
(which is the default) which will make the property read-only, write-only or
read-write, respectively. Read-only properties can only ever be read from,
write-only properties can only ever be written to, and read-write properties
can be both read and written.
.RS
.PP
Note that write-only properties are not particularly discoverable as they are
never reported by the \fBconfigure\fR method other than by error messages when
attempting to write to a property that does not exist.
.RE
.TP
\fB\-set \fIsetterScript\fR
.
This defines the implementation of how to write to the property; the
\fIsetterScript\fR will become the body of a method taking a single argument,
\fIvalue\fR, defined on the class, if the kind of the property is such that
the property can be written to. The method will be named
\fB<WriteProp-\fIpropertyName\fB>\fR, and will default to being a simple write
of the instance variable with the same name as the property (e.g.,
.QW "\fBproperty\fR xyz"
will result in a method
.QW <WriteProp-xyz>
being created).
.PP
Instances of the class that was created by \fBoo::configurable\fR will also
support \fBproperty\fR definitions; the semantics will be exactly as above
except that the properties will be defined on the instance alone.
.PP
Note that the property implementation methods that \fBproperty\fR defines
should not be private, as this makes them inaccessible from the implementation
of \fBconfigure\fR (by design; the property configuration mechanism is
intended for use mainly from outside a class, whereas a class may access
variables directly). The variables accessed by the default implementations of
the properties \fImay\fR be private, if so declared.
.SH "ADVANCED USAGE"
.PP
The configurable class system is comprised of several pieces. The
\fBoo::configurable\fR metaclass works by mixing in a class and setting
definition namespaces during object creation that provide the other bits and
pieces of machinery. The key pieces of the implementation are enumerated here
so that they can be used by other code:
.TP
\fBoo::configuresupport::configurable\fR
.
This is a class that provides the implementation of the \fBconfigure\fR method
(described above in \fBCONFIGURE METHOD\fR).
.TP
\fBoo::configuresupport::configurableclass\fR
.
This is a namespace that contains the definition dialect that provides the
\fBproperty\fR declaration for use in classes (i.e., via \fBoo::define\fR, and
class constructors under normal circumstances), as described above in
\fBPROPERTY DEFINITIONS\fR. It \fBnamespace export\fRs its \fBproperty\fR
command so that it may be used easily in user definition dialects.
.TP
\fBoo::configuresupport::configurableobject\fR
.
This is a namespace that contains the definition dialect that provides the
\fBproperty\fR declaration for use in instance objects (i.e., via
\fBoo::objdefine\fR, and the \fBself\fR declaration in \fBoo::define\fR), as
described above in \fBPROPERTY DEFINITIONS\fR. It \fBnamespace export\fRs its
\fBproperty\fR command so that it may be used easily in user definition
dialects.
.PP
The underlying property discovery mechanism relies on four slots (see
\fBoo::define\fR for what that implies) that list the properties that can be
configured. These slots do not themselves impose any semantics on what the
slots mean other than that they have unique names, no important order, can be
inherited and discovered on classes and instances.
.PP
These slots, and their intended semantics, are:
.TP
\fBoo::configuresupport::readableproperties\fR
.
The set of properties of a class (not including those from its superclasses)
that may be read from when configuring an instance of the class. This slot can
also be read with the \fBinfo class properties\fR command.
.TP
\fBoo::configuresupport::writableproperties\fR
.
The set of properties of a class (not including those from its superclasses)
that may be written to when configuring an instance of the class. This slot
can also be read with the \fBinfo class properties\fR command.
.TP
\fBoo::configuresupport::objreadableproperties\fR
.
The set of properties of an object instance (not including those from its
classes) that may be read from when configuring the object. This slot can
also be read with the \fBinfo object properties\fR command.
.TP
\fBoo::configuresupport::objwritableproperties\fR
.
The set of properties of an object instance (not including those from its
classes) that may be written to when configuring the object. This slot can
also be read with the \fBinfo object properties\fR command.
.PP
Note that though these are slots, they are \fInot\fR in the standard
\fBoo::define\fR or \fBoo::objdefine\fR namespaces; in order to use them
inside a definition script, they need to be referred to by full name. This is
because they are intended to be building bricks of configurable property
system, and not directly used by normal user code.
.SS "IMPLEMENTATION NOTE"
.PP
The implementation of the \fBconfigure\fR method uses
\fBinfo object properties\fR with the \fB\-all\fR option to discover what
properties it may manipulate.
.SH EXAMPLES
.PP
Here we create a simple configurable class and demonstrate how it can be
configured:
.PP
.CS
\fBoo::configurable\fR create Point {
\fBproperty\fR x y
constructor args {
my \fBconfigure\fR -x 0 -y 0 {*}$args
}
variable x y
method print {} {
puts "x=$x, y=$y"
}
}
set pt [Point new -x 27]
$pt print; \fI# x=27, y=0\fR
$pt \fBconfigure\fR -y 42
$pt print; \fI# x=27, y=42\fR
puts "distance from origin: [expr {
hypot([$pt \fBconfigure\fR -x], [$pt \fBconfigure\fR -y])
}]"; \fI# distance from origin: 49.92995093127971\fR
puts [$pt \fBconfigure\fR]
\fI# -x 27 -y 42\fR
.CE
.PP
Such a configurable class can be extended by subclassing, though the subclass
needs to also be created by \fBoo::configurable\fR if it will use the
\fBproperty\fR definition:
.PP
.CS
\fBoo::configurable\fR create Point3D {
superclass Point
\fBproperty\fR z
constructor args {
next -z 0 {*}$args
}
}
set pt2 [Point3D new -x 2 -y 3 -z 4]
puts [$pt2 \fBconfigure\fR]
\fI# -x 2 -y 3 -z 4\fR
.CE
.PP
Once you have a configurable class, you can also add instance properties to
it. (The backing variables for all properties start unset.) Note below that we
are using an unambiguous prefix of a property name when setting it; this is
supported for all properties though full names are normally recommended
because subclasses will not make an unambiguous prefix become ambiguous in
that case.
.PP
.CS
oo::objdefine $pt {
\fBproperty\fR color
}
$pt \fBconfigure\fR -c bisque
puts [$pt \fBconfigure\fR]
\fI# -color bisque -x 27 -y 42\fR
.CE
.PP
You can also do derived properties by making them read-only and supplying a
script that computes them.
.PP
.CS
\fBoo::configurable\fR create PointMk2 {
\fBproperty\fR x y
\fBproperty\fR distance -kind readable -get {
return [expr {hypot($x, $y)}]
}
variable x y
constructor args {
my \fBconfigure\fR -x 0 -y 0 {*}$args
}
}
set pt3 [PointMk2 new -x 3 -y 4]
puts [$pt3 \fBconfigure\fR -distance]
\fI# 5.0\fR
$pt3 \fBconfigure\fR -distance 10
\fI# ERROR: bad property "-distance": must be -x or -y\fR
.CE
.PP
Setters are used to validate the type of a property:
.PP
.CS
\fBoo::configurable\fR create PointMk3 {
\fBproperty\fR x -set {
if {![string is double -strict $value]} {
error "-x property must be a number"
}
set x $value
}
\fBproperty\fR y -set {
if {![string is double -strict $value]} {
error "-y property must be a number"
}
set y $value
}
variable x y
constructor args {
my \fBconfigure\fR -x 0 -y 0 {*}$args
}
}
set pt4 [PointMk3 new]
puts [$pt4 \fBconfigure\fR]
\fI# -x 0 -y 0\fR
$pt4 \fBconfigure\fR -x 3 -y 4
puts [$pt4 \fBconfigure\fR]
\fI# -x 3 -y 4\fR
$pt4 \fBconfigure\fR -x "obviously not a number"
\fI# ERROR: -x property must be a number\fR
.CE
.SH "SEE ALSO"
info(n), oo::class(n), oo::define(n)
.SH KEYWORDS
class, object, properties, configuration
.\" Local variables:
.\" mode: nroff
.\" fill-column: 78
.\" End:
+6
View File
@@ -493,6 +493,12 @@ the slot:
.
This appends the given \fImember\fR elements to the slot definition.
.TP
\fIslot\fR \fB\-appendifnew\fR ?\fImember ...\fR?
.VS TIP558
This appends the given \fImember\fR elements to the slot definition if they
do not already exist.
.VE TIP558
.TP
\fIslot\fR \fB\-clear\fR
.
This sets the slot definition to the empty list.
+47
View File
@@ -490,6 +490,29 @@ be discovered with \fBinfo class forward\fR.
This subcommand returns a list of all classes that have been mixed into the
class named \fIclass\fR.
.TP
\fBinfo class properties\fI class\fR ?\fIoptions...\fR
.VS "TIP 558"
This subcommand returns a sorted list of properties defined on the class named
\fIclass\fR. The \fIoptions\fR define exactly which properties are returned:
.RS
.TP
\fB\-all\fR
.
With this option, the properties from the superclasses and mixins of the class
are also returned.
.TP
\fB\-readable\fR
.
This option (the default behavior) asks for the readable properties to be
returned. Only readable or writable properties are returned, not both.
.TP
\fB\-writable\fR
.
This option asks for the writable properties to be returned. Only readable or
writable properties are returned, not both.
.RE
.VE "TIP 558"
.TP
\fBinfo class subclasses\fI class\fR ?\fIpattern\fR?
.
This subcommand returns a list of direct subclasses of class \fIclass\fR. If
@@ -679,6 +702,30 @@ object named \fIobject\fR.
This subcommand returns the name of the internal namespace of the object named
\fIobject\fR.
.TP
\fBinfo object properties\fI object\fR ?\fIoptions...\fR
.VS "TIP 558"
This subcommand returns a sorted list of properties defined on the object
named \fIobject\fR. The \fIoptions\fR define exactly which properties are
returned:
.RS
.TP
\fB\-all\fR
.
With this option, the properties from the class, superclasses and mixins of
the object are also returned.
.TP
\fB\-readable\fR
.
This option (the default behavior) asks for the readable properties to be
returned. Only readable or writable properties are returned, not both.
.TP
\fB\-writable\fR
.
This option asks for the writable properties to be returned. Only readable or
writable properties are returned, not both.
.RE
.VE "TIP 558"
.TP
\fBinfo object variables\fI object\fRR ?\fB\-private\fR?
.
This subcommand returns a list of all variables that have been declared for
+13 -13
View File
@@ -24,7 +24,7 @@ Arguments \fIfirst\fR and \fIlast\fR are index values specifying the first and
last elements of the range to replace. They are interpreted
the same as index values for the command \fBstring index\fR,
supporting simple index arithmetic and indices relative to the
end of the list. The index 0 refers to the first element of the
end of the list. The index \fB0\fR refers to the first element of the
list, and \fBend\fR refers to the last element of the list.
.PP
If either \fIfirst\fR or \fIlast\fR is less than zero, it is considered to
@@ -49,33 +49,33 @@ between \fIfirst\fR and \fIlast\fR are simply deleted.
Prepend to a list.
.PP
.CS
% set lst {c d e f g}
c d e f g
% ledit lst -1 -1 a b
a b c d e f g
set lst {c d e f g}
\fI\(-> c d e f g\fR
\fBledit\fR lst -1 -1 a b
\fI\(-> a b c d e f g\fR
.CE
.PP
Append to the list.
.PP
.CS
% ledit lst end+1 end+1 h i
a b c d e f g h i
\fBledit\fR lst end+1 end+1 h i
\fI\(-> a b c d e f g h i\fR
.CE
.PP
Delete third and fourth elements.
.PP
.CS
% ledit lst 2 3
a b e f g h i
\fBledit\fR lst 2 3
\fI\(-> a b e f g h i\fR
.CE
.PP
Replace two elements with three.
.PP
.CS
% ledit lst 2 3 x y z
a b x y z g h i
% set lst
a b x y z g h i
\fBledit\fR lst 2 3 x y z
\fI\(-> a b x y z g h i\fR
set lst
\fI\(-> a b x y z g h i\fR
.CE
.PP
.SH "SEE ALSO"
+111 -3
View File
@@ -58,6 +58,7 @@ the auto-load mechanism defined below.
The following procedures are provided in the Tcl library:
.TP
\fBauto_execok \fIcmd\fR
.
Determines whether there is an executable file or shell builtin
by the name \fIcmd\fR. If so, it returns a list of arguments to be
passed to \fBexec\fR to execute the executable file or shell builtin
@@ -70,8 +71,30 @@ remembers information about previous searches in an array named
\fBauto_execs\fR; this avoids the path search in future calls for the
same \fIcmd\fR. The command \fBauto_reset\fR may be used to force
\fBauto_execok\fR to forget its cached information.
.RS
.PP
For example, to run the \fIumask\fR shell builtin on Linux, you would do:
.PP
.CS
exec {*}[\fBauto_execok\fR umask]
.CE
.PP
To run the \fIDIR\fR shell builtin on Windows, you would do:
.PP
.CS
exec {*}[\fBauto_execok\fR dir]
.CE
.PP
To discover if there is a \fIfrobnicate\fR binary on the user's PATH,
you would do:
.PP
.CS
set mayFrob [expr {[llength [\fBauto_execok\fR frobnicate]] > 0}]
.CE
.RE
.TP
\fBauto_import \fIpattern\fR
.
\fBAuto_import\fR is invoked during \fBnamespace import\fR to see if
the imported commands specified by \fIpattern\fR reside in an
autoloaded library. If so, the commands are loaded so that they will
@@ -79,13 +102,18 @@ be available to the interpreter for creating the import links. If the
commands do not reside in an autoloaded library, \fBauto_import\fR
does nothing. The pattern matching is performed according to the
matching rules of \fBnamespace import\fR.
.RS
.PP
It is not normally necessary to call this command directly.
.RE
.TP
\fBauto_load \fIcmd\fR
.
This command attempts to load the definition for a Tcl command named
\fIcmd\fR. To do this, it searches an \fIauto-load path\fR, which is
a list of one or more directories. The auto-load path is given by the
global variable \fBauto_path\fR if it exists. If there is no
\fBauto_path\fR variable, then the TCLLIBPATH environment variable is
\fBauto_path\fR variable, then the \fBTCLLIBPATH\fR environment variable is
used, if it exists. Otherwise the auto-load path consists of just the
Tcl library directory. Within each directory in the auto-load path
there must be a file \fBtclIndex\fR that describes one or more
@@ -104,6 +132,11 @@ the array \fBauto_index\fR; future calls to \fBauto_load\fR check for
cached index information may be deleted with the command
\fBauto_reset\fR. This will force the next \fBauto_load\fR command to
reload the index database from disk.
.RS
.PP
It is not normally necessary to call this command directly; the
default \fBunknown\fR handler will do so.
.RE
.TP
\fBauto_mkindex \fIdir pattern pattern ...\fR
.
@@ -156,6 +189,7 @@ listed in the auto-load index, so that fresh copies of them will be
loaded the next time that they are used.
.TP
\fBauto_qualify \fIcommand namespace\fR
.
Computes a list of fully qualified names for \fIcommand\fR. This list
mirrors the path a standard Tcl interpreter follows for command
lookups: first it looks for the command in the current namespace, and
@@ -175,6 +209,7 @@ performing the actual auto-loading of functions at runtime.
.RE
.TP
\fBtcl_findLibrary \fIbasename version patch initScript enVarName varName\fR
.
This is a standard search procedure for use by extensions during
their initialization. They call this procedure to look for their
script library in several standard directories.
@@ -197,14 +232,25 @@ relative to the executable file in the current build tree;
relative to the executable file in a parallel build tree.
.TP
\fBparray \fIarrayName\fR ?\fIpattern\fR?
.
Prints on standard output the names and values of all the elements in the
array \fIarrayName\fR, or just the names that match \fIpattern\fR (using the
matching rules of \fBstring match\fR) and their values if \fIpattern\fR is
given.
\fIArrayName\fR must be an array accessible to the caller of \fBparray\fR.
It may be either local or global.
The result of this command is the empty string.
.RS
.PP
For example, to print the contents of the \fBtcl_platform\fR array, do:
.PP
.CS
\fBparray\fR tcl_platform
.CE
.RE
.TP
\fBtcl_endOfWord \fIstr start\fR
.
Returns the index of the first end-of-word location that occurs after
a starting index \fIstart\fR in the string \fIstr\fR. An end-of-word
location is defined to be the first non-word character following the
@@ -215,19 +261,35 @@ for more details on how Tcl determines which characters are word
characters.
.TP
\fBtcl_startOfNextWord \fIstr start\fR
.
Returns the index of the first start-of-word location that occurs
after a starting index \fIstart\fR in the string \fIstr\fR. A
start-of-word location is defined to be the first word character
following a non-word character. Returns \-1 if there are no more
start-of-word locations after the starting point.
.RS
.PP
For example, to print the indices of the starts of each word in a
string according to platform rules:
.PP
.CS
set theString "The quick brown fox"
for {set idx 0} {$idx >= 0} {
set idx [\fBtcl_startOfNextWord\fR $theString $idx]} {
puts "Word start index: $idx"
}
.CE
.RE
.TP
\fBtcl_startOfPreviousWord \fIstr start\fR
.
Returns the index of the first start-of-word location that occurs
before a starting index \fIstart\fR in the string \fIstr\fR. Returns
\-1 if there are no more start-of-word locations before the starting
point.
.TP
\fBtcl_wordBreakAfter \fIstr start\fR
.
Returns the index of the first word boundary after the starting index
\fIstart\fR in the string \fIstr\fR. Returns \-1 if there are no more
boundaries after the starting point in the given string. The index
@@ -235,6 +297,7 @@ returned refers to the second character of the pair that comprises a
boundary.
.TP
\fBtcl_wordBreakBefore \fIstr start\fR
.
Returns the index of the first word boundary before the starting index
\fIstart\fR in the string \fIstr\fR. Returns \-1 if there are no more
boundaries before the starting point in the given string. The index
@@ -248,18 +311,30 @@ commands and packages, and determining what are words.
.SS "AUTOLOADING AND PACKAGE MANAGEMENT VARIABLES"
.TP
\fBauto_execs\fR
.
Used by \fBauto_execok\fR to record information about whether
particular commands exist as executable files.
.RS
.PP
Not normally usefully accessed directly by user code.
.RE
.TP
\fBauto_index\fR
.
Used by \fBauto_load\fR to save the index information read from
disk.
.RS
.PP
Not normally usefully accessed directly by user code.
.RE
.TP
\fBauto_noexec\fR
.
If set to any value, then \fBunknown\fR will not attempt to auto-exec
any commands.
.TP
\fBauto_noload\fR
.
If set to any value, then \fBunknown\fR will not attempt to auto-load
any commands.
.TP
@@ -275,37 +350,70 @@ the parent directory of \fBtcl_library\fR,
the directories listed in the \fBtcl_pkgPath\fR variable.
Additional locations to look for files and package indices should
normally be added to this variable using \fBlappend\fR.
.RS
.PP
For example, to add the \fIlib\fR directory next to the running
script, you would do:
.PP
.CS
lappend \fBauto_path\fR [file dirname [info script]]/lib
.CE
.PP
Note that if the script uses \fBcd\fR, it is advisable to ensure that
entries on the \fBauto_path\fR are \fBfile normalize\fRd.
.RE
.TP
\fBenv(TCL_LIBRARY)\fR
.
If set, then it specifies the location of the directory containing
library scripts (the value of this variable will be
assigned to the \fBtcl_library\fR variable and therefore returned by
the command \fBinfo library\fR). If this variable is not set then
a default value is used.
.RS
.PP
Use of this environment variable is not recommended outside of testing.
Tcl installations should already know where to find their own script
files, as the value is baked in during the build or installation.
.RE
.TP
\fBenv(TCLLIBPATH)\fR
.
If set, then it must contain a valid Tcl list giving directories to
search during auto-load operations. Directories must be specified in
Tcl format, using
.QW /
as the path separator, regardless of platform.
This variable is only used when initializing the \fBauto_path\fR variable.
.RS
.PP
A key consequence of this variable is that it gives a way to let the user
of a script specify the list of places where that script may use
\fBpackage require\fR to read packages from. It is not normally usefully
settable within a Tcl script itself \fIexcept\fR to influence where other
interpreters load from (whether made with \fBinterp create\fR or launched
as their own threads or subprocesses).
.RE
.SS "WORD BOUNDARY DETERMINATION VARIABLES"
These variables are only used in the \fBtcl_endOfWord\fR,
\fBtcl_startOfNextWord\fR, \fBtcl_startOfPreviousWord\fR,
\fBtcl_wordBreakAfter\fR, and \fBtcl_wordBreakBefore\fR commands.
.TP
\fBtcl_nonwordchars\fR
.
This variable contains a regular expression that is used by routines
like \fBtcl_endOfWord\fR to identify whether a character is part of a
word or not. If the pattern matches a character, the character is
considered to be a non-word character. The default is "\\W".
considered to be a non-word character. The default value is
.QW "\\W" .
.TP
\fBtcl_wordchars\fR
.
This variable contains a regular expression that is used by routines
like \fBtcl_endOfWord\fR to identify whether a character is part of a
word or not. If the pattern matches a character, the character is
considered to be a word character. The default is "\\w".
considered to be a word character. The default value is
.QW "\\w" .
.SH "SEE ALSO"
env(n), info(n), re_syntax(n)
.SH KEYWORDS
+7 -7
View File
@@ -52,11 +52,11 @@ oo::class create ABC {
constructor {} {
\fBlink\fR Foo
# The method foo is now directly accessible as foo here
# The method Foo is now directly accessible as Foo here
\fBlink\fR {bar Foo}
# The method foo is now directly accessible as bar
# The method Foo is now directly accessible as bar
\fBlink\fR {::ExternalCall Foo}
# The method foo is now directly accessible in the global
# The method Foo is now directly accessible in the global
# namespace as ExternalCall
}
@@ -71,13 +71,13 @@ oo::class create ABC {
ABC create abc
abc grill
\fI\(-> Step 1:\fR
\fI\(-> This is foo in ::abc\fR
\fI\(-> This is Foo in ::abc\fR
\fI\(-> Step 2:\fR
\fI\(-> This is foo in ::abc\fR
\fI\(-> This is Foo in ::abc\fR
# Direct access via the linked command
puts "Step 3:"; ExternalCall
\fI\(-> Step 3:\fR
\fI\(-> This is foo in ::abc\fR
\fI\(-> This is Foo in ::abc\fR
.CE
.PP
This example shows that multiple linked commands can be made in a call to
@@ -88,7 +88,7 @@ oo::class create Ex {
constructor {} {
\fBlink\fR a b c
# The methods a, b, and c (defined below) are all now
# directly acessible within methods under their own names.
# directly accessible within methods under their own names.
}
method a {} {
+1 -1
View File
@@ -16,7 +16,7 @@ lremove \- Remove elements from a list by index
.SH DESCRIPTION
.PP
\fBlremove\fR returns a new list formed by simultaneously removing zero or
more elements of \fIlist\fR at each of the indices given by an arbirary number
more elements of \fIlist\fR at each of the indices given by an arbitrary number
of \fIindex\fR arguments. The indices may be in any order and may be repeated;
the element at index will only be removed once. The index values are
interpreted the same as index values for the command \fBstring index\fR,
+56 -49
View File
@@ -11,73 +11,80 @@
.SH NAME
lseq \- Build a numeric sequence returned as a list
.SH SYNOPSIS
\fBlseq \fIStart \fR?(\fB..\fR|\fBto\fR)? \fIEnd\fR ??\fBby\fR? \fIStep\fR?
\fBlseq \fIstart \fR?(\fB..\fR|\fBto\fR)? \fIend\fR ??\fBby\fR? \fIstep\fR?
\fBlseq \fIStart \fBcount\fR \fICount\fR ??\fBby\fR? \fIStep\fR?
\fBlseq \fIstart \fBcount\fR \fIcount\fR ??\fBby\fR? \fIstep\fR?
\fBlseq \fICount\fR ?\fBby \fIStep\fR?
\fBlseq \fIcount\fR ?\fBby \fIstep\fR?
.BE
.SH DESCRIPTION
.PP
The \fBlseq\fR command creates a sequence of numeric values using the given
parameters \fIStart\fR, \fIEnd\fR, and \fIStep\fR. The \fIoperation\fR
argument ".." or "to" defines an inclusive range. The "count" option is used
to define a count of the number of elements in the list. The short form with a
single count value will create a range from 0 to count-1.
The numeric arguments, \fIStart\fR, \fIEnd\fR, \fIStep\fR, and \fICount\fR,
can also be a valid expression. the lseq command will evaluate the expression
parameters \fIstart\fR, \fIend\fR, and \fIstep\fR.
The \fIoperation\fR argument
.QW \fB..\fR
or
.QW \fBto\fR
defines an inclusive range; if it is omitted, the range is exclusive.
The \fBcount\fR option is used to define a count of the number of elements in
the list.
The \fIstep\fR (which may be preceded by \fBby\fR) is 1 if not provided.
The short form with a
single \fIcount\fR value will create a range from 0 to \fIcount\fR-1 (i.e.,
\fIcount\fR values).
.PP
The numeric arguments, \fIstart\fR, \fIend\fR, \fIstep\fR, and \fIcount\fR,
can also be a valid expression. the \fBlseq\fR command will evaluate the
expression (as if with \fBexpr\fR)
and use the numeric result, or return an error as with any invalid argument
value. A valid expression is a valid [expr] expression, however, the result
must be numeric; a non-numeric string will result in an error.
value; a non-numeric expression result will result in an error.
.SH EXAMPLES
.CS
.\"
\fBlseq\fR 3
\fI\(-> 0 1 2\fR
lseq 3
\(-> 0 1 2
\fBlseq\fR 3 0
\fI\(-> 3 2 1 0\fR
lseq 3 0
\(-> 3 2 1 0
\fBlseq\fR 10 .. 1 by -2
\fI\(-> 10 8 6 4 2\fR
lseq 10 .. 1 by -2
\(-> 10 8 6 4 2
set l [\fBlseq\fR 0 -5]
\fI\(-> 0 -1 -2 -3 -4 -5\fR
set l [lseq 0 -5]
\(-> 0 -1 -2 -3 -4 -5
foreach i [lseq [llength $l]] {
puts l($i)=[lindex $l $i]
}
\(-> l(0)=0
l(1)=-1
l(2)=-2
l(3)=-3
l(4)=-4
l(5)=-5
foreach i [lseq [llength $l]-1 0] {
foreach i [\fBlseq\fR [llength $l]] {
puts l($i)=[lindex $l $i]
}
\(-> l(5)=-5
l(4)=-4
l(3)=-3
l(2)=-2
l(1)=-1
l(0)=0
}
\fI\(-> l(0)=0\fR
\fI\(-> l(1)=-1\fR
\fI\(-> l(2)=-2\fR
\fI\(-> l(3)=-3\fR
\fI\(-> l(4)=-4\fR
\fI\(-> l(5)=-5\fR
set i 17
\(-> 17
if {$i in [lseq 0 50]} { # equivalent to: (0 <= $i && $i < 50)
puts "Ok"
} else {
puts "outside :("
}
\(-> Ok
foreach i [\fBlseq\fR {[llength $l]-1} 0] {
puts l($i)=[lindex $l $i]
}
\fI\(-> l(5)=-5\fR
\fI\(-> l(4)=-4\fR
\fI\(-> l(3)=-3\fR
\fI\(-> l(2)=-2\fR
\fI\(-> l(1)=-1\fR
\fI\(-> l(0)=0\fR
set sqrs [lmap i [lseq 1 10] {expr $i*$i}]
\(-> 1 4 9 16 25 36 49 64 81 100
set i 17
\fI\(-> 17\fR
if {$i in [\fBlseq\fR 0 50]} { # equivalent to: (0 <= $i && $i < 50)
puts "Ok"
} else {
puts "outside :("
}
\fI\(-> Ok\fR
set sqrs [lmap i [\fBlseq\fR 1 10] { expr {$i*$i} }]
\fI\(-> 1 4 9 16 25 36 49 64 81 100\fR
.\"
.CE
.SH "SEE ALSO"
+22
View File
@@ -128,6 +128,28 @@ If a new file is created as part of opening it, \fIpermissions\fR
(an integer) is used to set the permissions for the new file in
conjunction with the process's file mode creation mask.
\fIPermissions\fR defaults to 0666.
.PP
.VS "8.7, TIP 603"
When the file opened is an ordinary disk file, the \fBchan configure\fR and
\fBfconfigure\fR commands can be used to query this additional configuration
option:
.TP
\fB\-stat\fR
.
This option, when read, returns a dictionary of values much as is obtained
from the \fBfile stat\fR command, where that stat information relates to the
real opened file. Keys in the dictionary may include \fBatime\fR, \fBctime\fR,
\fBdev\fR, \fBgid\fR, \fBino\fR, \fBmode\fR, \fBmtime\fR, \fBnlink\fR,
\fBsize\fR, \fBtype\fR, and \fBuid\fR among others; the \fBmtime\fR,
\fBsize\fR and \fBtype\fR fields are guaranteed to be present and meaningful
on all platforms; other keys may be present too.
.RS
.PP
\fIImplementation note:\fR This option maps to a call to \fBfstat()\fR on
POSIX platforms, and to a call to \fBGetFileInformationByHandle()\fR on
Windows; the information reported is what those system calls produce.
.RE
.VE "8.7, TIP 603"
.SH "COMMAND PIPELINES"
.PP
If the first character of \fIfileName\fR is
+14 -1
View File
@@ -11,7 +11,20 @@
.SH NAME
refchan \- command handler API of reflected channels
.SH SYNOPSIS
\fBcmdPrefix \fIoption\fR ?\fIarg arg ...\fR?
.nf
\fBchan create \fImode cmdPrefix\fR
\fIcmdPrefix \fBblocking\fR \fIchannelId mode\fR
\fIcmdPrefix \fBcget\fR \fIchannelId option\fR
\fIcmdPrefix \fBcgetall\fR \fIchannelId\fR
\fIcmdPrefix \fBconfigure\fR \fIchannelId option value\fR
\fIcmdPrefix \fBfinalize\fR \fIchannelId\fR
\fIcmdPrefix \fBinitialize\fR \fIchannelId mode\fR
\fIcmdPrefix \fBread\fR \fIchannelId count\fR
\fIcmdPrefix \fBseek\fR \fIchannelId offset base\fR
\fIcmdPrefix \fBwatch\fR \fIchannelId eventspec\fR
\fIcmdPrefix \fBwrite\fR \fIchannelId data\fR
.fi
.BE
.SH DESCRIPTION
.PP
+3 -3
View File
@@ -35,10 +35,10 @@ if \fItime\fR is not specified.
.sp
The parameter \fImax-count\fR could additionally impose a further restriction
by the maximal number of iterations to evaluate the script.
If \fImax-count\fR is specified, the evalution will stop either this count of
If \fImax-count\fR is specified, the evaluation will stop either this count of
iterations is reached or the time is exceeded.
.sp
It will then return a canonical tcl-list of the form:
It will then return a canonical Tcl-list of the form:
.PP
.CS
\fB0.095977 \(mcs/# 52095836 # 10419167 #/sec 5000.000 net-ms\fR
@@ -85,7 +85,7 @@ used to measure the cost of \fBTcl_EvalObjEx\fR, of the invocation of canonical
lists, and of the uncompiled versions of bytecoded commands.
.PP
As opposed to the \fBtime\fR commmand, which runs the tested script for a fixed
number of iterations, the timerate command runs it for a fixed time.
number of iterations, the \fBtimerate\fR command runs it for a fixed time.
Additionally, the compiled variant of the script will be used during the entire
measurement, as if the script were part of a compiled procedure, if the \fB\-direct\fR
option is not specified. The fixed time period and possibility of compilation allow
+12 -1
View File
@@ -11,7 +11,18 @@
.SH NAME
transchan \- command handler API of channel transforms
.SH SYNOPSIS
\fBcmdPrefix \fIoption\fR ?\fIarg arg ...\fR?
.nf
\fBchan push \fIchannelName cmdPrefix\fR
\fIcmdPrefix \fBclear \fIhandle\fR
\fIcmdPrefix \fBdrain \fIhandle\fR
\fIcmdPrefix \fBfinalize \fIhandle\fR
\fIcmdPrefix \fBflush \fIhandle\fR
\fIcmdPrefix \fBinitialize \fIhandle mode\fR
\fIcmdPrefix \fBlimit? \fIhandle\fR
\fIcmdPrefix \fBread \fIhandle buffer\fR
\fIcmdPrefix \fBwrite \fIhandle buffer\fR
.fi
.BE
.SH DESCRIPTION
.PP
-6
View File
@@ -84,15 +84,9 @@ typedef int celt; /* Type to hold chr, or NOCELT */
#define NOCELT (-1) /* Celt value which is not valid chr */
#define CHR(c) (UCHAR(c)) /* Turn char literal into chr literal */
#define DIGITVAL(c) ((c)-'0') /* Turn chr digit into its value */
#if TCL_UTF_MAX > 3
#define CHRBITS 32 /* Bits in a chr; must not use sizeof */
#define CHR_MIN 0x00000000 /* Smallest and largest chr; the value */
#define CHR_MAX 0x10FFFF /* CHR_MAX-CHR_MIN+1 should fit in uchr */
#else
#define CHRBITS 16 /* Bits in a chr; must not use sizeof */
#define CHR_MIN 0x0000 /* Smallest and largest chr; the value */
#define CHR_MAX 0xFFFF /* CHR_MAX-CHR_MIN+1 should fit in uchr */
#endif
/*
* Functions operating on chr.
+1 -1
View File
@@ -1442,7 +1442,7 @@ declare 392 {
}
declare 393 {
int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc,
void *clientData, Tcl_Size stackSize, int flags)
void *clientData, TCL_HASH_TYPE stackSize, int flags)
}
# Introduced in 8.3.2
+21 -110
View File
@@ -208,10 +208,6 @@ extern "C" {
# endif
#endif
#if !defined(CONST86) && !defined(TCL_NO_DEPRECATED)
# define CONST86 const
#endif
/*
* Make sure EXTERN isn't defined elsewhere.
*/
@@ -321,24 +317,12 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
#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 ptrdiff_t Tcl_Size;
# define TCL_SIZE_MAX PTRDIFF_MAX
# define TCL_SIZE_MODIFIER TCL_T_MODIFIER
#endif /* TCL_MAJOR_VERSION */
typedef ptrdiff_t Tcl_Size;
#define TCL_SIZE_MAX PTRDIFF_MAX
#define TCL_SIZE_MODIFIER TCL_T_MODIFIER
#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
typedef struct _stat32i64 Tcl_StatBuf;
# endif
typedef struct __stat64 Tcl_StatBuf;
#elif defined(__CYGWIN__)
typedef struct {
unsigned st_dev;
@@ -465,28 +449,18 @@ typedef void (Tcl_ThreadCreateProc) (void *clientData);
*/
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;
/*
@@ -608,10 +582,6 @@ typedef void *(Tcl_InitNotifierProc) (void);
typedef void (Tcl_FinalizeNotifierProc) (void *clientData);
typedef void (Tcl_MainLoopProc) (void);
#ifndef TCL_NO_DEPRECATED
# define Tcl_PackageInitProc Tcl_LibraryInitProc
# define Tcl_PackageUnloadProc Tcl_LibraryUnloadProc
#endif
/*
*----------------------------------------------------------------------------
@@ -809,8 +779,8 @@ typedef struct {
typedef struct Tcl_DString {
char *string; /* Points to beginning of string: either
* staticSpace below or a malloced array. */
Tcl_Size length; /* Number of non-NULL characters in the
* string. */
Tcl_Size length; /* Number of bytes in string excluding
* terminating nul */
Tcl_Size spaceAvl; /* Total number of bytes available for the
* string and its terminating NULL char. */
char staticSpace[TCL_DSTRING_STATIC_SIZE];
@@ -883,11 +853,7 @@ typedef struct Tcl_DString {
* TCL_COMBINE Combine surrogates
*/
#if TCL_MAJOR_VERSION > 8
# define TCL_COMBINE 0x1000000
#else
# define TCL_COMBINE 0
#endif
#define TCL_COMBINE 0x1000000
/*
*----------------------------------------------------------------------------
* Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv.
@@ -1001,11 +967,7 @@ typedef struct Tcl_DString {
*/
#ifndef TCL_HASH_TYPE
#if TCL_MAJOR_VERSION > 8
# define TCL_HASH_TYPE size_t
#else
# define TCL_HASH_TYPE unsigned
#endif
#define TCL_HASH_TYPE size_t
#endif
typedef struct Tcl_HashKeyType Tcl_HashKeyType;
@@ -1122,15 +1084,10 @@ struct Tcl_HashTable {
* table. */
Tcl_Size rebuildSize; /* Enlarge table when numEntries gets to be
* this large. */
#if TCL_MAJOR_VERSION > 8
size_t mask; /* Mask value used in hashing function. */
#endif
int downShift; /* Shift count used in hashing function.
* Designed to use high-order bits of
* randomized keys. */
#if TCL_MAJOR_VERSION < 9
int mask; /* Mask value used in hashing function. */
#endif
int keyType; /* Type of keys used in this table. It's
* either TCL_CUSTOM_KEYS, TCL_STRING_KEYS,
* TCL_ONE_WORD_KEYS, or an integer giving the
@@ -1296,11 +1253,7 @@ typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, void *clientData);
* interface.
*/
#if TCL_MAJOR_VERSION > 8
# define TCL_CLOSE2PROC NULL
#else
# define TCL_CLOSE2PROC ((void *) 1)
#endif
#define TCL_CLOSE2PROC NULL
/*
* Channel version tag. This was introduced in 8.3.2/8.4.
@@ -1850,12 +1803,10 @@ typedef struct Tcl_Parse {
* *tokenPtr. */
int errorType; /* One of the parsing error types defined
* above. */
#if TCL_MAJOR_VERSION > 8
int incomplete; /* This field is set to 1 by Tcl_ParseCommand
* if the command appears to be incomplete.
* This information is used by
* Tcl_CommandComplete. */
#endif
/*
* The fields below are intended only for the private use of the parser.
@@ -1874,9 +1825,6 @@ typedef struct Tcl_Parse {
* beginning of region where the error
* occurred (e.g. the open brace if the close
* brace is missing). */
#if TCL_MAJOR_VERSION < 9
int incomplete;
#endif
Tcl_Token staticTokens[NUM_STATIC_TOKENS];
/* Initial space for tokens for command. This
* space should be large enough to accommodate
@@ -1933,7 +1881,7 @@ typedef struct Tcl_EncodingType {
* reset to an initial state. If the source
* buffer contains the entire input stream to be
* converted, this flag should be set.
* TCL_ENCODING_STOPONERROR - Not used any more.
* TCL_ENCODING_STOPONERROR - Obsolete.
* TCL_ENCODING_NO_TERMINATE - If set, Tcl_ExternalToUtf does not append a
* terminating NUL byte. Since it does not need
* an extra byte for a terminating NUL, it fills
@@ -1958,11 +1906,7 @@ typedef struct Tcl_EncodingType {
#define TCL_ENCODING_START 0x01
#define TCL_ENCODING_END 0x02
#if TCL_MAJOR_VERSION > 8
# define TCL_ENCODING_STOPONERROR 0x0 /* Not used any more */
#else
# define TCL_ENCODING_STOPONERROR 0x04
#endif
#define TCL_ENCODING_STOPONERROR 0x0 /* Not used any more */
#define TCL_ENCODING_NO_TERMINATE 0x08
#define TCL_ENCODING_CHAR_LIMIT 0x10
/* Internal use bits, do not define bits in this space. See above comment */
@@ -1975,11 +1919,7 @@ typedef struct Tcl_EncodingType {
#define TCL_ENCODING_PROFILE_TCL8 0x01000000
#define TCL_ENCODING_PROFILE_STRICT 0x02000000
#define TCL_ENCODING_PROFILE_REPLACE 0x03000000
#if TCL_MAJOR_VERSION < 9
#define TCL_ENCODING_PROFILE_DEFAULT TCL_ENCODING_PROFILE_TCL8
#else
#define TCL_ENCODING_PROFILE_DEFAULT TCL_ENCODING_PROFILE_TCL8
#endif
#define TCL_ENCODING_PROFILE_DEFAULT TCL_ENCODING_PROFILE_STRICT
/*
* The following definitions are the error codes returned by the conversion
@@ -2021,11 +1961,7 @@ typedef struct Tcl_EncodingType {
*/
#ifndef TCL_UTF_MAX
# if TCL_MAJOR_VERSION > 8
# define TCL_UTF_MAX 4
# else
# define TCL_UTF_MAX 3
# endif
#endif
/*
@@ -2033,16 +1969,12 @@ typedef struct Tcl_EncodingType {
* reflected in regcustom.h.
*/
#if TCL_UTF_MAX > 3
/*
* int isn't 100% accurate as it should be a strict 4-byte value
* (perhaps int32_t). ILP64/SILP64 systems may have troubles. The
* size of this value must be reflected correctly in regcustom.h.
*/
/*
* int isn't 100% accurate as it should be a strict 4-byte value
* (perhaps int32_t). ILP64/SILP64 systems may have troubles. The
* size of this value must be reflected correctly in regcustom.h.
*/
typedef int Tcl_UniChar;
#else
typedef unsigned short Tcl_UniChar;
#endif
/*
*----------------------------------------------------------------------------
@@ -2229,11 +2161,7 @@ typedef int (Tcl_NRPostProc) (void *data[], Tcl_Interp *interp,
* stubs tables.
*/
#if TCL_MAJOR_VERSION > 8
# define TCL_STUB_MAGIC ((int) 0xFCA3BACB + (int) sizeof(void *))
#else
# define TCL_STUB_MAGIC ((int) 0xFCA3BACF)
#endif
#define TCL_STUB_MAGIC ((int) 0xFCA3BACB + (int) sizeof(void *))
/*
* The following function is required to be defined in all stubs aware
@@ -2255,19 +2183,7 @@ void * TclStubCall(void *arg);
#endif
#ifdef USE_TCL_STUBS
#if TCL_MAJOR_VERSION < 9
# if TCL_UTF_MAX < 4
# define Tcl_InitStubs(interp, version, exact) \
(Tcl_InitStubs)(interp, version, \
(exact)|(TCL_MAJOR_VERSION<<8)|(0xFF<<16), \
TCL_STUB_MAGIC)
# else
# define Tcl_InitStubs(interp, version, exact) \
(Tcl_InitStubs)(interp, "8.7.0", \
(exact)|(TCL_MAJOR_VERSION<<8)|(0xFF<<16), \
TCL_STUB_MAGIC)
# endif
#elif TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE
#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE
# define Tcl_InitStubs(interp, version, exact) \
(Tcl_InitStubs)(interp, version, \
(exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \
@@ -2279,9 +2195,7 @@ void * TclStubCall(void *arg);
TCL_STUB_MAGIC)
#endif
#else
#if TCL_MAJOR_VERSION < 9
# error "Please define -DUSE_TCL_STUBS"
#elif TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE
#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE
# define Tcl_InitStubs(interp, version, exact) \
Tcl_PkgInitStubsCheck(interp, version, \
(exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16))
@@ -2313,9 +2227,6 @@ EXTERN void Tcl_StaticLibrary(Tcl_Interp *interp,
const char *prefix,
Tcl_LibraryInitProc *initProc,
Tcl_LibraryInitProc *safeInitProc);
#ifndef TCL_NO_DEPRECATED
# define Tcl_StaticPackage Tcl_StaticLibrary
#endif
EXTERN Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc);
#ifdef _WIN32
EXTERN const char *TclZipfs_AppHook(int *argc, wchar_t ***argv);
@@ -2330,7 +2241,7 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv);
EXTERN TCL_NORETURN void Tcl_MainExW(Tcl_Size argc, wchar_t **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
#endif
#if defined(USE_TCL_STUBS) && (TCL_MAJOR_VERSION > 8)
#if defined(USE_TCL_STUBS)
#define Tcl_SetPanicProc(panicProc) \
TclInitStubTable(((const char *(*)(Tcl_PanicProc *))TclStubCall((void *)panicProc))(panicProc))
#define Tcl_InitSubsystems() \
+1 -1
View File
@@ -394,7 +394,7 @@ TclNewArithSeriesObj(
dstep = step;
}
if (dstep == 0) {
*arithSeriesObj = Tcl_NewObj();
TclNewObj(*arithSeriesObj);
return TCL_OK;
}
}
+8 -4
View File
@@ -805,7 +805,7 @@ Tcl_CreateInterp(void)
iPtr->legacyFreeProc = (void (*) (void))-1;
iPtr->errorLine = 0;
iPtr->stubTable = &tclStubs;
iPtr->objResultPtr = Tcl_NewObj();
TclNewObj(iPtr->objResultPtr);
Tcl_IncrRefCount(iPtr->objResultPtr);
iPtr->handle = TclHandleCreate(iPtr);
iPtr->globalNsPtr = NULL;
@@ -890,7 +890,7 @@ Tcl_CreateInterp(void)
iPtr->activeInterpTracePtr = NULL;
iPtr->assocData = NULL;
iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */
iPtr->emptyObjPtr = Tcl_NewObj();
TclNewObj(iPtr->emptyObjPtr);
/* Another empty object. */
Tcl_IncrRefCount(iPtr->emptyObjPtr);
iPtr->threadId = Tcl_GetCurrentThread();
@@ -954,7 +954,7 @@ Tcl_CreateInterp(void)
* TIP #285, Script cancellation support.
*/
iPtr->asyncCancelMsg = Tcl_NewObj();
TclNewObj(iPtr->asyncCancelMsg);
cancelInfo = (CancelInfo *)Tcl_Alloc(sizeof(CancelInfo));
cancelInfo->interp = interp;
@@ -6152,7 +6152,11 @@ TclNREvalObjEx(
*/
Tcl_IncrRefCount(objPtr);
listPtr = TclListObjCopy(interp, objPtr);
listPtr = TclDuplicatePureObj(interp, objPtr, &tclListType.objType);
if (!listPtr) {
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
Tcl_IncrRefCount(listPtr);
if (word != INT_MIN) {
+12 -70
View File
@@ -381,35 +381,6 @@ Tcl_GetBytesFromObj(
return baPtr->bytes;
}
#if !defined(TCL_NO_DEPRECATED)
unsigned char *
TclGetBytesFromObj(
Tcl_Interp *interp, /* For error reporting */
Tcl_Obj *objPtr, /* Value to extract from */
void *numBytesPtr) /* If non-NULL, write the number of bytes
* in the array here */
{
Tcl_Size numBytes = 0;
unsigned char *bytes = Tcl_GetBytesFromObj(interp, objPtr, &numBytes);
if (bytes && numBytesPtr) {
if (numBytes > INT_MAX) {
/* Caller asked for numBytes to be written to an int, but the
* value is outside the int range. */
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"byte sequence length exceeds INT_MAX", -1));
Tcl_SetErrorCode(interp, "TCL", "API", "OUTDATED", NULL);
}
return NULL;
} else {
*(int *)numBytesPtr = (int) numBytes;
}
}
return bytes;
}
#endif
/*
*----------------------------------------------------------------------
@@ -509,7 +480,7 @@ MakeByteArray(
for (; src < srcEnd && dst < dstEnd; ) {
int ch;
int count = TclUtfToUCS4(src, &ch);
int count = Tcl_UtfToUniChar(src, &ch);
if (ch > 255) {
proper = 0;
@@ -767,43 +738,14 @@ TclAppendBytesToByteArray(
}
needed = byteArrayPtr->used + len;
if (needed > byteArrayPtr->allocated) {
ByteArray *ptr = NULL;
/*
* Try to allocate double the total space that is needed.
*/
Tcl_Size attempt;
/* Make sure we do not wrap when doubling */
if (needed <= (BYTEARRAY_MAX_LEN - needed)) {
attempt = 2 * needed;
ptr = (ByteArray *) Tcl_AttemptRealloc(byteArrayPtr,
BYTEARRAY_SIZE(attempt));
}
if (ptr == NULL) {
/*
* Try to allocate double the increment that is needed.
* (Originally TCL_MIN_GROWTH was added as well but that would
* need one more separate overflow check so forget it.)
*/
if (len <= (BYTEARRAY_MAX_LEN - needed)) {
attempt = needed + len;
ptr = (ByteArray *)Tcl_AttemptRealloc(byteArrayPtr,
BYTEARRAY_SIZE(attempt));
}
}
if (ptr == NULL) {
/*
* Last chance: Try to allocate exactly what is needed.
*/
attempt = needed;
ptr = (ByteArray *)Tcl_Realloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
}
byteArrayPtr = ptr;
byteArrayPtr->allocated = attempt;
Tcl_Size newCapacity;
byteArrayPtr =
(ByteArray *)TclReallocElemsEx(byteArrayPtr,
needed,
1,
offsetof(ByteArray, bytes),
&newCapacity);
byteArrayPtr->allocated = newCapacity;
SET_BYTEARRAY(irPtr, byteArrayPtr);
}
@@ -2590,7 +2532,7 @@ BinaryDecodeHex(
if (pure) {
ucs4 = c;
} else {
TclUtfToUCS4((const char *)(data - 1), &ucs4);
Tcl_UtfToUniChar((const char *)(data - 1), &ucs4);
}
TclDecrRefCount(resultObj);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -3055,7 +2997,7 @@ BinaryDecodeUu(
if (pure) {
ucs4 = c;
} else {
TclUtfToUCS4((const char *)(data - 1), &ucs4);
Tcl_UtfToUniChar((const char *)(data - 1), &ucs4);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid uuencode character \"%c\" (U+%06X) at position %"
@@ -3230,7 +3172,7 @@ BinaryDecode64(
* of a multi-byte character. */
/* Safe because we know data is NUL-terminated */
TclUtfToUCS4((const char *)(data - 1), &ucs4);
Tcl_UtfToUniChar((const char *)(data - 1), &ucs4);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+143
View File
@@ -16,6 +16,7 @@
*/
#include "tclInt.h"
#include <assert.h>
#define FALSE 0
#define TRUE 1
@@ -1233,6 +1234,148 @@ TclDumpMemoryInfo(
#endif /* TCL_MEM_DEBUG */
/*
*------------------------------------------------------------------------
*
* TclAllocElemsEx --
*
* See TclAttemptAllocElemsEx. This function differs in that it panics
* on failure.
*
* Results:
* Non-NULL pointer to allocated memory block.
*
* Side effects:
* Panics if memory of at least the requested size could not be
* allocated.
*
*------------------------------------------------------------------------
*/
void *
TclAllocElemsEx(
Tcl_Size elemCount, /* Allocation will store at least these many... */
Tcl_Size elemSize, /* ...elements of this size */
Tcl_Size leadSize, /* Additional leading space in bytes */
Tcl_Size *capacityPtr) /* OUTPUT: Actual capacity is stored
here if non-NULL. Only modified on success */
{
void *ptr = TclAttemptReallocElemsEx(
NULL, elemCount, elemSize, leadSize, capacityPtr);
if (ptr == NULL) {
Tcl_Panic("Failed to allocate %" TCL_SIZE_MODIFIER
"d elements of size %" TCL_SIZE_MODIFIER "d bytes.",
elemCount,
elemSize);
}
return ptr;
}
/*
*------------------------------------------------------------------------
*
* TclAttemptReallocElemsEx --
*
* Attempts to allocate (oldPtr == NULL) or reallocate memory of the
* requested size plus some more for future growth. The amount of
* reallocation is adjusted depending on on failure.
*
*
* Results:
* Pointer to allocated memory block which is at least as large
* as the requested size or NULL if allocation failed.
*
*------------------------------------------------------------------------
*/
void *
TclAttemptReallocElemsEx(
void *oldPtr, /* Pointer to memory block to reallocate or
* NULL to indicate this is a new allocation */
Tcl_Size elemCount, /* Allocation will store at least these many... */
Tcl_Size elemSize, /* ...elements of this size */
Tcl_Size leadSize, /* Additional leading space in bytes */
Tcl_Size *capacityPtr) /* OUTPUT: Actual capacity is stored
here if non-NULL. Only modified on success */
{
void *ptr;
Tcl_Size limit;
Tcl_Size attempt;
assert(elemCount > 0);
assert(elemSize > 0);
assert(elemSize < TCL_SIZE_MAX);
assert(leadSize >= 0);
assert(leadSize < TCL_SIZE_MAX);
limit = (TCL_SIZE_MAX - leadSize) / elemSize;
if (elemCount > limit) {
return NULL;
}
/* Loop trying for extra space, reducing request each time */
attempt = TclUpsizeAlloc(0, elemCount, limit);
ptr = NULL;
while (attempt > elemCount) {
if (oldPtr) {
ptr = Tcl_AttemptRealloc(oldPtr, leadSize + attempt * elemSize);
} else {
ptr = Tcl_AttemptAlloc(leadSize + attempt * elemSize);
}
if (ptr) {
break;
}
attempt = TclUpsizeRetry(elemCount, attempt);
}
/* Try exact size as a last resort */
if (ptr == NULL) {
attempt = elemCount;
if (oldPtr) {
ptr = Tcl_AttemptRealloc(oldPtr, leadSize + attempt * elemSize);
} else {
ptr = Tcl_AttemptAlloc(leadSize + attempt * elemSize);
}
}
if (ptr && capacityPtr) {
*capacityPtr = attempt;
}
return ptr;
}
/*
*------------------------------------------------------------------------
*
* TclReallocElemsEx --
*
* See TclAttemptReallocElemsEx. This function differs in that it panics
* on failure.
*
* Results:
* Non-NULL pointer to allocated memory block.
*
* Side effects:
* Panics if memory of at least the requested size could not be
* allocated.
*
*------------------------------------------------------------------------
*/
void *
TclReallocElemsEx(
void *oldPtr, /* Pointer to memory block to reallocate */
Tcl_Size elemCount, /* Allocation will store at least these many... */
Tcl_Size elemSize, /* ...elements of this size */
Tcl_Size leadSize, /* Additional leading space in bytes */
Tcl_Size *capacityPtr) /* OUTPUT: Actual capacity is stored
here if non-NULL. Only modified on success */
{
void *ptr = TclAttemptReallocElemsEx(
oldPtr, elemCount, elemSize, leadSize, capacityPtr);
if (ptr == NULL) {
Tcl_Panic("Failed to reallocate %" TCL_SIZE_MODIFIER
"d elements of size %" TCL_SIZE_MODIFIER "d bytes.",
elemCount,
elemSize);
}
return ptr;
}
/*
*---------------------------------------------------------------------------
*
+24 -11
View File
@@ -435,7 +435,7 @@ EncodingConvertParseOptions (
Tcl_Encoding encoding;
Tcl_Obj *dataObj;
Tcl_Obj *failVarObj;
int profile = TCL_ENCODING_PROFILE_TCL8;
int profile = TCL_ENCODING_PROFILE_STRICT;
/*
* Possible combinations:
@@ -2325,7 +2325,7 @@ StoreStatData(
unsigned short mode;
if (varName == NULL) {
result = Tcl_NewObj();
TclNewObj(result);
Tcl_IncrRefCount(result);
#define DOBJPUT(key, objValue) \
Tcl_DictObjPut(NULL, result, \
@@ -2356,8 +2356,6 @@ StoreStatData(
}
/*
* Assume Tcl_ObjSetVar2() does not keep a copy of the field name!
*
* Might be a better idea to call Tcl_SetVar2Ex() instead, except we want
* to have an object (i.e. possibly cached) array variable name but a
* string element name, so no API exists. Messy.
@@ -2389,9 +2387,15 @@ StoreStatData(
#endif
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
STORE_ARY("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize));
#endif
#ifdef HAVE_STRUCT_STAT_ST_RDEV
if (S_ISCHR(statPtr->st_mode) || S_ISBLK(statPtr->st_mode)) {
STORE_ARY("rdev", Tcl_NewWideIntObj((long) statPtr->st_rdev));
}
#endif
STORE_ARY("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr)));
STORE_ARY("mtime", Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr)));
STORE_ARY("mtime", Tcl_NewWideIntObj(
Tcl_GetModificationTimeFromStat(statPtr)));
STORE_ARY("ctime", Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr)));
mode = (unsigned short) statPtr->st_mode;
STORE_ARY("mode", Tcl_NewWideIntObj(mode));
@@ -2784,13 +2788,18 @@ EachloopCmd(
for (i=0 ; i<numLists ; i++) {
/* List */
/* Variables */
statePtr->vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]);
if (statePtr->vCopyList[i] == NULL) {
statePtr->vCopyList[i] = TclDuplicatePureObj(
interp, objv[1+i*2], &tclListType.objType);
if (!statePtr->vCopyList[i]) {
result = TCL_ERROR;
goto done;
}
TclListObjLengthM(NULL, statePtr->vCopyList[i],
result = TclListObjLengthM(interp, statePtr->vCopyList[i],
&statePtr->varcList[i]);
if (result != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (statePtr->varcList[i] < 1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s varlist is empty",
@@ -2816,13 +2825,17 @@ EachloopCmd(
statePtr->argcList[i] = ABSTRACTLIST_PROC(statePtr->aCopyList[i], lengthProc)(statePtr->aCopyList[i]);
} else {
/* List values */
statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]);
if (statePtr->aCopyList[i] == NULL) {
statePtr->aCopyList[i] = TclDuplicatePureObj(
interp, objv[2+i*2], &tclListType.objType);
if (!statePtr->aCopyList[i]) {
result = TCL_ERROR;
goto done;
}
TclListObjGetElementsM(NULL, statePtr->aCopyList[i],
result = TclListObjGetElementsM(interp, statePtr->aCopyList[i],
&statePtr->argcList[i], &statePtr->argvList[i]);
if (result != TCL_OK) {
goto done;
}
}
/* account for variable <> value mismatch */
j = statePtr->argcList[i] / statePtr->varcList[i];
+87 -45
View File
@@ -712,7 +712,7 @@ InfoCommandsCmd(
if (entryPtr != NULL) {
if (specificNsInPattern) {
cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr);
elemObjPtr = Tcl_NewObj();
TclNewObj(elemObjPtr);
Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
} else {
cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
@@ -763,7 +763,7 @@ InfoCommandsCmd(
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (specificNsInPattern) {
cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr);
elemObjPtr = Tcl_NewObj();
TclNewObj(elemObjPtr);
Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
@@ -990,7 +990,8 @@ InfoDefaultCmd(
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1));
} else {
Tcl_Obj *nullObjPtr = Tcl_NewObj();
Tcl_Obj *nullObjPtr;
TclNewObj(nullObjPtr);
valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL,
nullObjPtr, TCL_LEAVE_ERR_MSG);
@@ -1906,7 +1907,7 @@ InfoProcsCmd(
} else {
simpleProcOK:
if (specificNsInPattern) {
elemObjPtr = Tcl_NewObj();
TclNewObj(elemObjPtr);
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
elemObjPtr);
} else {
@@ -1934,7 +1935,7 @@ InfoProcsCmd(
} else {
procOK:
if (specificNsInPattern) {
elemObjPtr = Tcl_NewObj();
TclNewObj(elemObjPtr);
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
elemObjPtr);
} else {
@@ -2252,7 +2253,7 @@ Tcl_JoinObjCmd(
} else {
Tcl_Size i;
resObjPtr = Tcl_NewObj();
TclNewObj(resObjPtr);
if (isArithSeries) {
Tcl_Obj *valueObj;
for (i = 0; i < listLen; i++) {
@@ -2327,20 +2328,25 @@ Tcl_LassignObjCmd(
Tcl_Obj **listObjv; /* The contents of the list. */
Tcl_Size listObjc; /* The length of the list. */
Tcl_Size origListObjc; /* Original length */
int code = TCL_OK;
int code;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?varName ...?");
return TCL_ERROR;
}
listCopyPtr = TclListObjCopy(interp, objv[1]);
if (listCopyPtr == NULL) {
listCopyPtr = TclDuplicatePureObj(interp, objv[1], &tclListType.objType);
if (!listCopyPtr) {
return TCL_ERROR;
}
Tcl_IncrRefCount(listCopyPtr); /* Important! fs */
TclListObjGetElementsM(NULL, listCopyPtr, &listObjc, &listObjv);
code = TclListObjGetElementsM(
interp, listCopyPtr, &listObjc, &listObjv);
if (code != TCL_OK) {
Tcl_DecrRefCount(listCopyPtr);
return code;
}
origListObjc = listObjc;
objc -= 2;
@@ -2466,7 +2472,7 @@ Tcl_LinsertObjCmd(
{
Tcl_Obj *listPtr;
Tcl_Size len, index;
int result;
int copied = 0, result;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?");
@@ -2499,7 +2505,11 @@ Tcl_LinsertObjCmd(
listPtr = objv[1];
if (Tcl_IsShared(listPtr)) {
listPtr = TclListObjCopy(NULL, listPtr);
listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType.objType);
if (!listPtr) {
return TCL_ERROR;
}
copied = 1;
}
if ((objc == 4) && (index == len)) {
@@ -2507,10 +2517,19 @@ Tcl_LinsertObjCmd(
* Special case: insert one element at the end of the list.
*/
Tcl_ListObjAppendElement(NULL, listPtr, objv[3]);
result = Tcl_ListObjAppendElement(NULL, listPtr, objv[3]);
if (result != TCL_OK) {
if (copied) {
Tcl_DecrRefCount(listPtr);
}
return result;
}
} else {
if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, index, 0,
(objc-3), &(objv[3]))) {
if (copied) {
Tcl_DecrRefCount(listPtr);
}
return TCL_ERROR;
}
}
@@ -2634,7 +2653,7 @@ Tcl_LpopObjCmd(
/* Argument objects. */
{
Tcl_Size listLen;
int result;
int copied = 0, result;
Tcl_Obj *elemPtr, *stored;
Tcl_Obj *listPtr, **elemPtrs;
@@ -2686,23 +2705,33 @@ Tcl_LpopObjCmd(
if (objc == 2) {
if (Tcl_IsShared(listPtr)) {
listPtr = TclListObjCopy(NULL, listPtr);
listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType.objType);
if (!listPtr) {
return TCL_ERROR;
}
copied = 1;
}
result = Tcl_ListObjReplace(interp, listPtr, listLen - 1, 1, 0, NULL);
if (result != TCL_OK) {
if (copied) {
Tcl_DecrRefCount(listPtr);
}
return result;
}
Tcl_IncrRefCount(listPtr);
} else {
listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL);
if (listPtr == NULL) {
Tcl_Obj *newListPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL);
if (newListPtr == NULL) {
if (copied) {
Tcl_DecrRefCount(listPtr);
}
return TCL_ERROR;
} else {
listPtr = newListPtr;
TclUndoRefCount(listPtr);
}
}
stored = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(listPtr);
if (stored == NULL) {
return TCL_ERROR;
}
@@ -2819,6 +2848,7 @@ Tcl_LremoveObjCmd(
Tcl_Size i, idxc, prevIdx, first, num;
Tcl_Size *idxv, listLen;
Tcl_Obj *listObj;
int copied = 0, status = TCL_OK;
/*
* Parse the arguments.
@@ -2841,10 +2871,10 @@ Tcl_LremoveObjCmd(
}
idxv = (Tcl_Size *)Tcl_Alloc((objc - 2) * sizeof(*idxv));
for (i = 2; i < objc; i++) {
if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1,
&idxv[i - 2]) != TCL_OK) {
Tcl_Free(idxv);
return TCL_ERROR;
status = (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1,
&idxv[i - 2]) != TCL_OK);
if (status != TCL_OK) {
goto done;
}
}
@@ -2862,7 +2892,12 @@ Tcl_LremoveObjCmd(
*/
if (Tcl_IsShared(listObj)) {
listObj = TclListObjCopy(NULL, listObj);
listObj = TclDuplicatePureObj(interp, listObj, &tclListType.objType);
if (!listObj) {
status = TCL_ERROR;
goto done;
}
copied = 1;
}
num = 0;
first = listLen;
@@ -2897,18 +2932,28 @@ Tcl_LremoveObjCmd(
* and we're only ever contracting that list.
*/
(void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL);
status = Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL);
if (status != TCL_OK) {
goto done;
}
listLen -= num;
num = 1;
first = idx;
}
}
if (num != 0) {
(void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL);
status = Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL);
if (status != TCL_OK) {
if (copied) {
Tcl_DecrRefCount(listObj);
}
goto done;
}
}
Tcl_Free(idxv);
Tcl_SetObjResult(interp, listObj);
return TCL_OK;
done:
Tcl_Free(idxv);
return status;
}
/*
@@ -3102,7 +3147,10 @@ Tcl_LreplaceObjCmd(
listPtr = objv[1];
if (Tcl_IsShared(listPtr)) {
listPtr = TclListObjCopy(NULL, listPtr);
listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType.objType);
if (!listPtr) {
return TCL_ERROR;
}
}
/*
@@ -3115,6 +3163,7 @@ Tcl_LreplaceObjCmd(
if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
objc-4, objv+4)) {
Tcl_DecrRefCount(listPtr);
return TCL_ERROR;
}
@@ -4722,7 +4771,7 @@ Tcl_LsortObjCmd(
* 1675116]
*/
listObj = TclListObjCopy(interp, listObj);
listObj = TclDuplicatePureObj(interp ,listObj, &tclListType.objType);
if (listObj == NULL) {
sortInfo.resultCode = TCL_ERROR;
goto done;
@@ -4739,8 +4788,6 @@ Tcl_LsortObjCmd(
if (Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr)
!= TCL_OK) {
TclDecrRefCount(newCommandPtr);
TclDecrRefCount(listObj);
Tcl_IncrRefCount(newObjPtr);
TclDecrRefCount(newObjPtr);
sortInfo.resultCode = TCL_ERROR;
goto done;
@@ -5080,7 +5127,10 @@ Tcl_LeditObjCmd(
}
if (Tcl_IsShared(listPtr)) {
listPtr = TclListObjCopy(NULL, listPtr);
listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType.objType);
if (!listPtr) {
return TCL_ERROR;
}
createdNewObj = 1;
} else {
createdNewObj = 0;
@@ -5097,18 +5147,10 @@ Tcl_LeditObjCmd(
/*
* Tcl_ObjSetVar2 may return a value different from listPtr in the
* presence of traces etc.. Note that finalValuePtr will always have a
* reference count of at least 1 corresponding to the reference from the
* var. If it is same as listPtr, then ref count will be at least 2
* since we are incr'ing the latter below (safer when calling
* Tcl_ObjSetVar2 which can release it in some cases). Note that we
* leave the incrref of listPtr this late because we want to pass it as
* unshared to Tcl_ListObjReplace above if possible.
* presence of traces etc.
*/
Tcl_IncrRefCount(listPtr);
finalValuePtr =
Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(listPtr); /* safe irrespective of createdNewObj */
if (finalValuePtr == NULL) {
return TCL_ERROR;
}
@@ -5423,8 +5465,8 @@ DictionaryCompare(
*/
if ((*left != '\0') && (*right != '\0')) {
left += TclUtfToUCS4(left, &uniLeft);
right += TclUtfToUCS4(right, &uniRight);
left += Tcl_UtfToUniChar(left, &uniLeft);
right += Tcl_UtfToUniChar(right, &uniRight);
/*
* Convert both chars to lower for the comparison, because
+13 -17
View File
@@ -357,7 +357,7 @@ Tcl_RegexpObjCmd(
objc = info.nsubs + 1;
if (all <= 1) {
resultPtr = Tcl_NewObj();
TclNewObj(resultPtr);
}
}
for (i = 0; i < objc; i++) {
@@ -399,7 +399,7 @@ Tcl_RegexpObjCmd(
offset + info.matches[i].start,
offset + info.matches[i].end - 1);
} else {
newPtr = Tcl_NewObj();
TclNewObj(newPtr);
}
}
if (doinline) {
@@ -1194,7 +1194,7 @@ Tcl_SplitObjCmd(
stringPtr = Tcl_GetStringFromObj(objv[1], &stringLen);
end = stringPtr + stringLen;
listPtr = Tcl_NewObj();
TclNewObj(listPtr);
if (stringLen == 0) {
/*
@@ -1217,7 +1217,7 @@ Tcl_SplitObjCmd(
Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; stringPtr < end; stringPtr += len) {
len = TclUtfToUCS4(stringPtr, &ch);
len = Tcl_UtfToUniChar(stringPtr, &ch);
hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(ch), &isNew);
if (isNew) {
TclNewStringObj(objPtr, stringPtr, len);
@@ -1263,9 +1263,9 @@ Tcl_SplitObjCmd(
splitEnd = splitChars + splitCharLen;
for (element = stringPtr; stringPtr < end; stringPtr += len) {
len = TclUtfToUCS4(stringPtr, &ch);
len = Tcl_UtfToUniChar(stringPtr, &ch);
for (p = splitChars; p < splitEnd; p += splitLen) {
splitLen = TclUtfToUCS4(p, &splitChar);
splitLen = Tcl_UtfToUniChar(p, &splitChar);
if (ch == splitChar) {
TclNewStringObj(objPtr, element, stringPtr - element);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
@@ -1431,11 +1431,6 @@ StringIndexCmd(
char buf[4] = "";
end = Tcl_UniCharToUtf(ch, buf);
#if TCL_UTF_MAX < 4
if ((ch >= 0xD800) && (end < 3)) {
end += Tcl_UniCharToUtf(-1, buf + end);
}
#endif
Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, end));
}
}
@@ -1896,7 +1891,7 @@ StringIsCmd(
for (; string1 < end; string1 += length2, failat++) {
int ucs4;
length2 = TclUtfToUCS4(string1, &ucs4);
length2 = Tcl_UtfToUniChar(string1, &ucs4);
if (!chcomp(ucs4)) {
result = 0;
break;
@@ -2524,7 +2519,7 @@ StringStartCmd(
if (index > 0) {
p = &string[index];
(void)TclUniCharToUCS4(p, &ch);
ch = *p;
for (cur = index; cur != TCL_INDEX_NONE; cur--) {
int delta = 0;
const Tcl_UniChar *next;
@@ -2533,10 +2528,11 @@ StringStartCmd(
break;
}
next = TclUCS4Prev(p, string);
next = p > string ? p - 1 : p;
do {
next += delta;
delta = TclUniCharToUCS4(next, &ch);
delta = 1;
ch = *next;
} while (next + delta < p);
p = next;
}
@@ -2594,7 +2590,7 @@ StringEndCmd(
p = &string[index];
end = string+length;
for (cur = index; p < end; cur++) {
p += TclUniCharToUCS4(p, &ch);
ch = *p++;
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
@@ -4701,7 +4697,7 @@ TclNRTryObjCmd(
return TCL_ERROR;
}
bodyObj = objv[1];
handlersObj = Tcl_NewObj();
TclNewObj(handlersObj);
bodyShared = 0;
haveHandlers = 0;
for (i=2 ; i<objc ; i++) {
+4 -4
View File
@@ -2093,9 +2093,9 @@ ParseLexeme(
if (end < start + numBytes && !TclIsBareword(*end)) {
number:
TclInitStringRep(literal, start, end-start);
*lexemePtr = NUMBER;
if (literalPtr) {
TclInitStringRep(literal, start, end-start);
*literalPtr = literal;
} else {
Tcl_DecrRefCount(literal);
@@ -2149,13 +2149,13 @@ ParseLexeme(
if (!TclIsBareword(*start) || *start == '_') {
Tcl_Size scanned;
if (Tcl_UtfCharComplete(start, numBytes)) {
scanned = TclUtfToUCS4(start, &ch);
scanned = Tcl_UtfToUniChar(start, &ch);
} else {
char utfBytes[8];
memcpy(utfBytes, start, numBytes);
utfBytes[numBytes] = '\0';
scanned = TclUtfToUCS4(utfBytes, &ch);
scanned = Tcl_UtfToUniChar(utfBytes, &ch);
}
*lexemePtr = INVALID;
Tcl_DecrRefCount(literal);
@@ -2168,7 +2168,7 @@ ParseLexeme(
}
*lexemePtr = BAREWORD;
if (literalPtr) {
Tcl_SetStringObj(literal, start, (int) (end-start));
Tcl_SetStringObj(literal, start, end-start);
*literalPtr = literal;
} else {
Tcl_DecrRefCount(literal);
-12
View File
@@ -316,10 +316,8 @@ typedef struct CompileEnv {
* array byte. */
int mallocedCodeArray; /* Set 1 if code array was expanded and
* codeStart points into the heap.*/
#if TCL_MAJOR_VERSION > 8
int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and
* exceptArrayPtr points in heap, else 0. */
#endif
LiteralEntry *literalArrayPtr;
/* Points to start of LiteralEntry array. */
Tcl_Size literalArrayNext; /* Index of next free object array entry. */
@@ -335,9 +333,6 @@ typedef struct CompileEnv {
* current range's array entry. */
Tcl_Size exceptArrayEnd; /* Index after the last ExceptionRange array
* entry. */
#if TCL_MAJOR_VERSION < 9
int mallocedExceptArray;
#endif
ExceptionAux *exceptAuxArrayPtr;
/* Array of information used to restore the
* state when processing BREAK/CONTINUE
@@ -350,19 +345,14 @@ typedef struct CompileEnv {
Tcl_Size cmdMapEnd; /* Index after last CmdLocation entry. */
int mallocedCmdMap; /* 1 if command map array was expanded and
* cmdMapPtr points in the heap, else 0. */
#if TCL_MAJOR_VERSION > 8
int mallocedAuxDataArray; /* 1 if aux data array was expanded and
* auxDataArrayPtr points in heap else 0. */
#endif
AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */
Tcl_Size auxDataArrayNext; /* Next free compile aux data array index.
* auxDataArrayNext is the number of aux data
* items and (auxDataArrayNext-1) is index of
* current aux data array entry. */
Tcl_Size auxDataArrayEnd; /* Index after last aux data array entry. */
#if TCL_MAJOR_VERSION < 9
int mallocedAuxDataArray;
#endif
unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES];
/* Initial storage for code. */
LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS];
@@ -1064,7 +1054,6 @@ typedef struct {
*----------------------------------------------------------------
*/
#if TCL_MAJOR_VERSION > 8
MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine;
/*
@@ -1203,7 +1192,6 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
MODULE_SCOPE int TclPushProcCallFrame(void *clientData,
Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[], int isLambda);
#endif /* TCL_MAJOR_VERSION > 8 */
/*
+16 -162
View File
@@ -27,10 +27,8 @@
#if !defined(BUILD_tcl)
# define TCL_DEPRECATED(msg) EXTERN TCL_DEPRECATED_API(msg)
#elif defined(TCL_NO_DEPRECATED)
# define TCL_DEPRECATED(msg) MODULE_SCOPE
#else
# define TCL_DEPRECATED(msg) EXTERN
# define TCL_DEPRECATED(msg) MODULE_SCOPE
#endif
@@ -1036,7 +1034,7 @@ EXTERN void Tcl_MutexFinalize(Tcl_Mutex *mutex);
/* 393 */
EXTERN int Tcl_CreateThread(Tcl_ThreadId *idPtr,
Tcl_ThreadCreateProc *proc, void *clientData,
Tcl_Size stackSize, int flags);
TCL_HASH_TYPE stackSize, int flags);
/* 394 */
EXTERN Tcl_Size Tcl_ReadRaw(Tcl_Channel chan, char *dst,
Tcl_Size bytesToRead);
@@ -2272,7 +2270,7 @@ typedef struct TclStubs {
int (*tcl_ProcObjCmd) (void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); /* 390 */
void (*tcl_ConditionFinalize) (Tcl_Condition *condPtr); /* 391 */
void (*tcl_MutexFinalize) (Tcl_Mutex *mutex); /* 392 */
int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, Tcl_Size stackSize, int flags); /* 393 */
int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, TCL_HASH_TYPE stackSize, int flags); /* 393 */
Tcl_Size (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, Tcl_Size bytesToRead); /* 394 */
Tcl_Size (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, Tcl_Size srcLen); /* 395 */
Tcl_Channel (*tcl_GetTopChannel) (Tcl_Channel chan); /* 396 */
@@ -4027,77 +4025,29 @@ extern const TclStubs *tclStubsPtr;
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, (sizePtr)) : \
tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (Tcl_Size *)(void *)(sizePtr)))
# define Tcl_GetStringFromObj(objPtr, sizePtr) \
(sizeof(*(sizePtr)) <= sizeof(int) ? \
tclStubsPtr->tclGetStringFromObj(objPtr, (sizePtr)) : \
tclStubsPtr->tcl_GetStringFromObj(objPtr, (Tcl_Size *)(void *)(sizePtr)))
# define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \
(sizeof(*(sizePtr)) <= sizeof(int) ? \
tclStubsPtr->tclGetUnicodeFromObj(objPtr, (sizePtr)) : \
tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (Tcl_Size *)(void *)(sizePtr)))
# endif
#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
(tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), \
#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)))
(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
(Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof(\
(*(boolPtr))), (char *)(boolPtr)))
#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
(sizeof(*(sizePtr)) <= sizeof(int) ? \
tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (sizePtr)) : \
tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (Tcl_Size *)(void *)(sizePtr)))
(tclStubsPtr->tcl_GetBytesFromObj(\
NULL, objPtr, (Tcl_Size *)(void *)(sizePtr)))
#else
#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
(sizeof(*(sizePtr)) <= sizeof(int) ? \
tclStubsPtr->tclGetByteArrayFromObj(objPtr, (sizePtr)) : \
tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (Tcl_Size *)(void *)(sizePtr)))
#endif
#else
#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \
(sizeof(*(sizePtr)) <= sizeof(int) ? \
TclGetBytesFromObj(interp, objPtr, (sizePtr)) : \
(Tcl_GetBytesFromObj)(interp, objPtr, (Tcl_Size *)(void *)(sizePtr)))
#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
((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)) ? 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)) ? Tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \
Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
#define Tcl_GetStringFromObj(objPtr, sizePtr) \
(sizeof(*(sizePtr)) <= sizeof(int) ? \
TclGetStringFromObj(objPtr, (sizePtr)) : \
(Tcl_GetStringFromObj)(objPtr, (Tcl_Size *)(void *)(sizePtr)))
#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
(sizeof(*(sizePtr)) <= sizeof(int) ? \
TclGetBytesFromObj(NULL, objPtr, (sizePtr)) : \
(Tcl_GetBytesFromObj)(NULL, objPtr, (Tcl_Size *)(void *)(sizePtr)))
#define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \
(sizeof(*(sizePtr)) <= sizeof(int) ? \
TclGetUnicodeFromObj(objPtr, (sizePtr)) : \
(Tcl_GetUnicodeFromObj)(objPtr, (Tcl_Size *)(void *)(sizePtr)))
(Tcl_GetBytesFromObj)(NULL, objPtr, (Tcl_Size *)(void *)(sizePtr))
#endif
#ifdef TCL_MEM_DEBUG
@@ -4126,36 +4076,6 @@ extern const TclStubs *tclStubsPtr;
#define Tcl_BackgroundError(interp) Tcl_BackgroundException((interp), TCL_ERROR)
#define Tcl_StringMatch(str, pattern) Tcl_StringCaseMatch((str), (pattern), 0)
#if TCL_UTF_MAX < 4
# undef Tcl_UniCharToUtfDString
# define Tcl_UniCharToUtfDString Tcl_Char16ToUtfDString
# undef Tcl_UtfToUniCharDString
# define Tcl_UtfToUniCharDString Tcl_UtfToChar16DString
# undef Tcl_UtfToUniChar
# define Tcl_UtfToUniChar Tcl_UtfToChar16
# undef Tcl_UniCharLen
# define Tcl_UniCharLen Tcl_Char16Len
# undef Tcl_UniCharToUtf
# if defined(USE_TCL_STUBS)
# define Tcl_UniCharToUtf(c, p) \
(tclStubsPtr->tcl_UniCharToUtf((c)|TCL_COMBINE, (p)))
# else
# define Tcl_UniCharToUtf(c, p) \
((Tcl_UniCharToUtf)((c)|TCL_COMBINE, (p)))
# endif
#if !defined(BUILD_tcl)
# undef Tcl_NumUtfChars
# define Tcl_NumUtfChars TclNumUtfChars
# undef Tcl_GetCharLength
# define Tcl_GetCharLength TclGetCharLength
# undef Tcl_UtfAtIndex
# define Tcl_UtfAtIndex TclUtfAtIndex
# undef Tcl_GetRange
# define Tcl_GetRange TclGetRange
# undef Tcl_GetUniChar
# define Tcl_GetUniChar TclGetUniChar
#endif
#endif
#if defined(USE_TCL_STUBS)
# define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \
? (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))tclStubsPtr->tcl_UniCharToUtfDString \
@@ -4169,36 +4089,6 @@ extern const TclStubs *tclStubsPtr;
# define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \
? (Tcl_Size (*)(wchar_t *))tclStubsPtr->tcl_UniCharLen \
: (Tcl_Size (*)(wchar_t *))Tcl_Char16Len)
#if TCL_MAJOR_VERSION < 9 || !defined(TCL_NO_DEPRECATED)
# undef Tcl_ListObjGetElements
# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(int) \
? tclStubsPtr->tclListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr)) \
: tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (Tcl_Size *)(void *)(objcPtr), (objvPtr)))
# undef Tcl_ListObjLength
# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) == sizeof(int) \
? tclStubsPtr->tclListObjLength((interp), (listPtr), (lengthPtr)) \
: tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (Tcl_Size *)(void *)(lengthPtr)))
# undef Tcl_DictObjSize
# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) == sizeof(int) \
? tclStubsPtr->tclDictObjSize((interp), (dictPtr), (sizePtr)) \
: tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (Tcl_Size *)(void *)(sizePtr)))
# undef Tcl_SplitList
# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
? tclStubsPtr->tclSplitList((interp), (listStr), (argcPtr), (argvPtr)) \
: tclStubsPtr->tcl_SplitList((interp), (listStr), (Tcl_Size *)(void *)(argcPtr), (argvPtr)))
# undef Tcl_SplitPath
# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
? tclStubsPtr->tclSplitPath((path), (argcPtr), (argvPtr)) \
: tclStubsPtr->tcl_SplitPath((path), (Tcl_Size *)(void *)(argcPtr), (argvPtr)))
# undef Tcl_FSSplitPath
# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) == sizeof(int) \
? tclStubsPtr->tclFSSplitPath((pathPtr), (lenPtr)) \
: tclStubsPtr->tcl_FSSplitPath((pathPtr), (Tcl_Size *)(void *)(lenPtr)))
# undef Tcl_ParseArgsObjv
# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(int) \
? tclStubsPtr->tclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) \
: tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (Tcl_Size *)(void *)(objcPtr), (objv), (remObjv)))
#endif /* TCL_MAJOR_VERSION < 9 || !defined(TCL_NO_DEPRECATED) */
#else
# define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \
? (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_UniCharToUtfDString \
@@ -4212,29 +4102,6 @@ extern const TclStubs *tclStubsPtr;
# 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), (objcPtr), (objvPtr)) \
: (Tcl_ListObjGetElements)((interp), (listPtr), (Tcl_Size *)(void *)(objcPtr), (objvPtr)))
# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) == sizeof(int) \
? TclListObjLength((interp), (listPtr), (lengthPtr)) \
: (Tcl_ListObjLength)((interp), (listPtr), (Tcl_Size *)(void *)(lengthPtr)))
# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) == sizeof(int) \
? TclDictObjSize((interp), (dictPtr), (sizePtr)) \
: (Tcl_DictObjSize)((interp), (dictPtr), (Tcl_Size *)(void *)(sizePtr)))
# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
? TclSplitList((interp), (listStr), (argcPtr), (argvPtr)) \
: (Tcl_SplitList)((interp), (listStr), (Tcl_Size *)(void *)(argcPtr), (argvPtr)))
# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
? TclSplitPath((path), (argcPtr), (argvPtr)) \
: (Tcl_SplitPath)((path), (Tcl_Size *)(void *)(argcPtr), (argvPtr)))
# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) == sizeof(int) \
? TclFSSplitPath((pathPtr), (lenPtr)) \
: (Tcl_FSSplitPath)((pathPtr), (Tcl_Size *)(void *)(lenPtr)))
# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(int) \
? TclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) \
: (Tcl_ParseArgsObjv)((interp), (argTable), (Tcl_Size *)(void *)(objcPtr), (objv), (remObjv)))
#endif /* !defined(BUILD_tcl) */
#endif
/*
@@ -4246,24 +4113,11 @@ extern const TclStubs *tclStubsPtr;
#define Tcl_GlobalEvalObj(interp, objPtr) \
Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL)
#if TCL_MAJOR_VERSION > 8
# undef Tcl_Close
# define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0)
#endif
# undef Tcl_Close
# define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0)
#undef TclUtfCharComplete
#undef TclUtfNext
#undef TclUtfPrev
#ifndef TCL_NO_DEPRECATED
# define Tcl_CreateSlave Tcl_CreateChild
# define Tcl_GetSlave Tcl_GetChild
# define Tcl_GetMaster Tcl_GetParent
#endif
/* TIP #660 for 8.7 */
#if TCL_MAJOR_VERSION < 9
# undef Tcl_GetSizeIntFromObj
# define Tcl_GetSizeIntFromObj Tcl_GetIntFromObj
#endif
#endif /* _TCLDECLS */
+20
View File
@@ -1045,6 +1045,26 @@ Tcl_DictObjRemove(
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DictGetSize
*
* Returns the size of dictPtr. Caller must ensure that dictPtr has type
* 'tclDicttype'.
*
*
*----------------------------------------------------------------------
*/
Tcl_Size
TclDictGetSize(Tcl_Obj *dictPtr)
{
Dict *dict;
DictGetInternalRep(dictPtr, dict);
return dict->table.numEntries;
}
/*
*----------------------------------------------------------------------
*
+1 -1
View File
@@ -875,7 +875,7 @@ PrintSourceToObj(
for (; (*p != '\0') && (i < maxChars); p+=len) {
int ucs4;
len = TclUtfToUCS4(p, &ucs4);
len = Tcl_UtfToUniChar(p, &ucs4);
switch (ucs4) {
case '"':
Tcl_AppendToObj(appendObj, "\\\"", -1);
+14 -174
View File
@@ -655,11 +655,6 @@ TclInitEncodingSubsystem(void)
type.clientData = INT2PTR(leFlags);
Tcl_CreateEncoding(&type);
#ifndef TCL_NO_DEPRECATED
type.encodingName = "unicode";
Tcl_CreateEncoding(&type);
#endif
/*
* Need the iso8859-1 encoding in order to process binary data, so force
* it to always be embedded. Note that this encoding *must* be a proper
@@ -1154,7 +1149,7 @@ Tcl_ExternalToUtfDString(
* converted string is stored. */
{
Tcl_ExternalToUtfDStringEx(
NULL, encoding, src, srcLen, TCL_ENCODING_PROFILE_TCL8, dstPtr, NULL);
NULL, encoding, src, srcLen, TCL_ENCODING_PROFILE_STRICT, dstPtr, NULL);
return Tcl_DStringValue(dstPtr);
}
@@ -1628,7 +1623,7 @@ Tcl_UtfToExternalDStringEx(
Tcl_Size pos = Tcl_NumUtfChars(srcStart, nBytesProcessed);
int ucs4;
char buf[TCL_INTEGER_SPACE];
TclUtfToUCS4(&srcStart[nBytesProcessed], &ucs4);
Tcl_UtfToUniChar(&srcStart[nBytesProcessed], &ucs4);
snprintf(buf, sizeof(buf), "%" TCL_Z_MODIFIER "u", nBytesProcessed);
Tcl_SetObjResult(
interp,
@@ -2531,16 +2526,6 @@ UtfToUtfProc(
flags |= PTR2INT(clientData);
dstEnd = dst + dstLen - ((flags & ENCODING_UTF) ? TCL_UTF_MAX : 6);
#if TCL_UTF_MAX < 4
/* Initialize the buffer so that some random data doesn't trick
* Tcl_UniCharToUtf() into thinking it should combine surrogate pairs.
* Once TCL_UTF_MAX == 3 is removed and Tcl_UniCharToUtf restored to its
* prior non-stateful nature, this call to memset can also be removed.
*/
memset(dst, 0xff, dstLen);
#endif
profile = ENCODING_PROFILE_GET(flags);
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
@@ -2588,10 +2573,10 @@ UtfToUtfProc(
} else if (!Tcl_UtfCharComplete(src, srcEnd - src)) {
/*
* Incomplete byte sequence.
* Always check before using TclUtfToUCS4. Not doing so can cause it
* run beyond the end of the buffer! If we happen on such an incomplete
* char its bytes are made to represent themselves unless the user has
* explicitly asked to be told.
* Always check before using Tcl_UtfToUniChar. Not doing can so cause
* it to run beyond the end of the buffer! If we happen such an
* incomplete char its bytes are made to represent themselves
* unless the user has explicitly asked to be told.
*/
if (flags & ENCODING_INPUT) {
@@ -2610,12 +2595,12 @@ UtfToUtfProc(
/* TCL_ENCODING_PROFILE_TCL8 */
char chbuf[2];
chbuf[0] = UCHAR(*src++); chbuf[1] = 0;
TclUtfToUCS4(chbuf, &ch);
Tcl_UtfToUniChar(chbuf, &ch);
}
dst += Tcl_UniCharToUtf(ch, dst);
} else {
int isInvalid = 0;
size_t len = TclUtfToUCS4(src, &ch);
size_t len = Tcl_UtfToUniChar(src, &ch);
if (flags & ENCODING_INPUT) {
if ((len < 2) && (ch != 0)) {
isInvalid = 1;
@@ -2643,44 +2628,10 @@ UtfToUtfProc(
*dst++ = (char) (((ch >> 10) & 0x3F) | 0x80);
ch = (ch & 0x0CFF) | 0xDC00;
}
#if TCL_UTF_MAX < 4
cesu8:
#endif
*dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF);
*dst++ = (char) (((ch >> 6) | 0x80) & 0xBF);
*dst++ = (char) ((ch | 0x80) & 0xBF);
continue;
#if TCL_UTF_MAX < 4
} else if (SURROGATE(ch)) {
/*
* A surrogate character is detected, handle especially.
*/
if (PROFILE_STRICT(profile) && (flags & ENCODING_UTF)) {
result = TCL_CONVERT_UNKNOWN;
src = saveSrc;
break;
}
if (PROFILE_REPLACE(profile)) {
/* TODO - is this right for cesu8 or should we fall through below? */
ch = UNICODE_REPLACE_CHAR;
} else {
int low = ch;
len = (src <= srcEnd - 3) ? TclUtfToUCS4(src, &low) : 0;
if ((!LOW_SURROGATE(low)) || (ch & 0x400)) {
if (PROFILE_STRICT(profile)) {
result = TCL_CONVERT_UNKNOWN;
src = saveSrc;
break;
}
goto cesu8;
}
src += len;
dst += Tcl_UniCharToUtf(ch, dst);
ch = low;
}
#endif
} else if (PROFILE_STRICT(profile) &&
(!(flags & ENCODING_INPUT)) &&
SURROGATE(ch)) {
@@ -2755,15 +2706,6 @@ Utf32ToUtfProc(
}
result = TCL_OK;
#if TCL_UTF_MAX < 4
/* Initialize the buffer so that some random data doesn't trick
* Tcl_UniCharToUtf() into thinking it should combine surrogate pairs.
* Once TCL_UTF_MAX == 3 is removed and Tcl_UniCharToUtf restored to its
* prior non-stateful nature, this call to memset can also be removed.
*/
memset(dst, 0xff, dstLen);
#endif
/*
* Check alignment with utf-32 (4 == sizeof(UTF-32))
*/
@@ -2773,21 +2715,6 @@ Utf32ToUtfProc(
srcLen -= bytesLeft;
}
#if TCL_UTF_MAX < 4
/*
* If last code point is a high surrogate, we cannot handle that yet,
* unless we are at the end.
*/
if (!(flags & TCL_ENCODING_END) && (srcLen >= 4) &&
((src[srcLen - ((flags & TCL_ENCODING_LE)?3:2)] & 0xFC) == 0xD8) &&
((src[srcLen - ((flags & TCL_ENCODING_LE)?2:3)]) == 0) &&
((src[srcLen - ((flags & TCL_ENCODING_LE)?1:4)]) == 0)) {
result = TCL_CONVERT_MULTIBYTE;
srcLen-= 4;
}
#endif
srcStart = src;
srcEnd = src + srcLen;
@@ -2800,20 +2727,11 @@ Utf32ToUtfProc(
break;
}
#if TCL_UTF_MAX < 4
int prev = ch;
#endif
if (flags & TCL_ENCODING_LE) {
ch = (unsigned int)(src[3] & 0xFF) << 24 | (src[2] & 0xFF) << 16 | (src[1] & 0xFF) << 8 | (src[0] & 0xFF);
} else {
ch = (unsigned int)(src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16 | (src[2] & 0xFF) << 8 | (src[3] & 0xFF);
}
#if TCL_UTF_MAX < 4
if (HIGH_SURROGATE(prev) && !LOW_SURROGATE(ch)) {
/* Bug [10c2c17c32]. If Hi surrogate not followed by Lo surrogate, finish 3-byte UTF-8 */
dst += Tcl_UniCharToUtf(-1, dst);
}
#endif
if ((unsigned)ch > 0x10FFFF) {
ch = UNICODE_REPLACE_CHAR;
@@ -2823,9 +2741,6 @@ Utf32ToUtfProc(
}
} else if (PROFILE_STRICT(flags) && SURROGATE(ch)) {
result = TCL_CONVERT_SYNTAX;
#if TCL_UTF_MAX < 4
ch = 0;
#endif
break;
} else if (PROFILE_REPLACE(flags) && SURROGATE(ch)) {
ch = UNICODE_REPLACE_CHAR;
@@ -2839,11 +2754,6 @@ Utf32ToUtfProc(
if ((unsigned)ch - 1 < 0x7F) {
*dst++ = (ch & 0xFF);
} else {
#if TCL_UTF_MAX < 4
if (!HIGH_SURROGATE(prev) && LOW_SURROGATE(ch)) {
*dst = 0; /* In case of lower surrogate, don't try to combine */
}
#endif
dst += Tcl_UniCharToUtf(ch, dst);
}
src += 4;
@@ -2853,13 +2763,6 @@ Utf32ToUtfProc(
* If we had a truncated code unit at the end AND this is the last
* fragment AND profile is not "strict", stick FFFD in its place.
*/
#if TCL_UTF_MAX < 4
if (HIGH_SURROGATE(ch)) {
/* Bug [10c2c17c32]. If Hi surrogate, finish 3-byte UTF-8 */
dst += Tcl_UniCharToUtf(-1, dst);
}
#endif
if ((flags & TCL_ENCODING_END) && (result == TCL_CONVERT_MULTIBYTE)) {
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
@@ -2952,7 +2855,7 @@ UtfToUtf32Proc(
result = TCL_CONVERT_NOSPACE;
break;
}
len = TclUtfToUCS4(src, &ch);
len = Tcl_UtfToUniChar(src, &ch);
if (SURROGATE(ch)) {
if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_UNKNOWN;
@@ -3033,15 +2936,6 @@ Utf16ToUtfProc(
}
result = TCL_OK;
#if TCL_UTF_MAX < 4
/* Initialize the buffer so that some random data doesn't trick
* Tcl_UniCharToUtf() into thinking it should combine surrogate pairs.
* Once TCL_UTF_MAX == 3 is removed and Tcl_UniCharToUtf restored to its
* prior non-stateful nature, this call to memset can also be removed.
*/
memset(dst, 0xff, dstLen);
#endif
/*
* Check alignment with utf-16 (2 == sizeof(UTF-16))
*/
@@ -3240,7 +3134,7 @@ UtfToUtf16Proc(
result = TCL_CONVERT_NOSPACE;
break;
}
len = TclUtfToUCS4(src, &ch);
len = Tcl_UtfToUniChar(src, &ch);
if (SURROGATE(ch)) {
if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_UNKNOWN;
@@ -3349,18 +3243,7 @@ UtfToUcs2Proc(
result = TCL_CONVERT_NOSPACE;
break;
}
#if TCL_UTF_MAX < 4
len = TclUtfToUniChar(src, &ch);
if ((ch >= 0xD800) && (len < 3)) {
if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_UNKNOWN;
break;
}
src += len;
src += TclUtfToUniChar(src, &ch);
ch = UNICODE_REPLACE_CHAR;
}
#else
len = TclUtfToUniChar(src, &ch);
if (ch > 0xFFFF) {
if (PROFILE_STRICT(flags)) {
@@ -3369,7 +3252,6 @@ UtfToUcs2Proc(
}
ch = UNICODE_REPLACE_CHAR;
}
#endif
if (PROFILE_STRICT(flags) && SURROGATE(ch)) {
result = TCL_CONVERT_SYNTAX;
break;
@@ -3455,15 +3337,6 @@ TableToUtfProc(
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
#if TCL_UTF_MAX < 4
/* Initialize the buffer so that some random data doesn't trick
* Tcl_UniCharToUtf() into thinking it should combine surrogate pairs.
* Once TCL_UTF_MAX == 3 is removed and Tcl_UniCharToUtf restored to its
* prior non-stateful nature, this call to memset can also be removed.
*/
memset(dst, 0xff, dstLen);
#endif
toUnicode = (const unsigned short *const *) dataPtr->toUnicode;
prefixBytes = dataPtr->prefixBytes;
pageZero = toUnicode[0];
@@ -3608,17 +3481,12 @@ TableFromUtfProc(
}
len = TclUtfToUniChar(src, &ch);
#if TCL_UTF_MAX > 3
/* Unicode chars > +U0FFFF cannot be represented in any table encoding */
if (ch & 0xFFFF0000) {
word = 0;
} else
#else
if (!len) {
word = 0;
} else
#endif
} else {
word = fromUnicode[(ch >> 8)][ch & 0xFF];
}
if ((word == 0) && (ch != 0)) {
if (PROFILE_STRICT(flags)) {
@@ -3705,15 +3573,6 @@ Iso88591ToUtfProc(
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
#if TCL_UTF_MAX < 4
/* Initialize the buffer so that some random data doesn't trick
* Tcl_UniCharToUtf() into thinking it should combine surrogate pairs.
* Once TCL_UTF_MAX == 3 is removed and Tcl_UniCharToUtf restored to its
* prior non-stateful nature, this call to memset can also be removed.
*/
memset(dst, 0xff, dstLen);
#endif
result = TCL_OK;
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
Tcl_UniChar ch = 0;
@@ -3815,24 +3674,14 @@ Iso88591FromUtfProc(
* Check for illegal characters.
*/
if (ch > 0xFF
#if TCL_UTF_MAX < 4
|| ((ch >= 0xD800) && (len < 3))
#endif
) {
if (ch > 0xFF) {
if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_UNKNOWN;
break;
}
#if TCL_UTF_MAX < 4
if ((ch >= 0xD800) && (len < 3)) {
len = 4;
}
#endif
/*
* Plunge on, using '?' as a fallback character.
*/
ch = (Tcl_UniChar) '?'; /* Profiles TCL8 and REPLACE */
}
@@ -3953,15 +3802,6 @@ EscapeToUtfProc(
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
#if TCL_UTF_MAX < 4
/* Initialize the buffer so that some random data doesn't trick
* Tcl_UniCharToUtf() into thinking it should combine surrogate pairs.
* Once TCL_UTF_MAX == 3 is removed and Tcl_UniCharToUtf restored to its
* prior non-stateful nature, this call to memset can also be removed.
*/
memset(dst, 0xff, dstLen);
#endif
state = PTR2INT(*statePtr);
if (flags & TCL_ENCODING_START) {
state = 0;
+34 -5
View File
@@ -312,7 +312,17 @@ TclNamespaceEnsembleCmd(
Tcl_AppendObjToObj(newCmd, listv[0]);
Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
if (patchedDict == NULL) {
patchedDict = Tcl_DuplicateObj(objv[1]);
patchedDict = TclDuplicatePureObj(
interp, objv[1], &tclDictType);
if (!patchedDict) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
Tcl_DecrRefCount(newList);
Tcl_DecrRefCount(newCmd);
Tcl_DecrRefCount(patchedDict);
return TCL_ERROR;
}
}
Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
newList);
@@ -596,7 +606,14 @@ TclNamespaceEnsembleCmd(
}
cmd = TclGetString(listv[0]);
if (!(cmd[0] == ':' && cmd[1] == ':')) {
Tcl_Obj *newList = Tcl_DuplicateObj(listObj);
Tcl_Obj *newList = TclDuplicatePureObj(
interp, listObj, &tclListType.objType);
if (!newList) {
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
}
goto freeMapAndError;
}
Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*)nsPtr);
if (nsPtr->parentPtr) {
@@ -606,7 +623,11 @@ TclNamespaceEnsembleCmd(
Tcl_ListObjReplace(NULL, newList, 0, 1, 1,
&newCmd);
if (patchedDict == NULL) {
patchedDict = Tcl_DuplicateObj(objv[1]);
patchedDict = TclDuplicatePureObj(
interp, objv[1], &tclListType.objType);
if (!patchedDict) {
goto freeMapAndError;
}
}
Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
newList);
@@ -1904,7 +1925,11 @@ NsEnsembleImplementationCmdNR(
TclListObjLengthM(NULL, prefixObj, &prefixObjc);
if (objc == 2) {
copyPtr = TclListObjCopy(NULL, prefixObj);
copyPtr = TclDuplicatePureObj(
interp, prefixObj, &tclListType.objType);
if (!copyPtr) {
return TCL_ERROR;
}
} else {
copyPtr = Tcl_NewListObj(objc - 2 + prefixObjc, NULL);
Tcl_ListObjAppendList(NULL, copyPtr, prefixObj);
@@ -2304,7 +2329,11 @@ EnsembleUnknownCallback(
* Create the "unknown" command callback to determine what to do.
*/
unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);
unknownCmd = TclDuplicatePureObj(
interp, ensemblePtr->unknownHandler, &tclListType.objType);
if (!unknownCmd) {
return TCL_ERROR;
}
TclNewObj(ensObj);
Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj);
Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj);
+6 -8
View File
@@ -232,7 +232,11 @@ HandleBgErrors(
* support one handler setting another handler.
*/
Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix);
Tcl_Obj *copyObj = TclDuplicatePureObj(
interp, assocPtr->cmdPrefix, &tclListType.objType);
if (!copyObj) {
return;
}
errPtr = assocPtr->firstBgPtr;
@@ -1084,9 +1088,6 @@ static const struct {
#ifdef USE_NMAKE
".nmake"
#endif
#ifdef TCL_NO_DEPRECATED
".no-deprecate"
#endif
#if !TCL_THREADS
".no-thread"
#endif
@@ -1108,9 +1109,6 @@ static const struct {
#ifdef STATIC_BUILD
".static"
#endif
#if TCL_UTF_MAX < 4
".utf-16"
#endif
}};
const char *
@@ -2048,7 +2046,7 @@ Tcl_CreateThread(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
void *clientData, /* The one argument to Main() */
Tcl_Size stackSize, /* Size of stack for the new thread */
TCL_HASH_TYPE stackSize, /* Size of stack for the new thread */
int flags) /* Flags controlling behaviour of the new
* thread. */
{
+117 -83
View File
@@ -366,7 +366,7 @@ VarHashCreateVar(
#define OBJ_AT_DEPTH(n) *(tosPtr-(n))
#define CURR_DEPTH ((size_t)(tosPtr - initTosPtr))
#define CURR_DEPTH (tosPtr - initTosPtr)
#define STACK_BASE(esPtr) ((esPtr)->stackWords - 1)
@@ -379,9 +379,9 @@ VarHashCreateVar(
#ifdef TCL_COMPILE_DEBUG
# define TRACE(a) \
while (traceInstructions) { \
fprintf(stdout, "%2" TCL_Z_MODIFIER "u: %2" TCL_Z_MODIFIER "u (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \
fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_T_MODIFIER "d (%" TCL_T_MODIFIER "d) %s ", iPtr->numLevels, \
CURR_DEPTH, \
(size_t)(pc - codePtr->codeStart), \
(pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
break; \
@@ -395,9 +395,9 @@ VarHashCreateVar(
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
# define TRACE_WITH_OBJ(a, objPtr) \
while (traceInstructions) { \
fprintf(stdout, "%2" TCL_Z_MODIFIER "u: %2" TCL_Z_MODIFIER "u (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \
fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_T_MODIFIER "d (%" TCL_T_MODIFIER "d) %s ", iPtr->numLevels, \
CURR_DEPTH, \
(size_t)(pc - codePtr->codeStart), \
(pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
TclPrintObject(stdout, objPtr, 30); \
@@ -636,7 +636,7 @@ static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc,
static const char * GetSrcInfoForPc(const unsigned char *pc,
ByteCode *codePtr, Tcl_Size *lengthPtr,
const unsigned char **pcBeg, int *cmdIdxPtr);
static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, size_t growth,
static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, TCL_HASH_TYPE growth,
int move);
static void IllegalExprOperandType(Tcl_Interp *interp,
const unsigned char *pc, Tcl_Obj *opndPtr);
@@ -644,8 +644,8 @@ static void InitByteCodeExecution(Tcl_Interp *interp);
static inline int wordSkip(void *ptr);
static void ReleaseDictIterator(Tcl_Obj *objPtr);
/* Useful elsewhere, make available in tclInt.h or stubs? */
static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, size_t numWords);
static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, size_t numWords);
static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, TCL_HASH_TYPE numWords);
static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, TCL_HASH_TYPE numWords);
static Tcl_NRPostProc CopyCallback;
static Tcl_NRPostProc ExprObjCallback;
static Tcl_NRPostProc FinalizeOONext;
@@ -792,7 +792,7 @@ ExecEnv *
TclCreateExecEnv(
Tcl_Interp *interp, /* Interpreter for which the execution
* environment is being created. */
size_t size) /* The initial stack size, in number of words
TCL_HASH_TYPE size) /* The initial stack size, in number of words
* [sizeof(Tcl_Obj*)] */
{
ExecEnv *eePtr = (ExecEnv *)Tcl_Alloc(sizeof(ExecEnv));
@@ -974,12 +974,12 @@ static Tcl_Obj **
GrowEvaluationStack(
ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation
* stack to enlarge. */
size_t growth1, /* How much larger than the current used
TCL_HASH_TYPE growth1, /* How much larger than the current used
* size. */
int move) /* 1 if move words since last marker. */
{
ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL;
size_t newBytes;
TCL_HASH_TYPE newBytes;
Tcl_Size growth = growth1;
Tcl_Size newElems, currElems, needed = growth - (esPtr->endPtr - esPtr->tosPtr);
Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart;
@@ -1126,7 +1126,7 @@ GrowEvaluationStack(
static Tcl_Obj **
StackAllocWords(
Tcl_Interp *interp,
size_t numWords)
TCL_HASH_TYPE numWords)
{
/*
* Note that GrowEvaluationStack sets a marker in the stack. This marker
@@ -1144,7 +1144,7 @@ StackAllocWords(
static Tcl_Obj **
StackReallocWords(
Tcl_Interp *interp,
size_t numWords)
TCL_HASH_TYPE numWords)
{
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr = iPtr->execEnvPtr;
@@ -1223,13 +1223,13 @@ TclStackFree(
void *
TclStackAlloc(
Tcl_Interp *interp,
Tcl_Size numBytes)
TCL_HASH_TYPE numBytes)
{
Interp *iPtr = (Interp *) interp;
Tcl_Size numWords;
TCL_HASH_TYPE numWords;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
return (void *) Tcl_Alloc(numBytes);
return Tcl_Alloc(numBytes);
}
numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
return StackAllocWords(interp, numWords);
@@ -1239,13 +1239,13 @@ void *
TclStackRealloc(
Tcl_Interp *interp,
void *ptr,
Tcl_Size numBytes)
TCL_HASH_TYPE numBytes)
{
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr;
ExecStack *esPtr;
Tcl_Obj **markerPtr;
Tcl_Size numWords;
TCL_HASH_TYPE numWords;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
return Tcl_Realloc(ptr, numBytes);
@@ -1888,10 +1888,10 @@ TclNRExecuteByteCode(
{
Interp *iPtr = (Interp *) interp;
TEBCdata *TD;
size_t size = sizeof(TEBCdata) - 1
TCL_HASH_TYPE size = sizeof(TEBCdata) - 1
+ (codePtr->maxStackDepth + codePtr->maxExceptDepth)
* sizeof(void *);
size_t numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *);
TCL_HASH_TYPE numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *);
TclPreserveByteCode(codePtr);
@@ -2065,7 +2065,7 @@ TEBCresume(
#ifdef TCL_COMPILE_DEBUG
if (!pc && (tclTraceExec >= 2)) {
PrintByteCodeInfo(codePtr);
fprintf(stdout, " Starting stack top=%" TCL_Z_MODIFIER "u\n", CURR_DEPTH);
fprintf(stdout, " Starting stack top=%" TCL_T_MODIFIER "d\n", CURR_DEPTH);
fflush(stdout);
}
#endif
@@ -2124,7 +2124,7 @@ TEBCresume(
* instruction.
*/
TRACE_WITH_OBJ(("%" TCL_Z_MODIFIER "u => ... after \"%.20s\": TCL_OK, result=",
TRACE_WITH_OBJ(("%" TCL_SIZE_MODIFIER "d => ... after \"%.20s\": TCL_OK, result=",
objc, cmdNameBuf), Tcl_GetObjResult(interp));
/*
@@ -2269,7 +2269,7 @@ TEBCresume(
CHECK_STACK();
if (traceInstructions) {
fprintf(stdout, "%2" TCL_Z_MODIFIER "u: %2" TCL_Z_MODIFIER "u ", iPtr->numLevels, CURR_DEPTH);
fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_T_MODIFIER "d ", iPtr->numLevels, CURR_DEPTH);
TclPrintInstruction(codePtr, pc);
fflush(stdout);
}
@@ -2389,7 +2389,7 @@ TEBCresume(
if (traceInstructions) {
TRACE_APPEND(("YIELD...\n"));
} else {
fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_T_MODIFIER "u) yielding value \"%.30s\"\n",
fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) yielding value \"%.30s\"\n",
iPtr->numLevels, (pc - codePtr->codeStart),
Tcl_GetString(OBJ_AT_TOS));
}
@@ -2432,7 +2432,7 @@ TEBCresume(
TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr)));
} else {
/* FIXME: What is the right thing to trace? */
fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_T_MODIFIER "u) yielding to [%.30s]\n",
fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) yielding to [%.30s]\n",
iPtr->numLevels, (pc - codePtr->codeStart),
TclGetString(valuePtr));
}
@@ -2636,10 +2636,10 @@ TEBCresume(
*/
TclNewObj(objPtr);
objPtr->internalRep.twoPtrValue.ptr2 = UINT2PTR(CURR_DEPTH);
objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(CURR_DEPTH);
objPtr->length = 0;
PUSH_TAUX_OBJ(objPtr);
TRACE(("=> mark depth as %" TCL_Z_MODIFIER "u\n", CURR_DEPTH));
TRACE(("=> mark depth as %" TCL_T_MODIFIER "d\n", CURR_DEPTH));
NEXT_INST_F(1, 0, 0);
break;
@@ -2651,13 +2651,13 @@ TEBCresume(
*/
CLANG_ASSERT(auxObjList);
objc = CURR_DEPTH - PTR2UINT(auxObjList->internalRep.twoPtrValue.ptr2);
objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2);
POP_TAUX_OBJ();
#ifdef TCL_COMPILE_DEBUG
/* Ugly abuse! */
starting = 1;
#endif
TRACE(("=> drop %" TCL_Z_MODIFIER "u items\n", objc));
TRACE(("=> drop %" TCL_SIZE_MODIFIER "d items\n", objc));
NEXT_INST_V(1, objc, 0);
case INST_EXPAND_STKTOP: {
@@ -2758,7 +2758,7 @@ TEBCresume(
case INST_INVOKE_EXPANDED:
CLANG_ASSERT(auxObjList);
objc = CURR_DEPTH - PTR2UINT(auxObjList->internalRep.twoPtrValue.ptr2);
objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2);
POP_TAUX_OBJ();
if (objc) {
pcAdjustment = 1;
@@ -2792,9 +2792,9 @@ TEBCresume(
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
TRACE(("%" TCL_Z_MODIFIER "u => call ", objc));
TRACE(("%" TCL_SIZE_MODIFIER "d => call ", objc));
} else {
fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_T_MODIFIER "u) invoking ", iPtr->numLevels,
fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) invoking ", iPtr->numLevels,
(pc - codePtr->codeStart));
}
for (i = 0; i < objc; i++) {
@@ -3374,7 +3374,12 @@ TEBCresume(
goto gotError;
}
if (Tcl_IsShared(objResultPtr)) {
Tcl_Obj *newValue = Tcl_DuplicateObj(objResultPtr);
Tcl_Obj *newValue = TclDuplicatePureObj(
interp, objResultPtr, &tclListType.objType);
if (!newValue) {
TRACE_ERROR(interp);
goto gotError;
}
TclDecrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr = newValue;
@@ -3433,7 +3438,11 @@ TEBCresume(
goto gotError;
} else {
if (Tcl_IsShared(objResultPtr)) {
valueToAssign = Tcl_DuplicateObj(objResultPtr);
valueToAssign = TclDuplicatePureObj(
interp, objResultPtr, &tclListType.objType);
if (!valueToAssign) {
goto errorInLappendListPtr;
}
createdNewObj = 1;
} else {
valueToAssign = objResultPtr;
@@ -4430,7 +4439,7 @@ TEBCresume(
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
} else {
fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ",
fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) invoking ",
iPtr->numLevels,
(size_t)(pc - codePtr->codeStart));
}
@@ -4532,8 +4541,8 @@ TEBCresume(
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
} else {
fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ",
iPtr->numLevels, (size_t)(pc - codePtr->codeStart));
fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ",
iPtr->numLevels, (pc - codePtr->codeStart));
}
for (i = 0; i < opnd; i++) {
TclPrintObject(stdout, objv[i], 15);
@@ -4650,8 +4659,8 @@ TEBCresume(
TRACE_ERROR(interp);
goto gotError;
}
TclNewUIntObj(objResultPtr, length);
TRACE_APPEND(("%" TCL_Z_MODIFIER "u\n", length));
TclNewIntObj(objResultPtr, length);
TRACE_APPEND(("%" TCL_SIZE_MODIFIER "d\n", length));
NEXT_INST_F(1, 1, 1);
case INST_LIST_INDEX: /* lindex with objc == 3 */
@@ -4682,23 +4691,43 @@ TEBCresume(
* Extract the desired list element.
*/
if ((TclListObjGetElementsM(interp, valuePtr, &objc, &objv) == TCL_OK)
&& !TclHasInternalRep(value2Ptr, &tclListType.objType)) {
int code;
{
Tcl_Size value2Length;
Tcl_Obj *indexListPtr = value2Ptr;
if ((TclListObjGetElementsM(interp, valuePtr, &objc, &objv) == TCL_OK)
&& (
!TclHasInternalRep(value2Ptr, &tclListType.objType)
||
((Tcl_ListObjLength(interp,value2Ptr,&value2Length),
value2Length == 1
? (indexListPtr = TclListObjGetElement(value2Ptr, 0), 1)
: 0
))
)
) {
int code;
DECACHE_STACK_INFO();
code = TclGetIntForIndexM(interp, value2Ptr, objc-1, &index);
CACHE_STACK_INFO();
if (code == TCL_OK) {
TclDecrRefCount(value2Ptr);
tosPtr--;
pcAdjustment = 1;
goto lindexFastPath;
/* increment the refCount of value2Ptr because TclListObjGetElement may
* have just extracted it from a list in the condition for this block.
*/
Tcl_IncrRefCount(indexListPtr);
DECACHE_STACK_INFO();
code = TclGetIntForIndexM(interp, indexListPtr, objc-1, &index);
TclDecrRefCount(indexListPtr);
CACHE_STACK_INFO();
if (code == TCL_OK) {
Tcl_DecrRefCount(value2Ptr);
tosPtr--;
pcAdjustment = 1;
goto lindexFastPath;
}
Tcl_ResetResult(interp);
}
Tcl_ResetResult(interp);
}
DECACHE_STACK_INFO();
objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
CACHE_STACK_INFO();
lindexDone:
if (!objResultPtr) {
@@ -5040,7 +5069,7 @@ TEBCresume(
case INST_LREPLACE4:
{
size_t numToDelete, numNewElems;
TCL_HASH_TYPE numToDelete, numNewElems;
int end_indicator;
int haveSecondIndex, flags;
Tcl_Obj *fromIdxObj, *toIdxObj;
@@ -5292,11 +5321,6 @@ TEBCresume(
TclNewObj(objResultPtr);
} else {
slength = Tcl_UniCharToUtf(ch, buf);
#if TCL_UTF_MAX < 4
if ((ch >= 0xD800) && (slength < 3)) {
slength += Tcl_UniCharToUtf(-1, buf + slength);
}
#endif
objResultPtr = Tcl_NewStringObj(buf, slength);
}
}
@@ -5508,7 +5532,7 @@ TEBCresume(
int ch;
end = ustring1 + slength;
for (p=ustring1 ; p<end ; ) {
p += TclUniCharToUCS4(p, &ch);
ch = *p++;
if (!tclStringClassTable[opnd].comparator(ch)) {
match = 0;
break;
@@ -6405,7 +6429,11 @@ TEBCresume(
goto gotError;
}
if (Tcl_IsShared(listPtr)) {
objPtr = TclListObjCopy(NULL, listPtr);
objPtr = TclDuplicatePureObj(
interp, listPtr, &tclListType.objType);
if (!objPtr) {
goto gotError;
}
Tcl_IncrRefCount(objPtr);
Tcl_DecrRefCount(listPtr);
OBJ_AT_DEPTH(listTmpDepth) = objPtr;
@@ -6467,6 +6495,7 @@ TEBCresume(
*/
if (iterNum < iterMax) {
int status;
/*
* Set the variables and jump back to run the body
*/
@@ -6480,7 +6509,12 @@ TEBCresume(
numVars = varListPtr->numVars;
listPtr = OBJ_AT_DEPTH(listTmpDepth);
TclListObjGetElementsM(interp, listPtr, &listLen, &elements);
status = TclListObjGetElementsM(
interp, listPtr, &listLen, &elements);
if (status != TCL_OK) {
goto gotError;
}
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
@@ -6509,7 +6543,7 @@ TEBCresume(
if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){
CACHE_STACK_INFO();
TRACE_APPEND(("ERROR init. index temp %" TCL_Z_MODIFIER "u: %.30s",
TRACE_APPEND(("ERROR init. index temp %" TCL_SIZE_MODIFIER "d: %.30s",
varIndex, O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
@@ -6556,7 +6590,7 @@ TEBCresume(
tmpPtr = OBJ_AT_DEPTH(1);
infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1;
numLists = infoPtr->numLists;
TRACE_APPEND(("=> appending to list at depth %" TCL_Z_MODIFIER "u\n", 3 + numLists));
TRACE_APPEND(("=> appending to list at depth %" TCL_SIZE_MODIFIER "d\n", 3 + numLists));
objPtr = OBJ_AT_DEPTH(3 + numLists);
Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS);
@@ -6571,9 +6605,9 @@ TEBCresume(
* stack.
*/
*(++catchTop) = (Tcl_Obj *)UINT2PTR(CURR_DEPTH);
TRACE(("%u => catchTop=%" TCL_Z_MODIFIER "u, stackTop=%" TCL_Z_MODIFIER "u\n",
TclGetUInt4AtPtr(pc+1), (size_t)(catchTop - initCatchTop - 1),
*(++catchTop) = (Tcl_Obj *)INT2PTR(CURR_DEPTH);
TRACE(("%u => catchTop=%" TCL_T_MODIFIER "d, stackTop=%" TCL_T_MODIFIER "d\n",
TclGetUInt4AtPtr(pc+1), (catchTop - initCatchTop - 1),
CURR_DEPTH));
NEXT_INST_F(5, 0, 0);
break;
@@ -7384,7 +7418,7 @@ TEBCresume(
if (result == TCL_BREAK) {
result = TCL_OK;
pc = (codePtr->codeStart + rangePtr->breakOffset);
TRACE_APPEND(("%s, range at %" TCL_Z_MODIFIER "u, new pc %" TCL_Z_MODIFIER "u\n",
TRACE_APPEND(("%s, range at %" TCL_SIZE_MODIFIER "d, new pc %" TCL_SIZE_MODIFIER "d\n",
StringForResultCode(result),
rangePtr->codeOffset, rangePtr->breakOffset));
NEXT_INST_F(0, 0, 0);
@@ -7396,7 +7430,7 @@ TEBCresume(
}
result = TCL_OK;
pc = (codePtr->codeStart + rangePtr->continueOffset);
TRACE_APPEND(("%s, range at %" TCL_Z_MODIFIER "u, new pc %" TCL_Z_MODIFIER "u\n",
TRACE_APPEND(("%s, range at %" TCL_SIZE_MODIFIER "d, new pc %" TCL_SIZE_MODIFIER "d\n",
StringForResultCode(result),
rangePtr->codeOffset, rangePtr->continueOffset));
NEXT_INST_F(0, 0, 0);
@@ -7486,8 +7520,8 @@ TEBCresume(
while (auxObjList) {
if ((catchTop != initCatchTop)
&& (PTR2UINT(*catchTop) >
PTR2UINT(auxObjList->internalRep.twoPtrValue.ptr2))) {
&& (PTR2INT(*catchTop) >
PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2))) {
break;
}
POP_TAUX_OBJ();
@@ -7562,16 +7596,16 @@ TEBCresume(
*/
processCatch:
while (CURR_DEPTH > PTR2UINT(*catchTop)) {
while (CURR_DEPTH > PTR2INT(*catchTop)) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " ... found catch at %" TCL_Z_MODIFIER "u, catchTop=%" TCL_Z_MODIFIER "u, "
"unwound to %" TCL_Z_MODIFIER "u, new pc %" TCL_Z_MODIFIER "u\n",
rangePtr->codeOffset, (size_t)(catchTop - initCatchTop - 1),
PTR2UINT(*catchTop), (size_t)rangePtr->catchOffset);
fprintf(stdout, " ... found catch at %" TCL_SIZE_MODIFIER "d, catchTop=%" TCL_T_MODIFIER "d, "
"unwound to %" TCL_T_MODIFIER "d, new pc %" TCL_SIZE_MODIFIER "d\n",
rangePtr->codeOffset, (catchTop - initCatchTop - 1),
PTR2INT(*catchTop), rangePtr->catchOffset);
}
#endif
pc = (codePtr->codeStart + rangePtr->catchOffset);
@@ -7607,9 +7641,9 @@ TEBCresume(
if (tosPtr < initTosPtr) {
fprintf(stderr,
"\nTclNRExecuteByteCode: abnormal return at pc %" TCL_Z_MODIFIER "u: "
"stack top %" TCL_Z_MODIFIER "u < entry stack top %d\n",
(size_t)(pc - codePtr->codeStart),
"\nTclNRExecuteByteCode: abnormal return at pc %" TCL_T_MODIFIER "d: "
"stack top %" TCL_T_MODIFIER "d < entry stack top %d\n",
(pc - codePtr->codeStart),
CURR_DEPTH, 0);
Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top");
}
@@ -9135,7 +9169,7 @@ GetSrcInfoForPc(
int bestCmdIdx = -1;
/* The pc must point within the bytecode */
assert (pcOffset < codePtr->numCodeBytes);
assert ((pcOffset >= 0) && (pcOffset < codePtr->numCodeBytes));
/*
* Decode the code and source offset and length for each command. The
@@ -9623,7 +9657,7 @@ EvalStatsCmd(
Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%" TCL_Z_MODIFIER "u\n",
statsPtr->numLiteralsCreated);
Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of current objects)\n",
Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%" TCL_SIZE_MODIFIER "d (%0.1f%% of current objects)\n",
globalTablePtr->numEntries,
Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed));
Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of current literals)\n",
@@ -9715,7 +9749,7 @@ EvalStatsCmd(
for (i = 0; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->literalCount[i];
Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_Z_MODIFIER "u\t\t%8.0f%%\n",
Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numLiteralsCreated));
}
@@ -9748,7 +9782,7 @@ EvalStatsCmd(
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->srcCount[i];
Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_Z_MODIFIER "u\t\t%8.0f%%\n",
Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numCompilations));
}
@@ -9772,7 +9806,7 @@ EvalStatsCmd(
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->byteCodeCount[i];
Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_Z_MODIFIER "u\t\t%8.0f%%\n",
Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numCompilations));
}
+28 -23
View File
@@ -205,7 +205,7 @@ static int FlushChannel(Tcl_Interp *interp, Channel *chanPtr,
int calledFromAsyncFlush);
static int TclGetsObjBinary(Tcl_Channel chan, Tcl_Obj *objPtr);
static Tcl_Encoding GetBinaryEncoding(void);
static Tcl_ExitProc FreeBinaryEncoding;
static void FreeBinaryEncoding(void);
static Tcl_HashTable * GetChannelTable(Tcl_Interp *interp);
static int GetInput(Channel *chanPtr);
static void PeekAhead(Channel *chanPtr, char **dstEndPtr,
@@ -659,7 +659,7 @@ TclFinalizeIOSubsystem(void)
statePtr->refCount--;
}
if (statePtr->refCount + 1 <= 1) {
if (statePtr->refCount <= 0) {
/*
* Close it only if the refcount indicates that the channel is
* not referenced from any interpreter. If it is, that
@@ -695,6 +695,7 @@ TclFinalizeIOSubsystem(void)
}
}
FreeBinaryEncoding();
TclpFinalizeSockets();
TclpFinalizePipes();
}
@@ -1077,7 +1078,7 @@ CheckForStdChannelsBeingClosed(
if (tsdPtr->stdinInitialized == 1
&& tsdPtr->stdinChannel != NULL
&& statePtr == ((Channel *)tsdPtr->stdinChannel)->state) {
if (statePtr->refCount + 1 < 3) {
if (statePtr->refCount < 2) {
statePtr->refCount = 0;
tsdPtr->stdinChannel = NULL;
return;
@@ -1085,7 +1086,7 @@ CheckForStdChannelsBeingClosed(
} else if (tsdPtr->stdoutInitialized == 1
&& tsdPtr->stdoutChannel != NULL
&& statePtr == ((Channel *)tsdPtr->stdoutChannel)->state) {
if (statePtr->refCount + 1 < 3) {
if (statePtr->refCount < 2) {
statePtr->refCount = 0;
tsdPtr->stdoutChannel = NULL;
return;
@@ -1093,7 +1094,7 @@ CheckForStdChannelsBeingClosed(
} else if (tsdPtr->stderrInitialized == 1
&& tsdPtr->stderrChannel != NULL
&& statePtr == ((Channel *)tsdPtr->stderrChannel)->state) {
if (statePtr->refCount + 1 < 3) {
if (statePtr->refCount < 2) {
statePtr->refCount = 0;
tsdPtr->stderrChannel = NULL;
return;
@@ -1255,7 +1256,7 @@ Tcl_UnregisterChannel(
* If the refCount reached zero, close the actual channel.
*/
if (statePtr->refCount + 1 <= 1) {
if (statePtr->refCount <= 0) {
Tcl_Preserve(statePtr);
if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
/*
@@ -1663,6 +1664,10 @@ Tcl_CreateChannel(
}
statePtr->channelName = tmp;
statePtr->flags = mask;
/* uncomment this to make default encoding error handling strict */
/*
statePtr->flags |= CHANNEL_ENCODING_STRICT;
*/
statePtr->maxPerms = mask; /* Save max privileges for close callback */
/*
@@ -2003,7 +2008,7 @@ static void
ChannelFree(
Channel *chanPtr)
{
if (!chanPtr->refCount) {
if (chanPtr->refCount == 0) {
Tcl_Free(chanPtr);
return;
}
@@ -2178,7 +2183,7 @@ Tcl_UnstackChannel(
* necessary.
*/
if (statePtr->refCount + 1 <= 1) {
if (statePtr->refCount <= 0) {
if (Tcl_CloseEx(interp, chan, 0) != TCL_OK) {
/*
* TIP #219, Tcl Channel Reflection API.
@@ -2546,7 +2551,7 @@ static int
IsShared(
ChannelBuffer *bufPtr)
{
return bufPtr->refCount + 1 > 2;
return bufPtr->refCount > 1;
}
/*
@@ -2995,7 +3000,7 @@ FlushChannel(
* current output buffer.
*/
if (GotFlag(statePtr, CHANNEL_CLOSED) && (statePtr->refCount + 1 <= 1) &&
if (GotFlag(statePtr, CHANNEL_CLOSED) && (statePtr->refCount <= 0) &&
(statePtr->outQueueHead == NULL) &&
((statePtr->curOutPtr == NULL) ||
IsBufferEmpty(statePtr->curOutPtr))) {
@@ -3456,7 +3461,7 @@ TclClose(
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
if (statePtr->refCount + 1 > 1) {
if (statePtr->refCount > 0) {
Tcl_Panic("called Tcl_Close on channel with refCount > 0");
}
@@ -4191,7 +4196,6 @@ Tcl_WriteChars(
}
objPtr = Tcl_NewStringObj(src, len);
Tcl_IncrRefCount(objPtr);
src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len);
if (src == NULL) {
Tcl_SetErrno(EILSEQ);
@@ -4365,8 +4369,8 @@ Write(
while (srcLen + saved + endEncoding > 0 && !encodingError) {
ChannelBuffer *bufPtr;
char *dst;
int result, srcRead, dstLen, dstWrote;
Tcl_Size srcLimit = srcLen;
int result, srcRead, dstLen, dstWrote;
Tcl_Size srcLimit = srcLen;
if (nextNewLine) {
srcLimit = nextNewLine - src;
@@ -4556,7 +4560,7 @@ Tcl_Gets(
TclNewObj(objPtr);
charsStored = Tcl_GetsObj(chan, objPtr);
if (charsStored + 1 > 1) {
if (charsStored > 0) {
TclDStringAppendObj(lineRead, objPtr);
}
TclDecrRefCount(objPtr);
@@ -5290,8 +5294,7 @@ TclGetsObjBinary(
*/
static void
FreeBinaryEncoding(
TCL_UNUSED(void *))
FreeBinaryEncoding(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -5308,7 +5311,6 @@ GetBinaryEncoding(void)
if (tsdPtr->binaryEncoding == NULL) {
tsdPtr->binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1");
Tcl_CreateThreadExitHandler(FreeBinaryEncoding, NULL);
}
if (tsdPtr->binaryEncoding == NULL) {
Tcl_Panic("binary encoding is not available");
@@ -5933,6 +5935,7 @@ DoReadChars(
ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR);
/* TODO: UpdateInterest not needed here? */
UpdateInterest(chanPtr);
Tcl_SetErrno(EILSEQ);
return -1;
}
@@ -5999,7 +6002,7 @@ DoReadChars(
}
ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF);
statePtr->inputEncodingFlags &= ~TCL_ENCODING_END;
for (copied = 0; toRead > 0 || toRead == TCL_INDEX_NONE; ) {
for (copied = 0; toRead != 0 ; ) {
int copiedNow = -1;
if (statePtr->inQueueHead != NULL) {
if (binaryMode) {
@@ -6033,6 +6036,7 @@ DoReadChars(
if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
&& !GotFlag(statePtr, CHANNEL_STICKY_EOF)
&& (!GotFlag(statePtr, CHANNEL_NONBLOCKING))) {
copied = -1;
goto finish;
}
}
@@ -6112,6 +6116,9 @@ finish:
copied = -1;
}
TclChannelRelease((Tcl_Channel)chanPtr);
if (copied == TCL_INDEX_NONE) {
ResetFlag(statePtr, CHANNEL_ENCODING_ERROR|CHANNEL_EOF);
}
return copied;
}
@@ -8207,9 +8214,7 @@ Tcl_SetChannelOption(
return TCL_OK;
} else if (HaveOpt(2, "-eofchar")) {
if (!newValue[0] || (!(newValue[0] & 0x80) && (!newValue[1]
#ifndef TCL_NO_DEPRECATED
|| !strcmp(newValue+1, " {}")
#endif
))) {
if (GotFlag(statePtr, TCL_READABLE)) {
statePtr->inEofChar = newValue[0];
@@ -8218,7 +8223,7 @@ Tcl_SetChannelOption(
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -eofchar: must be non-NUL ASCII"
" character", -1));
" character", TCL_INDEX_NONE));
}
Tcl_Free((void *)argv);
return TCL_ERROR;
@@ -10643,7 +10648,7 @@ Tcl_IsChannelShared(
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of real channel structure. */
return ((statePtr->refCount + 1 > 2) ? 1 : 0);
return ((statePtr->refCount > 1) ? 1 : 0);
}
/*
-4
View File
@@ -158,10 +158,6 @@ typedef struct ChannelState {
* of line sequences in output? */
int inEofChar; /* If nonzero, use this as a signal of EOF on
* input. */
#if TCL_MAJOR_VERSION < 9
int outEofChar; /* If nonzero, append this to the channel when
* it is closed if it is open for writing. For Tcl 8.x only */
#endif
int unreportedError; /* Non-zero if an error report was deferred
* because it happened in the background. The
* value is the POSIX error code. */
+17 -5
View File
@@ -283,7 +283,7 @@ Tcl_GetsObjCmd(
Tcl_Channel chan; /* The channel to read from. */
Tcl_Size lineLen; /* Length of line just read. */
int mode; /* Mode in which channel is opened. */
Tcl_Obj *linePtr, *chanObjPtr;
Tcl_Obj *linePtr, *chanObjPtr, *resultDictPtr, *returnOptsPtr;
int code = TCL_OK;
if ((objc != 2) && (objc != 3)) {
@@ -306,7 +306,6 @@ Tcl_GetsObjCmd(
lineLen = Tcl_GetsObj(chan, linePtr);
if (lineLen == TCL_IO_FAILURE) {
if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
Tcl_DecrRefCount(linePtr);
/*
* TIP #219.
@@ -320,7 +319,14 @@ Tcl_GetsObjCmd(
"error reading \"%s\": %s",
TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
resultDictPtr = Tcl_NewDictObj();
Tcl_DictObjPut(NULL, resultDictPtr, Tcl_NewStringObj("read", -1)
, linePtr);
returnOptsPtr = Tcl_NewDictObj();
Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-result", -1)
, resultDictPtr);
code = TCL_ERROR;
Tcl_SetReturnOptions(interp, returnOptsPtr);
goto done;
}
lineLen = TCL_IO_FAILURE;
@@ -371,7 +377,7 @@ Tcl_ReadObjCmd(
Tcl_WideInt toRead; /* How many bytes to read? */
Tcl_Size charactersRead; /* How many characters were read? */
int mode; /* Mode in which channel is opened. */
Tcl_Obj *resultPtr, *chanObjPtr;
Tcl_Obj *resultPtr, *resultDictPtr, *returnOptsPtr, *chanObjPtr;
if ((objc != 2) && (objc != 3)) {
Interp *iPtr;
@@ -433,7 +439,6 @@ Tcl_ReadObjCmd(
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
@@ -446,7 +451,14 @@ Tcl_ReadObjCmd(
"error reading \"%s\": %s",
TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
resultDictPtr = Tcl_NewDictObj();
Tcl_DictObjPut(NULL, resultDictPtr, Tcl_NewStringObj("read", -1)
, resultPtr);
returnOptsPtr = Tcl_NewDictObj();
Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-result", -1)
, resultDictPtr);
TclChannelRelease(chan);
Tcl_SetReturnOptions(interp, returnOptsPtr);
return TCL_ERROR;
}
@@ -1788,9 +1800,9 @@ ChanPendingObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
int mode;
static const char *const options[] = {"input", "output", NULL};
enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT} index;
int mode;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "mode channelId");
+11 -2
View File
@@ -379,7 +379,11 @@ ExecuteCallback(
unsigned char *resBuf;
Tcl_InterpState state = NULL;
int res = TCL_OK;
Tcl_Obj *command = TclListObjCopy(NULL, dataPtr->command);
Tcl_Obj *command = TclDuplicatePureObj(
interp, dataPtr->command, &tclListType.objType);
if (!command) {
return TCL_ERROR;
}
Tcl_Interp *eval = dataPtr->interp;
Tcl_Preserve(eval);
@@ -397,7 +401,12 @@ ExecuteCallback(
}
Tcl_IncrRefCount(command);
Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, -1));
res = Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, -1));
if (res != TCL_OK) {
Tcl_DecrRefCount(command);
Tcl_Release(eval);
return res;
}
/*
* Use a byte-array to prevent the misinterpretation of binary data coming
+11 -4
View File
@@ -580,6 +580,9 @@ TclChanCreateObjCmd(
rcId = NextHandle();
rcPtr = NewReflectedChannel(interp, cmdObj, mode, rcId);
if (!rcPtr) {
return TCL_ERROR;
}
/*
* Invoke 'initialize' and validate that the handler is present and ok.
@@ -2258,8 +2261,10 @@ NewReflectedChannel(
rcPtr->mode = mode;
rcPtr->interest = 0; /* Initially no interest registered */
/* ASSERT: cmdpfxObj is a Tcl List */
rcPtr->cmd = TclListObjCopy(NULL, cmdpfxObj);
rcPtr->cmd = TclDuplicatePureObj(interp, cmdpfxObj, &tclListType.objType);
if (!rcPtr->cmd) {
return NULL;
}
Tcl_IncrRefCount(rcPtr->cmd);
rcPtr->methods = Tcl_NewListObj(METH_WRITE + 1, NULL);
while (mn <= (int)METH_WRITE) {
@@ -2396,8 +2401,10 @@ InvokeTclMethod(
* before the channel id.
*/
cmd = TclListObjCopy(NULL, rcPtr->cmd);
cmd = TclDuplicatePureObj(NULL, rcPtr->cmd, &tclListType.objType);
if (!cmd) {
return TCL_ERROR;
}
Tcl_ListObjIndex(NULL, rcPtr->methods, method, &methObj);
Tcl_ListObjAppendElement(NULL, cmd, methObj);
Tcl_ListObjAppendElement(NULL, cmd, rcPtr->name);
+5
View File
@@ -1734,6 +1734,11 @@ Tcl_FSEvalFileEx(
Tcl_CloseEx(interp,chan,0);
return result;
}
if (Tcl_SetChannelOption(interp, chan, "-profile", "strict")
!= TCL_OK) {
Tcl_CloseEx(interp,chan,0);
return result;
}
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
+1 -1
View File
@@ -537,7 +537,7 @@ declare 214 {
void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding)
}
declare 215 {
void *TclStackAlloc(Tcl_Interp *interp, Tcl_Size numBytes)
void *TclStackAlloc(Tcl_Interp *interp, TCL_HASH_TYPE numBytes)
}
declare 216 {
void TclStackFree(Tcl_Interp *interp, void *freePtr)
+99 -83
View File
@@ -104,12 +104,6 @@
# endif
#endif
/*
* Maximum *signed* value that can be stored in a Tcl_Size type. This is
* primarily used for checking overflows in dynamically allocating memory.
*/
#define TCL_SIZE_SMAX ((((Tcl_Size) 1) << ((8*(Tcl_Size)sizeof(Tcl_Size)) - 1)) - 1)
/*
* Macros used to cast between pointers and integers (e.g. when storing an int
* in ClientData), on 64-bit architectures they avoid gcc warning about "cast
@@ -231,9 +225,7 @@ typedef struct NamespacePathEntry NamespacePathEntry;
typedef struct TclVarHashTable {
Tcl_HashTable table;
struct Namespace *nsPtr;
#if TCL_MAJOR_VERSION > 8
struct Var *arrayPtr;
#endif /* TCL_MAJOR_VERSION > 8 */
} TclVarHashTable;
/*
@@ -283,11 +275,7 @@ typedef struct Namespace {
* strings; values have type (Namespace *). If
* NULL, there are no children. */
#endif
#if TCL_MAJOR_VERSION > 8
size_t nsId; /* Unique id for the namespace. */
#else
unsigned long nsId;
#endif
Tcl_Interp *interp; /* The interpreter containing this
* namespace. */
int flags; /* OR-ed combination of the namespace status
@@ -968,9 +956,6 @@ typedef struct CompiledLocal {
* Among others used to speed up var lookups. */
Tcl_Size frameIndex; /* Index in the array of compiler-assigned
* variables in the procedure call frame. */
#if TCL_MAJOR_VERSION < 9
int flags;
#endif
Tcl_Obj *defValuePtr; /* Pointer to the default value of an
* argument, if any. NULL if not an argument
* or, if an argument, no default value. */
@@ -981,12 +966,10 @@ typedef struct CompiledLocal {
* is marked by a unique tag during
* compilation, and that same tag is used to
* find the variable at runtime. */
#if TCL_MAJOR_VERSION > 8
int flags; /* Flag bits for the local variable. Same as
* the flags for the Var structure above,
* although only VAR_ARGUMENT, VAR_TEMPORARY,
* and VAR_RESOLVED make sense. */
#endif
char name[TCLFLEXARRAY]; /* Name of the local variable starts here. If
* the name is NULL, this will just be '\0'.
* The actual size of this field will be large
@@ -1044,11 +1027,7 @@ typedef void (ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj);
typedef struct Trace {
Tcl_Size level; /* Only trace commands at nesting level less
* than or equal to this. */
#if TCL_MAJOR_VERSION > 8
Tcl_CmdObjTraceProc2 *proc; /* Procedure to call to trace command. */
#else
Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */
#endif
void *clientData; /* Arbitrary value to pass to proc. */
struct Trace *nextPtr; /* Next in list of traces for this interp. */
int flags; /* Flags governing the trace - see
@@ -1887,18 +1866,7 @@ typedef struct Interp {
void *interpInfo; /* Information used by tclInterp.c to keep
* track of parent/child interps on a
* per-interp basis. */
#if TCL_MAJOR_VERSION > 8
void (*optimizer)(void *envPtr);
#else
union {
void (*optimizer)(void *envPtr);
Tcl_HashTable unused2; /* No longer used (was mathFuncTable). The
* unused space in interp was repurposed for
* pluggable bytecode optimizers. The core
* contains one optimizer, which can be
* selectively overridden by extensions. */
} extra;
#endif
/*
* Information related to procedures and variables. See tclProc.c and
* tclVar.c for usage.
@@ -1927,12 +1895,6 @@ typedef struct Interp {
Namespace *lookupNsPtr; /* Namespace to use ONLY on the next
* TCL_EVAL_INVOKE call to Tcl_EvalObjv. */
#if TCL_MAJOR_VERSION < 9
char *appendResultDontUse;
int appendAvlDontUse;
int appendUsedDontUse;
#endif
/*
* Information about packages. Used only in tclPkg.c.
*/
@@ -1955,9 +1917,6 @@ typedef struct Interp {
* Normally zero, but may be set before
* calling Tcl_Eval. See below for valid
* values. */
#if TCL_MAJOR_VERSION < 9
int unused1; /* No longer used (was termOffset) */
#endif
LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl
* objects holding literals of scripts
* compiled by the interpreter. Indexed by the
@@ -1995,9 +1954,6 @@ typedef struct Interp {
* string. Returned by Tcl_ObjSetVar2 when
* variable traces change a variable in a
* gross way. */
#if TCL_MAJOR_VERSION < 9
char resultSpaceDontUse[TCL_DSTRING_STATIC_SIZE+1];
#endif
Tcl_Obj *objResultPtr; /* If the last command returned an object
* result, this points to it. Should not be
* accessed directly; see comment above. */
@@ -2504,7 +2460,7 @@ typedef struct ListStore {
typedef struct ListSpan {
Tcl_Size spanStart; /* Starting index of the span */
Tcl_Size spanLength; /* Number of elements in the span */
Tcl_Size refCount; /* Count of references to this span record */
size_t refCount; /* Count of references to this span record */
} ListSpan;
#ifndef LIST_SPAN_THRESHOLD /* May be set on build line */
#define LIST_SPAN_THRESHOLD 101
@@ -2584,6 +2540,7 @@ typedef struct ListRep {
(((objv_) = &ListObjStorePtr(listObj_)->slots[ListObjStart(listObj_)]), \
(ListObjLength(listObj_, (objc_))))
/*
* Returns 1/0 whether the internal representation (not the Tcl_Obj itself)
* is shared. Note by intent this only checks for sharing of ListStore,
@@ -2653,20 +2610,11 @@ typedef struct ListRep {
* WARNING: these macros eval their args more than once.
*/
#if TCL_MAJOR_VERSION > 8
#define TclGetBooleanFromObj(interp, objPtr, intPtr) \
(((objPtr)->typePtr == &tclIntType.objType \
|| (objPtr)->typePtr == &tclBooleanType.objType) \
? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \
: Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr)))
#else
#define TclGetBooleanFromObj(interp, objPtr, intPtr) \
(((objPtr)->typePtr == &tclIntType.objType) \
? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \
: ((objPtr)->typePtr == &tclBooleanType.objType) \
? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
: Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr)))
#endif
#ifdef TCL_WIDE_INT_IS_LONG
#define TclGetLongFromObj(interp, objPtr, longPtr) \
@@ -2871,6 +2819,75 @@ typedef struct ProcessGlobalValue {
(flags_) |= profile_; \
} while (0)
/*
*----------------------------------------------------------------------
* Common functions for calculating overallocation. Trivial but allows for
* experimenting with growth factors without having to change code in
* multiple places. See TclAttemptAllocElemsEx and similar for usage
* examples. Best to use those functions. Direct use of TclUpsizeAlloc /
* TclResizeAlloc is needed in special cases such as when total size of
* memory block is limited to less than TCL_SIZE_MAX.
*
*----------------------------------------------------------------------
*/
static inline Tcl_Size
TclUpsizeAlloc(TCL_UNUSED(Tcl_Size) /* oldSize. For future experiments with
* some growth algorithms that use this
* information. */,
Tcl_Size needed,
Tcl_Size limit)
{
/* assert (oldCapacity < needed <= limit) */
if (needed < (limit - needed/2)) {
return needed + needed / 2;
}
else {
return limit;
}
}
static inline Tcl_Size TclUpsizeRetry(Tcl_Size needed, Tcl_Size lastAttempt) {
/* assert (needed < lastAttempt) */
if (needed < lastAttempt - 1) {
/* (needed+lastAttempt)/2 but that formula may overflow Tcl_Size */
return needed + (lastAttempt - needed) / 2;
} else {
return needed;
}
}
MODULE_SCOPE void *TclAllocElemsEx(Tcl_Size elemCount, Tcl_Size elemSize,
Tcl_Size leadSize, Tcl_Size *capacityPtr);
MODULE_SCOPE void *TclReallocElemsEx(void *oldPtr, Tcl_Size elemCount,
Tcl_Size elemSize, Tcl_Size leadSize,
Tcl_Size *capacityPtr);
MODULE_SCOPE void *TclAttemptReallocElemsEx(void *oldPtr,
Tcl_Size elemCount, Tcl_Size elemSize,
Tcl_Size leadSize, Tcl_Size *capacityPtr);
/* Alloc elemCount elements of size elemSize with leadSize header
* returning actual capacity (in elements) in *capacityPtr. */
static inline void *TclAttemptAllocElemsEx(Tcl_Size elemCount, Tcl_Size elemSize,
Tcl_Size leadSize, Tcl_Size *capacityPtr) {
return TclAttemptReallocElemsEx(
NULL, elemCount, elemSize, leadSize, capacityPtr);
}
/* Alloc numByte bytes, returning actual capacity in *capacityPtr. */
static inline void *TclAllocEx(Tcl_Size numBytes, Tcl_Size *capacityPtr) {
return TclAllocElemsEx(numBytes, 1, 0, capacityPtr);
}
/* Alloc numByte bytes, returning actual capacity in *capacityPtr. */
static inline void *
TclAttemptAllocEx(Tcl_Size numBytes, Tcl_Size *capacityPtr)
{
return TclAttemptAllocElemsEx(numBytes, 1, 0, capacityPtr);
}
/* Realloc numByte bytes, returning actual capacity in *capacityPtr. */
static inline void *TclReallocEx(void *oldPtr, Tcl_Size numBytes, Tcl_Size *capacityPtr) {
return TclReallocElemsEx(oldPtr, numBytes, 1, 0, capacityPtr);
}
/* Realloc numByte bytes, returning actual capacity in *capacityPtr. */
static inline void *TclAttemptReallocEx(void *oldPtr, Tcl_Size numBytes, Tcl_Size *capacityPtr) {
return TclAttemptReallocElemsEx(oldPtr, numBytes, 1, 0, capacityPtr);
}
/*
*----------------------------------------------------------------
* Variables shared among Tcl modules but not used by the outside world.
@@ -3058,7 +3075,6 @@ struct Tcl_LoadHandle_ {
*----------------------------------------------------------------
*/
#if TCL_MAJOR_VERSION > 8
MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr,
const unsigned char *bytes, Tcl_Size len);
MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr,
@@ -3115,6 +3131,9 @@ MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp,
Tcl_Namespace *ensembleNamespacePtr, int flags);
MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr);
MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr);
MODULE_SCOPE Tcl_Size TclDictGetSize(Tcl_Obj *dictPtr);
MODULE_SCOPE Tcl_Obj* TclDuplicatePureObj(Tcl_Interp *interp,
Tcl_Obj * objPtr, const Tcl_ObjType *typPtr);
MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp,
const char *dict, Tcl_Size dictLength,
const char **elementPtr, const char **nextPtr,
@@ -3241,10 +3260,10 @@ MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp,
Tcl_Obj *listPtr, Tcl_Obj *argPtr);
MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Size indexCount, Tcl_Obj *const indexArray[]);
MODULE_SCOPE Tcl_Obj * TclListObjGetElement(Tcl_Obj *listObj, Tcl_Size index);
/* TIP #280 */
MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, Tcl_Size line, int n,
int *lines, Tcl_Obj *const *elems);
MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr);
MODULE_SCOPE int TclListObjAppendElements(Tcl_Interp *interp,
Tcl_Obj *toObj, Tcl_Size elemCount,
Tcl_Obj *const elemObjv[]);
@@ -3267,6 +3286,7 @@ MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options);
MODULE_SCOPE int TclNokia770Doubles(void);
MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr);
MODULE_SCOPE int TclNamespaceDeleted(Namespace *nsPtr);
MODULE_SCOPE Tcl_Obj * TclObjGetScalar(Tcl_Obj *objPtr);
MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, const char *operation,
const char *reason, int index);
@@ -3287,6 +3307,7 @@ MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string,
MODULE_SCOPE Tcl_Size TclParseAllWhiteSpace(const char *src, Tcl_Size numBytes);
MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp,
int code, int level, Tcl_Obj *returnOpts);
MODULE_SCOPE void TclUndoRefCount(Tcl_Obj *objPtr);
MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
MODULE_SCOPE Tcl_Obj * TclpTempFileName(void);
MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp,
@@ -3318,7 +3339,7 @@ MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp,
const char **errorMsgPtr);
MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr,
Tcl_ThreadCreateProc *proc, void *clientData,
size_t stackSize, int flags);
TCL_HASH_TYPE stackSize, int flags);
MODULE_SCOPE Tcl_Size TclpFindVariable(const char *name, Tcl_Size *lengthPtr);
MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr,
TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr);
@@ -3387,7 +3408,7 @@ MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp,
Tcl_Obj *const *objv, Tcl_Size objc, Tcl_Size subIdx,
Tcl_Obj *bad, Tcl_Obj *fix);
MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr,
Tcl_Size numBytes);
TCL_HASH_TYPE numBytes);
typedef int (*memCmpFn_t)(const void*, const void*, size_t);
MODULE_SCOPE int TclStringCmp(Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr,
int checkEq, int nocase, Tcl_Size reqlength);
@@ -3422,15 +3443,6 @@ MODULE_SCOPE void TclRegisterCommandTypeName(
MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct);
MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct);
MODULE_SCOPE int TclUtfCount(int ch);
#if TCL_UTF_MAX > 3
# define TclUtfToUCS4 Tcl_UtfToUniChar
# define TclUniCharToUCS4(src, ptr) (*ptr = *(src),1)
# define TclUCS4Prev(src, ptr) (((src) > (ptr)) ? ((src) - 1) : (src))
#else
MODULE_SCOPE int TclUtfToUCS4(const char *, int *);
MODULE_SCOPE int TclUniCharToUCS4(const Tcl_UniChar *, int *);
MODULE_SCOPE const Tcl_UniChar *TclUCS4Prev(const Tcl_UniChar *, const Tcl_UniChar *);
#endif
MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(void *clientData);
MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr);
MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr,
@@ -4186,7 +4198,6 @@ MODULE_SCOPE int TclIndexInvalidError(Tcl_Interp *interp,
*/
MODULE_SCOPE int TclCommandWordLimitError(Tcl_Interp *interp, Tcl_Size count);
#endif /* TCL_MAJOR_VERSION > 8 */
/* Constants used in index value encoding routines. */
#define TCL_INDEX_END ((Tcl_Size)-2)
@@ -4469,15 +4480,12 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
# define TclDecrRefCount(objPtr) \
Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)
# define TclNewListObjDirect(objc, objv) \
TclDbNewListObjDirect(objc, objv, __FILE__, __LINE__)
#undef USE_THREAD_ALLOC
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to set a Tcl_Obj's string representation to a
* Macros used by the Tcl core to set a Tcl_Obj's string representation to a
* copy of the "len" bytes starting at "bytePtr". The value of "len" must
* not be negative. When "len" is 0, then it is acceptable to pass
* "bytePtr" = NULL. When "len" > 0, "bytePtr" must not be NULL, and it
@@ -4490,17 +4498,22 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
* Because "len" is referenced multiple times, take care that it is an
* expression with the same value each use.
*
* The ANSI C "prototype" for this macro is:
* The ANSI C "prototypes" for these macros are:
*
* MODULE_SCOPE void TclInitEmptyStringRep(Tcl_Obj *objPtr);
* MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len);
* MODULE_SCOPE void TclAttemptInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len);
*
*----------------------------------------------------------------
*/
#define TclInitEmptyStringRep(objPtr) \
((objPtr)->length = (((objPtr)->bytes = &tclEmptyString), 0))
#define TclInitStringRep(objPtr, bytePtr, len) \
if ((len) == 0) { \
(objPtr)->bytes = &tclEmptyString; \
(objPtr)->length = 0; \
TclInitEmptyStringRep(objPtr); \
} else { \
(objPtr)->bytes = (char *)Tcl_Alloc((len) + 1U); \
memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)); \
@@ -4508,6 +4521,16 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
(objPtr)->length = (len); \
}
#define TclAttemptInitStringRep(objPtr, bytePtr, len) \
((((len) == 0) ? ( \
TclInitEmptyStringRep(objPtr) \
) : ( \
(objPtr)->bytes = (char *)Tcl_AttemptAlloc((len) + 1U), \
(objPtr)->length = ((objPtr)->bytes) ? \
(memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)), \
(objPtr)->bytes[len] = '\0', (len)) : (-1) \
)), (objPtr)->bytes)
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to get the string representation's byte array
@@ -4687,17 +4710,10 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[];
*----------------------------------------------------------------
*/
#if TCL_UTF_MAX > 3
#define TclUtfToUniChar(str, chPtr) \
(((UCHAR(*(str))) < 0x80) ? \
((*(chPtr) = UCHAR(*(str))), 1) \
: Tcl_UtfToUniChar(str, chPtr))
#else
#define TclUtfToUniChar(str, chPtr) \
(((UCHAR(*(str))) < 0x80) ? \
((*(chPtr) = UCHAR(*(str))), 1) \
: Tcl_UtfToChar16(str, chPtr))
#endif
/*
*----------------------------------------------------------------
@@ -4760,7 +4776,7 @@ MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3)
#if defined(WORDS_BIGENDIAN)
# define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar))
#endif /* WORDS_BIGENDIAN */
+3 -11
View File
@@ -451,7 +451,8 @@ EXTERN Tcl_Obj * TclGetObjNameOfExecutable(void);
EXTERN void TclSetObjNameOfExecutable(Tcl_Obj *name,
Tcl_Encoding encoding);
/* 215 */
EXTERN void * TclStackAlloc(Tcl_Interp *interp, Tcl_Size numBytes);
EXTERN void * TclStackAlloc(Tcl_Interp *interp,
TCL_HASH_TYPE numBytes);
/* 216 */
EXTERN void TclStackFree(Tcl_Interp *interp, void *freePtr);
/* 217 */
@@ -803,7 +804,7 @@ typedef struct TclIntStubs {
void (*tclpFindExecutable) (const char *argv0); /* 212 */
Tcl_Obj * (*tclGetObjNameOfExecutable) (void); /* 213 */
void (*tclSetObjNameOfExecutable) (Tcl_Obj *name, Tcl_Encoding encoding); /* 214 */
void * (*tclStackAlloc) (Tcl_Interp *interp, Tcl_Size numBytes); /* 215 */
void * (*tclStackAlloc) (Tcl_Interp *interp, TCL_HASH_TYPE numBytes); /* 215 */
void (*tclStackFree) (Tcl_Interp *interp, void *freePtr); /* 216 */
int (*tclPushStackFrame) (Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame); /* 217 */
void (*tclPopStackFrame) (Tcl_Interp *interp); /* 218 */
@@ -1280,15 +1281,6 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclStaticLibrary)
#endif /* defined(USE_TCL_STUBS) */
#if (TCL_MAJOR_VERSION < 9) && defined(USE_TCL_STUBS)
#undef TclpGetClicks
#define TclpGetClicks() \
((unsigned long)tclIntStubsPtr->tclpGetClicks())
#undef TclpGetSeconds
#define TclpGetSeconds() \
((unsigned long)tclIntStubsPtr->tclpGetSeconds())
#endif
#undef TclObjInterpProc
#define TclObjInterpProc TclGetObjInterpProc()
#define TclObjInterpProc2 TclGetObjInterpProc2()
-543
View File
@@ -30,535 +30,6 @@
* in the generic/tclInt.decls script.
*/
#if TCL_MAJOR_VERSION < 9
#ifdef __cplusplus
extern "C" {
#endif
/*
* Exported function declarations:
*/
#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
/* 0 */
EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
Tcl_Channel chan);
/* 1 */
EXTERN int TclpCloseFile(TclFile file);
/* 2 */
EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
TclFile writeFile, TclFile errorFile,
int numPids, Tcl_Pid *pidPtr);
/* 3 */
EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe);
/* 4 */
EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc,
const char **argv, TclFile inputFile,
TclFile outputFile, TclFile errorFile,
Tcl_Pid *pidPtr);
/* 5 */
EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout);
/* 6 */
EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction);
/* 7 */
EXTERN TclFile TclpOpenFile(const char *fname, int mode);
/* 8 */
EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout);
/* 9 */
EXTERN TclFile TclpCreateTempFile(const char *contents);
/* 10 */
EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir);
/* 11 */
EXTERN struct tm * TclpLocaltime_unix(const time_t *clock);
/* 12 */
EXTERN struct tm * TclpGmtime_unix(const time_t *clock);
/* 13 */
EXTERN char * TclpInetNtoa(struct in_addr addr);
/* 14 */
EXTERN int TclUnixCopyFile(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr,
int dontCopyAtts);
/* 15 */
EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp,
int objIndex, Tcl_Obj *fileName,
Tcl_Obj **attributePtrPtr);
/* 16 */
EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp,
int objIndex, Tcl_Obj *fileName,
Tcl_Obj *attributePtr);
/* 17 */
EXTERN int TclMacOSXCopyFileAttributes(const char *src,
const char *dst,
const Tcl_StatBuf *statBufPtr);
/* 18 */
EXTERN int TclMacOSXMatchType(Tcl_Interp *interp,
const char *pathName, const char *fileName,
Tcl_StatBuf *statBufPtr,
Tcl_GlobTypeData *types);
/* 19 */
EXTERN void TclMacOSXNotifierAddRunLoopMode(
const void *runLoopMode);
/* Slot 20 is reserved */
/* Slot 21 is reserved */
/* 22 */
EXTERN TclFile TclpCreateTempFile_(const char *contents);
/* Slot 23 is reserved */
/* Slot 24 is reserved */
/* Slot 25 is reserved */
/* Slot 26 is reserved */
/* Slot 27 is reserved */
/* Slot 28 is reserved */
/* 29 */
EXTERN int TclWinCPUID(int index, int *regs);
/* 30 */
EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
Tcl_Obj *resultingNameObj);
#endif /* UNIX */
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
/* 0 */
EXTERN void TclWinConvertError(DWORD errCode);
/* 1 */
EXTERN void TclWinConvertWSAError(DWORD errCode);
/* 2 */
EXTERN struct servent * TclWinGetServByName(const char *nm,
const char *proto);
/* 3 */
EXTERN int TclWinGetSockOpt(SOCKET s, int level, int optname,
char *optval, int *optlen);
/* 4 */
EXTERN HINSTANCE TclWinGetTclInstance(void);
/* 5 */
EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout);
/* 6 */
EXTERN unsigned short TclWinNToHS(unsigned short ns);
/* 7 */
EXTERN int TclWinSetSockOpt(SOCKET s, int level, int optname,
const char *optval, int optlen);
/* 8 */
EXTERN int TclpGetPid(Tcl_Pid pid);
/* 9 */
EXTERN int TclWinGetPlatformId(void);
/* 11 */
EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
Tcl_Channel chan);
/* 12 */
EXTERN int TclpCloseFile(TclFile file);
/* 13 */
EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
TclFile writeFile, TclFile errorFile,
int numPids, Tcl_Pid *pidPtr);
/* 14 */
EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe);
/* 15 */
EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc,
const char **argv, TclFile inputFile,
TclFile outputFile, TclFile errorFile,
Tcl_Pid *pidPtr);
/* 16 */
EXTERN int TclpIsAtty(int fd);
/* 17 */
EXTERN int TclUnixCopyFile(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr,
int dontCopyAtts);
/* 18 */
EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction);
/* 19 */
EXTERN TclFile TclpOpenFile(const char *fname, int mode);
/* 20 */
EXTERN void TclWinAddProcess(HANDLE hProcess, DWORD id);
/* 21 */
EXTERN char * TclpInetNtoa(struct in_addr addr);
/* 22 */
EXTERN TclFile TclpCreateTempFile(const char *contents);
/* Slot 23 is reserved */
/* 24 */
EXTERN char * TclWinNoBackslash(char *path);
/* Slot 25 is reserved */
/* 26 */
EXTERN void TclWinSetInterfaces(int wide);
/* 27 */
EXTERN void TclWinFlushDirtyChannels(void);
/* 28 */
EXTERN void TclWinResetInterfaces(void);
/* 29 */
EXTERN int TclWinCPUID(int index, int *regs);
/* 30 */
EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
Tcl_Obj *resultingNameObj);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 0 */
EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
Tcl_Channel chan);
/* 1 */
EXTERN int TclpCloseFile(TclFile file);
/* 2 */
EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
TclFile writeFile, TclFile errorFile,
int numPids, Tcl_Pid *pidPtr);
/* 3 */
EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe);
/* 4 */
EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc,
const char **argv, TclFile inputFile,
TclFile outputFile, TclFile errorFile,
Tcl_Pid *pidPtr);
/* 5 */
EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout);
/* 6 */
EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction);
/* 7 */
EXTERN TclFile TclpOpenFile(const char *fname, int mode);
/* 8 */
EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout);
/* 9 */
EXTERN TclFile TclpCreateTempFile(const char *contents);
/* 10 */
EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir);
/* 11 */
EXTERN struct tm * TclpLocaltime_unix(const time_t *clock);
/* 12 */
EXTERN struct tm * TclpGmtime_unix(const time_t *clock);
/* 13 */
EXTERN char * TclpInetNtoa(struct in_addr addr);
/* 14 */
EXTERN int TclUnixCopyFile(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr,
int dontCopyAtts);
/* 15 */
EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp,
int objIndex, Tcl_Obj *fileName,
Tcl_Obj **attributePtrPtr);
/* 16 */
EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp,
int objIndex, Tcl_Obj *fileName,
Tcl_Obj *attributePtr);
/* 17 */
EXTERN int TclMacOSXCopyFileAttributes(const char *src,
const char *dst,
const Tcl_StatBuf *statBufPtr);
/* 18 */
EXTERN int TclMacOSXMatchType(Tcl_Interp *interp,
const char *pathName, const char *fileName,
Tcl_StatBuf *statBufPtr,
Tcl_GlobTypeData *types);
/* 19 */
EXTERN void TclMacOSXNotifierAddRunLoopMode(
const void *runLoopMode);
/* Slot 20 is reserved */
/* Slot 21 is reserved */
/* 22 */
EXTERN TclFile TclpCreateTempFile_(const char *contents);
/* Slot 23 is reserved */
/* Slot 24 is reserved */
/* Slot 25 is reserved */
/* Slot 26 is reserved */
/* Slot 27 is reserved */
/* Slot 28 is reserved */
/* 29 */
EXTERN int TclWinCPUID(int index, int *regs);
/* 30 */
EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
Tcl_Obj *resultingNameObj);
#endif /* MACOSX */
typedef struct TclIntPlatStubs {
int magic;
void *hooks;
#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */
TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */
TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */
Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */
struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */
struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */
char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */
int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */
int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */
int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */
int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */
int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */
void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */
void (*reserved20)(void);
void (*reserved21)(void);
TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */
void (*reserved23)(void);
void (*reserved24)(void);
void (*reserved25)(void);
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* UNIX */
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
void (*tclWinConvertError) (DWORD errCode); /* 0 */
void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */
struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */
int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char *optval, int *optlen); /* 3 */
HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */
unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */
int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char *optval, int optlen); /* 7 */
int (*tclpGetPid) (Tcl_Pid pid); /* 8 */
int (*tclWinGetPlatformId) (void); /* 9 */
void *(*tclpReaddir) (void *dir); /* 10 */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */
int (*tclpCloseFile) (TclFile file); /* 12 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 14 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */
int (*tclpIsAtty) (int fd); /* 16 */
int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */
TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */
void (*tclWinAddProcess) (HANDLE hProcess, DWORD id); /* 20 */
char * (*tclpInetNtoa) (struct in_addr addr); /* 21 */
TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
void (*reserved23)(void);
char * (*tclWinNoBackslash) (char *path); /* 24 */
void (*reserved25)(void);
void (*tclWinSetInterfaces) (int wide); /* 26 */
void (*tclWinFlushDirtyChannels) (void); /* 27 */
void (*tclWinResetInterfaces) (void); /* 28 */
int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */
TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */
TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */
Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */
struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */
struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */
char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */
int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */
int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */
int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */
int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */
int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */
void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */
void (*reserved20)(void);
void (*reserved21)(void);
TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */
void (*reserved23)(void);
void (*reserved24)(void);
void (*reserved25)(void);
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* MACOSX */
} TclIntPlatStubs;
extern const TclIntPlatStubs *tclIntPlatStubsPtr;
#ifdef __cplusplus
}
#endif
#if defined(USE_TCL_STUBS)
/*
* Inline function declarations:
*/
#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
#define TclGetAndDetachPids \
(tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
#define TclpCloseFile \
(tclIntPlatStubsPtr->tclpCloseFile) /* 1 */
#define TclpCreateCommandChannel \
(tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */
#define TclpCreatePipe \
(tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */
#define TclpCreateProcess \
(tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */
#define TclUnixWaitForFile_ \
(tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */
#define TclpMakeFile \
(tclIntPlatStubsPtr->tclpMakeFile) /* 6 */
#define TclpOpenFile \
(tclIntPlatStubsPtr->tclpOpenFile) /* 7 */
#define TclUnixWaitForFile \
(tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */
#define TclpCreateTempFile \
(tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */
#define TclpReaddir \
(tclIntPlatStubsPtr->tclpReaddir) /* 10 */
#define TclpLocaltime_unix \
(tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */
#define TclpGmtime_unix \
(tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */
#define TclpInetNtoa \
(tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */
#define TclUnixCopyFile \
(tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */
#define TclMacOSXGetFileAttribute \
(tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */
#define TclMacOSXSetFileAttribute \
(tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */
#define TclMacOSXCopyFileAttributes \
(tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */
#define TclMacOSXMatchType \
(tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */
#define TclMacOSXNotifierAddRunLoopMode \
(tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */
/* Slot 20 is reserved */
/* Slot 21 is reserved */
#define TclpCreateTempFile_ \
(tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */
/* Slot 23 is reserved */
/* Slot 24 is reserved */
/* Slot 25 is reserved */
/* Slot 26 is reserved */
/* Slot 27 is reserved */
/* Slot 28 is reserved */
#define TclWinCPUID \
(tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
#define TclUnixOpenTemporaryFile \
(tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */
#endif /* UNIX */
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
#define TclWinConvertError \
(tclIntPlatStubsPtr->tclWinConvertError) /* 0 */
#define TclWinConvertWSAError \
(tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */
#define TclWinGetServByName \
(tclIntPlatStubsPtr->tclWinGetServByName) /* 2 */
#define TclWinGetSockOpt \
(tclIntPlatStubsPtr->tclWinGetSockOpt) /* 3 */
#define TclWinGetTclInstance \
(tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */
#define TclUnixWaitForFile \
(tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */
#define TclWinNToHS \
(tclIntPlatStubsPtr->tclWinNToHS) /* 6 */
#define TclWinSetSockOpt \
(tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */
#define TclpGetPid \
(tclIntPlatStubsPtr->tclpGetPid) /* 8 */
#define TclWinGetPlatformId \
(tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */
#define TclGetAndDetachPids \
(tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */
#define TclpCloseFile \
(tclIntPlatStubsPtr->tclpCloseFile) /* 12 */
#define TclpCreateCommandChannel \
(tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */
#define TclpCreatePipe \
(tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */
#define TclpCreateProcess \
(tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */
#define TclpIsAtty \
(tclIntPlatStubsPtr->tclpIsAtty) /* 16 */
#define TclUnixCopyFile \
(tclIntPlatStubsPtr->tclUnixCopyFile) /* 17 */
#define TclpMakeFile \
(tclIntPlatStubsPtr->tclpMakeFile) /* 18 */
#define TclpOpenFile \
(tclIntPlatStubsPtr->tclpOpenFile) /* 19 */
#define TclWinAddProcess \
(tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */
#define TclpInetNtoa \
(tclIntPlatStubsPtr->tclpInetNtoa) /* 21 */
#define TclpCreateTempFile \
(tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */
/* Slot 23 is reserved */
#define TclWinNoBackslash \
(tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */
/* Slot 25 is reserved */
#define TclWinSetInterfaces \
(tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */
#define TclWinFlushDirtyChannels \
(tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */
#define TclWinResetInterfaces \
(tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */
#define TclWinCPUID \
(tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
#define TclUnixOpenTemporaryFile \
(tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
#define TclGetAndDetachPids \
(tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
#define TclpCloseFile \
(tclIntPlatStubsPtr->tclpCloseFile) /* 1 */
#define TclpCreateCommandChannel \
(tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */
#define TclpCreatePipe \
(tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */
#define TclpCreateProcess \
(tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */
#define TclUnixWaitForFile_ \
(tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */
#define TclpMakeFile \
(tclIntPlatStubsPtr->tclpMakeFile) /* 6 */
#define TclpOpenFile \
(tclIntPlatStubsPtr->tclpOpenFile) /* 7 */
#define TclUnixWaitForFile \
(tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */
#define TclpCreateTempFile \
(tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */
#define TclpReaddir \
(tclIntPlatStubsPtr->tclpReaddir) /* 10 */
#define TclpLocaltime_unix \
(tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */
#define TclpGmtime_unix \
(tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */
#define TclpInetNtoa \
(tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */
#define TclUnixCopyFile \
(tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */
#define TclMacOSXGetFileAttribute \
(tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */
#define TclMacOSXSetFileAttribute \
(tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */
#define TclMacOSXCopyFileAttributes \
(tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */
#define TclMacOSXMatchType \
(tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */
#define TclMacOSXNotifierAddRunLoopMode \
(tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */
/* Slot 20 is reserved */
/* Slot 21 is reserved */
#define TclpCreateTempFile_ \
(tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */
/* Slot 23 is reserved */
/* Slot 24 is reserved */
/* Slot 25 is reserved */
/* Slot 26 is reserved */
/* Slot 27 is reserved */
/* Slot 28 is reserved */
#define TclWinCPUID \
(tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
#define TclUnixOpenTemporaryFile \
(tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */
#endif /* MACOSX */
#endif /* defined(USE_TCL_STUBS) */
#else /* TCL_MAJOR_VERSION > 8 */
/* !BEGIN!: Do not edit below this line. */
#ifdef __cplusplus
@@ -731,7 +202,6 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
#endif /* defined(USE_TCL_STUBS) */
/* !END!: Do not edit above this line. */
#endif /* TCL_MAJOR_VERSION */
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
@@ -739,10 +209,6 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
#undef TclpGmtime_unix
#undef TclWinConvertWSAError
#define TclWinConvertWSAError TclWinConvertError
#if !defined(TCL_USE_STUBS) && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
# undef TclWinConvertError
# define TclWinConvertError Tcl_WinConvertError
#endif
#undef TclpInetNtoa
#define TclpInetNtoa inet_ntoa
@@ -782,15 +248,6 @@ MODULE_SCOPE int TclMacOSXMatchType(Tcl_Interp *interp,
# undef TclWinGetPlatformId
# undef TclWinResetInterfaces
# undef TclWinSetInterfaces
# if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
# define TclWinNToHS ntohs
# define TclWinGetServByName getservbyname
# define TclWinGetSockOpt getsockopt
# define TclWinSetSockOpt setsockopt
# define TclWinGetPlatformId() (2) /* VER_PLATFORM_WIN32_NT */
# define TclWinResetInterfaces() /* nop */
# define TclWinSetInterfaces(dummy) /* nop */
# endif /* TCL_NO_DEPRECATED */
#else
# undef TclpGetPid
# define TclpGetPid(pid) ((size_t)(pid))
-6
View File
@@ -624,9 +624,7 @@ NRInterpCmd(
"hidden", "issafe", "invokehidden",
"limit", "marktrusted", "recursionlimit",
"share",
#ifndef TCL_NO_DEPRECATED
"slaves",
#endif
"target", "transfer", NULL
};
static const char *const optionsNoSlaves[] = {
@@ -644,9 +642,7 @@ NRInterpCmd(
OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE,
OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID,
OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT, OPT_SHARE,
#ifndef TCL_NO_DEPRECATED
OPT_SLAVES,
#endif
OPT_TARGET, OPT_TRANSFER
} index;
@@ -1033,9 +1029,7 @@ NRInterpCmd(
return TCL_ERROR;
}
return ChildRecursionLimit(interp, childInterp, objc - 3, objv + 3);
#ifndef TCL_NO_DEPRECATED
case OPT_SLAVES:
#endif
case OPT_CHILDREN: {
InterpInfo *iiPtr;
Tcl_Obj *resultPtr;
-16
View File
@@ -179,14 +179,6 @@ Tcl_LinkVar(
Tcl_IncrRefCount(linkPtr->varName);
linkPtr->addr = addr;
linkPtr->type = type & ~TCL_LINK_READ_ONLY;
#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
|| defined(_WIN32) || defined(__CYGWIN__))
if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) {
linkPtr->type = TCL_LINK_LONG;
} else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) {
linkPtr->type = TCL_LINK_ULONG;
}
#endif
if (type & TCL_LINK_READ_ONLY) {
linkPtr->flags = LINK_READ_ONLY;
} else {
@@ -262,14 +254,6 @@ Tcl_LinkArray(
linkPtr = (Link *)Tcl_Alloc(sizeof(Link));
linkPtr->type = type & ~TCL_LINK_READ_ONLY;
#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
|| defined(_WIN32) || defined(__CYGWIN__))
if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) {
linkPtr->type = TCL_LINK_LONG;
} else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) {
linkPtr->type = TCL_LINK_ULONG;
}
#endif
linkPtr->numElems = size;
if (type & TCL_LINK_READ_ONLY) {
linkPtr->flags = LINK_READ_ONLY;
+108 -138
View File
@@ -325,30 +325,6 @@ ListSpanMerited(
return 1;
}
/*
*------------------------------------------------------------------------
*
* ListStoreUpSize --
*
* For reasons of efficiency, extra space is allocated for a ListStore
* compared to what was requested. This function calculates how many
* slots should actually be allocated for a given request size.
*
* Results:
* Number of slots to allocate.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
static inline Tcl_Size
ListStoreUpSize(Tcl_Size numSlotsRequested) {
/* TODO -how much extra? May be double only for smaller requests? */
return numSlotsRequested < (LIST_MAX / 2) ? 2 * numSlotsRequested
: LIST_MAX;
}
/*
*------------------------------------------------------------------------
*
@@ -769,23 +745,21 @@ ListStoreNew(
return NULL;
}
storePtr = NULL;
if (flags & LISTREP_SPACE_FLAGS) {
/* Caller requests extra space front, back or both */
capacity = ListStoreUpSize(objc);
storePtr = (ListStore *)TclAttemptAllocElemsEx(
objc, sizeof(Tcl_Obj *), offsetof(ListStore, slots), &capacity);
} else {
/* Exact allocation */
capacity = objc;
}
storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity));
while (storePtr == NULL && (capacity > (objc+1))) {
/* Because of loop condition capacity won't overflow */
capacity = objc + ((capacity - objc) / 2);
storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity));
}
if (storePtr == NULL) {
if (flags & LISTREP_PANIC_ON_FAIL) {
Tcl_Panic("list creation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes",
LIST_SIZE(objc));
Tcl_Panic("list creation failed: unable to alloc %" TCL_Z_MODIFIER
"u bytes",
LIST_SIZE(objc));
}
return NULL;
}
@@ -844,38 +818,25 @@ ListStoreNew(
*------------------------------------------------------------------------
*/
ListStore *
ListStoreReallocate (ListStore *storePtr, Tcl_Size numSlots)
ListStoreReallocate (ListStore *storePtr, Tcl_Size needed)
{
Tcl_Size newCapacity;
ListStore *newStorePtr;
Tcl_Size capacity;
newCapacity = ListStoreUpSize(numSlots);
newStorePtr =
(ListStore *)Tcl_AttemptRealloc(storePtr, LIST_SIZE(newCapacity));
/*
* In case above failed keep looping reducing the requested extra space
* by half every time.
*/
while (newStorePtr == NULL && (newCapacity > (numSlots+1))) {
/* Because of loop condition newCapacity won't overflow */
newCapacity = numSlots + ((newCapacity - numSlots) / 2);
newStorePtr =
(ListStore *)Tcl_AttemptRealloc(storePtr, LIST_SIZE(newCapacity));
}
if (newStorePtr == NULL) {
/* Last resort - allcate what was asked */
newCapacity = numSlots;
newStorePtr = (ListStore *)Tcl_AttemptRealloc(storePtr,
LIST_SIZE(newCapacity));
if (newStorePtr == NULL)
return NULL;
if (needed > LIST_MAX) {
return NULL;
}
storePtr = (ListStore *)TclAttemptReallocElemsEx(storePtr,
needed,
sizeof(Tcl_Obj *),
offsetof(ListStore, slots),
&capacity);
/* Only the capacity has changed, fix it in the header */
newStorePtr->numAllocated = newCapacity;
return newStorePtr;
if (storePtr) {
storePtr->numAllocated = capacity;
}
return storePtr;
}
/*
*----------------------------------------------------------------------
*
@@ -1355,50 +1316,6 @@ Tcl_SetListObj(
}
}
/*
*----------------------------------------------------------------------
*
* TclListObjCopy --
*
* Makes a "pure list" copy of a list value. This provides for the C
* level a counterpart of the [lrange $list 0 end] command, while using
* internals details to be as efficient as possible.
*
* Results:
* Normally returns a pointer to a new Tcl_Obj, that contains the same
* list value as *listPtr does. The returned Tcl_Obj has a refCount of
* zero. If *listPtr does not hold a list, NULL is returned, and if
* interp is non-NULL, an error message is recorded there.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclListObjCopy(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listObj) /* List object for which an element array is
* to be returned. */
{
Tcl_Obj *copyObj;
if (!TclHasInternalRep(listObj, &tclListType.objType)) {
if (TclHasInternalRep(listObj,&tclArithSeriesType.objType)) {
return Tcl_DuplicateObj(listObj);
}
if (SetListFromAny(interp, listObj) != TCL_OK) {
return NULL;
}
}
TclNewObj(copyObj);
TclInvalidateStringRep(copyObj);
DupListInternalRep(listObj, copyObj);
return copyObj;
}
/*
*------------------------------------------------------------------------
*
@@ -1639,6 +1556,29 @@ TclListObjRange(
return listObj;
}
/*
*----------------------------------------------------------------------
*
* TclListObjGetElement --
*
* Returns a single element from the array of the elements in a list
* object, without doing doing any bounds checking. Caller must ensure
* that ObjPtr of of type 'tclListType' and that index is valid for the
* list.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclListObjGetElement(
Tcl_Obj *objPtr, /* List object for which an element array is
* to be returned. */
Tcl_Size index
)
{
return ListObjStorePtr(objPtr)->slots[ListObjStart(objPtr) + index];
}
/*
*----------------------------------------------------------------------
*
@@ -2579,6 +2519,7 @@ TclLindexList(
Tcl_Obj *indexListCopy;
Tcl_Obj **indexObjs;
Tcl_Size numIndexObjs;
int status;
/*
* Determine whether argPtr designates a list or a single index. We have
@@ -2596,19 +2537,30 @@ TclLindexList(
}
/*
* Here we make a private copy of the index list argument to avoid any
* shimmering issues that might invalidate the indices array below while
* we are still using it. This is probably unnecessary. It does not appear
* that any damaging shimmering is possible, and no test has been devised
* to show any error when this private copy is not made. But it's cheap,
* and it offers some future-proofing insurance in case the TclLindexFlat
* implementation changes in some unexpected way, or some new form of
* trace or callback permits things to happen that the current
* implementation does not.
* Make a private copy of the index list argument to keep the internal
* representation of th indices array unchanged while it is in use. This
* is probably unnecessary. It does not appear that any damaging change to
* the internal representation is possible, and no test has been devised to
* show any error when this private copy is not made, But it's cheap, and
* it offers some future-proofing insurance in case the TclLindexFlat
* implementation changes in some unexpected way, or some new form of trace
* or callback permits things to happen that the current implementation
* does not.
*/
indexListCopy = TclListObjCopy(NULL, argObj);
if (indexListCopy == NULL) {
indexListCopy = TclDuplicatePureObj(interp, argObj, &tclListType.objType);
if (!indexListCopy) {
/*
* The argument is neither an index nor a well-formed list.
* Report the error via TclLindexFlat.
* TODO - This is as original code. why not directly return an error?
*/
return TclLindexFlat(interp, listObj, 1, &argObj);
}
status = TclListObjGetElementsM(
interp, indexListCopy, &numIndexObjs, &indexObjs);
if (status != TCL_OK) {
Tcl_DecrRefCount(indexListCopy);
/*
* The argument is neither an index nor a well-formed list.
* Report the error via TclLindexFlat.
@@ -2616,8 +2568,6 @@ TclLindexList(
*/
return TclLindexFlat(interp, listObj, 1, &argObj);
}
ListObjGetElements(indexListCopy, numIndexObjs, indexObjs);
listObj = TclLindexFlat(interp, listObj, numIndexObjs, indexObjs);
Tcl_DecrRefCount(indexListCopy);
return listObj;
@@ -2798,23 +2748,30 @@ TclLsetList(
return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
}
indexListCopy = TclListObjCopy(NULL, indexArgObj);
if (indexListCopy == NULL) {
indexListCopy = TclDuplicatePureObj(
interp, indexArgObj, &tclListType.objType);
if (!indexListCopy) {
/*
* indexArgPtr designates something that is neither an index nor a
* well formed list. Report the error via TclLsetFlat.
*/
return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
}
if (TCL_OK != TclListObjGetElementsM(
interp, indexListCopy, &indexCount, &indices)) {
Tcl_DecrRefCount(indexListCopy);
/*
* indexArgPtr designates something that is neither an index nor a
* well formed list. Report the error via TclLsetFlat.
*/
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;
}
@@ -2865,7 +2822,7 @@ TclLsetFlat(
Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */
{
Tcl_Size index, len;
int result;
int copied = 0, result;
Tcl_Obj *subListObj, *retValueObj;
Tcl_Obj *pendingInvalidates[10];
Tcl_Obj **pendingInvalidatesPtr = pendingInvalidates;
@@ -2885,17 +2842,15 @@ TclLsetFlat(
}
/*
* If the list is shared, make a copy we can modify (copy-on-write). We
* use Tcl_DuplicateObj() instead of TclListObjCopy() for a few reasons:
* 1) we have not yet confirmed listObj is actually a list; 2) We make a
* verbatim copy of any existing string rep, and when we combine that with
* the delayed invalidation of string reps of modified Tcl_Obj's
* implemented below, the outcome is that any error condition that causes
* this routine to return NULL, will leave the string rep of listObj and
* all elements to be unchanged.
* If the list is shared, make a copy to modify (copy-on-write). The string
* representation and internal representation of listObj remains unchanged.
*/
subListObj = Tcl_IsShared(listObj) ? Tcl_DuplicateObj(listObj) : listObj;
subListObj = Tcl_IsShared(listObj)
? TclDuplicatePureObj(interp, listObj, &tclListType.objType) : listObj;
if (!subListObj) {
return NULL;
}
/*
* Anchor the linked list of Tcl_Obj's whose string reps must be
@@ -2965,10 +2920,9 @@ TclLsetFlat(
}
/*
* No error conditions. As long as we're not yet on the last index,
* determine the next sublist for the next pass through the loop,
* and take steps to make sure it is an unshared copy, as we intend
* to modify it.
* No error conditions. If this is not the last index, determine the
* next sublist for the next pass through the loop, and take steps to
* make sure it is unshared in order to modify it.
*/
if (--indexCount) {
@@ -2979,7 +2933,12 @@ TclLsetFlat(
subListObj = elemPtrs[index];
}
if (Tcl_IsShared(subListObj)) {
subListObj = Tcl_DuplicateObj(subListObj);
subListObj = TclDuplicatePureObj(
interp, subListObj, &tclListType.objType);
if (!subListObj) {
return NULL;
}
copied = 1;
}
/*
@@ -2997,7 +2956,17 @@ TclLsetFlat(
TclListObjSetElement(NULL, parentList, index, subListObj);
}
if (Tcl_IsShared(subListObj)) {
subListObj = Tcl_DuplicateObj(subListObj);
Tcl_Obj * newSubListObj;
newSubListObj = TclDuplicatePureObj(
interp, subListObj, &tclListType.objType);
if (copied) {
Tcl_DecrRefCount(subListObj);
}
if (newSubListObj) {
subListObj = newSubListObj;
} else {
return NULL;
}
TclListObjSetElement(NULL, parentList, index, subListObj);
}
@@ -3346,6 +3315,7 @@ SetListFromAny(
if (elemPtrs[j] == NULL) {
return TCL_ERROR;
}
Tcl_IncrRefCount(elemPtrs[j]);
}
} else {
+50 -10
View File
@@ -3,7 +3,7 @@
*
* This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
*
* Copyright © 2005-2012 Donal K. Fellows
* Copyright © 2005-2019 Donal K. Fellows
* Copyright © 2017 Nathan Coulter
*
* See the file "license.terms" for information on usage and redistribution of
@@ -138,9 +138,6 @@ static const Tcl_MethodType classConstructor = {
*/
static const char initScript[] =
#ifndef TCL_NO_DEPRECATED
"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
#endif
"package ifneeded tcl::oo " TCLOO_PATCHLEVEL " {# Already present, OK?};"
"namespace eval ::oo { variable version " TCLOO_VERSION " };"
"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
@@ -260,10 +257,6 @@ TclOOInit(
return TCL_ERROR;
}
#ifndef TCL_NO_DEPRECATED
Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL,
&tclOOStubs);
#endif
return Tcl_PkgProvideEx(interp, "tcl::oo", TCLOO_PATCHLEVEL,
&tclOOStubs);
}
@@ -327,6 +320,7 @@ InitFoundation(
DeletedObjdefNamespace);
fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
DeletedHelpersNamespace);
Tcl_CreateNamespace(interp, "::oo::configuresupport", NULL, NULL);
fPtr->epoch = 1;
fPtr->tsdPtr = tsdPtr;
TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
@@ -964,7 +958,7 @@ TclOOReleaseClassContents(
Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
Method *mPtr;
Foundation *fPtr = oPtr->fPtr;
Tcl_Obj *variableObj;
Tcl_Obj *variableObj, *propertyObj;
PrivateVariableMapping *privateVariable;
/*
@@ -1017,6 +1011,29 @@ TclOOReleaseClassContents(
clsPtr->classChainCache = NULL;
}
/*
* Squelch the property lists.
*/
if (clsPtr->properties.allReadableCache) {
Tcl_DecrRefCount(clsPtr->properties.allReadableCache);
}
if (clsPtr->properties.allWritableCache) {
Tcl_DecrRefCount(clsPtr->properties.allWritableCache);
}
if (clsPtr->properties.readable.num) {
FOREACH(propertyObj, clsPtr->properties.readable) {
Tcl_DecrRefCount(propertyObj);
}
Tcl_Free(clsPtr->properties.readable.list);
}
if (clsPtr->properties.writable.num) {
FOREACH(propertyObj, clsPtr->properties.writable) {
Tcl_DecrRefCount(propertyObj);
}
Tcl_Free(clsPtr->properties.writable.list);
}
/*
* Squelch our filter list.
*/
@@ -1118,7 +1135,7 @@ ObjectNamespaceDeleted(
FOREACH_HASH_DECLS;
Class *mixinPtr;
Method *mPtr;
Tcl_Obj *filterObj, *variableObj;
Tcl_Obj *filterObj, *variableObj, *propertyObj;
PrivateVariableMapping *privateVariable;
Tcl_Interp *interp = oPtr->fPtr->interp;
Tcl_Size i;
@@ -1271,6 +1288,29 @@ ObjectNamespaceDeleted(
oPtr->metadataPtr = NULL;
}
/*
* Squelch the property lists.
*/
if (oPtr->properties.allReadableCache) {
Tcl_DecrRefCount(oPtr->properties.allReadableCache);
}
if (oPtr->properties.allWritableCache) {
Tcl_DecrRefCount(oPtr->properties.allWritableCache);
}
if (oPtr->properties.readable.num) {
FOREACH(propertyObj, oPtr->properties.readable) {
Tcl_DecrRefCount(propertyObj);
}
Tcl_Free(oPtr->properties.readable.list);
}
if (oPtr->properties.writable.num) {
FOREACH(propertyObj, oPtr->properties.writable) {
Tcl_DecrRefCount(propertyObj);
}
Tcl_Free(oPtr->properties.writable.list);
}
/*
* Because an object can be a class that is an instance of itself, the
* class object's class structure should only be cleaned after most of
+261 -6
View File
@@ -2,9 +2,10 @@
* tclOOCall.c --
*
* This file contains the method call chain management code for the
* object-system core.
* object-system core. It also contains everything else that does
* inheritance hierarchy traversal.
*
* Copyright © 2005-2012 Donal K. Fellows
* Copyright © 2005-2019 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -58,6 +59,7 @@ typedef struct {
#define BUILDING_MIXINS 0x400000
#define TRAVERSED_MIXIN 0x800000
#define OBJECT_MIXIN 0x1000000
#define DEFINE_FOR_CLASS 0x2000000
#define MIXIN_CONSISTENT(flags) \
(((flags) & OBJECT_MIXIN) || \
!((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN))
@@ -1907,7 +1909,7 @@ TclOOGetDefineContextNamespace(
DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE];
DefineEntry *entryPtr;
Tcl_Namespace *nsPtr = NULL;
int i;
int i, flags = (forClass ? DEFINE_FOR_CLASS : 0);
define.list = staticSpace;
define.num = 0;
@@ -1918,8 +1920,8 @@ TclOOGetDefineContextNamespace(
* class mixins right.
*/
AddSimpleDefineNamespaces(oPtr, &define, forClass | BUILDING_MIXINS);
AddSimpleDefineNamespaces(oPtr, &define, forClass);
AddSimpleDefineNamespaces(oPtr, &define, flags | BUILDING_MIXINS);
AddSimpleDefineNamespaces(oPtr, &define, flags);
/*
* Go through the list until we find a namespace whose name we can
@@ -2003,7 +2005,7 @@ AddSimpleClassDefineNamespaces(
flags | TRAVERSED_MIXIN);
}
if (flags & ~(TRAVERSED_MIXIN | BUILDING_MIXINS)) {
if (flags & DEFINE_FOR_CLASS) {
AddDefinitionNamespaceToChain(classPtr, classPtr->clsDefinitionNs,
definePtr, flags);
} else {
@@ -2112,6 +2114,259 @@ AddDefinitionNamespaceToChain(
definePtr->num++;
}
/*
* ----------------------------------------------------------------------
*
* FindClassProps --
*
* Discover the properties known to a class and its superclasses.
* The property names become the keys in the accumulator hash table
* (which is used as a set).
*
* ----------------------------------------------------------------------
*/
static void
FindClassProps(
Class *clsPtr, /* The object to inspect. Must exist. */
int writable, /* Whether we're after the readable or writable
* property set. */
Tcl_HashTable *accumulator) /* Where to gather the names. */
{
int i, dummy;
Tcl_Obj *propName;
Class *mixin, *sup;
tailRecurse:
if (writable) {
FOREACH(propName, clsPtr->properties.writable) {
Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
}
} else {
FOREACH(propName, clsPtr->properties.readable) {
Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
}
}
if (clsPtr->thisPtr->flags & ROOT_OBJECT) {
/*
* We do *not* traverse upwards from the root!
*/
return;
}
FOREACH(mixin, clsPtr->mixins) {
FindClassProps(mixin, writable, accumulator);
}
if (clsPtr->superclasses.num == 1) {
clsPtr = clsPtr->superclasses.list[0];
goto tailRecurse;
}
FOREACH(sup, clsPtr->superclasses) {
FindClassProps(sup, writable, accumulator);
}
}
/*
* ----------------------------------------------------------------------
*
* FindObjectProps --
*
* Discover the properties known to an object and all its classes.
* The property names become the keys in the accumulator hash table
* (which is used as a set).
*
* ----------------------------------------------------------------------
*/
static void
FindObjectProps(
Object *oPtr, /* The object to inspect. Must exist. */
int writable, /* Whether we're after the readable or writable
* property set. */
Tcl_HashTable *accumulator) /* Where to gather the names. */
{
int i, dummy;
Tcl_Obj *propName;
Class *mixin;
if (writable) {
FOREACH(propName, oPtr->properties.writable) {
Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
}
} else {
FOREACH(propName, oPtr->properties.readable) {
Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
}
}
FOREACH(mixin, oPtr->mixins) {
FindClassProps(mixin, writable, accumulator);
}
FindClassProps(oPtr->selfCls, writable, accumulator);
}
/*
* ----------------------------------------------------------------------
*
* TclOOGetAllClassProperties --
*
* Get the list of all properties known to a class, including to its
* superclasses. Manages a cache so this operation is usually cheap.
* The order of properties in the resulting list is undefined.
*
* ----------------------------------------------------------------------
*/
Tcl_Obj *
TclOOGetAllClassProperties(
Class *clsPtr, /* The class to inspect. Must exist. */
int writable, /* Whether to get writable properties. If
* false, readable properties will be returned
* instead. */
int *allocated) /* Address of variable to set to true if a
* Tcl_Obj was allocated and may be safely
* modified by the caller. */
{
Tcl_HashTable hashTable;
FOREACH_HASH_DECLS;
Tcl_Obj *propName, *result;
void *dummy;
/*
* Look in the cache.
*/
if (clsPtr->properties.epoch == clsPtr->thisPtr->fPtr->epoch) {
if (writable) {
if (clsPtr->properties.allWritableCache) {
*allocated = 0;
return clsPtr->properties.allWritableCache;
}
} else {
if (clsPtr->properties.allReadableCache) {
*allocated = 0;
return clsPtr->properties.allReadableCache;
}
}
}
/*
* Gather the information. Unsorted! (Caller will sort.)
*/
*allocated = 1;
Tcl_InitObjHashTable(&hashTable);
FindClassProps(clsPtr, writable, &hashTable);
TclNewObj(result);
FOREACH_HASH(propName, dummy, &hashTable) {
Tcl_ListObjAppendElement(NULL, result, propName);
}
Tcl_DeleteHashTable(&hashTable);
/*
* Cache the information. Also purges the cache.
*/
if (clsPtr->properties.epoch != clsPtr->thisPtr->fPtr->epoch) {
if (clsPtr->properties.allWritableCache) {
Tcl_DecrRefCount(clsPtr->properties.allWritableCache);
clsPtr->properties.allWritableCache = NULL;
}
if (clsPtr->properties.allReadableCache) {
Tcl_DecrRefCount(clsPtr->properties.allReadableCache);
clsPtr->properties.allReadableCache = NULL;
}
}
clsPtr->properties.epoch = clsPtr->thisPtr->fPtr->epoch;
if (writable) {
clsPtr->properties.allWritableCache = result;
} else {
clsPtr->properties.allReadableCache = result;
}
Tcl_IncrRefCount(result);
return result;
}
/*
* ----------------------------------------------------------------------
*
* TclOOGetAllObjectProperties --
*
* Get the list of all properties known to a object, including to its
* classes. Manages a cache so this operation is usually cheap.
* The order of properties in the resulting list is undefined.
*
* ----------------------------------------------------------------------
*/
Tcl_Obj *
TclOOGetAllObjectProperties(
Object *oPtr, /* The object to inspect. Must exist. */
int writable, /* Whether to get writable properties. If
* false, readable properties will be returned
* instead. */
int *allocated) /* Address of variable to set to true if a
* Tcl_Obj was allocated and may be safely
* modified by the caller. */
{
Tcl_HashTable hashTable;
FOREACH_HASH_DECLS;
Tcl_Obj *propName, *result;
void *dummy;
/*
* Look in the cache.
*/
if (oPtr->properties.epoch == oPtr->fPtr->epoch) {
if (writable) {
if (oPtr->properties.allWritableCache) {
*allocated = 0;
return oPtr->properties.allWritableCache;
}
} else {
if (oPtr->properties.allReadableCache) {
*allocated = 0;
return oPtr->properties.allReadableCache;
}
}
}
/*
* Gather the information. Unsorted! (Caller will sort.)
*/
*allocated = 1;
Tcl_InitObjHashTable(&hashTable);
FindObjectProps(oPtr, writable, &hashTable);
TclNewObj(result);
FOREACH_HASH(propName, dummy, &hashTable) {
Tcl_ListObjAppendElement(NULL, result, propName);
}
Tcl_DeleteHashTable(&hashTable);
/*
* Cache the information.
*/
if (oPtr->properties.epoch != oPtr->fPtr->epoch) {
if (oPtr->properties.allWritableCache) {
Tcl_DecrRefCount(oPtr->properties.allWritableCache);
oPtr->properties.allWritableCache = NULL;
}
if (oPtr->properties.allReadableCache) {
Tcl_DecrRefCount(oPtr->properties.allReadableCache);
oPtr->properties.allReadableCache = NULL;
}
}
oPtr->properties.epoch = oPtr->fPtr->epoch;
if (writable) {
oPtr->properties.allWritableCache = result;
} else {
oPtr->properties.allReadableCache = result;
}
Tcl_IncrRefCount(result);
return result;
}
/*
* Local Variables:
* mode: c
+457 -9
View File
@@ -4,7 +4,7 @@
* This file contains the implementation of the ::oo::define command,
* part of the object-system core (NB: not Tcl_Obj, but ::oo).
*
* Copyright © 2006-2013 Donal K. Fellows
* Copyright © 2006-2019 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -60,6 +60,7 @@ struct DeclaredSlot {
*/
static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
static inline void BumpInstanceEpoch(Object *oPtr);
static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
Tcl_Namespace *const namespacePtr);
static inline void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr,
@@ -102,6 +103,8 @@ static int ClassVarsGet(void *clientData,
static int ClassVarsSet(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static Tcl_MethodCallProc ClassRPropsGet, ClassRPropsSet;
static Tcl_MethodCallProc ClassWPropsGet, ClassWPropsSet;
static int ObjFilterGet(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
@@ -120,6 +123,8 @@ static int ObjVarsGet(void *clientData,
static int ObjVarsSet(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static Tcl_MethodCallProc ObjRPropsGet, ObjRPropsSet;
static Tcl_MethodCallProc ObjWPropsGet, ObjWPropsSet;
static int ResolveClass(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
@@ -136,6 +141,14 @@ static const struct DeclaredSlot slots[] = {
SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL),
SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClass),
SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL),
SLOT("configuresupport::readableproperties",
ClassRPropsGet, ClassRPropsSet, NULL),
SLOT("configuresupport::writableproperties",
ClassWPropsGet, ClassWPropsSet, NULL),
SLOT("configuresupport::objreadableproperties",
ObjRPropsGet, ObjRPropsSet, NULL),
SLOT("configuresupport::objwritableproperties",
ObjWPropsGet, ObjWPropsSet, NULL),
{NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
};
@@ -201,18 +214,58 @@ BumpGlobalEpoch(
if (classPtr->thisPtr->mixins.num > 0) {
classPtr->thisPtr->epoch++;
/*
* Invalidate the property caches directly.
*/
if (classPtr->properties.allReadableCache) {
Tcl_DecrRefCount(classPtr->properties.allReadableCache);
classPtr->properties.allReadableCache = NULL;
}
if (classPtr->properties.allWritableCache) {
Tcl_DecrRefCount(classPtr->properties.allWritableCache);
classPtr->properties.allWritableCache = NULL;
}
}
return;
}
/*
* Either there's no class (?!) or we're reconfiguring something that is
* in use. Force regeneration of call chains.
* in use. Force regeneration of call chains and properties.
*/
TclOOGetFoundation(interp)->epoch++;
}
/*
* ----------------------------------------------------------------------
*
* BumpInstanceEpoch --
*
* Advances the epoch and clears the property cache of an object. The
* equivalent for classes is BumpGlobalEpoch(), as classes have a more
* complex set of relationships to other entities.
*
* ----------------------------------------------------------------------
*/
static inline void
BumpInstanceEpoch(
Object *oPtr)
{
oPtr->epoch++;
if (oPtr->properties.allReadableCache) {
Tcl_DecrRefCount(oPtr->properties.allReadableCache);
oPtr->properties.allReadableCache = NULL;
}
if (oPtr->properties.allWritableCache) {
Tcl_DecrRefCount(oPtr->properties.allWritableCache);
oPtr->properties.allWritableCache = NULL;
}
}
/*
* ----------------------------------------------------------------------
*
@@ -292,7 +345,7 @@ TclOOObjectSetFilters(
oPtr->filters.num = numFilters;
oPtr->flags &= ~USE_CLASS_CACHE;
}
oPtr->epoch++; /* Only this object can be affected. */
BumpInstanceEpoch(oPtr); /* Only this object can be affected. */
}
/*
@@ -415,7 +468,7 @@ TclOOObjectSetMixins(
}
}
}
oPtr->epoch++;
BumpInstanceEpoch(oPtr);
}
/*
@@ -482,6 +535,7 @@ TclOOClassSetMixins(
*
* ----------------------------------------------------------------------
*/
static inline void
InstallStandardVariableMapping(
VariableNameList *vnlPtr,
@@ -1507,7 +1561,7 @@ TclOODefineClassObjCmd(
if (oPtr->classPtr != NULL) {
BumpGlobalEpoch(interp, oPtr->classPtr);
} else {
oPtr->epoch++;
BumpInstanceEpoch(oPtr);
}
}
return TCL_OK;
@@ -1717,7 +1771,7 @@ TclOODefineDeleteMethodObjCmd(
}
if (isInstanceDeleteMethod) {
oPtr->epoch++;
BumpInstanceEpoch(oPtr);
} else {
BumpGlobalEpoch(interp, oPtr->classPtr);
}
@@ -1877,7 +1931,7 @@ TclOODefineExportObjCmd(
if (changed) {
if (isInstanceExport) {
oPtr->epoch++;
BumpInstanceEpoch(oPtr);
} else {
BumpGlobalEpoch(interp, clsPtr);
}
@@ -2095,7 +2149,7 @@ TclOODefineRenameMethodObjCmd(
}
if (isInstanceRenameMethod) {
oPtr->epoch++;
BumpInstanceEpoch(oPtr);
} else {
BumpGlobalEpoch(interp, oPtr->classPtr);
}
@@ -2189,7 +2243,7 @@ TclOODefineUnexportObjCmd(
if (changed) {
if (isInstanceUnexport) {
oPtr->epoch++;
BumpInstanceEpoch(oPtr);
} else {
BumpGlobalEpoch(interp, clsPtr);
}
@@ -3081,6 +3135,400 @@ ResolveClass(
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* ClassRPropsGet, ClassRPropsSet, ObjRPropsGet, ObjRPropsSet --
*
* Implementations of the "readableproperties" slot accessors for classes
* and instances.
*
* ----------------------------------------------------------------------
*/
static void
InstallReadableProps(
PropertyStorage *props,
Tcl_Size objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *propObj;
Tcl_Size i, n;
int created;
Tcl_HashTable uniqueTable;
if (props->allReadableCache) {
Tcl_DecrRefCount(props->allReadableCache);
props->allReadableCache = NULL;
}
for (i=0 ; i<objc ; i++) {
Tcl_IncrRefCount(objv[i]);
}
FOREACH(propObj, props->readable) {
Tcl_DecrRefCount(propObj);
}
if (i != objc) {
if (objc == 0) {
Tcl_Free(props->readable.list);
} else if (i) {
props->readable.list = (Tcl_Obj **)Tcl_Realloc(props->readable.list,
sizeof(Tcl_Obj *) * objc);
} else {
props->readable.list = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * objc);
}
}
props->readable.num = 0;
if (objc > 0) {
Tcl_InitObjHashTable(&uniqueTable);
for (i=n=0 ; i<objc ; i++) {
Tcl_CreateHashEntry(&uniqueTable, objv[i], &created);
if (created) {
props->readable.list[n++] = objv[i];
} else {
Tcl_DecrRefCount(objv[i]);
}
}
props->readable.num = n;
/*
* Shouldn't be necessary, but maintain num/list invariant.
*/
if (n != objc) {
props->readable.list = (Tcl_Obj **)Tcl_Realloc(props->readable.list,
sizeof(Tcl_Obj *) * n);
}
Tcl_DeleteHashTable(&uniqueTable);
}
}
static int
ClassRPropsGet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj, *propNameObj;
int i;
if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(propNameObj, oPtr->classPtr->properties.readable) {
Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassRPropsSet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Size varc;
Tcl_Obj **varv;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
&varv) != TCL_OK) {
return TCL_ERROR;
}
InstallReadableProps(&oPtr->classPtr->properties, varc, varv);
BumpGlobalEpoch(interp, oPtr->classPtr);
return TCL_OK;
}
static int
ObjRPropsGet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj, *propNameObj;
int i;
if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
if (oPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(propNameObj, oPtr->properties.readable) {
Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ObjRPropsSet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Size varc;
Tcl_Obj **varv;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
&varv) != TCL_OK) {
return TCL_ERROR;
}
InstallReadableProps(&oPtr->properties, varc, varv);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* ClassWPropsGet, ClassWPropsSet, ObjWPropsGet, ObjWPropsSet --
*
* Implementations of the "writableproperties" slot accessors for classes
* and instances.
*
* ----------------------------------------------------------------------
*/
static void
InstallWritableProps(
PropertyStorage *props,
Tcl_Size objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *propObj;
Tcl_Size i, n;
int created;
Tcl_HashTable uniqueTable;
if (props->allWritableCache) {
Tcl_DecrRefCount(props->allWritableCache);
props->allWritableCache = NULL;
}
for (i=0 ; i<objc ; i++) {
Tcl_IncrRefCount(objv[i]);
}
FOREACH(propObj, props->writable) {
Tcl_DecrRefCount(propObj);
}
if (i != objc) {
if (objc == 0) {
Tcl_Free(props->writable.list);
} else if (i) {
props->writable.list = (Tcl_Obj **)Tcl_Realloc(props->writable.list,
sizeof(Tcl_Obj *) * objc);
} else {
props->writable.list = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * objc);
}
}
props->writable.num = 0;
if (objc > 0) {
Tcl_InitObjHashTable(&uniqueTable);
for (i=n=0 ; i<objc ; i++) {
Tcl_CreateHashEntry(&uniqueTable, objv[i], &created);
if (created) {
props->writable.list[n++] = objv[i];
} else {
Tcl_DecrRefCount(objv[i]);
}
}
props->writable.num = n;
/*
* Shouldn't be necessary, but maintain num/list invariant.
*/
if (n != objc) {
props->writable.list = (Tcl_Obj **)Tcl_Realloc(props->writable.list,
sizeof(Tcl_Obj *) * n);
}
Tcl_DeleteHashTable(&uniqueTable);
}
}
static int
ClassWPropsGet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj, *propNameObj;
int i;
if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(propNameObj, oPtr->classPtr->properties.writable) {
Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassWPropsSet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Size varc;
Tcl_Obj **varv;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"propertyList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
&varv) != TCL_OK) {
return TCL_ERROR;
}
InstallWritableProps(&oPtr->classPtr->properties, varc, varv);
BumpGlobalEpoch(interp, oPtr->classPtr);
return TCL_OK;
}
static int
ObjWPropsGet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj, *propNameObj;
int i;
if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
if (oPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(propNameObj, oPtr->properties.writable) {
Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ObjWPropsSet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Size varc;
Tcl_Obj **varv;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"propertyList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
&varv) != TCL_OK) {
return TCL_ERROR;
}
InstallWritableProps(&oPtr->properties, varc, varv);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
+184 -1
View File
@@ -4,7 +4,7 @@
* This file contains the implementation of the ::oo-related [info]
* subcommands.
*
* Copyright © 2006-2011 Donal K. Fellows
* Copyright © 2006-2019 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -17,6 +17,7 @@
#include "tclOOInt.h"
static inline Class * GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void SortPropList(Tcl_Obj *list);
static Tcl_ObjCmdProc InfoObjectCallCmd;
static Tcl_ObjCmdProc InfoObjectClassCmd;
static Tcl_ObjCmdProc InfoObjectDefnCmd;
@@ -28,6 +29,7 @@ static Tcl_ObjCmdProc InfoObjectMethodsCmd;
static Tcl_ObjCmdProc InfoObjectMethodTypeCmd;
static Tcl_ObjCmdProc InfoObjectMixinsCmd;
static Tcl_ObjCmdProc InfoObjectNsCmd;
static Tcl_ObjCmdProc InfoObjectPropCmd;
static Tcl_ObjCmdProc InfoObjectVarsCmd;
static Tcl_ObjCmdProc InfoObjectVariablesCmd;
static Tcl_ObjCmdProc InfoClassCallCmd;
@@ -41,6 +43,7 @@ static Tcl_ObjCmdProc InfoClassInstancesCmd;
static Tcl_ObjCmdProc InfoClassMethodsCmd;
static Tcl_ObjCmdProc InfoClassMethodTypeCmd;
static Tcl_ObjCmdProc InfoClassMixinsCmd;
static Tcl_ObjCmdProc InfoClassPropCmd;
static Tcl_ObjCmdProc InfoClassSubsCmd;
static Tcl_ObjCmdProc InfoClassSupersCmd;
static Tcl_ObjCmdProc InfoClassVariablesCmd;
@@ -61,6 +64,7 @@ static const EnsembleImplMap infoObjectCmds[] = {
{"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
{"properties", InfoObjectPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"variables", InfoObjectVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
@@ -82,6 +86,7 @@ static const EnsembleImplMap infoClassCmds[] = {
{"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"properties", InfoClassPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"variables", InfoClassVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
@@ -1716,6 +1721,184 @@ InfoClassCallCmd(
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* InfoClassPropCmd, InfoObjectPropCmd --
*
* Implements [info class properties $clsName ?$option...?] and
* [info object properties $objName ?$option...?]
*
* ----------------------------------------------------------------------
*/
enum PropOpt {
PROP_ALL, PROP_READABLE, PROP_WRITABLE
};
static const char *const propOptNames[] = {
"-all", "-readable", "-writable",
NULL
};
static int
InfoClassPropCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr;
int i, idx, all = 0, writable = 0, allocated = 0;
Tcl_Obj *result, *propObj;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?");
return TCL_ERROR;
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
for (i = 2; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
&idx) != TCL_OK) {
return TCL_ERROR;
}
switch (idx) {
case PROP_ALL:
all = 1;
break;
case PROP_READABLE:
writable = 0;
break;
case PROP_WRITABLE:
writable = 1;
break;
}
}
/*
* Get the properties.
*/
if (all) {
result = TclOOGetAllClassProperties(clsPtr, writable, &allocated);
if (allocated) {
SortPropList(result);
}
} else {
TclNewObj(result);
if (writable) {
FOREACH(propObj, clsPtr->properties.writable) {
Tcl_ListObjAppendElement(NULL, result, propObj);
}
} else {
FOREACH(propObj, clsPtr->properties.readable) {
Tcl_ListObjAppendElement(NULL, result, propObj);
}
}
SortPropList(result);
}
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
static int
InfoObjectPropCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
int i, idx, all = 0, writable = 0, allocated = 0;
Tcl_Obj *result, *propObj;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?");
return TCL_ERROR;
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
for (i = 2; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
&idx) != TCL_OK) {
return TCL_ERROR;
}
switch (idx) {
case PROP_ALL:
all = 1;
break;
case PROP_READABLE:
writable = 0;
break;
case PROP_WRITABLE:
writable = 1;
break;
}
}
/*
* Get the properties.
*/
if (all) {
result = TclOOGetAllObjectProperties(oPtr, writable, &allocated);
if (allocated) {
SortPropList(result);
}
} else {
TclNewObj(result);
if (writable) {
FOREACH(propObj, oPtr->properties.writable) {
Tcl_ListObjAppendElement(NULL, result, propObj);
}
} else {
FOREACH(propObj, oPtr->properties.readable) {
Tcl_ListObjAppendElement(NULL, result, propObj);
}
}
SortPropList(result);
}
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* SortPropList --
* Sort a list of names of properties. Simple support function. Assumes
* that the list Tcl_Obj is unshared and doesn't have a string
* representation.
*
* ----------------------------------------------------------------------
*/
static int
PropNameCompare(
const void *a,
const void *b)
{
Tcl_Obj *first = *(Tcl_Obj **) a;
Tcl_Obj *second = *(Tcl_Obj **) b;
return strcmp(Tcl_GetString(first), Tcl_GetString(second));
}
static void
SortPropList(
Tcl_Obj *list)
{
Tcl_Size ec;
Tcl_Obj **ev;
Tcl_ListObjGetElements(NULL, list, &ec, &ev);
qsort(ev, ec, sizeof(Tcl_Obj *), PropNameCompare);
}
/*
* Local Variables:
* mode: c
+36 -6
View File
@@ -160,6 +160,26 @@ typedef struct {
typedef LIST_STATIC(Tcl_Obj *) VariableNameList;
typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList;
/*
* This type is used in various places.
*/
typedef struct {
LIST_STATIC(Tcl_Obj *) readable;
/* The readable properties slot. */
LIST_STATIC(Tcl_Obj *) writable;
/* The writable properties slot. */
Tcl_Obj *allReadableCache; /* The cache of all readable properties
* exposed by this object or class (in its
* stereotypical instancs). Contains a sorted
* unique list if not NULL. */
Tcl_Obj *allWritableCache; /* The cache of all writable properties
* exposed by this object or class (in its
* stereotypical instances). Contains a sorted
* unique list if not NULL. */
int epoch; /* The epoch that the caches are valid for. */
} PropertyStorage;
/*
* Now, the definition of what an object actually is.
*/
@@ -182,8 +202,8 @@ typedef struct Object {
LIST_STATIC(Tcl_Obj *) filters;
/* List of filter names. */
struct Class *classPtr; /* This is non-NULL for all classes, and NULL
* for everything else. It points to the class
* structure. */
* for everything else. It points to the class
* structure. */
Tcl_Size refCount; /* Number of strong references to this object.
* Note that there may be many more weak
* references; this mechanism exists to
@@ -211,12 +231,15 @@ typedef struct Object {
* used inside methods. */
Tcl_Command myclassCommand; /* Reference to this object's class dispatcher
* command. */
PropertyStorage properties; /* Information relating to the lists of
* properties that this object *claims* to
* support. */
} Object;
#define OBJECT_DESTRUCTING 1 /* Indicates that an object is being or has
* been destroyed */
#define DESTRUCTOR_CALLED 2 /* Indicates that evaluation of destructor script for the
object has began */
#define OBJECT_DESTRUCTING 1 /* Indicates that an object is being or has
* been destroyed */
#define DESTRUCTOR_CALLED 2 /* Indicates that evaluation of destructor
* script for the object has began */
#define OO_UNUSED_4 4 /* No longer used. */
#define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of
* the class hierarchy and should be treated
@@ -319,6 +342,9 @@ typedef struct Class {
* namespace is defined but doesn't exist; we
* also check at setting time but don't check
* between times. */
PropertyStorage properties; /* Information relating to the lists of
* properties that this class *claims* to
* support. */
} Class;
/*
@@ -521,6 +547,10 @@ MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr);
MODULE_SCOPE void TclOODeleteDescendants(Tcl_Interp *interp,
Object *oPtr);
MODULE_SCOPE void TclOODelMethodRef(Method *method);
MODULE_SCOPE Tcl_Obj * TclOOGetAllClassProperties(Class *clsPtr,
int writable, int *allocated);
MODULE_SCOPE Tcl_Obj * TclOOGetAllObjectProperties(Object *oPtr,
int writable, int *allocated);
MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
Tcl_Obj *methodNameObj, int flags,
Object *contextObjPtr, Class *contextClsPtr,
+247 -18
View File
@@ -19,7 +19,7 @@
/*
* The scripted part of the definitions of TclOO.
*
* Compiled from generic/tclOOScript.tcl by tools/makeHeader.tcl, which
* Compiled from tools/tclOOScript.tcl by tools/makeHeader.tcl, which
* contains the commented version of everything; *this* file is automatically
* generated.
*/
@@ -29,7 +29,7 @@ static const char *tclOOSetupScript =
"::namespace eval ::oo {\n"
"\t::namespace path {}\n"
"\tnamespace eval Helpers {\n"
"\t\t::namespace path {}\n"
"\t\tnamespace path {}\n"
"\t\tproc callback {method args} {\n"
"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n"
"\t\t}\n"
@@ -98,9 +98,9 @@ static const char *tclOOSetupScript =
"\t\t\tif {![info object isa class $d]} {\n"
"\t\t\t\tcontinue\n"
"\t\t\t}\n"
"\t\t\tdefine $delegate ::oo::define::superclass -append $d\n"
"\t\t\tdefine $delegate ::oo::define::superclass -appendifnew $d\n"
"\t\t}\n"
"\t\tobjdefine $class ::oo::objdefine::mixin -append $delegate\n"
"\t\tobjdefine $class ::oo::objdefine::mixin -appendifnew $delegate\n"
"\t}\n"
"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
"\t\tset originDelegate [DelegateName $originObject]\n"
@@ -141,34 +141,44 @@ static const char *tclOOSetupScript =
"\t\t::namespace delete tmp\n"
"\t}\n"
"\tdefine Slot {\n"
"\t\tmethod Get {} {\n"
"\t\tmethod Get -unexport {} {\n"
"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
"\t\tmethod Set list {\n"
"\t\tmethod Set -unexport list {\n"
"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
"\t\tmethod Resolve list {\n"
"\t\tmethod Resolve -unexport list {\n"
"\t\t\treturn $list\n"
"\t\t}\n"
"\t\tmethod -set args {\n"
"\t\tmethod -set -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\ttailcall my Set $args\n"
"\t\t}\n"
"\t\tmethod -append args {\n"
"\t\tmethod -append -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
"\t\t}\n"
"\t\tmethod -clear {} {tailcall my Set {}}\n"
"\t\tmethod -prepend args {\n"
"\t\tmethod -appendifnew -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\tset args [lmap a $args {\n"
"\t\t\t\tset a [uplevel 1 [list $my Resolve $a]]\n"
"\t\t\t\tif {$a in $current} continue\n"
"\t\t\t\tset a\n"
"\t\t\t}]\n"
"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
"\t\t}\n"
"\t\tmethod -clear -export {} {tailcall my Set {}}\n"
"\t\tmethod -prepend -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [list {*}$args {*}$current]\n"
"\t\t}\n"
"\t\tmethod -remove args {\n"
"\t\tmethod -remove -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
@@ -177,7 +187,7 @@ static const char *tclOOSetupScript =
"\t\t\t}]\n"
"\t\t}\n"
"\t\tforward --default-operation my -append\n"
"\t\tmethod unknown {args} {\n"
"\t\tmethod unknown -unexport {args} {\n"
"\t\t\tset def --default-operation\n"
"\t\t\tif {[llength $args] == 0} {\n"
"\t\t\t\ttailcall my $def\n"
@@ -186,13 +196,12 @@ static const char *tclOOSetupScript =
"\t\t\t}\n"
"\t\t\tnext {*}$args\n"
"\t\t}\n"
"\t\texport -set -append -clear -prepend -remove\n"
"\t\tunexport unknown destroy\n"
"\t\tunexport destroy\n"
"\t}\n"
"\tobjdefine define::superclass forward --default-operation my -set\n"
"\tobjdefine define::mixin forward --default-operation my -set\n"
"\tobjdefine objdefine::mixin forward --default-operation my -set\n"
"\tdefine object method <cloned> {originObject} {\n"
"\tdefine object method <cloned> -unexport {originObject} {\n"
"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
"\t\t\tset args [info args $p]\n"
"\t\t\tset idx -1\n"
@@ -219,7 +228,7 @@ static const char *tclOOSetupScript =
"\t\t\t}\n"
"\t\t}\n"
"\t}\n"
"\tdefine class method <cloned> {originObject} {\n"
"\tdefine class method <cloned> -unexport {originObject} {\n"
"\t\tnext $originObject\n"
"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
"\t}\n"
@@ -235,7 +244,7 @@ static const char *tclOOSetupScript =
"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
"\t\t\t\t\t}\n"
"\t\t\t\t\tmethod <cloned> {originObject} {\n"
"\t\t\t\t\tmethod <cloned> -unexport {originObject} {\n"
"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n"
"\t\t\t\t\t}\n"
@@ -248,6 +257,226 @@ static const char *tclOOSetupScript =
"\t\tsuperclass class\n"
"\t\tunexport create createWithNamespace new\n"
"\t}\n"
"\t::namespace eval configuresupport {\n"
"\t\tnamespace path ::tcl\n"
"\t\tproc PropertyImpl {readslot writeslot args} {\n"
"\t\t\tfor {set i 0} {$i < [llength $args]} {incr i} {\n"
"\t\t\t\tset prop [lindex $args $i]\n"
"\t\t\t\tif {[string match \"-*\" $prop]} {\n"
"\t\t\t\t\treturn -code error -level 2 \\\n"
"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not begin with -\"\n"
"\t\t\t\t}\n"
"\t\t\t\tif {$prop ne [list $prop]} {\n"
"\t\t\t\t\treturn -code error -level 2 \\\n"
"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must be a simple word\"\n"
"\t\t\t\t}\n"
"\t\t\t\tif {[string first \"::\" $prop] != -1} {\n"
"\t\t\t\t\treturn -code error -level 2 \\\n"
"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not contain namespace separators\"\n"
"\t\t\t\t}\n"
"\t\t\t\tif {[string match {*[()]*} $prop]} {\n"
"\t\t\t\t\treturn -code error -level 2 \\\n"
"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not contain parentheses\"\n"
"\t\t\t\t}\n"
"\t\t\t\tset realprop [string cat \"-\" $prop]\n"
"\t\t\t\tset getter [format {::set [my varname %s]} $prop]\n"
"\t\t\t\tset setter [format {::set [my varname %s] $value} $prop]\n"
"\t\t\t\tset kind readwrite\n"
"\t\t\t\twhile {[set next [lindex $args [expr {$i + 1}]]\n"
"\t\t\t\t\t\tstring match \"-*\" $next]} {\n"
"\t\t\t\t\tset arg [lindex $args [incr i 2]]\n"
"\t\t\t\t\tswitch [prefix match -error [list -level 2 -errorcode \\\n"
"\t\t\t\t\t\t\t[list TCL LOOKUP INDEX option $next]] {-get -kind -set} $next] {\n"
"\t\t\t\t\t\t-get {\n"
"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
"\t\t\t\t\t\t\t\treturn -code error -level 2 \\\n"
"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
"\t\t\t\t\t\t\t\t\t\"missing body to go with -get option\"\n"
"\t\t\t\t\t\t\t}\n"
"\t\t\t\t\t\t\tset getter $arg\n"
"\t\t\t\t\t\t}\n"
"\t\t\t\t\t\t-set {\n"
"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
"\t\t\t\t\t\t\t\treturn -code error -level 2 \\\n"
"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
"\t\t\t\t\t\t\t\t\t\"missing body to go with -set option\"\n"
"\t\t\t\t\t\t\t}\n"
"\t\t\t\t\t\t\tset setter $arg\n"
"\t\t\t\t\t\t}\n"
"\t\t\t\t\t\t-kind {\n"
"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
"\t\t\t\t\t\t\t\treturn -code error -level 2\\\n"
"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
"\t\t\t\t\t\t\t\t\t\"missing kind value to go with -kind option\"\n"
"\t\t\t\t\t\t\t}\n"
"\t\t\t\t\t\t\tset kind [prefix match -message \"kind\" -error [list \\\n"
"\t\t\t\t\t\t\t\t\t-level 2 \\\n"
"\t\t\t\t\t\t\t\t\t-errorcode [list TCL LOOKUP INDEX kind $arg]] {\n"
"\t\t\t\t\t\t\t\treadable readwrite writable\n"
"\t\t\t\t\t\t\t} $arg]\n"
"\t\t\t\t\t\t}\n"
"\t\t\t\t\t}\n"
"\t\t\t\t}\n"
"\t\t\t\tset reader <ReadProp$realprop>\n"
"\t\t\t\tset writer <WriteProp$realprop>\n"
"\t\t\t\tswitch $kind {\n"
"\t\t\t\t\treadable {\n"
"\t\t\t\t\t\tuplevel 2 [list $readslot -append $realprop]\n"
"\t\t\t\t\t\tuplevel 2 [list $writeslot -remove $realprop]\n"
"\t\t\t\t\t\tuplevel 2 [list method $reader -unexport {} $getter]\n"
"\t\t\t\t\t}\n"
"\t\t\t\t\twritable {\n"
"\t\t\t\t\t\tuplevel 2 [list $readslot -remove $realprop]\n"
"\t\t\t\t\t\tuplevel 2 [list $writeslot -append $realprop]\n"
"\t\t\t\t\t\tuplevel 2 [list method $writer -unexport {value} $setter]\n"
"\t\t\t\t\t}\n"
"\t\t\t\t\treadwrite {\n"
"\t\t\t\t\t\tuplevel 2 [list $readslot -append $realprop]\n"
"\t\t\t\t\t\tuplevel 2 [list $writeslot -append $realprop]\n"
"\t\t\t\t\t\tuplevel 2 [list method $reader -unexport {} $getter]\n"
"\t\t\t\t\t\tuplevel 2 [list method $writer -unexport {value} $setter]\n"
"\t\t\t\t\t}\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t}\n"
"\t\tnamespace eval configurableclass {\n"
"\t\t\t::proc property args {\n"
"\t\t\t\t::oo::configuresupport::PropertyImpl \\\n"
"\t\t\t\t\t::oo::configuresupport::readableproperties \\\n"
"\t\t\t\t\t::oo::configuresupport::writableproperties {*}$args\n"
"\t\t\t}\n"
"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
"\t\t\t::namespace path ::oo::define\n"
"\t\t\t::namespace export property\n"
"\t\t}\n"
"\t\tnamespace eval configurableobject {\n"
"\t\t\t::proc property args {\n"
"\t\t\t\t::oo::configuresupport::PropertyImpl \\\n"
"\t\t\t\t\t::oo::configuresupport::objreadableproperties \\\n"
"\t\t\t\t\t::oo::configuresupport::objwritableproperties {*}$args\n"
"\t\t\t}\n"
"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
"\t\t\t::namespace path ::oo::objdefine\n"
"\t\t\t::namespace export property\n"
"\t\t}\n"
"\t\tproc ReadAll {object my} {\n"
"\t\t\tset result {}\n"
"\t\t\tforeach prop [info object properties $object -all -readable] {\n"
"\t\t\t\ttry {\n"
"\t\t\t\t\tdict set result $prop [$my <ReadProp$prop>]\n"
"\t\t\t\t} on error {msg opt} {\n"
"\t\t\t\t\tdict set opt -level 2\n"
"\t\t\t\t\treturn -options $opt $msg\n"
"\t\t\t\t} on return {msg opt} {\n"
"\t\t\t\t\tdict incr opt -level 2\n"
"\t\t\t\t\treturn -options $opt $msg\n"
"\t\t\t\t} on break {} {\n"
"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
"\t\t\t\t\t\t\"property getter for $prop did a break\"\n"
"\t\t\t\t} on continue {} {\n"
"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
"\t\t\t\t\t\t\"property getter for $prop did a continue\"\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\treturn $result\n"
"\t\t}\n"
"\t\tproc ReadOne {object my propertyName} {\n"
"\t\t\tset props [info object properties $object -all -readable]\n"
"\t\t\ttry {\n"
"\t\t\t\tset prop [prefix match -message \"property\" $props $propertyName]\n"
"\t\t\t} on error {msg} {\n"
"\t\t\t\tcatch {\n"
"\t\t\t\t\tset wps [info object properties $object -all -writable]\n"
"\t\t\t\t\tset wprop [prefix match $wps $propertyName]\n"
"\t\t\t\t\tset msg \"property \\\"$wprop\\\" is write only\"\n"
"\t\t\t\t}\n"
"\t\t\t\treturn -code error -level 2 -errorcode [list \\\n"
"\t\t\t\t\t\tTCL LOOKUP INDEX property $propertyName] $msg\n"
"\t\t\t}\n"
"\t\t\ttry {\n"
"\t\t\t\tset value [$my <ReadProp$prop>]\n"
"\t\t\t} on error {msg opt} {\n"
"\t\t\t\tdict set opt -level 2\n"
"\t\t\t\treturn -options $opt $msg\n"
"\t\t\t} on return {msg opt} {\n"
"\t\t\t\tdict incr opt -level 2\n"
"\t\t\t\treturn -options $opt $msg\n"
"\t\t\t} on break {} {\n"
"\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
"\t\t\t\t\t\"property getter for $prop did a break\"\n"
"\t\t\t} on continue {} {\n"
"\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
"\t\t\t\t\t\"property getter for $prop did a continue\"\n"
"\t\t\t}\n"
"\t\t\treturn $value\n"
"\t\t}\n"
"\t\tproc WriteMany {object my setterMap} {\n"
"\t\t\tset props [info object properties $object -all -writable]\n"
"\t\t\tforeach {prop value} $setterMap {\n"
"\t\t\t\ttry {\n"
"\t\t\t\t\tset prop [prefix match -message \"property\" $props $prop]\n"
"\t\t\t\t} on error {msg} {\n"
"\t\t\t\t\tcatch {\n"
"\t\t\t\t\t\tset rps [info object properties $object -all -readable]\n"
"\t\t\t\t\t\tset rprop [prefix match $rps $prop]\n"
"\t\t\t\t\t\tset msg \"property \\\"$rprop\\\" is read only\"\n"
"\t\t\t\t\t}\n"
"\t\t\t\t\treturn -code error -level 2 -errorcode [list \\\n"
"\t\t\t\t\t\t\tTCL LOOKUP INDEX property $prop] $msg\n"
"\t\t\t\t}\n"
"\t\t\t\ttry {\n"
"\t\t\t\t\t$my <WriteProp$prop> $value\n"
"\t\t\t\t} on error {msg opt} {\n"
"\t\t\t\t\tdict set opt -level 2\n"
"\t\t\t\t\treturn -options $opt $msg\n"
"\t\t\t\t} on return {msg opt} {\n"
"\t\t\t\t\tdict incr opt -level 2\n"
"\t\t\t\t\treturn -options $opt $msg\n"
"\t\t\t\t} on break {} {\n"
"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
"\t\t\t\t\t\t\"property setter for $prop did a break\"\n"
"\t\t\t\t} on continue {} {\n"
"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
"\t\t\t\t\t\t\"property setter for $prop did a continue\"\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\treturn\n"
"\t\t}\n"
"\t\t::oo::class create configurable {\n"
"\t\t\tprivate variable my\n"
"\t\t\tmethod configure -export args {\n"
"\t\t\t\t::if {![::info exists my]} {\n"
"\t\t\t\t\t::set my [::namespace which my]\n"
"\t\t\t\t}\n"
"\t\t\t\t::if {[::llength $args] == 0} {\n"
"\t\t\t\t\t::oo::configuresupport::ReadAll [self] $my\n"
"\t\t\t\t} elseif {[::llength $args] == 1} {\n"
"\t\t\t\t\t::oo::configuresupport::ReadOne [self] $my \\\n"
"\t\t\t\t\t\t[::lindex $args 0]\n"
"\t\t\t\t} elseif {[::llength $args] % 2 == 0} {\n"
"\t\t\t\t\t::oo::configuresupport::WriteMany [self] $my $args\n"
"\t\t\t\t} else {\n"
"\t\t\t\t\t::return -code error -errorcode {TCL WRONGARGS} \\\n"
"\t\t\t\t\t\t[::format {wrong # args: should be \"%s\"} \\\n"
"\t\t\t\t\t\t\t\"[self] configure \?-option value ...\?\"]\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\tdefinitionnamespace -instance configurableobject\n"
"\t\t\tdefinitionnamespace -class configurableclass\n"
"\t\t}\n"
"\t}\n"
"\tclass create configurable {\n"
"\t\tsuperclass class\n"
"\t\tconstructor {{definitionScript \"\"}} {\n"
"\t\t\tnext {mixin ::oo::configuresupport::configurable}\n"
"\t\t\tnext $definitionScript\n"
"\t\t}\n"
"\t\tdefinitionnamespace -class configuresupport::configurableclass\n"
"\t}\n"
"}\n"
/* !END!: Do not edit above this line. */
;
+232 -69
View File
@@ -202,6 +202,9 @@ static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static void UpdateStringOfBignum(Tcl_Obj *objPtr);
static int GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int copy, mp_int *bignumValue);
static int SetDuplicatePureObj(Tcl_Interp *interp,
Tcl_Obj *dupPtr, Tcl_Obj *objPtr,
const Tcl_ObjType *typePtr);
/*
* Prototypes for the array hash key methods.
@@ -996,7 +999,7 @@ TclDbDumpActiveObjects(
tablePtr = tsdPtr->objThreadMap;
if (tablePtr != NULL) {
fprintf(outFile, "total objects: %" TCL_Z_MODIFIER "u\n", tablePtr->numEntries);
fprintf(outFile, "total objects: %" TCL_SIZE_MODIFIER "d\n", tablePtr->numEntries);
for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr);
@@ -1050,7 +1053,7 @@ TclDbInitNewObj(
{
objPtr->refCount = 0;
objPtr->typePtr = NULL;
TclInitStringRep(objPtr, NULL, 0);
TclInitEmptyStringRep(objPtr);
#if TCL_THREADS
/*
@@ -1192,7 +1195,9 @@ Tcl_DbNewObj(
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewObj();
Tcl_Obj *objPtr;
TclNewObj(objPtr);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
@@ -1523,6 +1528,14 @@ TclObjBeingDeleted(
* Create and return a new object that is a duplicate of the argument
* object.
*
* TclDuplicatePureObj --
* Like Tcl_DuplicateObj, except that it converts the duplicate to the
* specifid typ, does not duplicate the 'bytes'
* field unless it is necessary, i.e. the duplicated Tcl_Obj provides no
* updateStringProc. This can avoid an expensive memory allocation since
* the data in the 'bytes' field of each Tcl_Obj must reside in allocated
* memory.
*
* Results:
* The return value is a pointer to a newly created Tcl_Obj. This object
* has reference count 0 and the same type, if any, as the source object
@@ -1574,6 +1587,111 @@ Tcl_DuplicateObj(
return dupPtr;
}
/*
*----------------------------------------------------------------------
*
* TclDuplicatePureObj --
*
* Duplicates a Tcl_Obj and converts the internal representation of the
* duplicate to the given type, changing neither the 'bytes' field
* nor the internal representation of the original object, and without
* duplicating the bytes field unless necessary, i.e. unless the
* duplicate provides no updateStringProc after conversion. This can
* avoid an expensive memory allocation since the data in the 'bytes'
* field of each Tcl_Obj must reside in allocated memory.
*
* Results:
* A pointer to a newly-created Tcl_Obj or NULL if there was an error.
* This object has reference count 0. Also:
*
*----------------------------------------------------------------------
*/
int SetDuplicatePureObj(
Tcl_Interp *interp,
Tcl_Obj *dupPtr,
Tcl_Obj *objPtr,
const Tcl_ObjType *typePtr)
{
char *bytes = objPtr->bytes;
int status = TCL_OK;
TclInvalidateStringRep(dupPtr);
assert(dupPtr->typePtr == NULL);
if (objPtr->typePtr && objPtr->typePtr->dupIntRepProc) {
objPtr->typePtr->dupIntRepProc(objPtr, dupPtr);
} else {
dupPtr->internalRep = objPtr->internalRep;
dupPtr->typePtr = objPtr->typePtr;
}
if (typePtr != NULL && dupPtr->typePtr != typePtr) {
if (bytes) {
dupPtr->bytes = bytes;
dupPtr->length = objPtr->length;
}
/* borrow bytes from original object */
status = Tcl_ConvertToType(interp, dupPtr, typePtr);
if (bytes) {
dupPtr->bytes = NULL;
dupPtr->length = 0;
}
if (status != TCL_OK) {
return status;
}
}
/* tclStringType is treated as a special case because a Tcl_Obj having this
* type can not always update the string representation. This happens, for
* example, when Tcl_GetCharLength() converts the internal representation
* to tclStringType in order to store the number of characters, but does
* not store enough information to generate the string representation.
*
* Perhaps in the future this can be remedied and this special treatment
* removed.
*/
if (bytes && (dupPtr->typePtr == NULL
|| dupPtr->typePtr->updateStringProc == NULL
|| typePtr == &tclStringType
)
) {
if (!TclAttemptInitStringRep(dupPtr, bytes, objPtr->length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"insufficient memory to initialize string", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
status = TCL_ERROR;
}
}
return status;
}
Tcl_Obj *
TclDuplicatePureObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
const Tcl_ObjType *typePtr
) /* The object to duplicate. */
{
int status;
Tcl_Obj *dupPtr;
TclNewObj(dupPtr);
status = SetDuplicatePureObj(interp, dupPtr, objPtr, typePtr);
if (status == TCL_OK) {
return dupPtr;
} else {
Tcl_DecrRefCount(dupPtr);
return NULL;
}
}
void
TclSetDuplicateObj(
Tcl_Obj *dupPtr,
@@ -1586,6 +1704,80 @@ TclSetDuplicateObj(
TclFreeInternalRep(dupPtr);
SetDuplicateObj(dupPtr, objPtr);
}
/*
*----------------------------------------------------------------------
*
* TclObjGetScaler --
*
* Without perturbing any existing internal represenation, returns objPtr
* itself if it has an internal scalar type, is the empty list, or if the
* Tcl_Obj is list a containing only one scalar element, tries to returns
* scalar Tcl_Obj from that one item.
*
* Returns NULL if the Tcl_Obj is not scalar.
*
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclObjGetScalar(Tcl_Obj *objPtr)
{
Tcl_ObjType const *typePtr = objPtr->typePtr;
if (typePtr == &tclDictType) {
if (TclDictGetSize(objPtr) == 0) {
return objPtr;
} else {
return NULL;
}
}
if (TclHasInternalRep(objPtr, NULL) && objPtr->bytes != &tclEmptyString) {
void *ClientDataPtr;
int numTypePtr;
if (Tcl_GetNumberFromObj(NULL, objPtr, &ClientDataPtr, &numTypePtr) != TCL_OK) {
Tcl_Size length;
/* convert to list */
Tcl_ListObjLength(NULL, objPtr, &length);
}
}
if (typePtr == &tclIntType.objType
|| typePtr == &tclDoubleType.objType
|| typePtr == &tclBignumType.objType
) {
return objPtr;
}
if (typePtr == &tclListType.objType) {
if (TclListObjIsCanonical(objPtr)) {
Tcl_Size objc;
TclListObjLengthM(NULL, objPtr, &objc);
if (objc == 1) {
Tcl_Obj *elem, *elem2;
Tcl_IncrRefCount(objPtr);
elem = TclListObjGetElement(objPtr, 0);
Tcl_IncrRefCount(elem);
Tcl_DecrRefCount(objPtr);
elem2 = TclObjGetScalar(elem);
if (elem2) {
Tcl_IncrRefCount(elem2);
Tcl_DecrRefCount(elem);
TclUndoRefCount(elem2);
} else {
Tcl_DecrRefCount(elem);
}
return elem2;
} else if (objc == 0) {
return objPtr;
}
} else {
return NULL;
}
}
if (TclCheckEmptyString(objPtr)) {
return objPtr;
}
return NULL;
}
/*
*----------------------------------------------------------------------
@@ -1665,52 +1857,7 @@ Tcl_GetString(
*----------------------------------------------------------------------
*/
#if !defined(TCL_NO_DEPRECATED)
char *
TclGetStringFromObj(
Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
* be returned. */
void *lengthPtr) /* If non-NULL, the location where the string
* rep's byte array length should * be stored.
* If NULL, no length is stored. */
{
if (objPtr->bytes == NULL) {
/*
* Note we do not check for objPtr->typePtr == NULL. An invariant
* of a properly maintained Tcl_Obj is that at least one of
* objPtr->bytes and objPtr->typePtr must not be NULL. If broken
* extensions fail to maintain that invariant, we can crash here.
*/
if (objPtr->typePtr->updateStringProc == NULL) {
/*
* Those Tcl_ObjTypes which choose not to define an
* updateStringProc must be written in such a way that
* (objPtr->bytes) never becomes NULL.
*/
Tcl_Panic("UpdateStringProc should not be invoked for type %s",
objPtr->typePtr->name);
}
objPtr->typePtr->updateStringProc(objPtr);
if (objPtr->bytes == NULL || objPtr->length == TCL_INDEX_NONE
|| objPtr->bytes[objPtr->length] != '\0') {
Tcl_Panic("UpdateStringProc for type '%s' "
"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 'Tcl_Size'");
}
*(int *)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
@@ -1806,7 +1953,7 @@ Tcl_InitStringRep(
if (objPtr->bytes == NULL) {
/* Start with no string rep */
if (numBytes == 0) {
TclInitStringRep(objPtr, NULL, 0);
TclInitEmptyStringRep(objPtr);
return objPtr->bytes;
} else {
objPtr->bytes = (char *)Tcl_AttemptAlloc(numBytes + 1);
@@ -1833,7 +1980,7 @@ Tcl_InitStringRep(
/* Start with non-empty string rep (allocated) */
if (numBytes == 0) {
Tcl_Free(objPtr->bytes);
TclInitStringRep(objPtr, NULL, 0);
TclInitEmptyStringRep(objPtr);
return objPtr->bytes;
} else {
objPtr->bytes = (char *)Tcl_AttemptRealloc(objPtr->bytes,
@@ -1901,8 +2048,9 @@ Tcl_HasStringRep(
* Called to set the object's internal representation to match a
* particular type.
*
* It is the caller's resonsibility to ensure that the given IntRep is
* appropriate for the existing string.
* It is the caller's responsibility to guarantee that
* the value of the submitted internalrep is in agreement with
* the value of any existing string rep.
*
* Results:
* None.
@@ -1918,16 +2066,14 @@ void
Tcl_StoreInternalRep(
Tcl_Obj *objPtr, /* Object whose internal rep should be set. */
const Tcl_ObjType *typePtr, /* New type for the object */
const Tcl_ObjInternalRep *irPtr) /* New IntRep for the object */
const Tcl_ObjInternalRep *irPtr) /* New internalrep for the object */
{
/* Clear out any existing IntRep. This is the point where shimmering, i.e.
* repeated alteration of the type of the internal representation, may
* occur. */
/* Clear out any existing internalrep ( "shimmer" ) */
TclFreeInternalRep(objPtr);
/* When irPtr == NULL, just leave objPtr with no IntRep for typePtr */
/* When irPtr == NULL, just leave objPtr with no internalrep for typePtr */
if (irPtr) {
/* Copy the new IntRep into place */
/* Copy the new internalrep into place */
objPtr->internalRep = *irPtr;
/* Set the type to match */
@@ -2005,7 +2151,6 @@ Tcl_FreeInternalRep(
*----------------------------------------------------------------------
*/
#undef Tcl_GetBoolFromObj
int
Tcl_GetBoolFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
@@ -2075,7 +2220,6 @@ Tcl_GetBoolFromObj(
return TCL_ERROR;
}
#undef Tcl_GetBooleanFromObj
int
Tcl_GetBooleanFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
@@ -2163,8 +2307,8 @@ ParseBoolean(
if ((length == 0) || (length > 5)) {
/*
* Longest valid boolean string rep. is "false".
*/
* Longest valid boolean string rep. is "false".
*/
return TCL_ERROR;
}
@@ -2292,7 +2436,6 @@ ParseBoolean(
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewDoubleObj
Tcl_Obj *
Tcl_NewDoubleObj(
@@ -2769,7 +2912,6 @@ Tcl_GetLongFromObj(
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewWideIntObj
Tcl_Obj *
Tcl_NewWideIntObj(
@@ -3286,7 +3428,6 @@ UpdateStringOfBignum(
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewBignumObj
Tcl_Obj *
Tcl_NewBignumObj(
@@ -3398,7 +3539,7 @@ GetBignumFromObj(
* bignum values are converted to empty string.
*/
if (objPtr->bytes == NULL) {
TclInitStringRep(objPtr, NULL, 0);
TclInitEmptyStringRep(objPtr);
}
}
return TCL_OK;
@@ -3707,7 +3848,7 @@ Tcl_IncrRefCount(
* Decrements the reference count of the object.
*
* Results:
* None.
* The storage for objPtr may be freed.
*
*----------------------------------------------------------------------
*/
@@ -3722,6 +3863,28 @@ Tcl_DecrRefCount(
}
}
/*
*----------------------------------------------------------------------
*
* TclUndoRefCount --
*
* Decrement the refCount of objPtr without causing it to be freed if it
* drops from 1 to 0. This allows a function increment a refCount but
* then decrement it and still be able to pass return it to a caller,
* possibly with a refCount of 0. The caller must have previously
* incremented the refCount.
*
*----------------------------------------------------------------------
*/
void
TclUndoRefCount(
Tcl_Obj *objPtr) /* The object we are releasing a reference to. */
{
if (objPtr->refCount > 0) {
--objPtr->refCount;
}
}
/*
*----------------------------------------------------------------------
*
@@ -3740,7 +3903,7 @@ int
Tcl_IsShared(
Tcl_Obj *objPtr) /* The object to test for being shared. */
{
return ((objPtr)->refCount + 1 > 2);
return ((objPtr)->refCount > 1);
}
/*
@@ -4183,7 +4346,7 @@ TclHashObjKey(
* See [tcl-Feature Request #2958832]
*/
if (length) {
if (length > 0) {
result = UCHAR(*string);
while (--length) {
result += (result << 3) + UCHAR(*++string);
+2 -20
View File
@@ -871,18 +871,6 @@ TclParseBackslash(
* No hexdigits -> This is just "u".
*/
result = 'u';
#if TCL_UTF_MAX < 4
} else if (((result & 0xFC00) == 0xD800) && (count == 6)
&& (p[5] == '\\') && (p[6] == 'u') && (numBytes >= 10)) {
/* If high surrogate is immediately followed by a low surrogate
* escape, combine them into one character. */
int low;
int count2 = ParseHex(p+7, 4, &low);
if ((count2 == 4) && ((low & 0xFC00) == 0xDC00)) {
result = ((result & 0x3FF)<<10 | (low & 0x3FF)) + 0x10000;
count += count2 + 2;
}
#endif
}
break;
case 'U':
@@ -938,13 +926,13 @@ TclParseBackslash(
*/
if (Tcl_UtfCharComplete(p, numBytes - 1)) {
count = TclUtfToUCS4(p, &unichar) + 1; /* +1 for '\' */
count = Tcl_UtfToUniChar(p, &unichar) + 1; /* +1 for '\' */
} else {
char utfBytes[8];
memcpy(utfBytes, p, numBytes - 1);
utfBytes[numBytes - 1] = '\0';
count = TclUtfToUCS4(utfBytes, &unichar) + 1;
count = Tcl_UtfToUniChar(utfBytes, &unichar) + 1;
}
result = unichar;
break;
@@ -955,12 +943,6 @@ TclParseBackslash(
*readPtr = count;
}
count = Tcl_UniCharToUtf(result, dst);
#if TCL_UTF_MAX < 4
if ((result >= 0xD800) && (count < 3)) {
/* Special case for handling high surrogates. */
count += Tcl_UniCharToUtf(-1, dst + count);
}
#endif
return count;
}
+8 -3
View File
@@ -2330,10 +2330,15 @@ UpdateStringOfFsPath(
Tcl_Obj *copy;
if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) {
Tcl_Panic("Called UpdateStringOfFsPath with invalid object");
if (fsPathPtr->translatedPathPtr == NULL) {
Tcl_Panic("Called UpdateStringOfFsPath with invalid object");
} else {
copy = Tcl_DuplicateObj(fsPathPtr->translatedPathPtr);
}
} else {
copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr);
}
copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr);
if (Tcl_IsShared(copy)) {
copy = Tcl_DuplicateObj(copy);
}
@@ -2342,7 +2347,7 @@ UpdateStringOfFsPath(
/* Steal copy's string rep */
pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen);
pathPtr->length = cwdLen;
TclInitStringRep(copy, NULL, 0);
TclInitEmptyStringRep(copy);
TclDecrRefCount(copy);
}
+1 -90
View File
@@ -48,93 +48,6 @@
# endif
#endif
#if TCL_MAJOR_VERSION < 9
#ifdef __cplusplus
extern "C" {
#endif
/*
* Exported function declarations:
*/
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
/* 0 */
EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len,
Tcl_DString *dsPtr);
/* 1 */
EXTERN char * Tcl_WinTCharToUtf(const TCHAR *str, int len,
Tcl_DString *dsPtr);
/* Slot 2 is reserved */
/* 3 */
EXTERN void Tcl_WinConvertError(unsigned errCode);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 0 */
EXTERN int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
const char *bundleName, int hasResourceFile,
int maxPathLen, char *libraryPath);
/* 1 */
EXTERN int Tcl_MacOSXOpenVersionedBundleResources(
Tcl_Interp *interp, const char *bundleName,
const char *bundleVersion,
int hasResourceFile, int maxPathLen,
char *libraryPath);
/* 2 */
EXTERN void Tcl_MacOSXNotifierAddRunLoopMode(
const void *runLoopMode);
#endif /* MACOSX */
typedef struct TclPlatStubs {
int magic;
void *hooks;
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */
char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */
void (*reserved2)(void);
void (*tcl_WinConvertError) (unsigned errCode); /* 3 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */
int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath); /* 1 */
void (*tcl_MacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 2 */
#endif /* MACOSX */
} TclPlatStubs;
extern const TclPlatStubs *tclPlatStubsPtr;
#ifdef __cplusplus
}
#endif
#if defined(USE_TCL_STUBS)
/*
* Inline function declarations:
*/
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
#define Tcl_WinUtfToTChar \
(tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */
#define Tcl_WinTCharToUtf \
(tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */
/* Slot 2 is reserved */
#define Tcl_WinConvertError \
(tclPlatStubsPtr->tcl_WinConvertError) /* 3 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
#define Tcl_MacOSXOpenBundleResources \
(tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */
#define Tcl_MacOSXOpenVersionedBundleResources \
(tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */
#define Tcl_MacOSXNotifierAddRunLoopMode \
(tclPlatStubsPtr->tcl_MacOSXNotifierAddRunLoopMode) /* 2 */
#endif /* MACOSX */
#endif /* defined(USE_TCL_STUBS) */
#else /* TCL_MAJOR_VERSION > 8 */
/* !BEGIN!: Do not edit below this line. */
@@ -193,7 +106,6 @@ extern const TclPlatStubs *tclPlatStubsPtr;
/* !END!: Do not edit above this line. */
#endif /* TCL_MAJOR_VERSION */
#ifdef MAC_OSX_TCL /* MACOSX */
#undef Tcl_MacOSXOpenBundleResources
@@ -213,8 +125,7 @@ extern const TclPlatStubs *tclPlatStubsPtr;
# undef Tcl_MacOSXNotifierAddRunLoopMode
#endif
#if defined(USE_TCL_STUBS) && (defined(_WIN32) || defined(__CYGWIN__))\
&& (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8)
#if defined(USE_TCL_STUBS) && (defined(_WIN32) || defined(__CYGWIN__))
#undef Tcl_WinUtfToTChar
#undef Tcl_WinTCharToUtf
#ifdef _WIN32
+1 -1
View File
@@ -495,7 +495,7 @@ Tcl_SetErrorCode(
*/
va_start(argList, interp);
errorObj = Tcl_NewObj();
TclNewObj(errorObj);
/*
* Scan through the arguments one at a time, appending them to the
+3 -2
View File
@@ -903,7 +903,7 @@ Tcl_ScanObjCmd(
* Scan a single Unicode character.
*/
offset = TclUtfToUCS4(string, &i);
offset = Tcl_UtfToUniChar(string, &i);
string += offset;
if (!(flags & SCAN_SUPPRESS)) {
TclNewIntObj(objPtr, i);
@@ -1097,7 +1097,8 @@ Tcl_ScanObjCmd(
* We create an empty Tcl_Obj to fill missing values rather than
* allocating a new Tcl_Obj every time. See test scan-bigdata-XX.
*/
Tcl_Obj *emptyObj = Tcl_NewObj();
Tcl_Obj *emptyObj;
TclNewObj(emptyObj);
Tcl_IncrRefCount(emptyObj);
TclNewObj(objPtr);
for (i = 0; code == TCL_OK && i < totalVars; i++) {
+68 -216
View File
@@ -59,24 +59,14 @@ static void ExtendUnicodeRepWithString(Tcl_Obj *objPtr,
Tcl_Size numAppendChars);
static void FillUnicodeRep(Tcl_Obj *objPtr);
static void FreeStringInternalRep(Tcl_Obj *objPtr);
static void GrowStringBuffer(Tcl_Obj *objPtr, size_t needed, int flag);
static void GrowUnicodeBuffer(Tcl_Obj *objPtr, size_t needed);
static void GrowStringBuffer(Tcl_Obj *objPtr, Tcl_Size needed, int flag);
static void GrowUnicodeBuffer(Tcl_Obj *objPtr, Tcl_Size needed);
static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void SetUnicodeObj(Tcl_Obj *objPtr,
const Tcl_UniChar *unicode, Tcl_Size numChars);
static Tcl_Size UnicodeLength(const Tcl_UniChar *unicode);
static void UpdateStringOfString(Tcl_Obj *objPtr);
#if TCL_UTF_MAX > 3
#define ISCONTINUATION(bytes) (\
((bytes)[0] & 0xC0) == 0x80)
#else
#define ISCONTINUATION(bytes) (\
((((bytes)[0] & 0xC0) == 0x80) || (((bytes)[0] == '\xED') \
&& (((bytes)[1] & 0xF0) == 0xB0) && (((bytes)[2] & 0xC0) == 0x80))))
#endif
/*
* The structure below defines the string Tcl object type by means of
* functions that can be invoked by generic object code.
@@ -131,8 +121,8 @@ const Tcl_ObjType tclStringType = {
static void
GrowStringBuffer(
Tcl_Obj *objPtr,
size_t needed,
int flag)
Tcl_Size needed, /* Not including terminating nul */
int flag) /* If 0, try to overallocate */
{
/*
* Preconditions:
@@ -142,45 +132,35 @@ GrowStringBuffer(
*/
String *stringPtr = GET_STRING(objPtr);
char *ptr = NULL;
size_t attempt;
char *ptr;
Tcl_Size capacity;
assert(needed <= TCL_SIZE_MAX - 1);
needed += 1; /* Include terminating nul */
if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = NULL;
}
/*
* In code below, note 'capacity' and 'needed' include terminating nul,
* while stringPtr->allocated does not.
*/
if (flag == 0 || stringPtr->allocated > 0) {
attempt = 2 * needed;
ptr = (char *)Tcl_AttemptRealloc(objPtr->bytes, attempt + 1U);
if (ptr == NULL) {
/*
* Take care computing the amount of modest growth to avoid
* overflow into invalid argument values for attempt.
*/
size_t limit = INT_MAX - needed;
size_t extra = needed - objPtr->length + TCL_MIN_GROWTH;
size_t growth = (extra > limit) ? limit : extra;
attempt = needed + growth;
ptr = (char *)Tcl_AttemptRealloc(objPtr->bytes, attempt + 1U);
}
ptr = (char *)TclReallocEx(objPtr->bytes, needed, &capacity);
} else {
/* Allocate exact size */
ptr = (char *)Tcl_Realloc(objPtr->bytes, needed);
capacity = needed;
}
if (ptr == NULL) {
/*
* First allocation - just big enough; or last chance fallback.
*/
attempt = needed;
ptr = (char *)Tcl_Realloc(objPtr->bytes, attempt + 1U);
}
objPtr->bytes = ptr;
stringPtr->allocated = attempt;
stringPtr->allocated = capacity - 1; /* Does not include slot for end nul */
}
static void
GrowUnicodeBuffer(
Tcl_Obj *objPtr,
size_t needed)
Tcl_Size needed)
{
/*
* Preconditions:
@@ -188,39 +168,32 @@ GrowUnicodeBuffer(
* needed > stringPtr->maxChars
*/
String *ptr = NULL, *stringPtr = GET_STRING(objPtr);
size_t attempt;
String *stringPtr = GET_STRING(objPtr);
Tcl_Size maxChars;
/* Note STRING_MAXCHARS already takes into account space for nul */
if (needed > STRING_MAXCHARS) {
Tcl_Panic("max size for a Tcl unicode rep (%" TCL_Z_MODIFIER "d bytes) exceeded",
STRING_MAXCHARS);
}
if (stringPtr->maxChars > 0) {
/*
* Subsequent appends - apply the growth algorithm.
*/
attempt = 2 * needed;
ptr = stringAttemptRealloc(stringPtr, attempt);
if (ptr == NULL) {
/*
* Take care computing the amount of modest growth to avoid
* overflow into invalid argument values for attempt.
*/
size_t extra = needed - stringPtr->numChars
+ TCL_MIN_UNICHAR_GROWTH;
attempt = needed + extra;
ptr = stringAttemptRealloc(stringPtr, attempt);
}
/* Expansion - try allocating extra space */
stringPtr = (String *)TclReallocElemsEx(stringPtr,
needed + 1, /* +1 for nul */
sizeof(Tcl_UniChar),
offsetof(String, unicode),
&maxChars);
maxChars -= 1; /* End nul not included */
}
if (ptr == NULL) {
else {
/*
* First allocation - just big enough; or last chance fallback.
* First allocation - just big enough. Note needed does
* not include terminating nul but STRING_SIZE does
*/
attempt = needed;
ptr = stringRealloc(stringPtr, attempt);
stringPtr = (String *)Tcl_Realloc(stringPtr, STRING_SIZE(needed));
maxChars = needed;
}
stringPtr = ptr;
stringPtr->maxChars = attempt;
stringPtr->maxChars = maxChars;
SET_STRING(objPtr, stringPtr);
}
@@ -606,28 +579,12 @@ Tcl_GetUniChar(
return -1;
}
ch = stringPtr->unicode[index];
#if TCL_UTF_MAX < 4
/* See: bug [11ae2be95dac9417] */
if ((ch & 0xF800) == 0xD800) {
if (ch & 0x400) {
if ((index > 0)
&& ((stringPtr->unicode[index-1] & 0xFC00) == 0xD800)) {
ch = -1; /* low surrogate preceded by high surrogate */
}
} else if ((++index < stringPtr->numChars)
&& ((stringPtr->unicode[index] & 0xFC00) == 0xDC00)) {
/* high surrogate followed by low surrogate */
ch = (((ch & 0x3FF) << 10) |
(stringPtr->unicode[index] & 0x3FF)) + 0x10000;
}
}
#endif
return ch;
}
int
TclGetUniChar(
Tcl_Obj *objPtr, /* The object to get the Unicode charater
Tcl_Obj *objPtr, /* The object to get the Unicode character
* from. */
Tcl_Size index) /* Get the index'th Unicode character. */
{
@@ -683,36 +640,6 @@ TclGetUniChar(
*/
#undef Tcl_GetUnicodeFromObj
#if !defined(TCL_NO_DEPRECATED)
Tcl_UniChar *
TclGetUnicodeFromObj(
Tcl_Obj *objPtr, /* The object to find the Unicode string
* for. */
void *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 'Tcl_Size'");
}
*(int *)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
@@ -768,7 +695,7 @@ Tcl_GetRange(
Tcl_Size length = 0;
if (first < 0) {
first = TCL_INDEX_START;
first = 0;
}
/*
@@ -833,18 +760,6 @@ Tcl_GetRange(
TclNewObj(newObjPtr);
return newObjPtr;
}
#if TCL_UTF_MAX < 4
/* See: bug [11ae2be95dac9417] */
if ((first > 0) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00)
&& ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) {
++first;
}
if ((last + 1 < stringPtr->numChars)
&& ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00)
&& ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) {
++last;
}
#endif
return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1);
}
@@ -1099,9 +1014,9 @@ Tcl_AttemptSetObjLength(
char *newBytes;
if (objPtr->bytes == &tclEmptyString) {
newBytes = (char *)Tcl_AttemptAlloc(length + 1);
newBytes = (char *)Tcl_AttemptAlloc(length + 1U);
} else {
newBytes = (char *)Tcl_AttemptRealloc(objPtr->bytes, length + 1);
newBytes = (char *)Tcl_AttemptRealloc(objPtr->bytes, length + 1U);
}
if (newBytes == NULL) {
return 0;
@@ -1300,13 +1215,7 @@ Tcl_AppendLimitedToObj(
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
/* If appended string starts with a continuation byte or a lower surrogate,
* force objPtr to unicode representation. See [7f1162a867] */
if (bytes && ISCONTINUATION(bytes)) {
Tcl_GetUnicode(objPtr);
stringPtr = GET_STRING(objPtr);
}
if (stringPtr->hasUnicode && (stringPtr->numChars+1) > 1) {
if (stringPtr->hasUnicode && (stringPtr->numChars) > 0) {
AppendUtfToUnicodeRep(objPtr, bytes, toCopy);
} else {
AppendUtfToUtfRep(objPtr, bytes, toCopy);
@@ -1317,7 +1226,7 @@ Tcl_AppendLimitedToObj(
}
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode && (stringPtr->numChars+1) > 1) {
if (stringPtr->hasUnicode && (stringPtr->numChars) > 0) {
AppendUtfToUnicodeRep(objPtr, ellipsis, eLen);
} else {
AppendUtfToUtfRep(objPtr, ellipsis, eLen);
@@ -1505,13 +1414,6 @@ Tcl_AppendObjToObj(
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
/* If appended string starts with a continuation byte or a lower surrogate,
* force objPtr to unicode representation. See [7f1162a867]
* This fixes append-3.4, append-3.7 and utf-1.18 testcases. */
if (ISCONTINUATION(TclGetString(appendObjPtr))) {
Tcl_GetUnicode(objPtr);
stringPtr = GET_STRING(objPtr);
}
/*
* If objPtr has a valid Unicode rep, then get a Unicode string from
* appendObjPtr and append it.
@@ -1966,7 +1868,7 @@ Tcl_AppendFormatToObj(
}
gotSequential = 1;
}
if (objIndex < 0 || objIndex >= objc) {
if ((objIndex < 0) || (objIndex >= objc)) {
msg = badIndex[gotXpg];
errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
goto errorMsg;
@@ -2174,12 +2076,6 @@ Tcl_AppendFormatToObj(
code = 0xFFFD;
}
length = Tcl_UniCharToUtf(code, buf);
#if TCL_UTF_MAX < 4
if ((code >= 0xD800) && (length < 3)) {
/* Special case for handling high surrogates. */
length += Tcl_UniCharToUtf(-1, buf + length);
}
#endif
segment = Tcl_NewStringObj(buf, length);
Tcl_IncrRefCount(segment);
allocSegment = 1;
@@ -2555,7 +2451,7 @@ Tcl_AppendFormatToObj(
goto errorMsg;
}
bytes = TclGetString(segment);
if (!Tcl_AttemptSetObjLength(segment, sprintf(bytes, spec, d))) {
if (!Tcl_AttemptSetObjLength(segment, snprintf(bytes, segment->length, spec, d))) {
msg = overflow;
errCode = "OVERFLOW";
goto errorMsg;
@@ -3112,7 +3008,6 @@ TclStringRepeat(
(count - done) * length);
}
return objResultPtr;
}
/*
@@ -3142,7 +3037,7 @@ TclStringCat(
Tcl_Obj *objResultPtr, * const *ov;
int binary = 1;
Tcl_Size oc, length = 0;
int allowUniChar = 1, requestUniChar = 0, forceUniChar = 0;
int allowUniChar = 1, requestUniChar = 0;
Tcl_Size first = objc - 1; /* Index of first value possibly not empty */
Tcl_Size last = 0; /* Index of last value possibly not empty */
int inPlace = (flags & TCL_STRING_IN_PLACE) && !Tcl_IsShared(*objv);
@@ -3150,8 +3045,14 @@ TclStringCat(
/* assert ( objc >= 0 ) */
if (objc <= 1) {
/* Negative (shouldn't be), one or no objects; return first or empty */
return objc == 1 ? objv[0] : Tcl_NewObj();
if (objc != 1) {
/* Negative (shouldn't be) no objects; return empty */
Tcl_Obj *obj;
TclNewObj(obj);
return obj;
}
/* One object; return first */
return objv[0];
}
/* assert ( objc >= 2 ) */
@@ -3178,9 +3079,7 @@ TclStringCat(
*/
binary = 0;
if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) {
forceUniChar = 1;
} else if ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) {
if ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) {
/* Prevent shimmer of non-string types. */
allowUniChar = 0;
}
@@ -3230,7 +3129,7 @@ TclStringCat(
}
}
} while (--oc);
} else if ((allowUniChar && requestUniChar) || forceUniChar) {
} else if ((allowUniChar && requestUniChar)) {
/*
* Result will be pure Tcl_UniChar array. Pre-size it.
*/
@@ -3387,7 +3286,7 @@ TclStringCat(
dst += more;
}
}
} else if ((allowUniChar && requestUniChar) || forceUniChar) {
} else if ((allowUniChar && requestUniChar)) {
/* Efficiently produce a pure Tcl_UniChar array result */
Tcl_UniChar *dst;
@@ -3451,7 +3350,7 @@ TclStringCat(
if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"concatenation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes",
"concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes",
length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
@@ -3467,7 +3366,7 @@ TclStringCat(
Tcl_DecrRefCount(objResultPtr);
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"concatenation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes",
"concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes",
length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
@@ -3579,7 +3478,7 @@ TclStringCmp(
s1 = (char *) Tcl_GetUnicode(value1Ptr);
s2 = (char *) Tcl_GetUnicode(value2Ptr);
if (
#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3)
#if defined(WORDS_BIGENDIAN)
1
#else
checkEq
@@ -3592,7 +3491,7 @@ TclStringCmp(
reqlength *= sizeof(Tcl_UniChar);
}
} else {
memCmpFn = (memCmpFn_t) TclUniCharNcmp;
memCmpFn = (memCmpFn_t)(void *)TclUniCharNcmp;
}
}
}
@@ -3650,11 +3549,11 @@ TclStringCmp(
*/
if ((reqlength < 0) && !nocase) {
memCmpFn = (memCmpFn_t) TclpUtfNcmp2;
memCmpFn = (memCmpFn_t)(void *)TclpUtfNcmp2;
} else {
s1len = Tcl_NumUtfChars(s1, s1len);
s2len = Tcl_NumUtfChars(s2, s2len);
memCmpFn = (memCmpFn_t)
memCmpFn = (memCmpFn_t)(void *)
(nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp);
}
}
@@ -3939,9 +3838,6 @@ TclStringReverse(
String *stringPtr;
Tcl_UniChar ch = 0;
int inPlace = flags & TCL_STRING_IN_PLACE;
#if TCL_UTF_MAX < 4
int needFlip = 0;
#endif
if (TclIsPureByteArray(objPtr)) {
Tcl_Size numBytes = 0;
@@ -3974,54 +3870,19 @@ TclStringReverse(
to = Tcl_GetUnicode(objPtr);
stringPtr = GET_STRING(objPtr);
while (--src >= from) {
#if TCL_UTF_MAX < 4
ch = *src;
if ((ch & 0xF800) == 0xD800) {
needFlip = 1;
}
*to++ = ch;
#else
*to++ = *src;
#endif
}
} else {
/*
* Reversing in place.
*/
#if TCL_UTF_MAX < 4
to = src;
#endif
while (--src > from) {
ch = *src;
#if TCL_UTF_MAX < 4
if ((ch & 0xF800) == 0xD800) {
needFlip = 1;
}
#endif
*src = *from;
*from++ = ch;
}
}
#if TCL_UTF_MAX < 4
if (needFlip) {
/*
* Flip back surrogate pairs.
*/
from = to - stringPtr->numChars;
while (--to >= from) {
ch = *to;
if ((ch & 0xFC00) == 0xD800) {
if ((to-1 >= from) && ((to[-1] & 0xFC00) == 0xDC00)) {
to[0] = to[-1];
to[-1] = ch;
--to;
}
}
}
}
#endif
}
if (objPtr->bytes) {
@@ -4055,7 +3916,7 @@ TclStringReverse(
* skip calling Tcl_UtfCharComplete() here.
*/
int bytesInChar = TclUtfToUCS4(from, &chw);
int bytesInChar = Tcl_UtfToUniChar(from, &chw);
ReverseBytes((unsigned char *)to, (unsigned char *)from,
bytesInChar);
@@ -4321,7 +4182,6 @@ DupStringInternalRep(
* bother copying it. Don't even bother allocating space in which to
* copy it. Just let the copy be untyped.
*/
return;
}
@@ -4444,7 +4304,7 @@ UpdateStringOfString(
stringPtr->allocated = 0;
if (stringPtr->numChars == 0) {
TclInitStringRep(objPtr, NULL, 0);
TclInitEmptyStringRep(objPtr);
} else {
(void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode,
stringPtr->numChars);
@@ -4505,14 +4365,6 @@ ExtendStringRepWithUnicode(
copyBytes:
dst = objPtr->bytes + origLength;
#if TCL_UTF_MAX < 4
/* Initialize the buffer so that some random data doesn't trick
* Tcl_UniCharToUtf() into thinking it should combine surrogate pairs.
* Once TCL_UTF_MAX == 3 is removed and Tcl_UniCharToUtf restored to its
* prior non-stateful nature, this call to memset can also be removed.
*/
memset(dst, 0xff, stringPtr->allocated - origLength);
#endif
for (i = 0; i < numChars; i++) {
dst += Tcl_UniCharToUtf(unicode[i], dst);
}
+4 -3
View File
@@ -34,9 +34,10 @@ typedef struct {
* 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-8 string (minus 1 byte for the
* termination char). */
Tcl_Size allocated; /* The amount of space allocated for
* the UTF-8 string. Does not include nul
* terminator so actual allocation is
* (allocated+1). */
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
+1 -113
View File
@@ -79,16 +79,12 @@
# 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
# if TCL_UTF_MAX > 3
# define TclGetUnicodeFromObj 0
# endif
#endif
# define TclGetUnicodeFromObj 0
#undef Tcl_Close
#define Tcl_Close 0
#undef TclGetByteArrayFromObj
@@ -97,23 +93,10 @@
#define Tcl_GetByteArrayFromObj 0
#define TclUnusedStubEntry 0
#if TCL_UTF_MAX < 4
static void uniCodePanic() {
Tcl_Panic("This extension uses a deprecated function, not available now: Tcl is compiled with -DTCL_UTF_MAX==%d", TCL_UTF_MAX);
}
# define Tcl_GetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, Tcl_Size *))(void *)uniCodePanic
# define TclGetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, int *))(void *)uniCodePanic
# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const Tcl_UniChar *, Tcl_Size))(void *)uniCodePanic
# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, Tcl_Size))(void *)uniCodePanic
# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, Tcl_Size))(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
@@ -121,101 +104,6 @@ static void uniCodePanic() {
# define TclSplitPath 0
# define TclFSSplitPath 0
# define TclParseArgsObjv 0
#else /* !defined(TCL_NO_DEPRECATED) */
int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
void *objcPtr, Tcl_Obj ***objvPtr) {
Tcl_Size 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) {
Tcl_AppendResult(interp, "List too large to be processed", NULL);
}
return TCL_ERROR;
}
*(int *)objcPtr = (int)n;
}
return result;
}
int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
void *lengthPtr) {
Tcl_Size n = TCL_INDEX_NONE;
int result = Tcl_ListObjLength(interp, listPtr, &n);
if (lengthPtr) {
if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) {
if (interp) {
Tcl_AppendResult(interp, "List too large to be processed", NULL);
}
return TCL_ERROR;
}
*(int *)lengthPtr = (int)n;
}
return result;
}
int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr,
void *sizePtr) {
Tcl_Size n = TCL_INDEX_NONE;
int result = Tcl_DictObjSize(interp, dictPtr, &n);
if (sizePtr) {
if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) {
if (interp) {
Tcl_AppendResult(interp, "Dict too large to be processed", NULL);
}
return TCL_ERROR;
}
*(int *)sizePtr = (int)n;
}
return result;
}
int TclSplitList(Tcl_Interp *interp, const char *listStr, void *argcPtr,
const char ***argvPtr) {
Tcl_Size n = TCL_INDEX_NONE;
int result = Tcl_SplitList(interp, listStr, &n, argvPtr);
if (argcPtr) {
if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) {
if (interp) {
Tcl_AppendResult(interp, "List too large to be processed", NULL);
}
Tcl_Free((void *)*argvPtr);
return TCL_ERROR;
}
*(int *)argcPtr = (int)n;
}
return result;
}
void TclSplitPath(const char *path, void *argcPtr, const char ***argvPtr) {
Tcl_Size n = TCL_INDEX_NONE;
Tcl_SplitPath(path, &n, argvPtr);
if (argcPtr) {
if ((sizeof(int) != sizeof(size_t)) && (n > INT_MAX)) {
n = TCL_INDEX_NONE; /* No other way to return an error-situation */
Tcl_Free((void *)*argvPtr);
*argvPtr = NULL;
}
*(int *)argcPtr = (int)n;
}
}
Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, void *lenPtr) {
Tcl_Size n = TCL_INDEX_NONE;
Tcl_Obj *result = Tcl_FSSplitPath(pathPtr, &n);
if (lenPtr) {
if ((sizeof(int) != sizeof(size_t)) && result && (n > INT_MAX)) {
Tcl_DecrRefCount(result);
return NULL;
}
*(int *)lenPtr = (int)n;
}
return result;
}
int TclParseArgsObjv(Tcl_Interp *interp,
const Tcl_ArgvInfo *argTable, void *objcPtr, Tcl_Obj *const *objv,
Tcl_Obj ***remObjv) {
Tcl_Size n = (*(int *)objcPtr < 0) ? TCL_INDEX_NONE: (Tcl_Size)*(int *)objcPtr ;
int result = Tcl_ParseArgsObjv(interp, argTable, &n, objv, remObjv);
*(int *)objcPtr = (int)n;
return result;
}
#endif /* !defined(TCL_NO_DEPRECATED) */
#define TclBN_mp_add mp_add
#define TclBN_mp_add_d mp_add_d
+19 -32
View File
@@ -515,9 +515,6 @@ static const char version[] = TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID)
#ifdef STATIC_BUILD
".static"
#endif
#if TCL_UTF_MAX < 4
".utf-16"
#endif
;
int
@@ -546,12 +543,10 @@ Tcltest_Init(
}
if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
#if TCL_MAJOR_VERSION > 8
if (info.isNativeObjectProc == 2) {
Tcl_CreateObjCommand2(interp, "::tcl::test::build-info",
info.objProc2, (void *)version, NULL);
} else
#endif
Tcl_CreateObjCommand(interp, "::tcl::test::build-info",
info.objProc, (void *)version, NULL);
}
@@ -810,12 +805,10 @@ Tcltest_SafeInit(
return TCL_ERROR;
}
if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
#if TCL_MAJOR_VERSION > 8
if (info.isNativeObjectProc == 2) {
Tcl_CreateObjCommand2(interp, "::tcl::test::build-info",
info.objProc2, (void *)version, NULL);
} else
#endif
Tcl_CreateObjCommand(interp, "::tcl::test::build-info",
info.objProc, (void *)version, NULL);
}
@@ -1164,11 +1157,8 @@ TestcmdinfoObjCmd(
return info.objProc2(info.objClientData2, interp, cmdObjc, cmdObjv);
}
case CMDINFO_CREATE:
Tcl_CreateCommand(interp,
Tcl_GetString(objv[2]),
CmdProc1,
(void *)"original",
CmdDelProc1);
Tcl_CreateCommand(interp, Tcl_GetString(objv[2]), CmdProc1,
(void *)"original", CmdDelProc1);
break;
case CMDINFO_DELETE:
Tcl_DStringInit(&delString);
@@ -1206,10 +1196,8 @@ TestcmdinfoObjCmd(
} else if (info.isNativeObjectProc == 2) {
Tcl_AppendResult(interp, " nativeObjectProc2", NULL);
} else {
Tcl_SetObjResult(
interp,
Tcl_ObjPrintf("Invalid isNativeObjectProc value %d",
info.isNativeObjectProc));
Tcl_SetObjResult(interp, Tcl_ObjPrintf("Invalid isNativeObjectProc value %d",
info.isNativeObjectProc));
return TCL_ERROR;
}
break;
@@ -3732,7 +3720,7 @@ TestlinkarrayCmd(
static const char *LinkOption[] = {
"update", "remove", "create", NULL
};
enum LinkOptionEnum {LINK_UPDATE, LINK_REMOVE, LINK_CREATE} optionIndex;
enum LinkOptionEnum { LINK_UPDATE, LINK_REMOVE, LINK_CREATE } optionIndex;
static const char *LinkType[] = {
"char", "uchar", "short", "ushort", "int", "uint", "long", "ulong",
"wide", "uwide", "float", "double", "string", "char*", "binary", NULL
@@ -4214,7 +4202,7 @@ PrintParse(
Tcl_Size i;
objPtr = Tcl_GetObjResult(interp);
if (parsePtr->commentSize + 1 > 1) {
if (parsePtr->commentSize > 0) {
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(parsePtr->commentStart,
parsePtr->commentSize));
@@ -4652,15 +4640,15 @@ TestregexpObjCmd(
end--;
}
objs[0] = Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(start + 1U)) - 1);
objs[1] = Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(end + 1U)) - 1);
objs[0] = Tcl_NewWideIntObj(start);
objs[1] = Tcl_NewWideIntObj(end);
newPtr = Tcl_NewListObj(2, objs);
} else {
if (ii == TCL_INDEX_NONE) {
TclRegExpRangeUniChar(regExpr, ii, &start, &end);
newPtr = Tcl_GetRange(objPtr, start, end);
} else if (ii > info.nsubs || info.matches[ii].end + 1 <= 1) {
} else if (ii > info.nsubs || info.matches[ii].end <= 0) {
newPtr = Tcl_NewObj();
} else {
newPtr = Tcl_GetRange(objPtr, info.matches[ii].start,
@@ -5763,11 +5751,7 @@ TestbytestringObjCmd(
Tcl_Obj *const objv[]) /* The argument objects. */
{
struct {
#if !defined(TCL_NO_DEPRECATED)
int n; /* On purpose, not Tcl_Size, in order to demonstrate what happens */
#else
Tcl_Size n;
#endif
int m; /* This variable should not be overwritten */
} x = {0, 1};
const char *p;
@@ -5781,6 +5765,10 @@ TestbytestringObjCmd(
if (p == NULL) {
return TCL_ERROR;
}
#if !defined(TCL_NO_DEPRECATED) && defined(__clang__)
# pragma clang diagnostic pop
#endif
if (x.m != 1) {
Tcl_AppendResult(interp, "Tcl_GetBytesFromObj() overwrites variable", NULL);
return TCL_ERROR;
@@ -7518,7 +7506,7 @@ TestUtfNextCmd(
}
bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
if (numBytes + 4 > (Tcl_Size) sizeof(buffer)) {
if ((size_t)numBytes > sizeof(buffer) - 4) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"testutfnext\" can only handle %" TCL_Z_MODIFIER "u bytes",
sizeof(buffer) - 4));
@@ -7689,8 +7677,7 @@ TestGetIntForIndexCmd(
if (Tcl_GetIntForIndex(interp, objv[1], endvalue, &result) != TCL_OK) {
return TCL_ERROR;
}
/* Make sure that (size_t)-2 is output as "-2" and (size_t)-3 as "-3", even for 32-bit */
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(result + 3U)) - 3));
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
return TCL_OK;
}
@@ -7930,7 +7917,7 @@ TestNRELevels(
static ptrdiff_t *refDepth = NULL;
ptrdiff_t depth;
Tcl_Obj *levels[6];
size_t i = 0;
Tcl_Size i = 0;
NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr;
if (refDepth == NULL) {
@@ -7940,9 +7927,9 @@ TestNRELevels(
depth = (refDepth - &depth);
levels[0] = Tcl_NewWideIntObj(depth);
levels[1] = Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(iPtr->numLevels + 1U)) - 1);
levels[2] = Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(iPtr->cmdFramePtr->level + 1U)) - 1);
levels[3] = Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(iPtr->varFramePtr->level + 1U)) - 1);
levels[1] = Tcl_NewWideIntObj(iPtr->numLevels);
levels[2] = Tcl_NewWideIntObj(iPtr->cmdFramePtr->level);
levels[3] = Tcl_NewWideIntObj(iPtr->varFramePtr->level);
levels[4] = Tcl_NewWideIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr
- iPtr->execEnvPtr->execStackPtr->stackWords);
+10 -8
View File
@@ -119,8 +119,10 @@ TclObjTest_Init(
Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testbigdata", TestbigdataCmd,
NULL, NULL);
if (sizeof(Tcl_Size) == sizeof(Tcl_WideInt)) {
Tcl_CreateObjCommand(interp, "testbigdata", TestbigdataCmd,
NULL, NULL);
}
return TCL_OK;
}
@@ -596,7 +598,7 @@ TestindexobjCmd(
result = Tcl_GetIndexFromObj(NULL, objv[1],
tablePtr, "token", 0, &index);
if (result == TCL_OK) {
Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (Tcl_WideInt)((Tcl_WideUInt)(index + 1U)) - 1);
Tcl_SetWideIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
@@ -624,7 +626,7 @@ TestindexobjCmd(
&index);
Tcl_Free((void *)argv);
if (result == TCL_OK) {
Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (Tcl_WideInt)((Tcl_WideUInt)(index + 1U)) - 1);
Tcl_SetWideIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
@@ -1203,7 +1205,7 @@ TestobjCmd(
if (objc != 3) {
goto wrongNumArgs;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(varPtr[varIndex]->refCount + 1U)) - 1));
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(varPtr[varIndex]->refCount));
break;
case TESTOBJ_TYPE:
if (objc != 3) {
@@ -1424,7 +1426,7 @@ TeststringobjCmd(
} else {
length = TCL_INDEX_NONE;
}
Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (Tcl_WideInt)((Tcl_WideUInt)(length + 1U)) - 1);
Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length);
break;
case 10: { /* range */
Tcl_Size first, last;
@@ -1757,10 +1759,10 @@ CheckIfVarUnset(
Tcl_Obj ** varPtr,
Tcl_Size varIndex) /* Index of the test variable to check. */
{
if (varPtr[varIndex] == NULL) {
if (varIndex < 0 || varPtr[varIndex] == NULL) {
char buf[32 + TCL_INTEGER_SPACE];
snprintf(buf, sizeof(buf), "variable %" TCL_Z_MODIFIER "u is unset (NULL)", varIndex);
snprintf(buf, sizeof(buf), "variable %" TCL_SIZE_MODIFIER "d is unset (NULL)", varIndex);
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
return 1;
+7 -7
View File
@@ -35,22 +35,22 @@
/* Define custom memory allocation for libtommath */
/* MODULE_SCOPE void* TclBNAlloc( size_t ); */
#define TclBNAlloc(s) ((void*)Tcl_Alloc(s))
#define TclBNAlloc(s) Tcl_AttemptAlloc((size_t)(s))
/* MODULE_SCOPE void* TclBNCalloc( size_t, size_t ); */
#define TclBNCalloc(m,s) memset(Tcl_Alloc((size_t)(m)*(size_t)(s)),0,(size_t)(m)*(size_t)(s))
#define TclBNCalloc(m,s) memset(Tcl_AttemptAlloc((size_t)(m)*(size_t)(s)),0,(size_t)(m)*(size_t)(s))
/* MODULE_SCOPE void* TclBNRealloc( void*, size_t ); */
#define TclBNRealloc(x,s) ((void*)Tcl_Realloc((char*)(x),(size_t)(s)))
#define TclBNRealloc(x,s) Tcl_AttemptRealloc((x),(size_t)(s))
/* MODULE_SCOPE void TclBNFree( void* ); */
#define TclBNFree(x) (Tcl_Free((char*)(x)))
#define TclBNFree(x) Tcl_Free(x)
#undef MP_MALLOC
#undef MP_CALLOC
#undef MP_REALLOC
#undef MP_FREE
#define MP_MALLOC(size) TclBNAlloc(size)
#define MP_CALLOC(nmemb, size) TclBNCalloc(nmemb, size)
#define MP_REALLOC(mem, oldsize, newsize) TclBNRealloc(mem, newsize)
#define MP_FREE(mem, size) TclBNFree(mem)
#define MP_CALLOC(nmemb, size) TclBNCalloc((nmemb), (size))
#define MP_REALLOC(mem, oldsize, newsize) TclBNRealloc((mem), ((void)(oldsize), (newsize)))
#define MP_FREE(mem, size) TclBNFree(((void)(size), (mem)))
#ifndef MODULE_SCOPE
# ifdef __cplusplus
+2 -16
View File
@@ -195,7 +195,6 @@ static const unsigned short pageMap[] = {
1344, 1344, 1344, 10112, 10144, 1344, 10176, 1344, 10208, 10240, 10272,
10304, 10336, 10368, 1344, 1344, 1344, 10400, 10432, 64, 10464, 10496,
10528, 4736, 10560, 10592
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
,10624, 10656, 10688, 3296, 1344, 1344, 1344, 10720, 10752, 10784,
10816, 10848, 10880, 10912, 10944, 10976, 3296, 3296, 3296, 3296, 9216,
1344, 11008, 11040, 1344, 11072, 11104, 11136, 11168, 1344, 11200,
@@ -568,8 +567,6 @@ static const unsigned short pageMap[] = {
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 15520
#endif /* TCL_UTF_MAX > 3 */
};
/*
@@ -1180,7 +1177,6 @@ static const unsigned char groupMap[] = {
15, 15, 15, 0, 0, 15, 15, 15, 0, 0, 0, 4, 4, 7, 11, 14, 4, 4, 0, 14,
7, 7, 7, 7, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 14, 14,
0, 0
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
,15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
@@ -1653,8 +1649,6 @@ static const unsigned char groupMap[] = {
15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
#endif /* TCL_UTF_MAX > 3 */
};
/*
@@ -1702,11 +1696,7 @@ static const int groups[] = {
18, 17, 10305, 10370, 10049, 10114, 8769, 8834
};
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= 0x323C0)
#else
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1F0000) != 0)
#endif
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= 0x323C0)
/*
* The following constants are used to determine the category of a
@@ -1761,8 +1751,4 @@ enum {
* Unicode character tables.
*/
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
# define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0x1FFFFF) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]])
#else
# define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0xFFFF) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]])
#endif
# define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0x1FFFFF) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]])
+12 -172
View File
@@ -215,9 +215,7 @@ Tcl_UniCharToUtf(
* character (at most 4 bytes).
*/
{
#if TCL_UTF_MAX > 3
int flags = ch;
#endif
if (ch >= TCL_COMBINE) {
ch &= (TCL_COMBINE - 1);
@@ -234,9 +232,7 @@ Tcl_UniCharToUtf(
}
if (ch <= 0xFFFF) {
if (
#if TCL_UTF_MAX > 3
(flags & TCL_COMBINE) &&
#endif
((ch & 0xF800) == 0xD800)) {
if (ch & 0x0400) {
/* Low surrogate */
@@ -349,15 +345,6 @@ Tcl_UniCharToUtfDString(
p = string;
wEnd = uniStr + uniLength;
#if TCL_UTF_MAX < 4
/* Initialize the buffer so that some random data doesn't trick
* Tcl_UniCharToUtf() into thinking it should combine surrogate pairs.
* Once TCL_UTF_MAX == 3 is removed and Tcl_UniCharToUtf restored to its
* prior non-stateful nature, this call to memset can also be removed.
*/
memset(p, 0xff, Tcl_DStringLength(dsPtr) - oldLength);
#endif
for (w = uniStr; w < wEnd; ) {
p += Tcl_UniCharToUtf(*w, p);
w++;
@@ -402,15 +389,6 @@ Tcl_Char16ToUtfDString(
p = string;
wEnd = uniStr + uniLength;
#if TCL_UTF_MAX < 4
/* Initialize the buffer so that some random data doesn't trick
* Tcl_UniCharToUtf() into thinking it should combine surrogate pairs.
* Because TCL_COMBINE is used here, memset() is required even when
* TCL_UTF_MAX == 4.
*/
memset(p, 0xff, Tcl_DStringLength(dsPtr) - oldLength);
#endif
for (w = uniStr; w < wEnd; ) {
if (!len && ((*w & 0xFC00) != 0xDC00)) {
/* Special case for handling high surrogates. */
@@ -447,15 +425,6 @@ Tcl_Char16ToUtfDString(
* Tcl_UtfCharComplete() before calling this routine to ensure that
* enough bytes remain in the string.
*
* If TCL_UTF_MAX < 4, special handling of Surrogate pairs is done:
* For any UTF-8 string containing a character outside of the BMP, the
* first call to this function will fill *chPtr with the high surrogate
* and generate a return value of 1. Calling Tcl_UtfToUniChar again
* will produce the low surrogate and a return value of 3. Because *chPtr
* is used to remember whether the high surrogate is already produced, it
* is recommended to initialize the variable it points to as 0 before
* the first call to Tcl_UtfToUniChar is done.
*
* Results:
* *chPtr is filled with the Tcl_UniChar, and the return value is the
* number of bytes from the UTF-8 string that were consumed.
@@ -715,11 +684,11 @@ Tcl_UtfToUniCharDString(
endPtr = src + length;
optPtr = endPtr - 4;
while (p <= optPtr) {
p += TclUtfToUCS4(p, &ch);
p += Tcl_UtfToUniChar(p, &ch);
*w++ = ch;
}
while ((p < endPtr) && Tcl_UtfCharComplete(p, endPtr-p)) {
p += TclUtfToUCS4(p, &ch);
p += Tcl_UtfToUniChar(p, &ch);
*w++ = ch;
}
while (p < endPtr) {
@@ -965,7 +934,7 @@ Tcl_UtfFindFirst(
int ch) /* The Unicode character to search for. */
{
while (1) {
int find, len = TclUtfToUCS4(src, &find);
int find, len = Tcl_UtfToUniChar(src, &find);
if (find == ch) {
return src;
@@ -1004,7 +973,7 @@ Tcl_UtfFindLast(
const char *last = NULL;
while (1) {
int find, len = TclUtfToUCS4(src, &find);
int find, len = Tcl_UtfToUniChar(src, &find);
if (find == ch) {
last = src;
@@ -1227,13 +1196,7 @@ Tcl_UniCharAtIndex(
i = TclUtfToUniChar(src, &ch);
src += i;
}
#if TCL_UTF_MAX < 4
if ((ch >= 0xD800) && (i < 3)) {
/* Index points at character following high Surrogate */
return -1;
}
#endif
TclUtfToUCS4(src, &i);
Tcl_UtfToUniChar(src, &i);
return i;
}
@@ -1242,10 +1205,8 @@ Tcl_UniCharAtIndex(
*
* Tcl_UtfAtIndex --
*
* Returns a pointer to the specified character (not byte) position in
* the UTF-8 string. If TCL_UTF_MAX < 4, characters > U+FFFF count as
* 2 positions, but then the pointer should never be placed between
* the two positions.
* Returns a pointer to the specified character (not byte) position in the
* UTF-8 string.
*
* Results:
* As above.
@@ -1377,7 +1338,7 @@ Tcl_UtfToUpper(
src = dst = str;
while (*src) {
len = TclUtfToUCS4(src, &ch);
len = Tcl_UtfToUniChar(src, &ch);
upChar = Tcl_UniCharToUpper(ch);
/*
@@ -1430,7 +1391,7 @@ Tcl_UtfToLower(
src = dst = str;
while (*src) {
len = TclUtfToUCS4(src, &ch);
len = Tcl_UtfToUniChar(src, &ch);
lowChar = Tcl_UniCharToLower(ch);
/*
@@ -1486,7 +1447,7 @@ Tcl_UtfToTitle(
src = dst = str;
if (*src) {
len = TclUtfToUCS4(src, &ch);
len = Tcl_UtfToUniChar(src, &ch);
titleChar = Tcl_UniCharToTitle(ch);
if (len < TclUtfCount(titleChar)) {
@@ -1498,7 +1459,7 @@ Tcl_UtfToTitle(
src += len;
}
while (*src) {
len = TclUtfToUCS4(src, &ch);
len = Tcl_UtfToUniChar(src, &ch);
lowChar = ch;
/* Special exception for Georgian Asomtavruli chars, no titlecase. */
if ((unsigned)(lowChar - 0x1C90) >= 0x30) {
@@ -1605,16 +1566,6 @@ Tcl_UtfNcmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
#if TCL_UTF_MAX < 4
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
return ch1;
}
} else if ((ch2 & 0xFC00) == 0xD800) {
return -ch2;
}
#endif
return (ch1 - ch2);
}
}
@@ -1656,16 +1607,6 @@ Tcl_UtfNcasecmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
#if TCL_UTF_MAX < 4
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
return ch1;
}
} else if ((ch2 & 0xFC00) == 0xD800) {
return -ch2;
}
#endif
ch1 = Tcl_UniCharToLower(ch1);
ch2 = Tcl_UniCharToLower(ch2);
if (ch1 != ch2) {
@@ -1705,16 +1646,6 @@ TclUtfCmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
#if TCL_UTF_MAX < 4
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
return ch1;
}
} else if ((ch2 & 0xFC00) == 0xD800) {
return -ch2;
}
#endif
return ch1 - ch2;
}
}
@@ -1751,16 +1682,6 @@ TclUtfCasecmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
#if TCL_UTF_MAX < 4
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
return ch1;
}
} else if ((ch2 & 0xFC00) == 0xD800) {
return -ch2;
}
#endif
ch1 = Tcl_UniCharToLower(ch1);
ch2 = Tcl_UniCharToLower(ch2);
if (ch1 != ch2) {
@@ -1959,7 +1880,7 @@ TclUniCharNcmp(
const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
size_t numChars) /* Number of unichars to compare. */
{
#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3)
#if defined(WORDS_BIGENDIAN)
/*
* We are definitely on a big-endian machine; memcmp() is safe
*/
@@ -1973,14 +1894,6 @@ TclUniCharNcmp(
for ( ; numChars != 0; ucs++, uct++, numChars--) {
if (*ucs != *uct) {
#if TCL_UTF_MAX < 4
/* special case for handling upper surrogates */
if (((*ucs & 0xFC00) == 0xD800) && ((*uct & 0xFC00) != 0xD800)) {
return 1;
} else if (((*uct & 0xFC00) == 0xD800)) {
return -1;
}
#endif
return (*ucs - *uct);
}
}
@@ -2018,14 +1931,6 @@ TclUniCharNcasecmp(
Tcl_UniChar lct = Tcl_UniCharToLower(*uct);
if (lcs != lct) {
#if TCL_UTF_MAX < 4
/* special case for handling upper surrogates */
if (((lcs & 0xFC00) == 0xD800) && ((lct & 0xFC00) != 0xD800)) {
return 1;
} else if (((lct & 0xFC00) == 0xD800)) {
return -1;
}
#endif
return (lcs - lct);
}
}
@@ -2752,71 +2657,6 @@ TclUniCharMatch(
}
}
/*
*---------------------------------------------------------------------------
*
* TclUtfToUCS4 --
*
* Extracts the 4-byte codepoint from the leading bytes of the
* Modified UTF-8 string "src". This is a utility routine to
* contain the surrogate gymnastics in one place.
*
* The caller must ensure that the source buffer is long enough that this
* routine does not run off the end and dereference non-existent memory
* looking for trail bytes. If the source buffer is known to be '\0'
* terminated, this cannot happen. Otherwise, the caller should call
* Tcl_UtfCharComplete() before calling this routine to ensure that
* enough bytes remain in the string.
*
* Results:
* Fills *usc4Ptr with the UCS4 code point and returns the number of bytes
* consumed from the source string.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
#if TCL_UTF_MAX < 4
int
TclUtfToUCS4(
const char *src, /* The UTF-8 string. */
int *ucs4Ptr) /* Filled with the UCS4 codepoint represented
* by the UTF-8 string. */
{
/* Make use of the #undef Tcl_UtfToUniChar above, which already handles UCS4. */
return Tcl_UtfToUniChar(src, ucs4Ptr);
}
int
TclUniCharToUCS4(
const Tcl_UniChar *src, /* The Tcl_UniChar string. */
int *ucs4Ptr) /* Filled with the UCS4 codepoint represented
* by the Tcl_UniChar string. */
{
if (((src[0] & 0xFC00) == 0xD800) && ((src[1] & 0xFC00) == 0xDC00)) {
*ucs4Ptr = (((src[0] & 0x3FF) << 10) | (src[1] & 0x3FF)) + 0x10000;
return 2;
}
*ucs4Ptr = src[0];
return 1;
}
const Tcl_UniChar *TclUCS4Prev(const Tcl_UniChar *src, const Tcl_UniChar *ptr) {
if (src <= ptr + 1) {
return ptr;
}
if (((src[-1] & 0xFC00) == 0xDC00) && ((src[-2] & 0xFC00) == 0xD800)) {
return src - 2;
}
return src - 1;
}
#endif
/*
* Local Variables:
* mode: c
+55 -48
View File
@@ -1035,10 +1035,10 @@ TclScanElement(
* needs protection or escape. */
int requireEscape = 0; /* Force use of CONVERT_ESCAPE mode. For some
* reason bare or brace-quoted form fails. */
int extra = 0; /* Count of number of extra bytes needed for
Tcl_Size extra = 0; /* Count of number of extra bytes needed for
* formatted element, assuming we use escape
* sequences in formatting. */
TCL_HASH_TYPE bytesNeeded; /* Buffer length computed to complete the
Tcl_Size bytesNeeded; /* Buffer length computed to complete the
* element formatting in the selected mode. */
#if COMPAT
int preferEscape = 0; /* Use preferences to track whether to use */
@@ -1670,7 +1670,7 @@ TclTrimRight(
pp = Tcl_UtfPrev(p, bytes);
do {
pp += pInc;
pInc = TclUtfToUCS4(pp, &ch1);
pInc = Tcl_UtfToUniChar(pp, &ch1);
} while (pp + pInc < p);
/*
@@ -1678,7 +1678,7 @@ TclTrimRight(
*/
do {
pInc = TclUtfToUCS4(q, &ch2);
pInc = Tcl_UtfToUniChar(q, &ch2);
if (ch1 == ch2) {
break;
@@ -1743,7 +1743,7 @@ TclTrimLeft(
*/
do {
Tcl_Size pInc = TclUtfToUCS4(p, &ch1);
Tcl_Size pInc = Tcl_UtfToUniChar(p, &ch1);
const char *q = trim;
Tcl_Size bytesLeft = numTrim;
@@ -1752,7 +1752,7 @@ TclTrimLeft(
*/
do {
Tcl_Size qInc = TclUtfToUCS4(q, &ch2);
Tcl_Size qInc = Tcl_UtfToUniChar(q, &ch2);
if (ch1 == ch2) {
break;
@@ -1819,7 +1819,7 @@ TclTrim(
if (numBytes > 0) {
int ch;
const char *first = bytes + trimLeft;
bytes += TclUtfToUCS4(first, &ch);
bytes += Tcl_UtfToUniChar(first, &ch);
numBytes -= (bytes - first);
if (numBytes > 0) {
@@ -2004,7 +2004,11 @@ Tcl_ConcatObj(
goto slow;
}
} else {
resPtr = TclListObjCopy(NULL, objPtr);
resPtr = TclDuplicatePureObj(
NULL, objPtr, &tclListType.objType);
if (!resPtr) {
return NULL;
}
}
}
if (!resPtr) {
@@ -2145,7 +2149,7 @@ Tcl_StringCaseMatch(
ch2 = (int)
(nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
} else {
TclUtfToUCS4(pattern, &ch2);
Tcl_UtfToUniChar(pattern, &ch2);
if (nocase) {
ch2 = Tcl_UniCharToLower(ch2);
}
@@ -2161,7 +2165,7 @@ Tcl_StringCaseMatch(
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*str) {
charLen = TclUtfToUCS4(str, &ch1);
charLen = Tcl_UtfToUniChar(str, &ch1);
if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) {
break;
}
@@ -2175,7 +2179,7 @@ Tcl_StringCaseMatch(
*/
while (*str) {
charLen = TclUtfToUCS4(str, &ch1);
charLen = Tcl_UtfToUniChar(str, &ch1);
if (ch2 == ch1) {
break;
}
@@ -2189,7 +2193,7 @@ Tcl_StringCaseMatch(
if (*str == '\0') {
return 0;
}
str += TclUtfToUCS4(str, &ch1);
str += Tcl_UtfToUniChar(str, &ch1);
}
}
@@ -2200,7 +2204,7 @@ Tcl_StringCaseMatch(
if (p == '?') {
pattern++;
str += TclUtfToUCS4(str, &ch1);
str += Tcl_UtfToUniChar(str, &ch1);
continue;
}
@@ -2219,7 +2223,7 @@ Tcl_StringCaseMatch(
(nocase ? tolower(UCHAR(*str)) : UCHAR(*str));
str++;
} else {
str += TclUtfToUCS4(str, &ch1);
str += Tcl_UtfToUniChar(str, &ch1);
if (nocase) {
ch1 = Tcl_UniCharToLower(ch1);
}
@@ -2233,7 +2237,7 @@ Tcl_StringCaseMatch(
? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
pattern++;
} else {
pattern += TclUtfToUCS4(pattern, &startChar);
pattern += Tcl_UtfToUniChar(pattern, &startChar);
if (nocase) {
startChar = Tcl_UniCharToLower(startChar);
}
@@ -2248,7 +2252,7 @@ Tcl_StringCaseMatch(
? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
pattern++;
} else {
pattern += TclUtfToUCS4(pattern, &endChar);
pattern += Tcl_UtfToUniChar(pattern, &endChar);
if (nocase) {
endChar = Tcl_UniCharToLower(endChar);
}
@@ -2296,8 +2300,8 @@ Tcl_StringCaseMatch(
* each string match.
*/
str += TclUtfToUCS4(str, &ch1);
pattern += TclUtfToUCS4(pattern, &ch2);
str += Tcl_UtfToUniChar(str, &ch1);
pattern += Tcl_UtfToUniChar(pattern, &ch2);
if (nocase) {
if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) {
return 0;
@@ -2602,34 +2606,35 @@ Tcl_DStringAppend(
if (length < 0) {
length = strlen(bytes);
}
newSize = length + dsPtr->length;
/*
* Allocate a larger buffer for the string if the current one isn't large
* enough. Allocate extra space in the new buffer so that there will be
* room to grow before we have to allocate again.
*/
if (length > (TCL_SIZE_MAX - dsPtr->length - 1)) {
Tcl_Panic("max size for a Tcl value (%" TCL_SIZE_MODIFIER
"d bytes) exceeded",
TCL_SIZE_MAX);
return NULL; /* NOTREACHED */
}
newSize = length + dsPtr->length + 1;
if (newSize >= dsPtr->spaceAvl) {
dsPtr->spaceAvl = newSize * 2;
if (newSize > dsPtr->spaceAvl) {
if (dsPtr->string == dsPtr->staticSpace) {
char *newString = (char *)Tcl_Alloc(dsPtr->spaceAvl);
char *newString;
newString = (char *) TclAllocEx(newSize, &dsPtr->spaceAvl);
memcpy(newString, dsPtr->string, dsPtr->length);
dsPtr->string = newString;
} else {
Tcl_Size index = TCL_INDEX_NONE;
Tcl_Size offset = -1;
/* See [16896d49fd] */
if (bytes >= dsPtr->string
&& bytes <= dsPtr->string + dsPtr->length) {
index = bytes - dsPtr->string;
/* Source string is within this DString. Note offset */
offset = bytes - dsPtr->string;
}
dsPtr->string = (char *)Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl);
if (index >= 0) {
bytes = dsPtr->string + index;
dsPtr->string =
(char *)TclReallocEx(dsPtr->string, newSize, &dsPtr->spaceAvl);
if (offset >= 0) {
bytes = dsPtr->string + offset;
}
}
}
@@ -2741,12 +2746,11 @@ Tcl_DStringAppendElement(
* memcpy, not strcpy, to copy the string to a larger buffer, since there
* may be embedded NULLs in the string in some cases.
*/
if (newSize >= dsPtr->spaceAvl) {
dsPtr->spaceAvl = newSize * 2;
newSize += 1; /* For terminating nul */
if (newSize > dsPtr->spaceAvl) {
if (dsPtr->string == dsPtr->staticSpace) {
char *newString = (char *)Tcl_Alloc(dsPtr->spaceAvl);
char *newString;
newString = (char *) TclAllocEx(newSize, &dsPtr->spaceAvl);
memcpy(newString, dsPtr->string, dsPtr->length);
dsPtr->string = newString;
} else {
@@ -2755,11 +2759,11 @@ Tcl_DStringAppendElement(
/* See [16896d49fd] */
if (element >= dsPtr->string
&& element <= dsPtr->string + dsPtr->length) {
/* Source string is within this DString. Note offset */
offset = element - dsPtr->string;
}
dsPtr->string = (char *)Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl);
dsPtr->string =
(char *)TclReallocEx(dsPtr->string, newSize, &dsPtr->spaceAvl);
if (offset >= 0) {
element = dsPtr->string + offset;
}
@@ -2818,13 +2822,16 @@ Tcl_DStringSetLength(
* would be wasteful to overallocate that buffer, so we just allocate
* enough for the requested size plus the trailing null byte. In the
* second case, we are growing the buffer incrementally, so we need
* behavior similar to Tcl_DStringAppend. The requested length will
* usually be a small delta above the current spaceAvl, so we'll end
* up doubling the old size. This won't grow the buffer quite as
* quickly, but it should be close enough.
* behavior similar to Tcl_DStringAppend.
* TODO - the above makes no sense to me. How does the code below
* translate into distinguishing the two cases above? IMO, if caller
* specifically sets the length, there is no cause for overallocation.
*/
newsize = dsPtr->spaceAvl * 2;
if (length >= TCL_SIZE_MAX) {
Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
}
newsize = TclUpsizeAlloc(dsPtr->spaceAvl, length + 1, TCL_SIZE_MAX);
if (length < newsize) {
dsPtr->spaceAvl = newsize;
} else {
+13 -3
View File
@@ -3097,7 +3097,10 @@ ArrayForNRCmd(
* loop) don't vanish.
*/
varListObj = TclListObjCopy(NULL, objv[1]);
varListObj = TclDuplicatePureObj(interp, objv[1], &tclListType.objType);
if (!varListObj) {
return TCL_ERROR;
}
scriptObj = objv[3];
Tcl_IncrRefCount(scriptObj);
@@ -3176,7 +3179,10 @@ ArrayForLoopCallback(
goto arrayfordone;
}
TclListObjGetElementsM(NULL, varListObj, &varc, &varv);
result = TclListObjGetElementsM(NULL, varListObj, &varc, &varv);
if (result != TCL_OK) {
goto arrayfordone;
}
if (Tcl_ObjSetVar2(interp, varv[0], NULL, keyObj,
TCL_LEAVE_ERR_MSG) == NULL) {
result = TCL_ERROR;
@@ -4067,7 +4073,11 @@ ArraySetCmd(
* the loop and return an error.
*/
copyListObj = TclListObjCopy(NULL, arrayElemObj);
copyListObj =
TclDuplicatePureObj(interp, arrayElemObj, &tclListType.objType);
if (!copyListObj) {
return TCL_ERROR;
}
for (i=0 ; i<elemLen ; i+=2) {
Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
+1 -1
View File
@@ -1902,7 +1902,7 @@ ListMountPoints(
return (ZipFS.zipHash.numEntries ? TCL_OK : TCL_BREAK);
}
resultList = Tcl_NewObj();
TclNewObj(resultList);
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
zf = (ZipFile *) Tcl_GetHashValue(hPtr);
+70 -65
View File
@@ -310,28 +310,28 @@ proc ::tcl::clock::Initialize {} {
{-43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Kwajalein
{-39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Midway
{-36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Honolulu
{-32400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Anchorage
{-28800 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Los_Angeles
{-28800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Tijuana
{-25200 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Denver
{-25200 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Chihuahua
{-32400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Anchorage
{-28800 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Los_Angeles
{-28800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Tijuana
{-25200 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Denver
{-25200 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Chihuahua
{-25200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Phoenix
{-21600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Regina
{-21600 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Chicago
{-21600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Mexico_City
{-21600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Mexico_City
{-18000 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/New_York
{-18000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Indianapolis
{-14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Caracas
{-14400 0 3600 0 3 6 2 23 59 59 999 0 10 6 2 23 59 59 999}
{-14400 0 3600 0 3 6 2 23 59 59 999 0 10 6 2 23 59 59 999}
:America/Santiago
{-14400 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Manaus
{-14400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Halifax
{-14400 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Manaus
{-14400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Halifax
{-12600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/St_Johns
{-10800 0 3600 0 2 0 2 2 0 0 0 0 10 0 3 2 0 0 0} :America/Sao_Paulo
{-10800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Godthab
{-10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Buenos_Aires
{-10800 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Bahia
{-10800 0 3600 0 3 0 2 2 0 0 0 0 10 0 1 2 0 0 0} :America/Montevideo
{-10800 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Bahia
{-10800 0 3600 0 3 0 2 2 0 0 0 0 10 0 1 2 0 0 0} :America/Montevideo
{-7200 0 3600 0 9 0 5 2 0 0 0 0 3 0 5 2 0 0 0} :America/Noronha
{-3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Atlantic/Azores
{-3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Atlantic/Cape_Verde
@@ -339,22 +339,22 @@ proc ::tcl::clock::Initialize {} {
{0 0 3600 0 10 0 5 2 0 0 0 0 3 0 5 1 0 0 0} :Europe/London
{3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Kinshasa
{3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :CET
{7200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Harare
{7200 0 3600 0 9 4 5 23 59 59 0 0 4 4 5 23 59 59 0}
{7200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Harare
{7200 0 3600 0 9 4 5 23 59 59 0 0 4 4 5 23 59 59 0}
:Africa/Cairo
{7200 0 3600 0 10 0 5 4 0 0 0 0 3 0 5 3 0 0 0} :Europe/Helsinki
{7200 0 3600 0 9 0 3 2 0 0 0 0 3 5 5 2 0 0 0} :Asia/Jerusalem
{7200 0 3600 0 9 0 3 2 0 0 0 0 3 5 5 2 0 0 0} :Asia/Jerusalem
{7200 0 3600 0 9 0 5 1 0 0 0 0 3 0 5 0 0 0 0} :Europe/Bucharest
{7200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Athens
{7200 0 3600 0 9 5 5 1 0 0 0 0 3 4 5 0 0 0 0} :Asia/Amman
{7200 0 3600 0 10 6 5 23 59 59 999 0 3 0 5 0 0 0 0}
{7200 0 3600 0 9 5 5 1 0 0 0 0 3 4 5 0 0 0 0} :Asia/Amman
{7200 0 3600 0 10 6 5 23 59 59 999 0 3 0 5 0 0 0 0}
:Asia/Beirut
{7200 0 -3600 0 4 0 1 2 0 0 0 0 9 0 1 2 0 0 0} :Africa/Windhoek
{7200 0 -3600 0 4 0 1 2 0 0 0 0 9 0 1 2 0 0 0} :Africa/Windhoek
{10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Riyadh
{10800 0 3600 0 10 0 1 4 0 0 0 0 4 0 1 3 0 0 0} :Asia/Baghdad
{10800 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Moscow
{12600 0 3600 0 9 2 4 2 0 0 0 0 3 0 1 2 0 0 0} :Asia/Tehran
{14400 0 3600 0 10 0 5 5 0 0 0 0 3 0 5 4 0 0 0} :Asia/Baku
{14400 0 3600 0 10 0 5 5 0 0 0 0 3 0 5 4 0 0 0} :Asia/Baku
{14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Muscat
{14400 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Tbilisi
{16200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Kabul
@@ -584,8 +584,8 @@ proc ::tcl::clock::Initialize {} {
jst +0900 \
kst +0900 \
cast +0930 \
jdt +1000 \
kdt +1000 \
jdt +1000 \
kdt +1000 \
cadt +1030 \
east +1000 \
eadt +1030 \
@@ -1158,8 +1158,8 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} {
}
proc $procName {clockval timezone} "
$preFormatCode
return \[::format [list $formatString] $substituents\]
$preFormatCode
return \[::format [list $formatString] $substituents\]
"
# puts [list $procName [info args $procName] [info body $procName]]
@@ -1173,7 +1173,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} {
#
# Inputs a count of seconds since the Posix Epoch as a time of day.
#
# The 'clock format' command scans times of day on input. Refer to the user
# The 'clock scan' command scans times of day on input. Refer to the user
# documentation to see what it does.
#
#----------------------------------------------------------------------
@@ -1189,10 +1189,10 @@ proc ::tcl::clock::scan { args } {
return -code error \
-errorcode [list CLOCK wrongNumArgs] \
"wrong \# args: should be\
\"$cmdName string\
?-base seconds?\
?-format string? ?-gmt boolean?\
?-locale LOCALE? ?-timezone ZONE?\""
\"$cmdName string\
?-base seconds?\
?-format string? ?-gmt boolean?\
?-locale LOCALE? ?-timezone ZONE?\""
}
# Set defaults
@@ -1207,28 +1207,31 @@ proc ::tcl::clock::scan { args } {
# Pick up command line options.
foreach { flag value } [lreplace $args 0 0] {
set saw($flag) {}
switch -exact -- $flag {
-b - -ba - -bas - -base {
set base $value
}
-f - -fo - -for - -form - -forma - -format {
set saw(-format) {}
set format $value
}
-g - -gm - -gmt {
set saw(-gmt) {}
set gmt $value
}
-l - -lo - -loc - -loca - -local - -locale {
set saw(-locale) {}
set locale [string tolower $value]
}
-t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone {
set saw(-timezone) {}
set timezone $value
}
default {
return -code error \
-errorcode [list CLOCK badOption $flag] \
"bad option \"$flag\",\
must be -base, -format, -gmt, -locale or -timezone"
must be -base, -format, -gmt, -locale or -timezone"
}
}
}
@@ -1975,7 +1978,7 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} {
# being processed - they're always absolute
if { ![dict exists $fieldSet seconds]
&& ![dict exists $fieldSet starDate] } {
&& ![dict exists $fieldSet starDate] } {
append procBody {
if { [dict get $date julianDay] > 5373484 } {
return -code error -errorcode [list CLOCK dateTooLarge] \
@@ -2379,8 +2382,8 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } {
M %N
yyyy %Y
yy %y
y %y
gg {}
y %y
gg {}
} $unquoted]
if { $quoted eq {} } {
set quote '
@@ -2409,8 +2412,8 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } {
M %N
yyyy %Y
yy %y
y %y
gg {}
y %y
gg {}
} $unquoted]
if { $quoted eq {} } {
set quote '
@@ -2989,19 +2992,19 @@ proc ::tcl::clock::GetSystemTimeZone {} {
} elseif {[set result [getenv TZ]] ne {}} {
set timezone $result
} else {
# Cache the time zone only if it was detected by one of the
# expensive methods.
if { [info exists CachedSystemTimeZone] } {
set timezone $CachedSystemTimeZone
} elseif { $::tcl_platform(platform) eq {windows} } {
set timezone [GuessWindowsTimeZone]
} elseif { [file exists /etc/localtime]
&& ![catch {ReadZoneinfoFile \
Tcl/Localtime /etc/localtime}] } {
set timezone :Tcl/Localtime
} else {
set timezone :localtime
}
# Cache the time zone only if it was detected by one of the
# expensive methods.
if { [info exists CachedSystemTimeZone] } {
set timezone $CachedSystemTimeZone
} elseif { $::tcl_platform(platform) eq {windows} } {
set timezone [GuessWindowsTimeZone]
} elseif { [file exists /etc/localtime]
&& ![catch {ReadZoneinfoFile \
Tcl/Localtime /etc/localtime}] } {
set timezone :Tcl/Localtime
} else {
set timezone :localtime
}
set CachedSystemTimeZone $timezone
}
if { ![dict exists $TimeZoneBad $timezone] } {
@@ -3608,7 +3611,7 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } {
# 4 - Standard time zone offset, minutes
: ([[:digit:]]{1,2})
(?:
# 5 - Standard time zone offset, seconds
# 5 - Standard time zone offset, seconds
: ([[:digit:]]{1,2} )
)?
)?
@@ -3616,7 +3619,7 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } {
# 6 - DST time zone name
([[:alpha:]]+ | <[-+[:alnum:]]+>)
(?:
(?:
(?:
# 7 - DST time zone offset, signum
([-+]?)
# 8 - DST time zone offset, hours
@@ -3625,17 +3628,17 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } {
# 9 - DST time zone offset, minutes
: ([[:digit:]]{1,2})
(?:
# 10 - DST time zone offset, seconds
# 10 - DST time zone offset, seconds
: ([[:digit:]]{1,2})
)?
)?
)?
(?:
(?:
,
(?:
# 11 - Optional J in n and Jn form 12 - Day of year
( J ? ) ( [[:digit:]]+ )
| M
( J ? ) ( [[:digit:]]+ )
| M
# 13 - Month number 14 - Week of month 15 - Day of week
( [[:digit:]] + )
[.] ( [[:digit:]] + )
@@ -3644,7 +3647,7 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } {
(?:
# 16 - Start time of DST - hours
/ ( [[:digit:]]{1,2} )
(?:
(?:
# 17 - Start time of DST - minutes
: ( [[:digit:]]{1,2} )
(?:
@@ -3656,8 +3659,8 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } {
,
(?:
# 19 - Optional J in n and Jn form 20 - Day of year
( J ? ) ( [[:digit:]]+ )
| M
( J ? ) ( [[:digit:]]+ )
| M
# 21 - Month number 22 - Week of month 23 - Day of week
( [[:digit:]] + )
[.] ( [[:digit:]] + )
@@ -3666,7 +3669,7 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } {
(?:
# 24 - End time of DST - hours
/ ( [[:digit:]]{1,2} )
(?:
(?:
# 25 - End time of DST - minutes
: ( [[:digit:]]{1,2} )
(?:
@@ -3675,9 +3678,9 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } {
)?
)?
)?
)?
)?
)?
)?
)?
$
} $tz -> x(stdName) x(stdSignum) x(stdHours) x(stdMinutes) x(stdSeconds) \
x(dstName) x(dstSignum) x(dstHours) x(dstMinutes) x(dstSeconds) \
@@ -4243,8 +4246,8 @@ proc ::tcl::clock::add { clockval args } {
return -code error \
-errorcode [list CLOCK wrongNumArgs] \
"wrong \# args: should be\
\"$cmdName clockval ?number units?...\
?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?\""
\"$cmdName clockval ?number units?...\
?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?\""
}
if { [catch { expr {wide($clockval)} } result] } {
return -code error $result
@@ -4261,6 +4264,7 @@ proc ::tcl::clock::add { clockval args } {
} else {
switch -exact -- $a {
-g - -gm - -gmt {
set saw(-gmt) {}
set gmt $b
}
-l - -lo - -loc - -loca - -local - -locale {
@@ -4268,12 +4272,13 @@ proc ::tcl::clock::add { clockval args } {
}
-t - -ti - -tim - -time - -timez - -timezo - -timezon -
-timezone {
set saw(-timezone) {}
set timezone $b
}
default {
throw [list CLOCK badOption $a] \
"bad option \"$a\",\
must be -gmt, -locale or -timezone"
must be -gmt, -locale or -timezone"
}
}
}
@@ -4338,7 +4343,7 @@ proc ::tcl::clock::add { clockval args } {
default {
throw [list CLOCK badUnit $unit] \
"unknown unit \"$unit\", must be \
years, months, weeks, days, hours, minutes or seconds"
years, months, weeks, days, hours, minutes or seconds"
}
}
}
@@ -4498,10 +4503,10 @@ proc ::tcl::clock::ChangeCurrentLocale {args} {
variable TimeZoneBad
foreach p [info procs [namespace current]::scanproc'*'current] {
rename $p {}
rename $p {}
}
foreach p [info procs [namespace current]::formatproc'*'current] {
rename $p {}
rename $p {}
}
catch {array unset FormatProc *'current}
+3 -24
View File
@@ -1746,9 +1746,6 @@ proc http::OpenSocket {token DoLater} {
}
fconfigure $sock -translation {auto crlf} \
-buffersize $state(-blocksize)
if {[package vsatisfies [package provide Tcl] 9.0-]} {
fconfigure $sock -profile tcl8
}
##Log socket opened, DONE fconfigure - token $token
}
@@ -2167,9 +2164,6 @@ proc http::Connected {token proto phost srvurl} {
lassign [fconfigure $sock -translation] trRead trWrite
fconfigure $sock -translation [list $trRead crlf] \
-buffersize $state(-blocksize)
if {[package vsatisfies [package provide Tcl] 9.0-]} {
fconfigure $sock -profile tcl8
}
# The following is disallowed in safe interpreters, but the socket is
# already in non-blocking mode in that case.
@@ -2560,9 +2554,6 @@ proc http::ReceiveResponse {token} {
lassign [fconfigure $sock -translation] trRead trWrite
fconfigure $sock -translation [list auto $trWrite] \
-buffersize $state(-blocksize)
if {[package vsatisfies [package provide Tcl] 9.0-]} {
fconfigure $sock -profile tcl8
}
Log ^D$tk begin receiving response - token $token
coroutine ${token}--EventCoroutine http::Event $sock $token
@@ -4554,11 +4545,7 @@ proc http::Eot {token {reason {}}} {
set enc [CharsetToEncoding $state(charset)]
if {$enc ne "binary"} {
if {[package vsatisfies [package provide Tcl] 9.0-]} {
set state(body) [encoding convertfrom -profile tcl8 $enc $state(body)]
} else {
set state(body) [encoding convertfrom $enc $state(body)]
}
set state(body) [encoding convertfrom $enc $state(body)]
}
# Translate text line endings.
@@ -4641,11 +4628,7 @@ proc http::GuessType {token} {
if {$enc eq "binary"} {
return 0
}
if {[package vsatisfies [package provide Tcl] 9.0-]} {
set state(body) [encoding convertfrom -profile tcl8 $enc $state(body)]
} else {
set state(body) [encoding convertfrom $enc $state(body)]
}
set state(body) [encoding convertfrom $enc $state(body)]
set state(body) [string map {\r\n \n \r \n} $state(body)]
set state(type) application/xml
set state(binary) 0
@@ -4726,11 +4709,7 @@ proc http::quoteString {string} {
# a pre-computed map and [string map] to do the conversion (much faster
# than [regsub]/[subst]). [Bug 1020491]
if {[package vsatisfies [package provide Tcl] 9.0-]} {
set string [encoding convertto -profile tcl8 $http(-urlencoding) $string]
} else {
set string [encoding convertto $http(-urlencoding) $string]
}
set string [encoding convertto $http(-urlencoding) $string]
return [string map $formMap $string]
}
+10 -13
View File
@@ -400,7 +400,7 @@ namespace eval tcltest {
default {
set outputChannel [open $filename a]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $outputChannel -profile tcl8 -encoding utf-8
fconfigure $outputChannel -encoding utf-8
}
set ChannelsWeOpened($outputChannel) 1
@@ -447,7 +447,7 @@ namespace eval tcltest {
default {
set errorChannel [open $filename a]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $errorChannel -profile tcl8 -encoding utf-8
fconfigure $errorChannel -encoding utf-8
}
set ChannelsWeOpened($errorChannel) 1
@@ -792,7 +792,7 @@ namespace eval tcltest {
if {$Option(-loadfile) eq {}} {return}
set tmp [open $Option(-loadfile) r]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $tmp -profile tcl8 -encoding utf-8
fconfigure $tmp -encoding utf-8
}
loadScript [read $tmp]
close $tmp
@@ -1134,6 +1134,7 @@ proc tcltest::SafeFetch {n1 n2 op} {
}
}
# tcltest::Asciify --
#
# Transforms the passed string to contain only printable ascii characters.
@@ -1371,7 +1372,7 @@ proc tcltest::DefineConstraintInitializers {} {
set code 0
if {![catch {set f [open "|[list [interpreter]]" w]}]} {
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $f -profile tcl8 -encoding utf-8
fconfigure $f -encoding utf-8
}
if {![catch {puts $f exit}]} {
if {![catch {close $f}]} {
@@ -2221,7 +2222,7 @@ proc tcltest::test {name description args} {
if {[file readable $testFile]} {
set testFd [open $testFile r]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $testFd -profile tcl8 -encoding utf-8
fconfigure $testFd -encoding utf-8
}
set testLine [expr {[lsearch -regexp \
[split [read $testFd] "\n"] \
@@ -2252,11 +2253,7 @@ proc tcltest::test {name description args} {
if {$scriptCompare} {
puts [outputChannel] "---- Error testing result: $scriptMatch"
} else {
if {[catch {
puts [outputChannel] "---- Result was:\n[Asciify $actualAnswer]"
} errMsg]} {
puts [outputChannel] "\n---- Result was:\n<error printing result: $errMsg>"
}
puts [outputChannel] "---- Result was:\n[Asciify $actualAnswer]"
puts [outputChannel] "---- Result should have been\
($match matching):\n[Asciify $result]"
}
@@ -2936,7 +2933,7 @@ proc tcltest::runAllTests { {shell ""} } {
incr numTestFiles
set pipeFd [open $cmd "r"]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $pipeFd -profile tcl8 -encoding utf-8
fconfigure $pipeFd -encoding utf-8
}
while {[gets $pipeFd line] >= 0} {
if {[regexp [join {
@@ -3136,7 +3133,7 @@ proc tcltest::makeFile {contents name {directory ""}} {
set fd [open $fullName w]
fconfigure $fd -translation lf
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $fd -profile tcl8 -encoding utf-8
fconfigure $fd -encoding utf-8
}
if {[string index $contents end] eq "\n"} {
puts -nonewline $fd $contents
@@ -3287,7 +3284,7 @@ proc tcltest::viewFile {name {directory ""}} {
set fullName [file join $directory $name]
set f [open $fullName]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $f -profile tcl8 -encoding utf-8
fconfigure $f -encoding utf-8
}
set data [read -nonewline $f]
close $f
-2
View File
@@ -223,7 +223,6 @@
F96437C90EF0D4B2003F468E /* tclZlib.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclZlib.c; sourceTree = "<group>"; };
F96437E60EF0D652003F468E /* libz.dylib */ = {isa = PBXFileReference; lastKnownFileType = "compiled.mach-o.dylib"; name = libz.dylib; path = /usr/lib/libz.dylib; sourceTree = "<absolute>"; };
F966C07408F2820D005CB29B /* CoreFoundation.framework */ = {isa = PBXFileReference; lastKnownFileType = wrapper.framework; name = CoreFoundation.framework; path = /System/Library/Frameworks/CoreFoundation.framework; sourceTree = "<absolute>"; };
F96D3DFA08F272A4004A47F5 /* ChangeLog */ = {isa = PBXFileReference; explicitFileType = text; fileEncoding = 4; path = ChangeLog; sourceTree = "<group>"; };
F96D3DFB08F272A4004A47F5 /* changes */ = {isa = PBXFileReference; explicitFileType = text; fileEncoding = 4; path = changes; sourceTree = "<group>"; };
F96D3DFD08F272A4004A47F5 /* Access.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Access.3; sourceTree = "<group>"; };
F96D3DFE08F272A4004A47F5 /* AddErrInfo.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = AddErrInfo.3; sourceTree = "<group>"; };
@@ -950,7 +949,6 @@
F96D3DFC08F272A4004A47F5 /* doc */,
F96D43D008F272B8004A47F5 /* tools */,
F9183E690EFC81560030B814 /* pkgs */,
F96D3DFA08F272A4004A47F5 /* ChangeLog */,
F96D3DFB08F272A4004A47F5 /* changes */,
F96D434308F272B5004A47F5 /* README */,
F96D432B08F272B4004A47F5 /* license.terms */,
+3 -3
View File
@@ -72,15 +72,15 @@ test append-3.6 {append surrogates} -body {
test append-3.7 {append \xC0 \x80} -constraints testbytestring -body {
set x [testbytestring \xC0]
string length [append x [testbytestring \x80]]
} -result 2
} -result 1
test append-3.8 {append \xC0 \x80} -constraints testbytestring -body {
set x [testbytestring \xC0]
string length $x[testbytestring \x80]
} -result 2
} -result 1
test append-3.9 {append \xC0 \x80} -constraints testbytestring -body {
set x [testbytestring \x80]
string length [testbytestring \xC0]$x
} -result 2
} -result 1
test append-3.10 {append surrogates} -body {
set x \uD83D
string range $x 0 end
-3
View File
@@ -3042,9 +3042,6 @@ test binary-80.3 {Tcl_GetBytesFromObj} -constraints testbytestring -returnCodes
test binary-80.4 {Tcl_GetBytesFromObj} -constraints testbytestring -returnCodes 1 -body {
testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xF0\x9F\x98\x81"]
} -result "expected byte sequence but character 4 was '\U01F601' (U+01F601)"
test binary-80.5 {Tcl_GetBytesFromObj} -constraints testbytestring -constraints {pointerIs64bit deprecated} -body {
testbytestring [string repeat A [expr 2**31]]
} -returnCodes 1 -result "byte sequence length exceeds INT_MAX"
# ----------------------------------------------------------------------
# cleanup
+1 -1
View File
@@ -56,7 +56,7 @@ test chan-4.2 {chan command: [Bug 800753]} -body {
test chan-4.3 {chan command: [Bug 800753]} -body {
chan configure stdout -eofchar \x00
} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character}
test chan-4.4 {chan command: check valid inValue, no outValue} -constraints deprecated -body {
test chan-4.4 {chan command: check valid inValue, no outValue} -body {
chan configure stdout -eofchar [list \x27 {}]
} -result {}
test chan-4.5 {chan command: check valid inValue, invalid outValue} -body {
+2 -2
View File
@@ -5287,7 +5287,7 @@ test chan-io-39.21 {Tcl_SetChannelOption, setting read mode independently} \
test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup {
file delete $path(test1)
set l ""
} -constraints {unix deprecated} -body {
} -constraints unix -body {
set f1 [open $path(test1) w+]
lappend l [chan configure $f1 -eofchar]
chan configure $f1 -eofchar {O {}}
@@ -5297,7 +5297,7 @@ test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup {
} -cleanup {
chan close $f1
} -result {{} O D}
test chan-io-39.22a {Tcl_SetChannelOption, invariance} -constraints deprecated -setup {
test chan-io-39.22a {Tcl_SetChannelOption, invariance} -setup {
file delete $path(test1)
set l [list]
} -body {
+17
View File
@@ -36768,6 +36768,14 @@ test clock-57.1 {clock scan - abbreviated options} {
clock scan 1970-01-01 -f %Y-%m-%d -g true
} 0
test clock-57.2 {clock scan - not -gmt and -timezone in the same call} {
catch {clock scan 1970-01-01 -format %Y-%m-%d -gmt true -timezone :Europe/Berlin}
} 1
test clock-57.3 {clock scan - not -g and -timezone in the same call} {
catch {clock scan 1970-01-01 -format %Y-%m-%d -g true -timezone :Europe/Berlin}
} 1
test clock-58.1 {clock l10n - Japanese localisation} {*}{
-setup {
proc backslashify { string } {
@@ -36980,6 +36988,15 @@ test clock-65.1 {clock add, bad option [Bug 2481670]} {*}{
-result {bad option "-foo"*}
}
test clock-65.2 {clock add with both -timezone and -gmt} {*}{
-body {
clock add 0 1 year -timezone :CET -gmt true
}
-match glob
-returnCodes error
-result {cannot use -gmt and -timezone in same call}
}
test clock-66.1 {clock scan, no date, never-before-seen timezone} {*}{
-setup {
::tcl::clock::ClearCaches
-1
View File
@@ -334,7 +334,6 @@ test cmdAH-4.2.2 {Tcl_EncodingObjCmd} -setup {
} -cleanup {
encoding system $system
} -result iso8859-1
#
# encoding convertfrom 4.3.*
+21 -7
View File
@@ -569,12 +569,17 @@ test {encoding-16.19 strict} {Utf16ToUtfProc, bug [d19fe0a5b]} -body {
encoding convertfrom -profile strict utf-16 "\x41\x41\x41"
} -returnCodes 1 -result {unexpected byte sequence starting at index 2: '\x41'}
test {encoding-16.19 tcl8} {Utf16ToUtfProc, bug [d19fe0a5b]} -body {
encoding convertfrom -profile strict utf-16 "\x41\x41\x41"
} -returnCodes 1 -result {unexpected byte sequence starting at index 2: '\x41'}
test encoding-16.19.tcl8 {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 {
test encoding-16.19.strict {Utf16ToUtfProc, bug [d19fe0a5b]} -body {
encoding convertfrom -profile strict utf-16 "\x41\x41\x41"
} -returnCodes 1 -result {unexpected byte sequence starting at index 2: '\x41'}
test encoding-16.20 {utf16ToUtfProc, bug [d19fe0a5b]} -body {
encoding convertfrom utf-16 "\xD8\xD8"
} -result \uD8D8
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xD8'}
test encoding-16.21.tcl8 {Utf32ToUtfProc, bug [d19fe0a5b]} -body {
encoding convertfrom -profile tcl8 utf-32 "\x00\x00\x00\x00\x41\x41"
} -result \x00\uFFFD
@@ -779,9 +784,12 @@ test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
list $count [viewable $line]
} [list 3 "乎乞也 (\\u4E4E\\u4E5E\\u4E5F)"]
test encoding-24.4 {Parse valid or invalid utf-8} {
string length [encoding convertfrom utf-8 "\xC0\x80"]
} 1
test {encoding-24.4 utf-8 invalid strict} {Parse invalid utf-8, strict} -body {
string length [encoding convertfrom -profile strict utf-8 "\xC0\x80"]
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'}
test {encoding-24.4 utf-8 invalid tcl8} {UtfToUtfProc utf-8} {
encoding convertfrom -profile tcl8 utf-8 \xC0\x80
} \x00
test encoding-24.5 {Parse valid or invalid utf-8} {
string length [encoding convertfrom -profile tcl8 utf-8 "\xC0\x81"]
} 2
@@ -812,6 +820,9 @@ test encoding-24.13 {Parse invalid utf-8} -body {
test encoding-24.14 {Parse valid utf-8} {
expr {[encoding convertfrom utf-8 "\xC2\x80"] eq "\u80"}
} 1
test encoding-24.15.default {Parse invalid utf-8, default} -body {
encoding convertfrom -profile strict utf-8 "Z\xE0\x80"
} -returnCodes 1 -result "unexpected byte sequence starting at index 1: '\\xE0'"
test encoding-24.15.strict {Parse invalid utf-8, -profile strict} -body {
encoding convertfrom -profile strict utf-8 "Z\xE0\x80"
} -returnCodes 1 -result "unexpected byte sequence starting at index 1: '\\xE0'"
@@ -833,6 +844,9 @@ test encoding-24.19.1 {Parse valid or invalid utf-8} -body {
test encoding-24.19.2 {Parse valid or invalid utf-8} -body {
encoding convertto -profile strict utf-8 "ZX\uD800"
} -returnCodes 1 -match glob -result "unexpected character at index 2: 'U+00D800'"
test encoding-24.19.3 {Parse valid or invalid utf-8} -body {
encoding convertto utf-8 "ZX\uD800"
} -returnCodes 1 -match glob -result "unexpected character at index 2: 'U+00D800'"
test encoding-24.20 {Parse with -profile tcl8 but without providing encoding} -body {
encoding convertfrom -profile tcl8 "\x20"
} -result {wrong # args: should be "::tcl::encoding::convertfrom ?-profile profile? ?-failindex var? encoding data" or "::tcl::encoding::convertfrom data"} -returnCodes error
@@ -869,7 +883,7 @@ test encoding-24.30 {Parse noncharacter with -profile strict} -body {
test encoding-24.31 {Parse invalid utf-8 with -profile tcl8} -body {
encoding convertfrom -profile tcl8 utf-8 \xEF\xBF\xBF
} -result \uFFFF
test encoding-24.32 {Try to generate invalid utf-8} -body {
test encoding-24.33 {Try to generate invalid utf-8} -body {
encoding convertto utf-8 \uFFFF
} -result \xEF\xBF\xBF
test encoding-24.33 {Try to generate invalid utf-8} -body {

Some files were not shown because too many files have changed in this diff Show More