summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog483
-rw-r--r--changes126
-rw-r--r--generic/regc_locale.c2
-rw-r--r--generic/tclBasic.c129
-rw-r--r--generic/tclBinary.c24
-rw-r--r--generic/tclCkalloc.c65
-rw-r--r--generic/tclClock.c12
-rw-r--r--generic/tclCmdAH.c44
-rw-r--r--generic/tclCmdIL.c251
-rw-r--r--generic/tclCmdMZ.c94
-rw-r--r--generic/tclConfig.c8
-rw-r--r--generic/tclDictObj.c39
-rw-r--r--generic/tclEncoding.c6
-rw-r--r--generic/tclEnsemble.c167
-rw-r--r--generic/tclEvent.c9
-rw-r--r--generic/tclExecute.c38
-rw-r--r--generic/tclFCmd.c144
-rw-r--r--generic/tclFileName.c139
-rw-r--r--generic/tclIO.c132
-rw-r--r--generic/tclIOCmd.c152
-rw-r--r--generic/tclIOGT.c4
-rw-r--r--generic/tclIORChan.c136
-rw-r--r--generic/tclIORTrans.c111
-rw-r--r--generic/tclIOSock.c36
-rw-r--r--generic/tclIOUtil.c117
-rw-r--r--generic/tclIndexObj.c110
-rw-r--r--generic/tclInterp.c109
-rw-r--r--generic/tclLoad.c67
-rw-r--r--generic/tclLoadNone.c4
-rw-r--r--generic/tclMain.c98
-rw-r--r--generic/tclNamesp.c64
-rw-r--r--generic/tclOO.c80
-rw-r--r--generic/tclOOBasic.c100
-rw-r--r--generic/tclOODefineCmds.c140
-rw-r--r--generic/tclOOInfo.c64
-rw-r--r--generic/tclOOMethod.c8
-rw-r--r--generic/tclOOStubLib.c11
-rw-r--r--generic/tclObj.c42
-rw-r--r--generic/tclParse.c33
-rw-r--r--generic/tclPathObj.c16
-rw-r--r--generic/tclPipe.c101
-rw-r--r--generic/tclPkg.c108
-rw-r--r--generic/tclProc.c71
-rw-r--r--generic/tclRegexp.c4
-rw-r--r--generic/tclResult.c100
-rw-r--r--generic/tclScan.c55
-rw-r--r--generic/tclTest.c59
-rw-r--r--generic/tclTimer.c9
-rw-r--r--generic/tclTomMathStubLib.c8
-rw-r--r--generic/tclTrace.c24
-rw-r--r--generic/tclUniData.c2
-rw-r--r--generic/tclUtil.c847
-rw-r--r--generic/tclVar.c73
-rw-r--r--generic/tclZlib.c193
-rw-r--r--library/dde/pkgIndex.tcl8
-rw-r--r--library/http/http.tcl7
-rw-r--r--library/init.tcl15
-rwxr-xr-xlibrary/reg/pkgIndex.tcl4
-rw-r--r--macosx/tclMacOSXFCmd.c57
-rw-r--r--tests/assocd.test3
-rw-r--r--tests/async.test3
-rw-r--r--tests/basic.test3
-rw-r--r--tests/chanio.test3
-rw-r--r--tests/clock.test6
-rw-r--r--tests/cmdAH.test3
-rw-r--r--tests/cmdIL.test3
-rw-r--r--tests/cmdInfo.test3
-rw-r--r--tests/compExpr-old.test3
-rw-r--r--tests/compExpr.test3
-rw-r--r--tests/compile.test3
-rw-r--r--tests/coroutine.test3
-rw-r--r--tests/dcall.test3
-rw-r--r--tests/dstring.test3
-rw-r--r--tests/encoding.test11
-rw-r--r--tests/event.test12
-rw-r--r--tests/execute.test3
-rw-r--r--tests/expr-old.test3
-rw-r--r--tests/expr.test3
-rw-r--r--tests/fCmd.test3
-rw-r--r--tests/fileName.test9
-rw-r--r--tests/fileSystem.test31
-rw-r--r--tests/format.test7
-rw-r--r--tests/get.test3
-rw-r--r--tests/http.test15
-rw-r--r--tests/indexObj.test3
-rw-r--r--tests/info.test20
-rw-r--r--tests/interp.test3
-rw-r--r--tests/io.test4
-rw-r--r--tests/ioCmd.test3
-rw-r--r--tests/ioTrans.test3
-rw-r--r--tests/iogt.test4
-rw-r--r--tests/lindex.test3
-rw-r--r--tests/link.test3
-rw-r--r--tests/listObj.test3
-rw-r--r--tests/load.test5
-rw-r--r--tests/lset.test3
-rw-r--r--tests/misc.test3
-rw-r--r--tests/namespace.test3
-rwxr-xr-xtests/notify.test3
-rw-r--r--tests/nre.test3
-rw-r--r--tests/obj.test3
-rw-r--r--tests/parse.test3
-rw-r--r--tests/parseExpr.test3
-rw-r--r--tests/parseOld.test3
-rw-r--r--tests/platform.test3
-rw-r--r--tests/reg.test3
-rw-r--r--tests/registry.test14
-rw-r--r--tests/rename.test3
-rw-r--r--tests/resolver.test3
-rw-r--r--tests/result.test3
-rw-r--r--tests/set.test3
-rw-r--r--tests/string.test7
-rw-r--r--tests/stringComp.test3
-rw-r--r--tests/stringObj.test3
-rw-r--r--tests/tailcall.test3
-rw-r--r--tests/thread.test3
-rw-r--r--tests/trace.test3
-rw-r--r--tests/unixFCmd.test3
-rw-r--r--tests/unixFile.test3
-rw-r--r--tests/unload.test3
-rw-r--r--tests/upvar.test3
-rw-r--r--tests/utf.test3
-rw-r--r--tests/util.test3
-rw-r--r--tests/var.test3
-rw-r--r--tests/winDde.test80
-rw-r--r--tests/winFCmd.test3
-rw-r--r--tests/winFile.test3
-rw-r--r--tests/winNotify.test3
-rw-r--r--tests/winPipe.test20
-rw-r--r--tests/winTime.test3
-rw-r--r--unix/Makefile.in25
-rwxr-xr-xunix/configure4
-rw-r--r--unix/configure.in16
-rwxr-xr-xunix/install-sh4
-rw-r--r--unix/tclLoadDl.c10
-rw-r--r--unix/tclLoadDyld.c252
-rw-r--r--unix/tclLoadNext.c27
-rw-r--r--unix/tclLoadOSF.c24
-rw-r--r--unix/tclLoadShl.c28
-rw-r--r--unix/tclUnixChan.c75
-rw-r--r--unix/tclUnixCompat.c2
-rw-r--r--unix/tclUnixFCmd.c81
-rw-r--r--unix/tclUnixFile.c64
-rw-r--r--unix/tclUnixNotfy.c179
-rw-r--r--unix/tclUnixPipe.c86
-rw-r--r--unix/tclUnixSock.c146
-rw-r--r--win/Makefile.in58
-rw-r--r--win/README26
-rw-r--r--win/coffbase.txt2
-rwxr-xr-xwin/configure14
-rw-r--r--win/configure.in2
-rw-r--r--win/makefile.vc95
-rw-r--r--win/nmakehlp.c71
-rw-r--r--win/rules.vc10
-rw-r--r--win/tcl.m412
-rw-r--r--win/tclWinChan.c16
-rw-r--r--win/tclWinDde.c92
-rw-r--r--win/tclWinFCmd.c16
-rw-r--r--win/tclWinFile.c12
-rw-r--r--win/tclWinInt.h6
-rw-r--r--win/tclWinLoad.c34
-rw-r--r--win/tclWinPipe.c88
-rw-r--r--win/tclWinPort.h4
-rw-r--r--win/tclWinReg.c99
-rw-r--r--win/tclWinSerial.c143
-rw-r--r--win/tclWinSock.c370
166 files changed, 4413 insertions, 3352 deletions
diff --git a/ChangeLog b/ChangeLog
index d1a2d6a..4391648 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,132 @@
+2012-08-09 Reinhard Max <max@suse.de>
+
+ * tests/http.test: Fix http-3.29 for machines without IPv6 support.
+
+2010-08-08 Stuart Cassoff <stwo@users.sourceforge.net>
+
+ * unix/tclUnixCompat.c: Change one '#ifdef' to '#if defined()' for
+ improved consistency within the file.
+
+2012-08-08 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * generic/tclfileName.c: [Bug #1536227]: Cygwin network pathname
+ * tests/fileName.test: support
+
+2012-08-07 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclIOUtil.c: [Bug 3554250] Overlooked one field of
+ cleanup in the thread exit handler for the filesystem subsystem.
+
+2012-07-31 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclInterp.c (Tcl_GetInterpPath):
+ * unix/tclUnixPipe.c (TclGetAndDetachPids, Tcl_PidObjCmd):
+ * win/tclWinPipe.c (TclGetAndDetachPids, Tcl_PidObjCmd):
+ Purge use of Tcl_AppendElement, and corrected conversion of PIDs to
+ integer objects.
+
+2012-07-31 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * win/nmakehlp.c: Add -Q option from sampleextension.
+ * win/Makefile.in: [FRQ 3544967]: Missing objectfiles in static lib
+ * win/makefile.vc: (Thanks to Jos Decoster).
+
+2012-07-29 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * win/Makefile.in: No longer build tcltest.exe to run the tests,
+ but use tclsh86.exe in combination with tcltest86.dll to do that.
+ * tests/*.test: load tcltest86.dll if necessary.
+
+2012-07-28 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * tests/clock.test: [Bug 3549770]: Multiple test failures running
+ * tests/registry.test: tcltest outside build tree
+ * tests/winDde.test:
+
+2012-07-27 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * generic/tclUniData.c: Support Unicode 6.2 (Add Turkish lira sign)
+ * generic/regc_locale.c:
+
+2012-07-25 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
+
+ * win/tclWinPipe.c: [Bug 3547994]: Abandon the synchronous Windows
+ pipe driver to its fate when needed to honour TIP#398.
+
+2012-07-24 Trevor Davel <twylite@crypt.co.za>
+
+ * win/tclWinSock.c: [Bug: 3545363]: Loop over multiple underlying file
+ descriptors for a socket where required (TcpCloseProc, SocketProc).
+ Refactor socket/descriptor setup to manage linked list operations in
+ one place. Fix memory leak in socket close (TcpCloseProc) and related
+ dangling pointers in SocketEventProc.
+
+2012-07-19 Reinhard Max <max@suse.de>
+
+ * win/tclWinSock.c (TcpAccept): [Bug: 3545363]: Use a large enough
+ buffer for accept()ing IPv6 connections. Fix conversion of host and
+ port for passing to the accept proc to be independent of the IP
+ version.
+
+2012-07-23 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
+
+ * generic/tclIO.c: [Bug 3545365]: Never try a bg-flush on a dead
+ channel, just like before 2011-08-17.
+
+2012-07-19 Joe Mistachkin <joe@mistachkin.com>
+
+ * generic/tclTest.c: Fix several more missing mutex-locks in
+ TestasyncCmd.
+
+2012-07-19 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
+
+ * generic/tclTest.c: [Bug 3544685]: Missing mutex-lock in
+ TestasyncCmd since 2011-08-19. Unbounded gratitude to Stuart
+ Cassoff for spotting it.
+
+2012-07-17 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * win/makefile.vc: [Bug 3544932]: Visual studio compiler check fails
+
+2012-07-16 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclUtil.c (UpdateStringOfEndOffset): [Bug 3544658]: Stop
+ 1-byte overrun in memcpy, that object placement rules made harmless
+ but which still caused compiler complaints.
+
+2012-07-16 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * library/reg/pkgIndex.tcl: Make registry 1.3 package dynamically
+ loadable when ::tcl::pkgconfig is available.
+
+2012-07-11 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * win/tclWinReg.c: [Bug 3362446]: registry keys command fails
+ with 8.5/8.6. Follow Microsofts example better in order to prevent
+ problems when using HKEY_PERFORMANCE_DATA.
+
+2012-07-10 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * unix/tclUnixNotfy.c: [Bug 3541646]: Don't panic on triggerPipe
+ overrun.
+
+2012-07-10 Donal K. Fellows <dkf@users.sf.net>
+
+ * win/tclWinSock.c (InitializeHostName): Corrected logic that
+ extracted the name of the computer from the gethostname call so that
+ it would use the name on success, not failure. Also ensured that the
+ buffer size is exactly that recommended by Microsoft.
+
+2012-07-08 Reinhard Max <max@suse.de>
+
+ * library/http/http.tcl: [Bug 3531209]: Add fix and test for URLs that
+ * tests/http.test: contain literal IPv6 addresses.
+
+2012-07-05 Don Porter <dgp@users.sourceforge.net>
+
+ * unix/tclUnixPipe.c: [Bug 1189293]: Make "<<" binary safe.
+ * win/tclWinPipe.c:
+
2012-07-03 Donal K. Fellows <dkf@users.sf.net>
* generic/tclUtil.c (TclDStringAppendObj, TclDStringAppendDString):
@@ -13,10 +142,10 @@
2012-06-29 Harald Oehlmann <harald.oehlmann@elmicron.de>
- * library/msgcat/msgcat.tcl: [Bug 3536888] Locale guessing of msgcat
- * library/msgcat/pkgIndex.tcl: fails on (some) Windows 7. Bump to 1.4.5
- * unix/Makefile.in
- * win/Makefile.in
+ * library/msgcat/msgcat.tcl: [Bug 3536888]: Locale guessing of
+ * library/msgcat/pkgIndex.tcl: msgcat fails on (some) Windows 7. Bump
+ * unix/Makefile.in: to 1.4.5
+ * win/Makefile.in:
2012-06-29 Donal K. Fellows <dkf@users.sf.net>
@@ -40,7 +169,7 @@
2012-06-25 Don Porter <dgp@users.sourceforge.net>
- * generic/tclFileSystem.h: [Bug 3024359] Make sure that the
+ * generic/tclFileSystem.h: [Bug 3024359]: Make sure that the
* generic/tclIOUtil.c: per-thread cache of the list of file systems
* generic/tclPathObj.c: currently registered is only updated at times
when no active loops are traversing it. Also reduce the amount of
@@ -254,17 +383,17 @@
2012-05-09 Andreas Kupries <andreask@activestate.com>
- * generic/tclIORChan.c [Bug 3522560]: Fixed the crash, enabled the
- test case. Modified [chan postevent] to properly inject the
- event(s) into the owner thread's event queue for execution in the
- correct context. Renamed the ForwardOpTo...Thread() function to
- match with our terminology.
+ * generic/tclIORChan.c: [Bug 3522560]: Fixed the crash, enabled the
+ test case. Modified [chan postevent] to properly inject the event(s)
+ into the owner thread's event queue for execution in the correct
+ context. Renamed the ForwardOpTo...Thread() function to match with our
+ terminology.
- * tests/ioCmd.test [Bug 3522560]: Added a test which crashes the
- core if it were not disabled as knownBug. For a reflected channel
+ * tests/ioCmd.test: [Bug 3522560]: Added a test which crashes the core
+ if it were not disabled as knownBug. For a reflected channel
transfered to a different thread the [chan postevent] run in the
- handler thread tries to execute the owner threads's fileevent
- scripts by itself, wrongly reaching across thread boundaries.
+ handler thread tries to execute the owner threads's fileevent scripts
+ by itself, wrongly reaching across thread boundaries.
2012-04-28 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
@@ -320,11 +449,11 @@
2012-04-26 Jan Nijtmans <nijtmans@users.sf.net>
- * generic/tclStubInit.c: get rid of _ANSI_ARGS_ and CONST
- * generic/tclIO.c
- * generic/tclIOCmd.c
- * generic/tclTest.c
- * unix/tclUnixChan.c
+ * generic/tclStubInit.c: Get rid of _ANSI_ARGS_ and CONST
+ * generic/tclIO.c:
+ * generic/tclIOCmd.c:
+ * generic/tclTest.c:
+ * unix/tclUnixChan.c:
2012-04-25 Donal K. Fellows <dkf@users.sf.net>
@@ -389,8 +518,8 @@
* unix/tcl.m4: Use NDEBUG consistantly meaning: no debugging.
* unix/configure:
* generic/tclBasic.c:
- * library/dde/pkgIndex.tcl Use [::tcl::pkgconfig get debug] instead
- * library/reg/pkgIndex.tcl of [info exists ::tcl_platform(debug)]
+ * library/dde/pkgIndex.tcl: Use [::tcl::pkgconfig get debug] instead
+ * library/reg/pkgIndex.tcl: of [info exists ::tcl_platform(debug)]
2012-04-10 Donal K. Fellows <dkf@users.sf.net>
@@ -480,7 +609,7 @@
* generic/tclCmdAH.c: on windows (but now for cygwin as well).
* generic/tclOODefineCmds.c: minor gcc warning
* win/tclWinPort.h: Use lower numbers, preventing integer overflow.
- Remove the workaround for mingw-w64 [bug 3407992]. It's long fixed.
+ Remove the workaround for mingw-w64 [Bug 3407992]. It's long fixed.
2012-03-27 Donal K. Fellows <dkf@users.sf.net>
@@ -555,31 +684,31 @@
2012-03-19 Venkat Iyer <venkat@comit.com>
* library/tzdata/America/Atikokan: Update to tzdata2012b.
- * library/tzdata/America/Blanc-Sablon
- * library/tzdata/America/Dawson_Creek
- * library/tzdata/America/Edmonton
- * library/tzdata/America/Glace_Bay
- * library/tzdata/America/Goose_Bay
- * library/tzdata/America/Halifax
- * library/tzdata/America/Havana
- * library/tzdata/America/Moncton
- * library/tzdata/America/Montreal
- * library/tzdata/America/Nipigon
- * library/tzdata/America/Rainy_River
- * library/tzdata/America/Regina
- * library/tzdata/America/Santiago
- * library/tzdata/America/St_Johns
- * library/tzdata/America/Swift_Current
- * library/tzdata/America/Toronto
- * library/tzdata/America/Vancouver
- * library/tzdata/America/Winnipeg
- * library/tzdata/Antarctica/Casey
- * library/tzdata/Antarctica/Davis
- * library/tzdata/Antarctica/Palmer
- * library/tzdata/Asia/Yerevan
- * library/tzdata/Atlantic/Stanley
- * library/tzdata/Pacific/Easter
- * library/tzdata/Pacific/Fakaofo
+ * library/tzdata/America/Blanc-Sablon:
+ * library/tzdata/America/Dawson_Creek:
+ * library/tzdata/America/Edmonton:
+ * library/tzdata/America/Glace_Bay:
+ * library/tzdata/America/Goose_Bay:
+ * library/tzdata/America/Halifax:
+ * library/tzdata/America/Havana:
+ * library/tzdata/America/Moncton:
+ * library/tzdata/America/Montreal:
+ * library/tzdata/America/Nipigon:
+ * library/tzdata/America/Rainy_River:
+ * library/tzdata/America/Regina:
+ * library/tzdata/America/Santiago:
+ * library/tzdata/America/St_Johns:
+ * library/tzdata/America/Swift_Current:
+ * library/tzdata/America/Toronto:
+ * library/tzdata/America/Vancouver:
+ * library/tzdata/America/Winnipeg:
+ * library/tzdata/Antarctica/Casey:
+ * library/tzdata/Antarctica/Davis:
+ * library/tzdata/Antarctica/Palmer:
+ * library/tzdata/Asia/Yerevan:
+ * library/tzdata/Atlantic/Stanley:
+ * library/tzdata/Pacific/Easter:
+ * library/tzdata/Pacific/Fakaofo:
* library/tzdata/America/Creston: (new)
2012-03-19 Reinhard Max <max@suse.de>
@@ -593,11 +722,11 @@
2012-03-15 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tcl.h: [Bug 3288345]: Wrong Tcl_StatBuf used on Cygwin
- * unix/tclUnixFile.c
- * unix/tclUnixPort.h
+ * unix/tclUnixFile.c:
+ * unix/tclUnixPort.h:
* win/cat.c: Remove cygwin stuff no longer needed
- * win/tclWinFile.c
- * win/tclWinPort.h
+ * win/tclWinFile.c:
+ * win/tclWinPort.h:
2012-03-12 Jan Nijtmans <nijtmans@users.sf.net>
@@ -641,7 +770,7 @@
* generic/tclIOUtil.c: [Bug 3466099]: BOM in Unicode
* generic/tclEncoding.c:
- * tests/source.test
+ * tests/source.test:
2012-02-23 Donal K. Fellows <dkf@users.sf.net>
@@ -795,13 +924,13 @@
2011-12-30 Venkat Iyer <venkat@comit.com>
- * library/tzdata/America/Bahia : Update to Olson's tzdata2011n
- * library/tzdata/America/Havana
- * library/tzdata/Europe/Kiev
- * library/tzdata/Europe/Simferopol
- * library/tzdata/Europe/Uzhgorod
- * library/tzdata/Europe/Zaporozhye
- * library/tzdata/Pacific/Fiji
+ * library/tzdata/America/Bahia: Update to Olson's tzdata2011n
+ * library/tzdata/America/Havana:
+ * library/tzdata/Europe/Kiev:
+ * library/tzdata/Europe/Simferopol:
+ * library/tzdata/Europe/Uzhgorod:
+ * library/tzdata/Europe/Zaporozhye:
+ * library/tzdata/Pacific/Fiji:
2011-12-23 Jan Nijtmans <nijtmans@users.sf.net>
@@ -831,9 +960,8 @@
2011-11-30 Jan Nijtmans <nijtmans@users.sf.net>
- * library/tcltest/tcltest.tcl: [Bug 967195]: Make tcltest work when
- tclsh is compiled without using the setargv() function on mingw (No
- need to incr the version, since 2.2.10 is never released).
+ * library/tcltest/tcltest.tcl: [Bug 967195]: Make tcltest work
+ when tclsh is compiled without using the setargv() function on mingw.
2011-11-29 Jan Nijtmans <nijtmans@users.sf.net>
@@ -854,7 +982,7 @@
2011-11-22 Jan Nijtmans <nijtmans@users.sf.net>
- * win/tclWinPort.h: [Bug 2935503]: Windows: [file mtime] sets wrong
+ * win/tclWinPort.h: [Bug 3354324]: Windows: [file mtime] sets wrong
* win/tclWinFile.c: time (VS2005+ only).
* generic/tclTest.c:
@@ -941,9 +1069,9 @@
2011-10-15 Venkat Iyer <venkat@comit.com>
- * library/tzdata/America/Sitka : Update to Olson's tzdata2011l
- * library/tzdata/Pacific/Fiji
- * library/tzdata/Asia/Hebron (New)
+ * library/tzdata/America/Sitka: Update to Olson's tzdata2011l
+ * library/tzdata/Pacific/Fiji:
+ * library/tzdata/Asia/Hebron: (New)
2011-10-11 Jan Nijtmans <nijtmans@users.sf.net>
@@ -977,16 +1105,16 @@
2011-10-03 Venkat Iyer <venkat@comit.com>
* library/tzdata/Africa/Dar_es_Salaam: Update to Olson's tzdata2011k
- * library/tzdata/Africa/Kampala
- * library/tzdata/Africa/Nairobi
- * library/tzdata/Asia/Gaza
- * library/tzdata/Europe/Kaliningrad
- * library/tzdata/Europe/Kiev
- * library/tzdata/Europe/Minsk
- * library/tzdata/Europe/Simferopol
- * library/tzdata/Europe/Uzhgorod
- * library/tzdata/Europe/Zaporozhye
- * library/tzdata/Pacific/Apia
+ * library/tzdata/Africa/Kampala:
+ * library/tzdata/Africa/Nairobi:
+ * library/tzdata/Asia/Gaza:
+ * library/tzdata/Europe/Kaliningrad:
+ * library/tzdata/Europe/Kiev:
+ * library/tzdata/Europe/Minsk:
+ * library/tzdata/Europe/Simferopol:
+ * library/tzdata/Europe/Uzhgorod:
+ * library/tzdata/Europe/Zaporozhye:
+ * library/tzdata/Pacific/Apia:
2011-09-29 Donal K. Fellows <dkf@users.sf.net>
@@ -1085,15 +1213,15 @@
IMPLEMENTATION OF TIP #388
- * doc/Tcl.n
- * doc/re_syntax.n
- * generic/regc_lex.c
- * generic/regcomp.c
- * generic/regcustom.h
- * generic/tcl.h
- * generic/tclParse.c
- * tests/reg.test
- * tests/utf.test
+ * doc/Tcl.n:
+ * doc/re_syntax.n:
+ * generic/regc_lex.c:
+ * generic/regcomp.c:
+ * generic/regcustom.h:
+ * generic/tcl.h:
+ * generic/tclParse.c:
+ * tests/reg.test:
+ * tests/utf.test:
2011-09-16 Donal K. Fellows <dkf@users.sf.net>
@@ -1172,8 +1300,8 @@
2011-09-06 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tcl.h: [RFE 1711975]: Tcl_MainEx() (like Tk_MainEx())
- * generic/tclDecls.h
- * generic/tclMain.c
+ * generic/tclDecls.h:
+ * generic/tclMain.c:
2011-09-02 Don Porter <dgp@users.sourceforge.net>
@@ -1244,8 +1372,8 @@
2011-08-18 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclUniData.c: [Bug 3393714]: Overflow in toupper delta
- * tools/uniParse.tcl
- * tests/utf.test
+ * tools/uniParse.tcl:
+ * tests/utf.test:
2011-08-17 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
@@ -1282,8 +1410,8 @@
* generic/tclPosixStr.c: [Bug 3388350]: mingw64 compiler warnings
* win/tclWinPort.h:
- * win/configure.in
- * win/configure
+ * win/configure.in:
+ * win/configure:
2011-08-14 Jan Nijtmans <nijtmans@users.sf.net>
@@ -1321,9 +1449,9 @@
2011-08-09 Jan Nijtmans <nijtmans@users.sf.net>
* win/tclWinConsole.c: [Bug 3388350]: mingw64 compiler warnings
- * win/tclWinDde.c
- * win/tclWinPipe.c
- * win/tclWinSerial.c
+ * win/tclWinDde.c:
+ * win/tclWinPipe.c:
+ * win/tclWinSerial.c:
2011-08-09 Jan Nijtmans <nijtmans@users.sf.net>
@@ -1649,8 +1777,8 @@
* library/msgcat/msgcat.tcl: Bump to msgcat 1.4.4.
* library/msgcat/pkgIndex.tcl:
- * unix/Makefile.in
- * win/Makefile.in
+ * unix/Makefile.in:
+ * win/Makefile.in:
2011-05-25 Donal K. Fellows <dkf@users.sf.net>
@@ -2056,7 +2184,7 @@
2011-03-21 Jan Nijtmans <nijtmans@users.sf.net>
- * unix/tclLoadDl.c: [Bug #3216070]: Loading extension libraries
+ * unix/tclLoadDl.c: [Bug 3216070]: Loading extension libraries
* unix/tclLoadDyld.c: from embedded Tcl applications.
***POTENTIAL INCOMPATIBILITY***
For extensions which rely on symbols from other extensions being
@@ -2333,20 +2461,20 @@
* win/tclWinChan.c: Fix various gcc-4.5.2 64-bit warning
* win/tclWinConsole.c: messages, e.g. by using full 64-bits for
* win/tclWinDde.c: socket fd's
- * win/tclWinPipe.c
- * win/tclWinReg.c
- * win/tclWinSerial.c
- * win/tclWinSock.c
- * win/tclWinThrd.c
+ * win/tclWinPipe.c:
+ * win/tclWinReg.c:
+ * win/tclWinSerial.c:
+ * win/tclWinSock.c:
+ * win/tclWinThrd.c:
2011-01-19 Jan Nijtmans <nijtmans@users.sf.net>
- * tools/genStubs.tcl: [Enh #3159920]: Tcl_ObjPrintf() crashes with
+ * tools/genStubs.tcl: [FRQ 3159920]: Tcl_ObjPrintf() crashes with
* generic/tcl.decls bad format specifier.
- * generic/tcl.h
- * generic/tclDecls.h
+ * generic/tcl.h:
+ * generic/tclDecls.h:
-2011-01-18 Donal K. Fellows <dkf@users.sf.net>3159920
+2011-01-18 Donal K. Fellows <dkf@users.sf.net>
* generic/tclOOMethod.c (PushMethodCallFrame): [Bug 3001438]: Make
sure that the cmdPtr field of the procPtr is correct and relevant at
@@ -2359,10 +2487,10 @@
* generic/tclBasic.c: Various mismatches between Tcl_Panic
* generic/tclCompCmds.c: format string and its arguments,
* generic/tclCompCmdsSZ.c: discovered thanks to [Bug 3159920]
- * generic/tclCompExpr.c
- * generic/tclEnsemble.c
- * generic/tclPreserve.c
- * generic/tclTest.c
+ * generic/tclCompExpr.c:
+ * generic/tclEnsemble.c:
+ * generic/tclPreserve.c:
+ * generic/tclTest.c:
2011-01-17 Jan Nijtmans <nijtmans@users.sf.net>
@@ -2605,7 +2733,7 @@
* generic/tclBinary.c: [Bug 3129448]: Possible over-allocation on
* generic/tclCkalloc.c: 64-bit platforms.
- * generic/tclTrace.c
+ * generic/tclTrace.c:
2010-12-05 Jan Nijtmans <nijtmans@users.sf.net>
@@ -2741,7 +2869,7 @@
* win/cat.c: to reality. See for what's missing:
* win/tcl.m4: <https://sourceforge.net/apps/trac/mingw-w64/wiki/Unicode%20apps>
* win/configure: (re-generated)
- * win/tclWinPort.h: [Bug #3110161]: Extensions using TCHAR don't
+ * win/tclWinPort.h: [Bug 3110161]: Extensions using TCHAR don't
compile on VS2005 SP1
2010-11-15 Andreas Kupries <andreask@activestate.com>
@@ -6895,9 +7023,9 @@
* unix/tclUnixChan.c: TclUnixWaitForFile(): use FD_* macros
* macosx/tclMacOSXNotify.c: to manipulate select masks (Cassoff).
- [Freq 1960647] [Bug 3486554]
+ [FRQ 1960647] [Bug 3486554]
- * unix/tclLoadDyld.c: use RTLD_GLOBAL instead of RTLD_LOCAL.
+ * unix/tclLoadDyld.c: Use RTLD_GLOBAL instead of RTLD_LOCAL.
[Bug 1961211]
* macosx/tclMacOSXNotify.c: revise CoreFoundation notifier to allow
@@ -7093,9 +7221,8 @@
2009-03-15 Joe Mistachkin <joe@mistachkin.com>
- * generic/tclThread.c: Modify fix for TSD leak to match Tcl 8.5
- * generic/tclThreadStorage.c: (and prior) allocation semantics. [Bug
- 2687952]
+ * generic/tclThread.c: [Bug 2687952]: Modify fix for TSD leak to match
+ * generic/tclThreadStorage.c: Tcl 8.5 (and prior) allocation semantics
2009-03-15 Donal K. Fellows <dkf@users.sf.net>
@@ -7183,10 +7310,10 @@
2009-02-20 Don Porter <dgp@users.sourceforge.net>
- * generic/tclPathObj.c: Fixed mistaken logic in TclFSGetPathType()
- * tests/fileName.test: that assumed (not "absolute" => "relative").
- This is a false assumption on Windows, where "volumerelative" is
- another possibility. [Bug 2571597]
+ * generic/tclPathObj.c: [Bug 2571597]: Fixed mistaken logic in
+ * tests/fileName.test: TclFSGetPathType() that assumed (not
+ "absolute") => "relative". This is a false assumption on Windows,
+ where "volumerelative" is another possibility.
2009-02-18 Don Porter <dgp@users.sourceforge.net>
@@ -7240,23 +7367,23 @@
2009-02-16 Jan Nijtmans <nijtmans@users.sf.net>
- * generic/tclZlib.c: hack needed for official zlib1.dll build.
+ * generic/tclZlib.c: Hack needed for official zlib1.dll build.
* win/configure.in: fix [Feature Request 2605263] use official
* win/Makefile.in: zlib build.
* win/configure: (regenerated)
* compat/zlib/zdll.lib: new files
* compat/zlib/zlib1.dll:
- * win/Makefile.in: fix [Bug 2605232] tdbc doesn't build when
- Tcl is compiled with --disable-shared.
+ * win/Makefile.in: [Bug 2605232]: tdbc doesn't build when Tcl is
+ compiled with --disable-shared.
2009-02-15 Don Porter <dgp@users.sourceforge.net>
- * generic/tclStringObj.c: Added protections from invalid memory
- * generic/tclTestObj.c: accesses when we append (some part of)
- * tests/stringObj.test: a Tcl_Obj to itself. Added the
- appendself and appendself2 subcommands to the [teststringobj] testing
- command and added tests to the test suite. [Bug 2603158]
+ * generic/tclStringObj.c: [Bug 2603158]: Added protections from
+ * generic/tclTestObj.c: invalid memory accesses when we append
+ * tests/stringObj.test: (some part of) a Tcl_Obj to itself.
+ Added the appendself and appendself2 subcommands to the
+ [teststringobj] testing command and added tests to the test suite.
* generic/tclStringObj.c: Factor out duplicate code from
Tcl_AppendObjToObj.
@@ -7392,7 +7519,7 @@
2009-02-09 Jan Nijtmans <nijtmans@users.sf.net>
- * generic/tclCompile.c: fix [Bug 2555129] const compiler warning (as
+ * generic/tclCompile.c: [Bug 2555129]: const compiler warning (as
error) in tclCompile.c
2009-02-07 Donal K. Fellows <dkf@users.sf.net>
@@ -7404,8 +7531,8 @@
2009-02-05 Joe Mistachkin <joe@mistachkin.com>
- * generic/tclInterp.c: Fix argument checking for [interp cancel]. [Bug
- 2544618]
+ * generic/tclInterp.c: [Bug 2544618]: Fix argument checking for
+ [interp cancel].
* unix/Makefile.in: Fix build issue with zlib on FreeBSD (and possibly
other platforms).
@@ -7427,12 +7554,12 @@
2009-02-04 Don Porter <dgp@users.sourceforge.net>
- * generic/tclStringObj.c: Added overflow protections to the
- AppendUtfToUtfRep routine to either avoid invalid arguments and
- crashes, or to replace them with controlled panics. [Bug 2561794]
+ * generic/tclStringObj.c: [Bug 2561794]: Added overflow protections to
+ the AppendUtfToUtfRep routine to either avoid invalid arguments and
+ crashes, or to replace them with controlled panics.
- * generic/tclCmdMZ.c: Prevent crashes due to int overflow of the
- length of the result of [string repeat]. [Bug 2561746]
+ * generic/tclCmdMZ.c: [Bug 2561746]: Prevent crashes due to int
+ overflow of the length of the result of [string repeat].
2009-02-03 Jan Nijtmans <nijtmans@users.sf.net>
@@ -7464,9 +7591,9 @@
2009-02-03 Don Porter <dgp@users.sourceforge.net>
- * generic/tclStringObj.c (SetUnicodeObj): Corrected failure of
- Tcl_SetUnicodeObj() to panic on a shared object. [Bug 2561488]. Also
- factored out common code to reduce duplication.
+ * generic/tclStringObj.c (SetUnicodeObj): [Bug 2561488]:
+ Corrected failure of Tcl_SetUnicodeObj() to panic on a shared object.
+ Also factored out common code to reduce duplication.
* generic/tclObj.c (Tcl_GetStringFromObj): Reduce code duplication.
@@ -7541,19 +7668,19 @@
2009-01-26 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
- * generic/tclInt.h: Fix [Bug 1028264]: WSACleanup() too early.
- * generic/tclEvent.c: The fix introduces "late exit handlers"
- * win/tclWinSock.c: for similar late process-wide cleanups.
+ * generic/tclInt.h: [Bug 1028264]: WSACleanup() too early.
+ * generic/tclEvent.c: The fix introduces "late exit handlers" for
+ * win/tclWinSock.c: similar late process-wide cleanups.
2009-01-26 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
- * win/tclWinSock.c: Fix [Bug 2446662]: resync Win behavior on RST
- with that of unix (EOF).
+ * win/tclWinSock.c: [Bug 2446662]: Resync Win behavior on RST with
+ that of unix (EOF).
2009-01-26 Donal K. Fellows <dkf@users.sf.net>
- * generic/tclZlib.c (ChanClose): Only generate error messages in the
- interpreter when the thread is not being closed down. [Bug 2536400]
+ * generic/tclZlib.c (ChanClose): [Bug 2536400]: Only generate error
+ messages in the interpreter when the thread is not being closed down.
2009-01-23 Donal K. Fellows <dkf@users.sf.net>
@@ -7580,7 +7707,7 @@
2009-01-21 Andreas Kupries <andreask@activestate.com>
- * generic/tclIORChan.c (ReflectClose): Fix for [Bug 2458202].
+ * generic/tclIORChan.c (ReflectClose): [Bug 2458202]:
* generic/tclIORTrans.c (ReflectClose): Closing a channel may supply
NULL for the 'interp'. Test for finalization needs to be different,
and one place has to pull the interp out of the channel instead.
@@ -7592,12 +7719,12 @@
2009-01-19 Kevin B. Kenny <kennykb@acm.org>
- * unix/Makefile.in: Added a CONFIG_INSTALL_DIR parameter so that
- * unix/tcl.m4: distributors can control where tclConfig.sh goes.
- Made the installation of 'ldAix' conditional upon actually being on an
- AIX system. Allowed for downstream packagers to customize
- SHLIB_VERSION on BSD-derived systems. Thanks to Stuart Cassoff for
- [Patch 907924].
+ * unix/Makefile.in: [Patch 907924]:Added a CONFIG_INSTALL_DIR
+ * unix/tcl.m4: parameter so that distributors can control where
+ tclConfig.sh goes. Made the installation of 'ldAix' conditional upon
+ actually being on an AIX system. Allowed for downstream packagers to
+ customize SHLIB_VERSION on BSD-derived systems. Thanks to Stuart
+ Cassoff for his help.
* unix/configure: Autoconf 2.59
2009-01-19 David Gravereaux <davygrvy@pobox.com>
@@ -7634,8 +7761,8 @@
2009-01-13 Jan Nijtmans <nijtmans@users.sf.net>
- * unix/tcl.m4: fix [tcl-Bug 2502365] Building of head on HPUX is
- broken when using the native CC.
+ * unix/tcl.m4: [Bug 2502365]: Building of head on HPUX is broken when
+ using the native CC.
* unix/configure (autoconf-2.59)
2009-01-13 Donal K. Fellows <dkf@users.sf.net>
@@ -7658,20 +7785,20 @@
2009-01-09 Don Porter <dgp@users.sourceforge.net>
- * generic/tclStringObj.c (STRING_SIZE): Corrected failure to limit
- memory allocation requests to the sizes that can be supported by Tcl's
- memory allocation routines. [Bug 2494093]
+ * generic/tclStringObj.c (STRING_SIZE): [Bug 2494093]: Corrected
+ failure to limit memory allocation requests to the sizes that can be
+ supported by Tcl's memory allocation routines.
2009-01-09 Donal K. Fellows <dkf@users.sf.net>
- * generic/tclNamesp.c (NamespaceEnsembleCmd): Error out when someone
- gives wrong # of args to [namespace ensemble create]. [Bug 1558654]
+ * generic/tclNamesp.c (NamespaceEnsembleCmd): [Bug 1558654]: Error out
+ when someone gives wrong # of args to [namespace ensemble create].
2009-01-08 Don Porter <dgp@users.sourceforge.net>
- * generic/tclStringObj.c (STRING_UALLOC): Added missing parens
- required to get correct results out of things like
- STRING_UALLOC(num + append). [Bug 2494093]
+ * generic/tclStringObj.c (STRING_UALLOC): [Bug 2494093]: Added missing
+ parens required to get correct results out of things like
+ STRING_UALLOC(num + append).
2009-01-08 Donal K. Fellows <dkf@users.sf.net>
@@ -7683,7 +7810,7 @@
2009-01-07 Donal K. Fellows <dkf@users.sf.net>
- * doc/dict.n: Added more examples. [Tk Bug 2491235]
+ * doc/dict.n: [Tk Bug 2491235]: Added more examples.
* tests/oo.test (oo-22.1): Adjusted test to be less dependent on the
specifics of how [info frame] reports general frame information, and
@@ -7702,20 +7829,20 @@
* generic/tclDictObj.c (DictIncrCmd): Corrected twiddling in internals
of dictionaries so that literals can't get destroyed.
- * tests/expr.test: Eliminate non-ASCII char. [Bug 2006879]
+ * tests/expr.test: [Bug 2006879]: Eliminate non-ASCII char.
- * generic/tclOOInfo.c (InfoObjectMethodsCmd,InfoClassMethodsCmd): Only
- delete pointers that were actually allocated! [Bug 2489836]
+ * generic/tclOOInfo.c (InfoObjectMethodsCmd,InfoClassMethodsCmd):
+ [Bug 2489836]: Only delete pointers that were actually allocated!
* generic/tclOO.c (TclNRNewObjectInstance, Tcl_NewObjectInstance):
- Perform search for existing commands in right context. [Bug 2481109]
+ [Bug 2481109]: Perform search for existing commands in right context.
2009-01-05 Donal K. Fellows <dkf@users.sf.net>
- * generic/tclCmdMZ.c (TclNRSourceObjCmd): Make implementation of the
- * generic/tclIOUtil.c (TclNREvalFile): [source] command be NRE
- enabled so that [yield] inside a script sourced in a coroutine can
- work. [Bug 2412068]
+ * generic/tclCmdMZ.c (TclNRSourceObjCmd): [Bug 2412068]: Make
+ * generic/tclIOUtil.c (TclNREvalFile): implementation of the
+ [source] command be NRE enabled so that [yield] inside a script
+ sourced in a coroutine can work.
2009-01-04 Donal K. Fellows <dkf@users.sf.net>
@@ -7730,12 +7857,12 @@
2009-01-02 Donal K. Fellows <dkf@users.sf.net>
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Force the use of the compatibility
- version of mkstemp() on IRIX. [Bug 878333]
+ * unix/tcl.m4 (SC_CONFIG_CFLAGS): [Bug 878333]: Force the use of the
+ compatibility version of mkstemp() on IRIX.
* unix/configure.in, unix/Makefile.in (mkstemp.o):
- * compat/mkstemp.c (new file): Added a compatibility implementation of
- the mkstemp() function, which is apparently needed on some platforms.
- [Bug 741967]
+ * compat/mkstemp.c (new file): [Bug 741967]: Added a compatibility
+ implementation of the mkstemp() function, which is apparently needed
+ on some platforms.
******************************************************************
*** CHANGELOG ENTRIES FOR 2008 IN "ChangeLog.2008" ***
diff --git a/changes b/changes
index cf8a62e..1430f8c 100644
--- a/changes
+++ b/changes
@@ -7976,17 +7976,135 @@ Many more Tcl built-in command errors now set an -errorcode.
like "nano()" instead of parsing as "nan o()" with missing op (duquette,porter)
*** POTENTIAL INCOMPATIBILITY ***
+2011-09-10 (bug fix)[3400658] wrong num args msg with TclOO (rsooltan,fellows)
+
2011-09-13 (bug fix)[3390638] solaris studio cc workaround (kechel,porter)
2011-09-13 (bug fix)[3405652] DTrace workaround (michelson,porter)
2011-09-16 (bug fix)[3391977] -headers overrides -type (ziegenhagen,fellows)
-=> http 2.7.7
+=> http 2.8.3
+
+2011-09-16 (TIP 388) New \Uhhhhhhhh syntax (nijtmans)
-2011-09-16 (bug fix)[3400658] wrong num args msg with TclOO (rsooltan,fellows)
+2011-10-06 (enhancement) bytecode compile [dict with] (fellows)
2011-10-11 (bug fix)[2935503] [file stat] returns bad mode (nadkarni,nijtmans)
-2011-10-15 tzdata updated to Olson's tzdata2011l (iyer)
+2011-10-20 (bug fix)[3418547] cmd lits and custom resolvers (soberning,fellows)
+
+2011-10-31 (bug fix)[3414754] EIAS violation in fs paths (porter)
+
+2011-11-22 (bug fix)[3354324] Win: [file mtime] sets wrong time (nijtmans)
+
+2011-11-30 (bug fix)[967195] Simply args passed to child processes (nijtmans)
+=> tcltest 2.3.4
+
+2011-12-07 (bug fix)[3444754] fix [string tolower \u01C5] (nijtmans)
+
+2011-12-11 (update)[3457031] Update [[:print:]] to Unicode 6.0 (nijtmans)
+
+2011-12-24 (bug fix)[3464428] fix [string is graph \u0120] (nijtmans)
+
+2012-01-08 (bug fix)[3470928] zoneinfo trouble with Windhoek data file (kenny)
+
+2012-01-13 (bug fix)[3472316] fix retrieval of socket error (fellows)
+
+2012-01-21 (bug fix)[3475667] [regexp] buffer read overflow (sebres)
+
+2012-01-22 (bug fix)[3475264] [dict exists] return 0, not error (fellows)
+
+2012-01-25 (bug fix)[3474460] [oo::copy] var resolution list (fellows)
+
+2012-01-26 (bug fix)[3475569,3479689] mem corrupt in fs path (sebres,porter)
+
+2012-01-30 (enhancement) improve bytecode compile of [catch] (fellows)
+
+2012-02-02 (bug fix)[2974459,2879351,1951574,1852572,1661378,1613456] Fix
+problems where [file *able] would return false results on Win/Samba (porter)
+
+2012-02-02 (update)[3464401] Support Unicode 6.1 (nijtmans)
+
+2012-02-06 (bug fix)[3484621] bump bytecode epoch on exec traces (kuhn,sofer)
+
+2012-02-15 (bug fix)[3487626] crash compiling [dict for] (fellows)
+
+2012-02-15 (enhancement) bytecode compile [lrange],[lreplace] (fellows)
+
+2012-02-17 (bug fix)[2233954] compile problem on AIX & Android (nijtmans)
+
+2012-02-29 (bug fix)[3466099] BOM in Unicode (nijtmans)
+
+2012-03-07 (bug fix)[3498327] RFC 3986 compliance (kupries)
+
+2012-03-26 (TIP 380) New builtin class [oo::Slot] (fellows)
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2012-03-27 (TIP 397) <cloned> method to extend [oo::copy] (fellows)
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2012-03-27 (TIP 395) New subcommand [string is entier] (fellows)
+
+2012-04-02 (TIP 396) New command [yieldto] (fellows)
+
+2012-04-04 (bug fix)[3514761] crash combining objects and ensembles (fellows)
+
+2012-04-09 (bug fix)[2712377] [info vars] and oo variables (fellows)
+
+2012-04-09 (bug fix)[3396896] no dups in oo var lists (fellows)
+
+2012-04-11 (bug fix)[3448512] [clock scan 1958-01-01] fail on Win (nijtmans)
+
+2012-04-15 (bug fix)[3517696] fix flush of zlib chan xform (fellows)
+
+2012-04-18 tzdata updated to Olson's tzdata2012c (kenny)
+
+2012-04-28 (TIP 398) exit non-blocking chan without flush (ferrieux)
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2012-05-02 (enhancement) Better use of Intel cpuid instruction (nijtmans)
+
+2012-05-03 (bug fix)[3428753] Unbreak synchronous [socket -async] (porter)
+
+2012-05-10 (bug fix)[2812981] force consistent config of Tcl+pkgs (ferrieux)
+
+2012-05-10 (bug fix)[473946] correct send of special characters (nijtmans)
+
+2012-05-17 (bug fix)[3445787] fix [file] ensemble in Safe Base (fellows)
+
+2012-05-17 (bug fix)[2964715] fix [glob] in Safe Base (fellows)
+
+2012-05-17 (bug fix)[3106532] proper [switch -indexvar] values (fellows)
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2012-05-21 (TIP 106) New -binary option to [dde execute|poke] (oehlmann)
+=> dde 1.4.0
+
+2012-05-23 (bug fix)[3525907] [zlib push decompress] & [chan event]
+(fellows,ferrieux,kupries)
+
+2012-05-28 (bug fix)[3529949] Protect ~ paths in Safe Base (fellows)
+
+2012-06-21 (bug fix)[3362446] [registry keys] failure (nijtmans)
+=> registry 1.3.0
+
+2012-06-25 (bug fix)[3537605] [encoding dirs a b] error message (fellows)
+
+2012-06-25 (bug fix)[3024359] crash when multi-thread concurrent [file system]
+and Tcl_FSMountsChanged(). (porter)
+
+2012-06-29 (bug fix)[3536888] fix locale guessing (oehlmann,nijtmans)
+=> msgcat 1.4.5
+
+2012-07-05 (bug fix)[1189293] make "<<" redirect binary safe (porter)
+
+2012-07-08 (bug fix)[3531209] accept IPv6 URLs (max)
+=> http 2.8.4
+
+2012-07-24 (bug fix) stop mem corruption in stacked channel events (max,porter)
+
+2012-07-25 (bug fix)[3546275] [auto_execok] search match [exec] (danckaert)
+
+Many revisions to better support a Cygwin environment (nijtmans)
---- Released 8.6b3, November 20, 2011 --- See ChangeLog for details ---
+--- Released 8.6b3, July 30, 2012 --- See ChangeLog for details ---
diff --git a/generic/regc_locale.c b/generic/regc_locale.c
index 188d6de..40791f4 100644
--- a/generic/regc_locale.c
+++ b/generic/regc_locale.c
@@ -617,7 +617,7 @@ static const crange graphRangeTable[] = {
{0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4},
{0x1fb6, 0x1fc4}, {0x1fc6, 0x1fd3}, {0x1fd6, 0x1fdb}, {0x1fdd, 0x1fef},
{0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffe}, {0x2010, 0x2027}, {0x2030, 0x205e},
- {0x2074, 0x208e}, {0x2090, 0x209c}, {0x20a0, 0x20b9}, {0x20d0, 0x20f0},
+ {0x2074, 0x208e}, {0x2090, 0x209c}, {0x20a0, 0x20ba}, {0x20d0, 0x20f0},
{0x2100, 0x2189}, {0x2190, 0x23f3}, {0x2400, 0x2426}, {0x2440, 0x244a},
{0x2460, 0x26ff}, {0x2701, 0x2b4c}, {0x2b50, 0x2b59}, {0x2c00, 0x2c2e},
{0x2c30, 0x2c5e}, {0x2c60, 0x2cf3}, {0x2cf9, 0x2d25}, {0x2d30, 0x2d67},
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 537750e..db365e3 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -1708,9 +1708,9 @@ Tcl_HideCommand(
*/
if (strstr(hiddenCmdToken, "::") != NULL) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot use namespace qualifiers in hidden command"
- " token (rename)", NULL);
+ " token (rename)", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", NULL);
return TCL_ERROR;
}
@@ -1733,8 +1733,9 @@ Tcl_HideCommand(
*/
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
- Tcl_AppendResult(interp, "can only hide global namespace commands"
- " (use rename then hide)", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can only hide global namespace commands (use rename then hide)",
+ -1));
Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", NULL);
return TCL_ERROR;
}
@@ -1758,8 +1759,9 @@ Tcl_HideCommand(
hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &isNew);
if (!isNew) {
- Tcl_AppendResult(interp, "hidden command named \"", hiddenCmdToken,
- "\" already exists", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "hidden command named \"%s\" already exists",
+ hiddenCmdToken));
Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", NULL);
return TCL_ERROR;
}
@@ -1861,8 +1863,9 @@ Tcl_ExposeCommand(
*/
if (strstr(cmdName, "::") != NULL) {
- Tcl_AppendResult(interp, "cannot expose to a namespace "
- "(use expose to toplevel, then rename)", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot expose to a namespace (use expose to toplevel, then rename)",
+ -1));
Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", NULL);
return TCL_ERROR;
}
@@ -1877,8 +1880,8 @@ Tcl_ExposeCommand(
hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken);
}
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "unknown hidden command \"", hiddenCmdToken,
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown hidden command \"%s\"", hiddenCmdToken));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN",
hiddenCmdToken, NULL);
return TCL_ERROR;
@@ -1897,9 +1900,9 @@ Tcl_ExposeCommand(
* than 'nicely' erroring out ?
*/
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"trying to expose a non-global command namespace command",
- NULL);
+ -1));
return TCL_ERROR;
}
@@ -1916,8 +1919,8 @@ Tcl_ExposeCommand(
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew);
if (!isNew) {
- Tcl_AppendResult(interp, "exposed command \"", cmdName,
- "\" already exists", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "exposed command \"%s\" already exists", cmdName));
Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", NULL);
return TCL_ERROR;
}
@@ -2497,9 +2500,10 @@ TclRenameCommand(
cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0);
cmdPtr = (Command *) cmd;
if (cmdPtr == NULL) {
- Tcl_AppendResult(interp, "can't ",
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't %s \"%s\": command doesn't exist",
((newName == NULL)||(*newName == '\0'))? "delete":"rename",
- " \"", oldName, "\": command doesn't exist", NULL);
+ oldName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL);
return TCL_ERROR;
}
@@ -2529,15 +2533,15 @@ TclRenameCommand(
TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail);
if ((newNsPtr == NULL) || (newTail == NULL)) {
- Tcl_AppendResult(interp, "can't rename to \"", newName,
- "\": bad command name", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't rename to \"%s\": bad command name", newName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
result = TCL_ERROR;
goto done;
}
if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
- Tcl_AppendResult(interp, "can't rename to \"", newName,
- "\": command already exists", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't rename to \"%s\": command already exists", newName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME",
"TARGET_EXISTS", NULL);
result = TCL_ERROR;
@@ -3538,9 +3542,9 @@ OldMathFuncProc(
* We have a non-numeric argument.
*/
- Tcl_SetResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument to math function didn't have numeric value",
- TCL_STATIC);
+ -1));
TclCheckBadOctal(interp, Tcl_GetString(valuePtr));
ckfree(args);
return TCL_ERROR;
@@ -3827,9 +3831,8 @@ TclInterpReady(
*/
if (iPtr->flags & DELETED) {
- /* JJM - Superfluous Tcl_ResetResult call removed. */
- Tcl_AppendResult(interp,
- "attempt to call eval in deleted interpreter", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to call eval in deleted interpreter", -1));
Tcl_SetErrorCode(interp, "TCL", "IDELETE",
"attempt to call eval in deleted interpreter", NULL);
return TCL_ERROR;
@@ -3857,8 +3860,8 @@ TclInterpReady(
return TCL_OK;
}
- Tcl_AppendResult(interp,
- "too many nested evaluations (infinite loop?)", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "too many nested evaluations (infinite loop?)", -1));
Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL);
return TCL_ERROR;
}
@@ -3992,8 +3995,7 @@ Tcl_Canceled(
}
}
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, message, NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(message, -1));
Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL);
}
@@ -4616,8 +4618,8 @@ TEOV_NotFound(
cmdPtr = TEOV_LookupCmdFromObj(interp, newObjv[0], lookupNsPtr);
if (cmdPtr == NULL) {
- Tcl_AppendResult(interp, "invalid command name \"",
- TclGetString(objv[0]), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid command name \"%s\"", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
TclGetString(objv[0]), NULL);
@@ -6285,11 +6287,11 @@ ProcessUnexpectedResult(
Tcl_ResetResult(interp);
if (returnCode == TCL_BREAK) {
- Tcl_AppendResult(interp,
- "invoked \"break\" outside of a loop", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "invoked \"break\" outside of a loop", -1));
} else if (returnCode == TCL_CONTINUE) {
- Tcl_AppendResult(interp,
- "invoked \"continue\" outside of a loop", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "invoked \"continue\" outside of a loop", -1));
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"command returned bad code: %d", returnCode));
@@ -6624,7 +6626,8 @@ TclObjInvoke(
}
if ((objc < 1) || (objv == NULL)) {
- Tcl_AppendResult(interp, "illegal argument vector", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "illegal argument vector", -1));
return TCL_ERROR;
}
@@ -6642,8 +6645,8 @@ TclObjInvoke(
hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
}
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "invalid hidden command name \"",
- cmdName, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid hidden command name \"%s\"", cmdName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
NULL);
return TCL_ERROR;
@@ -7269,7 +7272,8 @@ ExprIsqrtFunc(
return TCL_OK;
negarg:
- Tcl_SetResult(interp, "square root of negative argument", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "square root of negative argument", -1));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range", NULL);
return TCL_ERROR;
@@ -8319,9 +8323,8 @@ TclNRTailcallObjCmd(
}
if (!iPtr->varFramePtr->isProcCallFrame) { /* or is upleveled */
- Tcl_SetResult(interp,
- "tailcall can only be called from a proc or lambda",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "tailcall can only be called from a proc or lambda", -1));
Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
return TCL_ERROR;
}
@@ -8480,8 +8483,8 @@ TclNRYieldObjCmd(
}
if (!corPtr) {
- Tcl_SetResult(interp, "yield can only be called in a coroutine",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "yield can only be called in a coroutine", -1));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL);
return TCL_ERROR;
}
@@ -8514,8 +8517,8 @@ TclNRYieldToObjCmd(
}
if (!corPtr) {
- Tcl_SetResult(interp, "yieldto can only be called in a coroutine",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "yieldto can only be called in a coroutine", -1));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL);
return TCL_ERROR;
}
@@ -8763,8 +8766,8 @@ NRCoroutineActivateCallback(
*/
if (corPtr->stackLevel != stackLevel) {
- Tcl_SetResult(interp, "cannot yield: C stack busy",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot yield: C stack busy", -1));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD",
NULL);
return TCL_ERROR;
@@ -8823,8 +8826,8 @@ NRCoroInjectObjCmd(
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
- Tcl_AppendResult(interp, "can only inject a command into a coroutine",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can only inject a command into a coroutine", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
@@ -8832,8 +8835,8 @@ NRCoroInjectObjCmd(
corPtr = cmdPtr->objClientData;
if (!COR_IS_SUSPENDED(corPtr)) {
- Tcl_AppendResult(interp,
- "can only inject a command into a suspended coroutine", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can only inject a command into a suspended coroutine", -1));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
return TCL_ERROR;
}
@@ -8860,9 +8863,9 @@ TclNRInterpCoroutine(
CoroutineData *corPtr = clientData;
if (!COR_IS_SUSPENDED(corPtr)) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "coroutine \"", Tcl_GetString(objv[0]),
- "\" is already running", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "coroutine \"%s\" is already running",
+ Tcl_GetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL);
return TCL_ERROR;
}
@@ -8943,22 +8946,24 @@ TclNRCoroutineObjCmd(
&nsPtr, &altNsPtr, &cxtNsPtr, &procName);
if (nsPtr == NULL) {
- Tcl_AppendResult(interp, "can't create procedure \"", fullName,
- "\": unknown namespace", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create procedure \"%s\": unknown namespace",
+ fullName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL);
return TCL_ERROR;
}
if (procName == NULL) {
- Tcl_AppendResult(interp, "can't create procedure \"", fullName,
- "\": bad procedure name", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create procedure \"%s\": bad procedure name",
+ fullName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL);
return TCL_ERROR;
}
if ((nsPtr != iPtr->globalNsPtr)
&& (procName != NULL) && (procName[0] == ':')) {
- Tcl_AppendResult(interp, "can't create procedure \"", procName,
- "\" in non-global namespace with name starting with \":\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create procedure \"%s\" in non-global namespace with"
+ " name starting with \":\"", procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL);
return TCL_ERROR;
}
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 444e7fa..a1e836e 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -873,9 +873,9 @@ BinaryFormatCmd(
if (count == BINARY_ALL) {
count = listc;
} else if (count > listc) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"number of elements in list does not match count",
- NULL);
+ -1));
return TCL_ERROR;
}
}
@@ -884,9 +884,8 @@ BinaryFormatCmd(
case 'x':
if (count == BINARY_ALL) {
- Tcl_AppendResult(interp,
- "cannot use \"*\" in format string with \"x\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot use \"*\" in format string with \"x\"", -1));
return TCL_ERROR;
} else if (count == BINARY_NOCOUNT) {
count = 1;
@@ -1198,8 +1197,9 @@ BinaryFormatCmd(
badValue:
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "expected ", errorString,
- " string but got \"", errorValue, "\" instead", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected %s string but got \"%s\" instead",
+ errorString, errorValue));
return TCL_ERROR;
badCount:
@@ -1217,12 +1217,13 @@ BinaryFormatCmd(
Tcl_UtfToUniChar(errorString, &ch);
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
- Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad field specifier \"%s\"", buf));
return TCL_ERROR;
}
error:
- Tcl_AppendResult(interp, errorString, NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1));
return TCL_ERROR;
}
@@ -1586,12 +1587,13 @@ BinaryScanCmd(
Tcl_UtfToUniChar(errorString, &ch);
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
- Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad field specifier \"%s\"", buf));
return TCL_ERROR;
}
error:
- Tcl_AppendResult(interp, errorString, NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1));
return TCL_ERROR;
}
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 5b5a0d6..ab977cb 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -170,11 +170,15 @@ TclInitDbCkalloc(void)
*/
int
-TclDumpMemoryInfo(ClientData clientData, int flags)
+TclDumpMemoryInfo(
+ ClientData clientData,
+ int flags)
{
char buf[1024];
- if (clientData == NULL) { return 0; }
+ if (clientData == NULL) {
+ return 0;
+ }
sprintf(buf,
"total mallocs %10d\n"
"total frees %10d\n"
@@ -815,15 +819,16 @@ MemoryCmd(
size_t len;
if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option [args..]\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: should be \"%s option [args..]\"", argv[0]));
return TCL_ERROR;
}
- if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) {
+ if (strcmp(argv[1], "active") == 0 || strcmp(argv[1], "display") == 0) {
if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ", argv[1], " file\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: should be \"%s %s file\"",
+ argv[0], argv[1]));
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
@@ -833,7 +838,8 @@ MemoryCmd(
result = Tcl_DumpActiveMemory(fileName);
Tcl_DStringFree(&buffer);
if (result != TCL_OK) {
- Tcl_AppendResult(interp, "error accessing ", argv[2], NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s",
+ argv[2], Tcl_PosixError(interp)));
return TCL_ERROR;
}
return TCL_OK;
@@ -857,17 +863,17 @@ MemoryCmd(
"maximum bytes allocated", (unsigned long)maximum_bytes_malloced));
return TCL_OK;
}
- if (strcmp(argv[1],"init") == 0) {
+ if (strcmp(argv[1], "init") == 0) {
if (argc != 3) {
goto bad_suboption;
}
init_malloced_bodies = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
- if (strcmp(argv[1],"objs") == 0) {
+ if (strcmp(argv[1], "objs") == 0) {
if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " objs file\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: should be \"%s objs file\"", argv[0]));
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
@@ -876,7 +882,9 @@ MemoryCmd(
}
fileP = fopen(fileName, "w");
if (fileP == NULL) {
- Tcl_AppendResult(interp, "cannot open output file", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "cannot open output file: %s",
+ Tcl_PosixError(interp)));
return TCL_ERROR;
}
TclDbDumpActiveObjects(fileP);
@@ -886,8 +894,8 @@ MemoryCmd(
}
if (strcmp(argv[1],"onexit") == 0) {
if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " onexit file\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: should be \"%s onexit file\"", argv[0]));
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
@@ -901,8 +909,8 @@ MemoryCmd(
}
if (strcmp(argv[1],"tag") == 0) {
if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " tag string\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: should be \"%s tag string\"", argv[0]));
return TCL_ERROR;
}
if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
@@ -939,19 +947,20 @@ MemoryCmd(
return TCL_OK;
}
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": should be active, break_on_malloc, info, init, objs, onexit, "
- "tag, trace, trace_on_at_malloc, or validate", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad option \"%s\": should be active, break_on_malloc, info, "
+ "init, objs, onexit, tag, trace, trace_on_at_malloc, or validate",
+ argv[1]));
return TCL_ERROR;
argError:
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ", argv[1], " count\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: should be \"%s %s count\"", argv[0], argv[1]));
return TCL_ERROR;
bad_suboption:
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ", argv[1], " on|off\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: should be \"%s %s on|off\"", argv[0], argv[1]));
return TCL_ERROR;
}
@@ -981,8 +990,8 @@ CheckmemCmd(
const char *argv[]) /* String values of arguments. */
{
if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " fileName\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: should be \"%s fileName\"", argv[0]));
return TCL_ERROR;
}
tclMemDumpFileName = dumpFile;
@@ -1250,7 +1259,9 @@ Tcl_ValidateAllMemory(
}
int
-TclDumpMemoryInfo(ClientData clientData, int flags)
+TclDumpMemoryInfo(
+ ClientData clientData,
+ int flags)
{
return 1;
}
diff --git a/generic/tclClock.c b/generic/tclClock.c
index 7fa4017..6d2976d 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -878,8 +878,8 @@ ConvertLocalToUTCUsingC(
if (localErrno != 0
|| (fields->seconds == -1 && timeVal.tm_yday == -1)) {
- Tcl_SetResult(interp, "time value too large/small to represent",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "time value too large/small to represent", -1));
return TCL_ERROR;
}
return TCL_OK;
@@ -1018,17 +1018,17 @@ ConvertUTCToLocalUsingC(
tock = (time_t) fields->seconds;
if ((Tcl_WideInt) tock != fields->seconds) {
- Tcl_AppendResult(interp,
- "number too large to represent as a Posix time", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "number too large to represent as a Posix time", -1));
Tcl_SetErrorCode(interp, "CLOCK", "argTooLarge", NULL);
return TCL_ERROR;
}
TzsetIfNecessary();
timeVal = ThreadSafeLocalTime(&tock);
if (timeVal == NULL) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"localtime failed (clock value may be too "
- "large/small to represent)", NULL);
+ "large/small to represent)", -1));
Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", NULL);
return TCL_ERROR;
}
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index f09ee70..5ca5cf8 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -194,7 +194,8 @@ Tcl_CaseObjCmd(
if (i == caseObjc-1) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "extra case pattern with no body", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "extra case pattern with no body", -1));
return TCL_ERROR;
}
@@ -409,8 +410,9 @@ Tcl_CdObjCmd(
} else {
result = Tcl_FSChdir(dir);
if (result != TCL_OK) {
- Tcl_AppendResult(interp, "couldn't change working directory to \"",
- TclGetString(dir), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't change working directory to \"%s\": %s",
+ TclGetString(dir), Tcl_PosixError(interp)));
result = TCL_ERROR;
}
}
@@ -642,8 +644,9 @@ EncodingDirsObjCmd(
dirListObj = objv[2];
if (Tcl_SetEncodingSearchPath(dirListObj) == TCL_ERROR) {
- Tcl_AppendResult(interp, "expected directory list but got \"",
- TclGetString(dirListObj), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected directory list but got \"%s\"",
+ TclGetString(dirListObj)));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "ENCODING", "BADPATH",
NULL);
return TCL_ERROR;
@@ -1165,9 +1168,9 @@ FileAttrAccessTimeCmd(
tval.modtime = buf.st_mtime;
if (Tcl_FSUtime(objv[1], &tval) != 0) {
- Tcl_AppendResult(interp, "could not set access time for file \"",
- TclGetString(objv[1]), "\": ", Tcl_PosixError(interp),
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not set access time for file \"%s\": %s",
+ TclGetString(objv[1]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
@@ -1237,9 +1240,9 @@ FileAttrModifyTimeCmd(
tval.modtime = newTime;
if (Tcl_FSUtime(objv[1], &tval) != 0) {
- Tcl_AppendResult(interp, "could not set modification time for "
- "file \"", TclGetString(objv[1]), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not set modification time for file \"%s\": %s",
+ TclGetString(objv[1]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
@@ -1842,7 +1845,7 @@ PathFilesystemCmd(
}
fsInfo = Tcl_FSFileSystemInfo(objv[1]);
if (fsInfo == NULL) {
- Tcl_SetResult(interp, "unrecognised path", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("unrecognised path", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
Tcl_GetString(objv[1]), NULL);
return TCL_ERROR;
@@ -1990,8 +1993,9 @@ PathSplitCmd(
}
res = Tcl_FSSplitPath(objv[1], NULL);
if (res == NULL) {
- Tcl_AppendResult(interp, "could not read \"", TclGetString(objv[1]),
- "\": no such file or directory", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read \"%s\": no such file or directory",
+ TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PATHSPLIT", "NONESUCH",
NULL);
return TCL_ERROR;
@@ -2092,7 +2096,8 @@ FilesystemSeparatorCmd(
Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[1]);
if (separatorObj == NULL) {
- Tcl_SetResult(interp, "unrecognised path", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unrecognised path", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
Tcl_GetString(objv[1]), NULL);
return TCL_ERROR;
@@ -2211,9 +2216,9 @@ GetStatBuf(
if (status < 0) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "could not read \"",
- TclGetString(pathPtr), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read \"%s\": %s",
+ TclGetString(pathPtr), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -2648,7 +2653,8 @@ TclNRForeachCmd(
TclListObjGetElements(NULL, statePtr->vCopyList[i],
&statePtr->varcList[i], &statePtr->varvList[i]);
if (statePtr->varcList[i] < 1) {
- Tcl_AppendResult(interp, "foreach varlist is empty", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "foreach varlist is empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FOREACH",
"NEEDVARS", NULL);
result = TCL_ERROR;
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index b312026..14e0092 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -27,15 +27,15 @@
*/
typedef struct SortElement {
- union { /* The value that we sorting by. */
+ union { /* The value that we sorting by. */
const char *strValuePtr;
long intValue;
double doubleValue;
Tcl_Obj *objValuePtr;
} collationKey;
- union { /* Object being sorted, or its index. */
- Tcl_Obj *objPtr;
- int index;
+ union { /* Object being sorted, or its index. */
+ Tcl_Obj *objPtr;
+ int index;
} payload;
struct SortElement *nextPtr;/* Next element in the list, or NULL for end
* of list. */
@@ -229,8 +229,9 @@ TclNRIfObjCmd(
Tcl_Obj *boolObj;
if (objc <= 1) {
- Tcl_AppendResult(interp, "wrong # args: no expression after \"",
- TclGetString(objv[0]), "\" argument", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: no expression after \"%s\" argument",
+ TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
@@ -319,8 +320,9 @@ IfConditionCallback(
*/
if (i >= objc) {
- Tcl_AppendResult(interp, "wrong # args: ",
- "no expression after \"", clause, "\" argument", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: no expression after \"%s\" argument",
+ clause));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
@@ -345,8 +347,9 @@ IfConditionCallback(
}
}
if (i < objc - 1) {
- Tcl_AppendResult(interp, "wrong # args: ",
- "extra words after \"else\" clause in \"if\" command", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "wrong # args: extra words after \"else\" clause in \"if\" command",
+ -1));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
@@ -361,9 +364,9 @@ IfConditionCallback(
return TclNREvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i);
missingScript:
- clause = TclGetString(objv[i-1]);
- Tcl_AppendResult(interp, "wrong # args: no script following \"", clause,
- "\" argument", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: no script following \"%s\" argument",
+ TclGetString(objv[i-1])));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
@@ -491,7 +494,8 @@ InfoArgsCmd(
name = TclGetString(objv[1]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
- Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't a procedure", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL);
return TCL_ERROR;
}
@@ -552,7 +556,8 @@ InfoBodyCmd(
name = TclGetString(objv[1]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
- Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't a procedure", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL);
return TCL_ERROR;
}
@@ -981,7 +986,8 @@ InfoDefaultCmd(
procPtr = TclFindProc(iPtr, procName);
if (procPtr == NULL) {
- Tcl_AppendResult(interp, "\"", procName, "\" isn't a procedure",NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't a procedure", procName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName,
NULL);
return TCL_ERROR;
@@ -1012,8 +1018,9 @@ InfoDefaultCmd(
}
}
- Tcl_AppendResult(interp, "procedure \"", procName,
- "\" doesn't have an argument \"", argName, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "procedure \"%s\" doesn't have an argument \"%s\"",
+ procName, argName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL);
return TCL_ERROR;
}
@@ -1055,10 +1062,10 @@ InfoErrorStackCmd(
target = interp;
if (objc == 2) {
- target = Tcl_GetSlave(interp, Tcl_GetString(objv[1]));
- if (target == NULL) {
- return TCL_ERROR;
- }
+ target = Tcl_GetSlave(interp, Tcl_GetString(objv[1]));
+ if (target == NULL) {
+ return TCL_ERROR;
+ }
}
iPtr = (Interp *) target;
@@ -1158,12 +1165,13 @@ InfoFrameCmd(
* A coroutine: must fix the level computations AND the cmdFrame chain,
* which is interrupted at the base.
*/
+
CmdFrame *lastPtr = NULL;
- runPtr = iPtr->cmdFramePtr;
+ runPtr = iPtr->cmdFramePtr;
/* TODO - deal with overflow */
- topLevel += corPtr->caller.cmdFramePtr->level;
+ topLevel += corPtr->caller.cmdFramePtr->level;
while (runPtr) {
runPtr->level += corPtr->caller.cmdFramePtr->level;
lastPtr = runPtr;
@@ -1196,8 +1204,8 @@ InfoFrameCmd(
if ((level > topLevel) || (level <= - topLevel)) {
levelError:
- Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad level \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_FRAME",
TclGetString(objv[1]), NULL);
code = TCL_ERROR;
@@ -1401,15 +1409,15 @@ TclInfoFrame(
Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr;
if (namePtr) {
- Tcl_Obj *procNameObj;
+ Tcl_Obj *procNameObj;
/*
* This is a regular command.
*/
- TclNewObj(procNameObj);
- Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr,
- procNameObj);
+ TclNewObj(procNameObj);
+ Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr,
+ procNameObj);
ADD_PAIR("proc", procNameObj);
} else if (procPtr->cmdPtr->clientData) {
ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData;
@@ -1538,7 +1546,9 @@ InfoHostnameCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1));
return TCL_OK;
}
- Tcl_SetResult(interp, "unable to determine name of host", TCL_STATIC);
+
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unable to determine name of host", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", NULL);
return TCL_ERROR;
}
@@ -1609,8 +1619,8 @@ InfoLevelCmd(
return TCL_ERROR;
levelError:
- Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad level \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
@@ -1656,7 +1666,9 @@ InfoLibraryCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1));
return TCL_OK;
}
- Tcl_SetResult(interp, "no library has been specified for Tcl",TCL_STATIC);
+
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no library has been specified for Tcl", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library",NULL);
return TCL_ERROR;
}
@@ -2590,9 +2602,10 @@ Tcl_LrepeatObjCmd(
return TCL_ERROR;
}
if (elementCount < 0) {
- Tcl_SetObjResult(interp, Tcl_Format(NULL,
- "bad count \"%d\": must be integer >= 0", 1, objv+1));
- Tcl_SetErrorCode(interp, "TCL","OPERATION","LREPEAT","NEGARG", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad count \"%d\": must be integer >= 0", elementCount));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG",
+ NULL);
return TCL_ERROR;
}
@@ -2608,7 +2621,7 @@ Tcl_LrepeatObjCmd(
if (elementCount && objc > LIST_MAX/elementCount) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max length of a Tcl list (%d elements) exceeded", LIST_MAX));
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
}
totalElems = objc * elementCount;
@@ -2723,9 +2736,10 @@ Tcl_LreplaceObjCmd(
*/
if ((first >= listLen) && (listLen > 0)) {
- Tcl_AppendResult(interp, "list doesn't contain element ",
- TclGetString(objv[2]), NULL);
- Tcl_SetErrorCode(interp, "TCL","OPERATION","LREPLACE","BADIDX", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "list doesn't contain element %s", TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPLACE", "BADIDX",
+ NULL);
return TCL_ERROR;
}
if (last >= listLen) {
@@ -2996,8 +3010,9 @@ Tcl_LsearchObjCmd(
Tcl_DecrRefCount(startPtr);
}
if (i > objc-4) {
- Tcl_AppendResult(interp, "missing starting index", NULL);
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "missing starting index", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
result = TCL_ERROR;
goto done;
}
@@ -3027,10 +3042,10 @@ Tcl_LsearchObjCmd(
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-index\" option must be followed by list index",
- NULL);
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
@@ -3088,18 +3103,18 @@ Tcl_LsearchObjCmd(
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
- Tcl_AppendResult(interp,
- "-subindices cannot be used without -index option", NULL);
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
- "BAD_OPTION_MIX", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "-subindices cannot be used without -index option", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
+ "BAD_OPTION_MIX", NULL);
return TCL_ERROR;
}
if (bisect && (allMatches || negatedMatch)) {
- Tcl_AppendResult(interp,
- "-bisect is not compatible with -all or -not", NULL);
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
- "BAD_OPTION_MIX", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "-bisect is not compatible with -all or -not", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
+ "BAD_OPTION_MIX", NULL);
return TCL_ERROR;
}
@@ -3531,7 +3546,7 @@ Tcl_LsetObjCmd(
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
- "listVar ?index? ?index ...? value");
+ "listVar ?index? ?index ...? value");
return TCL_ERROR;
}
@@ -3664,10 +3679,10 @@ Tcl_LsortObjCmd(
break;
case LSORT_COMMAND:
if (i == objc-2) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-command\" option must be followed "
- "by comparison command", NULL);
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ "by comparison command", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done2;
}
@@ -3685,29 +3700,30 @@ Tcl_LsortObjCmd(
sortInfo.isIncreasing = 1;
break;
case LSORT_INDEX: {
- int indexc, dummy;
+ int indexc, dummy;
Tcl_Obj **indexv;
if (i == objc-2) {
- Tcl_AppendResult(interp, "\"-index\" option must be "
- "followed by list index", NULL);
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
- sortInfo.resultCode = TCL_ERROR;
- goto done2;
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-index\" option must be followed by list index",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
if (TclListObjGetElements(interp, objv[i+1], &indexc,
&indexv) != TCL_OK) {
- sortInfo.resultCode = TCL_ERROR;
- goto done2;
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
- /*
- * Check each of the indices for syntactic correctness. Note that
- * we do not store the converted values here because we do not
- * know if this is the only -index option yet and so we can't
- * allocate any space; that happens after the scan through all the
- * options is done.
- */
+ /*
+ * Check each of the indices for syntactic correctness. Note that
+ * we do not store the converted values here because we do not
+ * know if this is the only -index option yet and so we can't
+ * allocate any space; that happens after the scan through all the
+ * options is done.
+ */
for (j=0 ; j<indexc ; j++) {
if (TclGetIntForIndexM(interp, indexv[j], SORTIDX_END,
@@ -3719,7 +3735,7 @@ Tcl_LsortObjCmd(
}
}
indexPtr = objv[i+1];
- i++;
+ i++;
break;
}
case LSORT_INTEGER:
@@ -3739,9 +3755,10 @@ Tcl_LsortObjCmd(
break;
case LSORT_STRIDE:
if (i == objc-2) {
- Tcl_AppendResult(interp, "\"-stride\" option must be ",
- "followed by stride length", NULL);
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-stride\" option must be "
+ "followed by stride length", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done2;
}
@@ -3750,10 +3767,10 @@ Tcl_LsortObjCmd(
goto done2;
}
if (groupSize < 2) {
- Tcl_AppendResult(interp, "stride length must be at least 2",
- NULL);
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
- "BADSTRIDE", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "stride length must be at least 2", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
+ "BADSTRIDE", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done2;
}
@@ -3773,26 +3790,26 @@ Tcl_LsortObjCmd(
*/
if (indexPtr) {
- Tcl_Obj **indexv;
-
- TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv);
- switch (sortInfo.indexc) {
- case 0:
- sortInfo.indexv = NULL;
- break;
- case 1:
- sortInfo.indexv = &sortInfo.singleIndex;
- break;
- default:
- sortInfo.indexv =
+ Tcl_Obj **indexv;
+
+ TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv);
+ switch (sortInfo.indexc) {
+ case 0:
+ sortInfo.indexv = NULL;
+ break;
+ case 1:
+ sortInfo.indexv = &sortInfo.singleIndex;
+ break;
+ default:
+ sortInfo.indexv =
TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
- allocatedIndexVector = 1; /* Cannot use indexc field, as it
- * might be decreased by 1 later. */
- }
- for (j=0 ; j<sortInfo.indexc ; j++) {
- TclGetIntForIndexM(interp, indexv[j], SORTIDX_END,
+ allocatedIndexVector = 1; /* Cannot use indexc field, as it
+ * might be decreased by 1 later. */
+ }
+ for (j=0 ; j<sortInfo.indexc ; j++) {
+ TclGetIntForIndexM(interp, indexv[j], SORTIDX_END,
&sortInfo.indexv[j]);
- }
+ }
}
listObj = objv[objc-1];
@@ -3847,11 +3864,11 @@ Tcl_LsortObjCmd(
if (group) {
if (length % groupSize) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"list size must be a multiple of the stride length",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE",
NULL);
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE",
- NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
@@ -3867,11 +3884,11 @@ Tcl_LsortObjCmd(
groupOffset = (groupOffset - SORTIDX_END) + groupSize - 1;
}
if (groupOffset < 0 || groupOffset >= groupSize) {
- Tcl_AppendResult(interp, "when used with \"-stride\", the "
- "leading \"-index\" value must be within the group",
- NULL);
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
- "BADINDEX", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "when used with \"-stride\", the leading \"-index\""
+ " value must be within the group", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
+ "BADINDEX", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
@@ -4255,11 +4272,10 @@ SortCompare(
if (TclGetIntFromObj(infoPtr->interp,
Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
- Tcl_ResetResult(infoPtr->interp);
- Tcl_AppendResult(infoPtr->interp,
- "-compare command returned non-integer result", NULL);
- Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
- "COMPARISONFAILED", NULL);
+ Tcl_SetObjResult(infoPtr->interp, Tcl_NewStringObj(
+ "-compare command returned non-integer result", -1));
+ Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
+ "COMPARISONFAILED", NULL);
infoPtr->resultCode = TCL_ERROR;
return 0;
}
@@ -4470,11 +4486,11 @@ SelectObjFromSublist(
return NULL;
}
if (currentObj == NULL) {
- Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
- "element %d missing from sublist \"%s\"",
- index, TclGetString(objPtr)));
- Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
- "INDEXFAILED", NULL);
+ Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
+ "element %d missing from sublist \"%s\"",
+ index, TclGetString(objPtr)));
+ Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
+ "INDEXFAILED", NULL);
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
@@ -4489,6 +4505,5 @@ SelectObjFromSublist(
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
- * indent-tabs-mode: nil
* End:
*/
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 7e94d9f..9e720ea 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -204,8 +204,8 @@ Tcl_RegexpObjCmd(
*/
if (doinline && ((objc - 2) != 0)) {
- Tcl_AppendResult(interp, "regexp match variables not allowed"
- " when using -inline", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "regexp match variables not allowed when using -inline", -1));
goto optionError;
}
@@ -1839,8 +1839,8 @@ StringMapCmd(
strncmp(string, "-nocase", (size_t) length2) == 0) {
nocase = 1;
} else {
- Tcl_AppendResult(interp, "bad option \"", string,
- "\": must be -nocase", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad option \"%s\": must be -nocase", string));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
string, NULL);
return TCL_ERROR;
@@ -2106,8 +2106,8 @@ StringMatchCmd(
strncmp(string, "-nocase", (size_t) length) == 0) {
nocase = TCL_MATCH_NOCASE;
} else {
- Tcl_AppendResult(interp, "bad option \"", string,
- "\": must be -nocase", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad option \"%s\": must be -nocase", string));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
string, NULL);
return TCL_ERROR;
@@ -2567,8 +2567,9 @@ StringEqualCmd(
return TCL_ERROR;
}
} else {
- Tcl_AppendResult(interp, "bad option \"", string2,
- "\": must be -nocase or -length", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad option \"%s\": must be -nocase or -length",
+ string2));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
string2, NULL);
return TCL_ERROR;
@@ -2716,8 +2717,9 @@ StringCmpCmd(
return TCL_ERROR;
}
} else {
- Tcl_AppendResult(interp, "bad option \"", string2,
- "\": must be -nocase or -length", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad option \"%s\": must be -nocase or -length",
+ string2));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
string2, NULL);
return TCL_ERROR;
@@ -3515,9 +3517,9 @@ TclNRSwitchObjCmd(
* Mode already set via -exact, -glob, or -regexp.
*/
- Tcl_AppendResult(interp, "bad option \"",
- TclGetString(objv[i]), "\": ", options[mode],
- " option already found", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad option \"%s\": %s option already found",
+ TclGetString(objv[i]), options[mode]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"DOUBLEOPT", NULL);
return TCL_ERROR;
@@ -3534,8 +3536,9 @@ TclNRSwitchObjCmd(
case OPT_INDEXV:
i++;
if (i >= objc-2) {
- Tcl_AppendResult(interp, "missing variable name argument to ",
- "-indexvar", " option", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing variable name argument to %s option",
+ "-indexvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"NOVAR", NULL);
return TCL_ERROR;
@@ -3546,8 +3549,9 @@ TclNRSwitchObjCmd(
case OPT_MATCHV:
i++;
if (i >= objc-2) {
- Tcl_AppendResult(interp, "missing variable name argument to ",
- "-matchvar", " option", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing variable name argument to %s option",
+ "-matchvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"NOVAR", NULL);
return TCL_ERROR;
@@ -3565,15 +3569,15 @@ TclNRSwitchObjCmd(
return TCL_ERROR;
}
if (indexVarObj != NULL && mode != OPT_REGEXP) {
- Tcl_AppendResult(interp,
- "-indexvar option requires -regexp option", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s option requires -regexp option", "-indexvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"MODERESTRICTION", NULL);
return TCL_ERROR;
}
if (matchVarObj != NULL && mode != OPT_REGEXP) {
- Tcl_AppendResult(interp,
- "-matchvar option requires -regexp option", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s option requires -regexp option", "-matchvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"MODERESTRICTION", NULL);
return TCL_ERROR;
@@ -3622,7 +3626,8 @@ TclNRSwitchObjCmd(
if (objc % 2) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "extra switch pattern with no body", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "extra switch pattern with no body", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM",
NULL);
@@ -3637,10 +3642,10 @@ TclNRSwitchObjCmd(
if (splitObjs) {
for (i=0 ; i<objc ; i+=2) {
if (TclGetString(objv[i])[0] == '#') {
- Tcl_AppendResult(interp, ", this may be due to a "
- "comment incorrectly placed outside of a "
- "switch body - see the \"switch\" "
- "documentation", NULL);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ ", this may be due to a comment incorrectly"
+ " placed outside of a switch body - see the"
+ " \"switch\" documentation", -1);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"BADARM", "COMMENT?", NULL);
break;
@@ -3657,9 +3662,9 @@ TclNRSwitchObjCmd(
*/
if (strcmp(TclGetString(objv[objc-1]), "-") == 0) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "no body specified for pattern \"",
- TclGetString(objv[objc-2]), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "no body specified for pattern \"%s\"",
+ TclGetString(objv[objc-2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM",
"FALLTHROUGH", NULL);
return TCL_ERROR;
@@ -3985,7 +3990,8 @@ Tcl_ThrowObjCmd(
if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
return TCL_ERROR;
} else if (len < 1) {
- Tcl_AppendResult(interp, "type must be non-empty list", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "type must be non-empty list", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION",
NULL);
return TCL_ERROR;
@@ -4169,15 +4175,16 @@ TclNRTryObjCmd(
switch ((enum Handlers) type) {
case TryFinally: /* finally script */
if (i < objc-2) {
- Tcl_AppendResult(interp, "finally clause must be last", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "finally clause must be last", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
"NONTERMINAL", NULL);
return TCL_ERROR;
} else if (i == objc-1) {
- Tcl_AppendResult(interp, "wrong # args to finally clause: ",
- "must be \"", TclGetString(objv[0]),
- " ... finally script\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "wrong # args to finally clause: must be"
+ " \"... finally script\"", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
"ARGUMENT", NULL);
@@ -4188,15 +4195,16 @@ TclNRTryObjCmd(
case TryOn: /* on code variableList script */
if (i > objc-4) {
- Tcl_AppendResult(interp, "wrong # args to on clause: ",
- "must be \"", TclGetString(objv[0]),
- " ... on code variableList script\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "wrong # args to on clause: must be \"... on code"
+ " variableList script\"", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON",
"ARGUMENT", NULL);
return TCL_ERROR;
}
- if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, objv[i+1], &code)) {
+ if (TclGetCompletionCodeFromObj(interp, objv[i+1],
+ &code) != TCL_OK) {
Tcl_DecrRefCount(handlersObj);
return TCL_ERROR;
}
@@ -4205,9 +4213,10 @@ TclNRTryObjCmd(
case TryTrap: /* trap pattern variableList script */
if (i > objc-4) {
- Tcl_AppendResult(interp, "wrong # args to trap clause: ",
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "wrong # args to trap clause: "
"must be \"... trap pattern variableList script\"",
- NULL);
+ -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
"ARGUMENT", NULL);
@@ -4248,9 +4257,8 @@ TclNRTryObjCmd(
}
}
if (bodyShared) {
- Tcl_AppendResult(interp,
- "last non-finally clause must not have a body of \"-\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "last non-finally clause must not have a body of \"-\"", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH",
NULL);
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index dea487a..a4ba71a 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -236,7 +236,7 @@ QueryConfigObjCmd(
* present.
*/
- Tcl_SetResult(interp, "package not known", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
Tcl_GetString(pkgName), NULL);
return TCL_ERROR;
@@ -251,7 +251,7 @@ QueryConfigObjCmd(
if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK
|| val == NULL) {
- Tcl_SetResult(interp, "key not known", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
Tcl_GetString(objv[2]), NULL);
return TCL_ERROR;
@@ -270,8 +270,8 @@ QueryConfigObjCmd(
listPtr = Tcl_NewListObj(n, NULL);
if (!listPtr) {
- Tcl_SetResult(interp, "insufficient memory to create list",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "insufficient memory to create list", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
}
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index ac2cb62..691fab9 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -700,7 +700,8 @@ SetDictFromAny(
missingValue:
if (interp != NULL) {
- Tcl_SetResult(interp, "missing value to go with key", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "missing value to go with key", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
}
result = TCL_ERROR;
@@ -779,9 +780,9 @@ TclTraceDictPath(
}
if ((flags & DICT_PATH_CREATE) != DICT_PATH_CREATE) {
if (interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "key \"", TclGetString(keyv[i]),
- "\" not known in dictionary", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "key \"%s\" not known in dictionary",
+ TclGetString(keyv[i])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
TclGetString(keyv[i]), NULL);
}
@@ -1571,9 +1572,9 @@ DictGetCmd(
return result;
}
if (valuePtr == NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "key \"", TclGetString(objv[objc-1]),
- "\" not known in dictionary", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "key \"%s\" not known in dictionary",
+ TclGetString(objv[objc-1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
TclGetString(objv[objc-1]), NULL);
return TCL_ERROR;
@@ -2027,6 +2028,7 @@ DictInfoCmd(
{
Tcl_Obj *dictPtr;
Dict *dict;
+ char *statsStr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
@@ -2042,7 +2044,9 @@ DictInfoCmd(
}
dict = dictPtr->internalRep.otherValuePtr;
- Tcl_SetResult(interp, Tcl_HashStats(&dict->table), TCL_DYNAMIC);
+ statsStr = Tcl_HashStats(&dict->table);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1));
+ ckfree(statsStr);
return TCL_OK;
}
@@ -2371,8 +2375,8 @@ DictForNRCmd(
return TCL_ERROR;
}
if (varc != 2) {
- Tcl_SetResult(interp, "must have exactly two variable names",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "must have exactly two variable names", -1));
return TCL_ERROR;
}
searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch));
@@ -2787,8 +2791,8 @@ DictFilterCmd(
return TCL_ERROR;
}
if (varc != 2) {
- Tcl_SetResult(interp, "must have exactly two variable names",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "must have exactly two variable names", -1));
return TCL_ERROR;
}
keyVarObj = varv[0];
@@ -2828,16 +2832,19 @@ DictFilterCmd(
if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "couldn't set key variable: \"",
- TclGetString(keyVarObj), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't set key variable: \"%s\"",
+ TclGetString(keyVarObj)));
result = TCL_ERROR;
goto abnormalResult;
}
if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "couldn't set value variable: \"",
- TclGetString(valueVarObj), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't set value variable: \"%s\"",
+ TclGetString(valueVarObj)));
+ result = TCL_ERROR;
goto abnormalResult;
}
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 0fa6661..7a55724 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -1542,7 +1542,8 @@ OpenEncodingFileChannel(
}
if ((NULL == chan) && (interp != NULL)) {
- Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown encoding \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL);
}
Tcl_DecrRefCount(fileNameObj);
@@ -1616,7 +1617,8 @@ LoadEncodingFile(
break;
}
if ((encoding == NULL) && (interp != NULL)) {
- Tcl_AppendResult(interp, "invalid encoding file \"", name, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid encoding file \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL);
}
Tcl_Close(NULL, chan);
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 754e480..b76c603 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -17,6 +17,7 @@
* Declarations for functions local to this file:
*/
+static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr);
static inline int EnsembleUnknownCallback(Tcl_Interp *interp,
EnsembleConfig *ensemblePtr, int objc,
Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr);
@@ -78,6 +79,19 @@ const Tcl_ObjType tclEnsembleCmdType = {
NULL /* setFromAnyProc */
};
+static inline Tcl_Obj *
+NewNsObj(
+ Tcl_Namespace *namespacePtr)
+{
+ register Namespace *nsPtr = (Namespace *) namespacePtr;
+
+ if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) {
+ return Tcl_NewStringObj("::", 2);
+ } else {
+ return Tcl_NewStringObj(nsPtr->fullName, -1);
+ }
+}
+
/*
*----------------------------------------------------------------------
*
@@ -116,9 +130,10 @@ TclNamespaceEnsembleCmd(
if (nsPtr == NULL || nsPtr->flags & NS_DYING) {
if (!Tcl_InterpDeleted(interp)) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"tried to manipulate ensemble of deleted namespace",
- NULL);
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL);
}
return TCL_ERROR;
}
@@ -235,9 +250,11 @@ TclNamespaceEnsembleCmd(
return TCL_ERROR;
}
if (len < 1) {
- Tcl_SetResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"ensemble subcommand implementations "
- "must be non-empty lists", TCL_STATIC);
+ "must be non-empty lists", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
+ "EMPTY_TARGET", NULL);
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
@@ -250,7 +267,7 @@ TclNamespaceEnsembleCmd(
cmd = TclGetString(listv[0]);
if (!(cmd[0] == ':' && cmd[1] == ':')) {
Tcl_Obj *newList = Tcl_NewListObj(len, listv);
- Tcl_Obj *newCmd = Tcl_NewStringObj(nsPtr->fullName,-1);
+ Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace *) nsPtr);
if (nsPtr->parentPtr) {
Tcl_AppendStringsToObj(newCmd, "::", NULL);
@@ -370,8 +387,7 @@ TclNamespaceEnsembleCmd(
case CONF_NAMESPACE:
namespacePtr = NULL; /* silence gcc 4 warning */
Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
- Tcl_SetResult(interp, ((Namespace *) namespacePtr)->fullName,
- TCL_VOLATILE);
+ Tcl_SetObjResult(interp, NewNsObj(namespacePtr));
break;
case CONF_PREFIX: {
int flags = 0; /* silence gcc 4 warning */
@@ -411,9 +427,7 @@ TclNamespaceEnsembleCmd(
-1));
namespacePtr = NULL; /* silence gcc 4 warning */
Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
- Tcl_ListObjAppendElement(NULL, resultObj,
- Tcl_NewStringObj(((Namespace *) namespacePtr)->fullName,
- -1));
+ Tcl_ListObjAppendElement(NULL, resultObj, NewNsObj(namespacePtr));
/* -parameters option */
Tcl_ListObjAppendElement(NULL, resultObj,
@@ -515,9 +529,11 @@ TclNamespaceEnsembleCmd(
goto freeMapAndError;
}
if (len < 1) {
- Tcl_SetResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"ensemble subcommand implementations "
- "must be non-empty lists", TCL_STATIC);
+ "must be non-empty lists", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
+ "EMPTY_TARGET", NULL);
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
@@ -527,8 +543,7 @@ TclNamespaceEnsembleCmd(
cmd = TclGetString(listv[0]);
if (!(cmd[0] == ':' && cmd[1] == ':')) {
Tcl_Obj *newList = Tcl_DuplicateObj(listObj);
- Tcl_Obj *newCmd =
- Tcl_NewStringObj(nsPtr->fullName, -1);
+ Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*)nsPtr);
if (nsPtr->parentPtr) {
Tcl_AppendStringsToObj(newCmd, "::", NULL);
@@ -554,7 +569,9 @@ TclNamespaceEnsembleCmd(
continue;
}
case CONF_NAMESPACE:
- Tcl_AppendResult(interp, "option -namespace is read-only",
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "option -namespace is read-only", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY",
NULL);
goto freeMapAndError;
case CONF_PREFIX:
@@ -629,7 +646,7 @@ Tcl_CreateEnsemble(
*/
if (!(name[0] == ':' && name[1] == ':')) {
- nameObj = Tcl_NewStringObj(nsPtr->fullName, -1);
+ nameObj = NewNsObj((Tcl_Namespace *) nsPtr);
if (nsPtr->parentPtr == NULL) {
Tcl_AppendStringsToObj(nameObj, name, NULL);
} else {
@@ -702,7 +719,9 @@ Tcl_SetEnsembleSubcommandList(
Tcl_Obj *oldList;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (subcmdList != NULL) {
@@ -776,7 +795,9 @@ Tcl_SetEnsembleParameterList(
int length;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (paramList == NULL) {
@@ -850,7 +871,9 @@ Tcl_SetEnsembleMappingDict(
Tcl_Obj *oldDict;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (mapDict != NULL) {
@@ -873,9 +896,11 @@ Tcl_SetEnsembleMappingDict(
}
bytes = TclGetString(cmdObjPtr);
if (bytes[0] != ':' || bytes[1] != ':') {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"ensemble target is not a fully-qualified command",
- NULL);
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
+ "UNQUALIFIED_TARGET", NULL);
Tcl_DictObjDone(&search);
return TCL_ERROR;
}
@@ -945,7 +970,9 @@ Tcl_SetEnsembleUnknownHandler(
Tcl_Obj *oldList;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (unknownList != NULL) {
@@ -1009,7 +1036,9 @@ Tcl_SetEnsembleFlags(
int wasCompiled;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
@@ -1084,7 +1113,9 @@ Tcl_GetEnsembleSubcommandList(
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
@@ -1124,7 +1155,9 @@ Tcl_GetEnsembleParameterList(
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
@@ -1164,7 +1197,9 @@ Tcl_GetEnsembleMappingDict(
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
@@ -1203,7 +1238,9 @@ Tcl_GetEnsembleUnknownHandler(
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
@@ -1242,7 +1279,9 @@ Tcl_GetEnsembleFlags(
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
@@ -1281,7 +1320,9 @@ Tcl_GetEnsembleNamespace(
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
@@ -1337,8 +1378,9 @@ Tcl_FindEnsemble(
if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){
if (flags & TCL_LEAVE_ERR_MSG) {
- Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj),
- "\" is not an ensemble command", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not an ensemble command",
+ TclGetString(cmdNameObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
TclGetString(cmdNameObj), NULL);
}
@@ -1591,6 +1633,7 @@ NsEnsembleImplementationCmdNR(
* specified but not yet cached command
* names. */
int reparseCount = 0; /* Number of reparses. */
+ Tcl_Obj *errorObj; /* Used for building error messages. */
/*
* Must recheck objc, since numParameters might have changed. Cf. test
@@ -1631,8 +1674,9 @@ NsEnsembleImplementationCmdNR(
*/
if (!Tcl_InterpDeleted(interp)) {
- Tcl_AppendResult(interp,
- "ensemble activated for deleted namespace", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "ensemble activated for deleted namespace", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL);
}
return TCL_ERROR;
}
@@ -1880,35 +1924,34 @@ NsEnsembleImplementationCmdNR(
*/
Tcl_ResetResult(interp);
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
TclGetString(objv[1+ensemblePtr->numParameters]), NULL);
if (ensemblePtr->subcommandTable.numEntries == 0) {
- Tcl_AppendResult(interp, "unknown subcommand \"",
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown subcommand \"%s\": namespace %s does not"
+ " export any commands",
TclGetString(objv[1+ensemblePtr->numParameters]),
- "\": namespace ", ensemblePtr->nsPtr->fullName,
- " does not export any commands", NULL);
+ ensemblePtr->nsPtr->fullName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
TclGetString(objv[1+ensemblePtr->numParameters]), NULL);
return TCL_ERROR;
}
- Tcl_AppendResult(interp, "unknown ",
- (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""),
- "subcommand \"", TclGetString(objv[1+ensemblePtr->numParameters]),
- "\": must be ", NULL);
+ errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ",
+ (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""),
+ TclGetString(objv[1+ensemblePtr->numParameters]));
if (ensemblePtr->subcommandTable.numEntries == 1) {
- Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL);
+ Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1);
} else {
int i;
for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
- Tcl_AppendResult(interp,
- ensemblePtr->subcommandArrayPtr[i], ", ", NULL);
+ Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], -1);
+ Tcl_AppendToObj(errorObj, ", ", 2);
}
- Tcl_AppendResult(interp, "or ",
- ensemblePtr->subcommandArrayPtr[i], NULL);
+ Tcl_AppendPrintfToObj(errorObj, "or %s",
+ ensemblePtr->subcommandArrayPtr[i]);
}
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
- TclGetString(objv[1+ensemblePtr->numParameters]), NULL);
+ Tcl_SetObjResult(interp, errorObj);
return TCL_ERROR;
}
@@ -2034,7 +2077,6 @@ EnsembleUnknownCallback(
{
int paramc, i, result, prefixObjc;
Tcl_Obj **paramv, *unknownCmd, *ensObj;
- char buf[TCL_INTEGER_SPACE];
/*
* Create the unknown command callback to determine what to do.
@@ -2061,9 +2103,12 @@ EnsembleUnknownCallback(
((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT;
result = Tcl_EvalObjv(interp, paramc, paramv, 0);
if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) {
- Tcl_SetResult(interp,
- "unknown subcommand handler deleted its ensemble",
- TCL_STATIC);
+ if (!Tcl_InterpDeleted(interp)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unknown subcommand handler deleted its ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED",
+ NULL);
+ }
result = TCL_ERROR;
}
Tcl_Release(ensemblePtr);
@@ -2112,26 +2157,26 @@ EnsembleUnknownCallback(
if (!Tcl_InterpDeleted(interp)) {
if (result != TCL_ERROR) {
Tcl_ResetResult(interp);
- Tcl_SetResult(interp,
- "unknown subcommand handler returned bad code: ",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unknown subcommand handler returned bad code: ", -1));
switch (result) {
case TCL_RETURN:
- Tcl_AppendResult(interp, "return", NULL);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", -1);
break;
case TCL_BREAK:
- Tcl_AppendResult(interp, "break", NULL);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", -1);
break;
case TCL_CONTINUE:
- Tcl_AppendResult(interp, "continue", NULL);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", -1);
break;
default:
- sprintf(buf, "%d", result);
- Tcl_AppendResult(interp, buf, NULL);
+ Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result);
}
Tcl_AddErrorInfo(interp, "\n result of "
"ensemble unknown subcommand handler: ");
Tcl_AddErrorInfo(interp, TclGetString(unknownCmd));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_RESULT",
+ NULL);
} else {
Tcl_AddErrorInfo(interp,
"\n (ensemble unknown subcommand handler)");
@@ -2392,7 +2437,7 @@ BuildEnsembleConfig(
* the programmer's responsibility (or [::unknown] of course).
*/
- cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1);
+ cmdObj = NewNsObj((Tcl_Namespace *) ensemblePtr->nsPtr);
if (ensemblePtr->nsPtr->parentPtr != NULL) {
Tcl_AppendStringsToObj(cmdObj, "::", name, NULL);
} else {
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index e65862c..0b585b6 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -1416,7 +1416,7 @@ Tcl_VwaitObjCmd(
}
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "limit exceeded", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
break;
}
}
@@ -1426,8 +1426,9 @@ Tcl_VwaitObjCmd(
if (!foundEvent) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
- "\": would wait forever", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't wait for variable \"%s\": would wait forever",
+ nameString));
Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL);
return TCL_ERROR;
}
@@ -1519,7 +1520,7 @@ Tcl_UpdateObjCmd(
}
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "limit exceeded", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
return TCL_ERROR;
}
}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index e402634..3c0b472 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4896,8 +4896,8 @@ TEBCresume(
case INST_RSHIFT:
if (l2 < 0) {
- Tcl_SetResult(interp, "negative shift argument",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "negative shift argument", -1));
#if 0
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
@@ -4944,8 +4944,8 @@ TEBCresume(
case INST_LSHIFT:
if (l2 < 0) {
- Tcl_SetResult(interp, "negative shift argument",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "negative shift argument", -1));
#if 0
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
@@ -4967,9 +4967,8 @@ TEBCresume(
* good place to draw the line.
*/
- Tcl_SetResult(interp,
- "integer value too large to represent",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "integer value too large to represent", -1));
#if 0
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
@@ -5671,9 +5670,9 @@ TEBCresume(
NEXT_INST_V(5, opnd+1, 1);
}
DECACHE_STACK_INFO();
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS),
- "\" not known in dictionary", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "key \"%s\" not known in dictionary",
+ TclGetString(OBJ_AT_TOS)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
TclGetString(OBJ_AT_TOS), NULL);
CACHE_STACK_INFO();
@@ -6304,7 +6303,7 @@ TEBCresume(
divideByZero:
DECACHE_STACK_INFO();
- Tcl_SetResult(interp, "divide by zero", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
CACHE_STACK_INFO();
goto gotError;
@@ -6316,8 +6315,8 @@ TEBCresume(
exponOfZero:
DECACHE_STACK_INFO();
- Tcl_SetResult(interp, "exponentiation of zero by negative power",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "exponentiation of zero by negative power", -1));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"exponentiation of zero by negative power", NULL);
CACHE_STACK_INFO();
@@ -6693,7 +6692,8 @@ ExecuteExtendedBinaryMathOp(
invalid = 0;
}
if (invalid) {
- Tcl_SetResult(interp, "negative shift argument", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "negative shift argument", -1));
return GENERAL_ARITHMETIC_ERROR;
}
@@ -6723,8 +6723,8 @@ ExecuteExtendedBinaryMathOp(
* place to draw the line.
*/
- Tcl_SetResult(interp, "integer value too large to represent",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "integer value too large to represent", -1));
return GENERAL_ARITHMETIC_ERROR;
}
shift = (int)(*((const long *)ptr2));
@@ -7125,7 +7125,8 @@ ExecuteExtendedBinaryMathOp(
*/
if (type2 != TCL_NUMBER_LONG) {
- Tcl_SetResult(interp, "exponent too large", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "exponent too large", -1));
return GENERAL_ARITHMETIC_ERROR;
}
@@ -7363,7 +7364,8 @@ ExecuteExtendedBinaryMathOp(
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
if (big2.used > 1) {
mp_clear(&big2);
- Tcl_SetResult(interp, "exponent too large", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "exponent too large", -1));
return GENERAL_ARITHMETIC_ERROR;
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index a868fe3..33c1496 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -10,11 +10,6 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-#ifndef _WIN64
-/* See [Bug 2935503]: file mtime sets wrong time */
-# define _USE_32BIT_TIME_T
-#endif
-
#include "tclInt.h"
#include "tclFileSystem.h"
@@ -152,9 +147,9 @@ FileCopyRename(
if ((objc - i) > 2) {
errno = ENOTDIR;
Tcl_PosixError(interp);
- Tcl_AppendResult(interp, "error ",
- (copyFlag ? "copying" : "renaming"), ": target \"",
- TclGetString(target), "\" is not a directory", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error %s: target \"%s\" is not a directory",
+ (copyFlag?"copying":"renaming"), TclGetString(target)));
result = TCL_ERROR;
} else {
/*
@@ -304,8 +299,9 @@ TclFileMakeDirsCmd(
done:
if (errfile != NULL) {
- Tcl_AppendResult(interp, "can't create directory \"",
- TclGetString(errfile), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create directory \"%s\": %s",
+ TclGetString(errfile), Tcl_PosixError(interp)));
result = TCL_ERROR;
}
if (split != NULL) {
@@ -384,9 +380,9 @@ TclFileDeleteCmd(
result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer);
if (result != TCL_OK) {
if ((force == 0) && (errno == EEXIST)) {
- Tcl_AppendResult(interp, "error deleting \"",
- TclGetString(objv[i]), "\": directory not empty",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error deleting \"%s\": directory not empty",
+ TclGetString(objv[i])));
Tcl_PosixError(interp);
goto done;
}
@@ -426,12 +422,13 @@ TclFileDeleteCmd(
* We try to accomodate poor error results from our Tcl_FS calls.
*/
- Tcl_AppendResult(interp, "error deleting unknown file: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error deleting unknown file: %s",
+ Tcl_PosixError(interp)));
} else {
- Tcl_AppendResult(interp, "error deleting \"",
- TclGetString(errfile), "\": ", Tcl_PosixError(interp),
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error deleting \"%s\": %s",
+ TclGetString(errfile), Tcl_PosixError(interp)));
}
}
@@ -540,17 +537,17 @@ CopyRenameOneFile(
if (S_ISDIR(sourceStatBuf.st_mode)
&& !S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
- Tcl_AppendResult(interp, "can't overwrite file \"",
- TclGetString(target), "\" with directory \"",
- TclGetString(source), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't overwrite file \"%s\" with directory \"%s\"",
+ TclGetString(target), TclGetString(source)));
goto done;
}
if (!S_ISDIR(sourceStatBuf.st_mode)
&& S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
- Tcl_AppendResult(interp, "can't overwrite directory \"",
- TclGetString(target), "\" with file \"",
- TclGetString(source), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't overwrite directory \"%s\" with file \"%s\"",
+ TclGetString(target), TclGetString(source)));
goto done;
}
@@ -581,10 +578,10 @@ CopyRenameOneFile(
}
if (errno == EINVAL) {
- Tcl_AppendResult(interp, "error renaming \"",
- TclGetString(source), "\" to \"", TclGetString(target),
- "\": trying to rename a volume or "
- "move a directory into itself", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error renaming \"%s\" to \"%s\": trying to rename a"
+ " volume or move a directory into itself",
+ TclGetString(source), TclGetString(target)));
goto done;
} else if (errno != EXDEV) {
errfile = target;
@@ -628,8 +625,9 @@ CopyRenameOneFile(
* Actual file doesn't exist.
*/
- Tcl_AppendResult(interp, "error copying \"", TclGetString(source),
- "\": the target of this link doesn't exist", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error copying \"%s\": the target of this link doesn't"
+ " exist", TclGetString(source)));
goto done;
} else {
int counter = 0;
@@ -764,23 +762,27 @@ CopyRenameOneFile(
}
}
if (result != TCL_OK) {
- Tcl_AppendResult(interp, "can't unlink \"", TclGetString(errfile),
- "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("can't unlink \"%s\": %s",
+ TclGetString(errfile), Tcl_PosixError(interp)));
errfile = NULL;
}
}
done:
if (errfile != NULL) {
- Tcl_AppendResult(interp, "error ", (copyFlag ? "copying" : "renaming"),
- " \"", TclGetString(source), NULL);
+ Tcl_Obj *errorMsg = Tcl_ObjPrintf("error %s \"%s\"",
+ (copyFlag ? "copying" : "renaming"), TclGetString(source));
+
if (errfile != source) {
- Tcl_AppendResult(interp, "\" to \"", TclGetString(target), NULL);
+ Tcl_AppendPrintfToObj(errorMsg, " to \"%s\"",
+ TclGetString(target));
if (errfile != target) {
- Tcl_AppendResult(interp, "\": \"", TclGetString(errfile),NULL);
+ Tcl_AppendPrintfToObj(errorMsg, ": \"%s\"",
+ TclGetString(errfile));
}
}
- Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_AppendPrintfToObj(errorMsg, ": %s", Tcl_PosixError(interp));
+ Tcl_SetObjResult(interp, errorMsg);
}
if (errorBuffer != NULL) {
Tcl_DecrRefCount(errorBuffer);
@@ -983,9 +985,10 @@ TclFileAttrsCmd(
* There was an error, probably that the filePtr is not
* accepted by any filesystem
*/
- Tcl_AppendResult(interp, "could not read \"",
- TclGetString(filePtr), "\": ", Tcl_PosixError(interp),
- NULL);
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read \"%s\": %s",
+ TclGetString(filePtr), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -1071,9 +1074,9 @@ TclFileAttrsCmd(
Tcl_Obj *objPtr = NULL;
if (numObjStrings == 0) {
- Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]),
- "\", there are no file attributes in this filesystem.",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad option \"%s\", there are no file attributes in this"
+ " filesystem", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
goto end;
}
@@ -1098,9 +1101,9 @@ TclFileAttrsCmd(
int i, index;
if (numObjStrings == 0) {
- Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]),
- "\", there are no file attributes in this filesystem.",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad option \"%s\", there are no file attributes in this"
+ " filesystem", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
goto end;
}
@@ -1114,8 +1117,8 @@ TclFileAttrsCmd(
TclFreeIntRep(objv[i]);
}
if (i + 1 == objc) {
- Tcl_AppendResult(interp, "value for \"",
- TclGetString(objv[i]), "\" missing", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "value for \"%s\" missing", TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR",
"NOVALUE", NULL);
goto end;
@@ -1224,9 +1227,9 @@ TclFileLinkCmd(
*/
if (errno == EEXIST) {
- Tcl_AppendResult(interp, "could not create new link \"",
- TclGetString(objv[index]),
- "\": that path already exists", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not create new link \"%s\": that path already"
+ " exists", TclGetString(objv[index])));
Tcl_PosixError(interp);
} else if (errno == ENOENT) {
/*
@@ -1244,23 +1247,23 @@ TclFileLinkCmd(
access = Tcl_FSAccess(dirPtr, F_OK);
Tcl_DecrRefCount(dirPtr);
if (access != 0) {
- Tcl_AppendResult(interp, "could not create new link \"",
- TclGetString(objv[index]),
- "\": no such file or directory", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not create new link \"%s\": no such file"
+ " or directory", TclGetString(objv[index])));
Tcl_PosixError(interp);
} else {
- Tcl_AppendResult(interp, "could not create new link \"",
- TclGetString(objv[index]), "\": target \"",
- TclGetString(objv[index+1]), "\" doesn't exist",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not create new link \"%s\": target \"%s\" "
+ "doesn't exist", TclGetString(objv[index]),
+ TclGetString(objv[index+1])));
errno = ENOENT;
Tcl_PosixError(interp);
}
} else {
- Tcl_AppendResult(interp, "could not create new link \"",
- TclGetString(objv[index]), "\" pointing to \"",
- TclGetString(objv[index+1]), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not create new link \"%s\" pointing to \"%s\": %s",
+ TclGetString(objv[index]),
+ TclGetString(objv[index+1]), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -1275,9 +1278,9 @@ TclFileLinkCmd(
contents = Tcl_FSLink(objv[index], NULL, 0);
if (contents == NULL) {
- Tcl_AppendResult(interp, "could not read link \"",
- TclGetString(objv[index]), "\": ", Tcl_PosixError(interp),
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read link \"%s\": %s",
+ TclGetString(objv[index]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
}
@@ -1332,8 +1335,9 @@ TclFileReadLinkCmd(
contents = Tcl_FSLink(objv[1], NULL, 0);
if (contents == NULL) {
- Tcl_AppendResult(interp, "could not readlink \"",
- TclGetString(objv[1]), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read link \"%s\": %s",
+ TclGetString(objv[1]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
Tcl_SetObjResult(interp, contents);
@@ -1487,8 +1491,8 @@ TclFileTemporaryCmd(
if (nameVarObj) {
TclDecrRefCount(nameObj);
}
- Tcl_AppendResult(interp, "can't create temporary file: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create temporary file: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
Tcl_RegisterChannel(interp, chan);
@@ -1499,7 +1503,7 @@ TclFileTemporaryCmd(
return TCL_ERROR;
}
}
- Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
return TCL_OK;
}
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index edb6581..5d4702b 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -411,25 +411,28 @@ TclpGetNativePathType(
* Paths that begin with / are absolute.
*/
-#ifdef __QNX__
- /*
- * Check for QNX //<node id> prefix
- */
- if (*path && (pathLen > 3) && (path[0] == '/')
- && (path[1] == '/') && isdigit(UCHAR(path[2]))) {
- path += 3;
- while (isdigit(UCHAR(*path))) {
- path++;
- }
- }
-#endif
if (path[0] == '/') {
-#ifdef __CYGWIN__
+ ++path;
+#if defined(__CYGWIN__) || defined(__QNX__)
/*
- * Check for Cygwin // network path prefix
+ * Check for "//" network path prefix
*/
- if (path[1] == '/') {
- path++;
+ if ((*path == '/') && path[1] && (path[1] != '/')) {
+ path += 2;
+ while (*path && *path != '/') {
+ ++path;
+ }
+#if defined(__CYGWIN__)
+ /* UNC paths need to be followed by a share name */
+ if (*path++ && (*path && *path != '/')) {
+ ++path;
+ while (*path && *path != '/') {
+ ++path;
+ }
+ } else {
+ path = origPath + 1;
+ }
+#endif
}
#endif
if (driveNameLengthPtr != NULL) {
@@ -437,7 +440,7 @@ TclpGetNativePathType(
* We need this addition in case the QNX or Cygwin code was used.
*/
- *driveNameLengthPtr = (1 + path - origPath);
+ *driveNameLengthPtr = (path - origPath);
}
} else {
type = TCL_PATH_RELATIVE;
@@ -640,41 +643,43 @@ SplitUnixPath(
const char *path) /* Pointer to string containing a path. */
{
int length;
- const char *p, *elementStart;
+ const char *origPath = path, *elementStart;
Tcl_Obj *result = Tcl_NewObj();
/*
* Deal with the root directory as a special case.
*/
-#ifdef __QNX__
- /*
- * Check for QNX //<node id> prefix
- */
-
- if ((path[0] == '/') && (path[1] == '/')
- && isdigit(UCHAR(path[2]))) { /* INTL: digit */
- path += 3;
- while (isdigit(UCHAR(*path))) { /* INTL: digit */
- path++;
- }
- }
-#endif
-
- p = path;
- if (*p == '/') {
- Tcl_Obj *rootElt = Tcl_NewStringObj("/", 1);
- p++;
-#ifdef __CYGWIN__
+ if (*path == '/') {
+ Tcl_Obj *rootElt;
+ ++path;
+#if defined(__CYGWIN__) || defined(__QNX__)
/*
- * Check for Cygwin // network path prefix
+ * Check for "//" network path prefix
*/
- if (*p == '/') {
- Tcl_AppendToObj(rootElt, "/", 1);
- p++;
+ if ((*path == '/') && path[1] && (path[1] != '/')) {
+ path += 2;
+ while (*path && *path != '/') {
+ ++path;
+ }
+#if defined(__CYGWIN__)
+ /* UNC paths need to be followed by a share name */
+ if (*path++ && (*path && *path != '/')) {
+ ++path;
+ while (*path && *path != '/') {
+ ++path;
+ }
+ } else {
+ path = origPath + 1;
+ }
+#endif
}
#endif
+ rootElt = Tcl_NewStringObj(origPath, path - origPath);
Tcl_ListObjAppendElement(NULL, result, rootElt);
+ while (*path == '/') {
+ ++path;
+ }
}
/*
@@ -683,14 +688,14 @@ SplitUnixPath(
*/
for (;;) {
- elementStart = p;
- while ((*p != '\0') && (*p != '/')) {
- p++;
+ elementStart = path;
+ while ((*path != '\0') && (*path != '/')) {
+ path++;
}
- length = p - elementStart;
+ length = path - elementStart;
if (length > 0) {
Tcl_Obj *nextElt;
- if ((elementStart[0] == '~') && (elementStart != path)) {
+ if ((elementStart[0] == '~') && (elementStart != origPath)) {
TclNewLiteralStringObj(nextElt, "./");
Tcl_AppendToObj(nextElt, elementStart, length);
} else {
@@ -698,7 +703,7 @@ SplitUnixPath(
}
Tcl_ListObjAppendElement(NULL, result, nextElt);
}
- if (*p++ == '\0') {
+ if (*path++ == '\0') {
break;
}
}
@@ -1174,9 +1179,10 @@ DoTildeSubst(
dir = TclGetEnv("HOME", &dirString);
if (dir == NULL) {
if (interp) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "couldn't find HOME environment "
- "variable to expand path", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "couldn't find HOME environment "
+ "variable to expand path", -1));
+ Tcl_SetErrorCode(interp, "TCL", "FILENAME", "NO_HOME", NULL);
}
return NULL;
}
@@ -1185,8 +1191,9 @@ DoTildeSubst(
} else if (TclpGetUserHome(user, resultPtr) == NULL) {
if (interp) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "user \"%s\" doesn't exist", user));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "USER", user, NULL);
}
return NULL;
}
@@ -1329,9 +1336,9 @@ Tcl_GlobObjCmd(
endOfForLoop:
if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-tails\" must be used with either "
- "\"-directory\" or \"-path\"", NULL);
+ "\"-directory\" or \"-path\"", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
"BADOPTIONCOMBINATION", NULL);
return TCL_ERROR;
@@ -1625,20 +1632,23 @@ Tcl_GlobObjCmd(
}
if (length == 0) {
- Tcl_AppendResult(interp, "no files matched glob pattern",
- (join || (objc == 1)) ? " \"" : "s \"", NULL);
+ Tcl_Obj *errorMsg =
+ Tcl_ObjPrintf("no files matched glob pattern%s \"",
+ (join || (objc == 1)) ? "" : "s");
+
if (join) {
- Tcl_AppendResult(interp, Tcl_DStringValue(&prefix), NULL);
+ Tcl_AppendToObj(errorMsg, Tcl_DStringValue(&prefix), -1);
} else {
const char *sep = "";
for (i = 0; i < objc; i++) {
- string = Tcl_GetString(objv[i]);
- Tcl_AppendResult(interp, sep, string, NULL);
+ Tcl_AppendPrintfToObj(errorMsg, "%s%s",
+ sep, Tcl_GetString(objv[i]));
sep = " ";
}
}
- Tcl_AppendResult(interp, "\"", NULL);
+ Tcl_AppendToObj(errorMsg, "\"", -1);
+ Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH",
NULL);
result = TCL_ERROR;
@@ -1769,6 +1779,7 @@ TclGlob(
if (c != '\0') {
tail++;
}
+ Tcl_DStringFree(&buffer);
} else {
tail = pattern;
}
@@ -2206,15 +2217,15 @@ DoGlob(
closeBrace = p;
break;
}
- Tcl_SetResult(interp, "unmatched open-brace in file name",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unmatched open-brace in file name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
NULL);
return TCL_ERROR;
} else if (*p == '}') {
- Tcl_SetResult(interp, "unmatched close-brace in file name",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unmatched close-brace in file name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
NULL);
return TCL_ERROR;
diff --git a/generic/tclIO.c b/generic/tclIO.c
index ea6c2d7..4e24533 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -427,7 +427,10 @@ TclFinalizeIOSubsystem(void)
statePtr != NULL;
statePtr = statePtr->nextCSPtr) {
chanPtr = statePtr->topChanPtr;
- if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED | CHANNEL_DEAD)
+ if (GotFlag(statePtr, CHANNEL_DEAD)) {
+ continue;
+ }
+ if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED )
|| GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
active = 1;
@@ -1024,8 +1027,9 @@ Tcl_UnregisterChannel(
if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "Illegal recursive call to close "
- "through close-handler of channel", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "illegal recursive call to close through close-handler"
+ " of channel", -1));
}
return TCL_ERROR;
}
@@ -1260,8 +1264,8 @@ Tcl_GetChannel(
hTblPtr = GetChannelTable(interp);
hPtr = Tcl_FindHashEntry(hTblPtr, name);
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "can not find channel named \"", chanName,
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can not find channel named \"%s\"", chanName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanName, NULL);
return NULL;
}
@@ -1581,8 +1585,9 @@ Tcl_StackChannel(
if (statePtr == NULL) {
if (interp) {
- Tcl_AppendResult(interp, "couldn't find state for channel \"",
- Tcl_GetChannelName(prevChan), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't find state for channel \"%s\"",
+ Tcl_GetChannelName(prevChan)));
}
return NULL;
}
@@ -1602,9 +1607,9 @@ Tcl_StackChannel(
if ((mask & (statePtr->flags & (TCL_READABLE | TCL_WRITABLE))) == 0) {
if (interp) {
- Tcl_AppendResult(interp,
- "reading and writing both disallowed for channel \"",
- Tcl_GetChannelName(prevChan), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "reading and writing both disallowed for channel \"%s\"",
+ Tcl_GetChannelName(prevChan)));
}
return NULL;
}
@@ -1627,8 +1632,9 @@ Tcl_StackChannel(
statePtr->csPtrR = csPtrR;
statePtr->csPtrW = csPtrW;
if (interp) {
- Tcl_AppendResult(interp, "could not flush channel \"",
- Tcl_GetChannelName(prevChan), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not flush channel \"%s\"",
+ Tcl_GetChannelName(prevChan)));
}
return NULL;
}
@@ -1781,9 +1787,9 @@ Tcl_UnstackChannel(
*/
if (!TclChanCaughtErrorBypass(interp, chan) && interp) {
- Tcl_AppendResult(interp, "could not flush channel \"",
- Tcl_GetChannelName((Tcl_Channel) chanPtr), "\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not flush channel \"%s\"",
+ Tcl_GetChannelName((Tcl_Channel) chanPtr)));
}
return TCL_ERROR;
}
@@ -2315,8 +2321,8 @@ CheckForDeadChannel(
Tcl_SetErrno(EINVAL);
if (interp) {
- Tcl_AppendResult(interp, "unable to access channel: invalid channel",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unable to access channel: invalid channel", -1));
}
return 1;
}
@@ -3048,8 +3054,9 @@ Tcl_Close(
if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
if (interp) {
- Tcl_AppendResult(interp, "Illegal recursive call to close "
- "through close-handler of channel", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "illegal recursive call to close through close-handler"
+ " of channel", -1));
}
return TCL_ERROR;
}
@@ -3207,8 +3214,9 @@ Tcl_CloseEx(
*/
if (!chanPtr->typePtr->close2Proc) {
- Tcl_AppendResult(interp, "Half-close of channels not supported by ",
- chanPtr->typePtr->typeName, "s", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "half-close of channels not supported by %ss",
+ chanPtr->typePtr->typeName));
return TCL_ERROR;
}
@@ -3217,9 +3225,8 @@ Tcl_CloseEx(
*/
if (chanPtr != statePtr->topChanPtr) {
- Tcl_AppendResult(interp,
- "Half-close not applicable to stack of transformations",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "half-close not applicable to stack of transformations", -1));
return TCL_ERROR;
}
@@ -3237,9 +3244,9 @@ Tcl_CloseEx(
} else {
msg = "write";
}
- Tcl_AppendResult(interp, "Half-close of ", msg,
- "-side not possible, side not opened or already closed",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "Half-close of %s-side not possible, side not opened or"
+ " already closed", msg));
return TCL_ERROR;
}
@@ -3250,8 +3257,9 @@ Tcl_CloseEx(
if (statePtr->flags & CHANNEL_INCLOSE) {
if (interp) {
- Tcl_AppendResult(interp, "Illegal recursive call to close "
- "through close-handler of channel", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "illegal recursive call to close through close-handler"
+ " of channel", -1));
}
return TCL_ERROR;
}
@@ -7544,6 +7552,7 @@ Tcl_BadChannelOption(
const char **argv;
int argc, i;
Tcl_DString ds;
+ Tcl_Obj *errObj;
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, genericopt, -1);
@@ -7556,13 +7565,14 @@ Tcl_BadChannelOption(
Tcl_Panic("malformed option list in channel driver");
}
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad option \"", optionName,
- "\": should be one of ", NULL);
+ errObj = Tcl_ObjPrintf("bad option \"%s\": should be one of ",
+ optionName);
argc--;
for (i = 0; i < argc; i++) {
- Tcl_AppendResult(interp, "-", argv[i], ", ", NULL);
+ Tcl_AppendPrintfToObj(errObj, "-%s, ", argv[i]);
}
- Tcl_AppendResult(interp, "or -", argv[i], NULL);
+ Tcl_AppendPrintfToObj(errObj, "or -%s", argv[i]);
+ Tcl_SetObjResult(interp, errObj);
Tcl_DStringFree(&ds);
ckfree(argv);
}
@@ -7840,8 +7850,9 @@ Tcl_SetChannelOption(
if (statePtr->csPtrR || statePtr->csPtrW) {
if (interp) {
- Tcl_AppendResult(interp, "unable to set channel options: "
- "background copy in progress", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unable to set channel options: background copy in"
+ " progress", -1));
}
return TCL_ERROR;
}
@@ -7890,8 +7901,9 @@ Tcl_SetChannelOption(
ResetFlag(statePtr, CHANNEL_LINEBUFFERED);
SetFlag(statePtr, CHANNEL_UNBUFFERED);
} else if (interp) {
- Tcl_AppendResult(interp, "bad value for -buffering: "
- "must be one of full, line, or none", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad value for -buffering: must be one of"
+ " full, line, or none", -1));
return TCL_ERROR;
}
return TCL_OK;
@@ -7946,8 +7958,9 @@ Tcl_SetChannelOption(
if (inValue & 0x80 || outValue & 0x80) {
if (interp) {
- Tcl_AppendResult(interp, "bad value for -eofchar: ",
- "must be non-NUL ASCII character", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad value for -eofchar: must be non-NUL ASCII"
+ " character", -1));
}
ckfree(argv);
return TCL_ERROR;
@@ -7960,9 +7973,9 @@ Tcl_SetChannelOption(
}
} else {
if (interp) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -eofchar: should be a list of zero,"
- " one, or two elements", NULL);
+ " one, or two elements", -1));
}
ckfree(argv);
return TCL_ERROR;
@@ -7994,9 +8007,9 @@ Tcl_SetChannelOption(
writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[1] : NULL;
} else {
if (interp) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be a one or two"
- " element list", NULL);
+ " element list", -1));
}
ckfree(argv);
return TCL_ERROR;
@@ -8024,10 +8037,9 @@ Tcl_SetChannelOption(
translation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
- Tcl_AppendResult(interp,
- "bad value for -translation: "
- "must be one of auto, binary, cr, lf, crlf,"
- " or platform", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad value for -translation: must be one of "
+ "auto, binary, cr, lf, crlf, or platform", -1));
}
ckfree(argv);
return TCL_ERROR;
@@ -8075,10 +8087,9 @@ Tcl_SetChannelOption(
statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
- Tcl_AppendResult(interp,
- "bad value for -translation: "
- "must be one of auto, binary, cr, lf, crlf,"
- " or platform", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad value for -translation: must be one of "
+ "auto, binary, cr, lf, crlf, or platform", -1));
}
ckfree(argv);
return TCL_ERROR;
@@ -8822,6 +8833,7 @@ TclChannelEventScriptInvoker(
*/
Tcl_Preserve(interp);
+ Tcl_Preserve(chanPtr);
result = Tcl_EvalObjEx(interp, esPtr->scriptPtr, TCL_EVAL_GLOBAL);
/*
@@ -8838,6 +8850,7 @@ TclChannelEventScriptInvoker(
}
Tcl_BackgroundException(interp, result);
}
+ Tcl_Release(chanPtr);
Tcl_Release(interp);
}
@@ -8896,8 +8909,8 @@ Tcl_FileEventObjCmd(
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
if ((statePtr->flags & mask) == 0) {
- Tcl_AppendResult(interp, "channel is not ",
- (mask == TCL_READABLE) ? "readable" : "writable", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("channel is not %s",
+ (mask == TCL_READABLE) ? "readable" : "writable"));
return TCL_ERROR;
}
@@ -9018,15 +9031,15 @@ TclCopyChannel(
if (BUSY_STATE(inStatePtr, TCL_READABLE)) {
if (interp) {
- Tcl_AppendResult(interp, "channel \"",
- Tcl_GetChannelName(inChan), "\" is busy", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" is busy", Tcl_GetChannelName(inChan)));
}
return TCL_ERROR;
}
if (BUSY_STATE(outStatePtr, TCL_WRITABLE)) {
if (interp) {
- Tcl_AppendResult(interp, "channel \"",
- Tcl_GetChannelName(outChan), "\" is busy", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" is busy", Tcl_GetChannelName(outChan)));
}
return TCL_ERROR;
}
@@ -10152,8 +10165,9 @@ SetBlockMode(
*/
if (!TclChanCaughtErrorBypass(interp, (Tcl_Channel) chanPtr)) {
- Tcl_AppendResult(interp, "error setting blocking mode: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error setting blocking mode: %s",
+ Tcl_PosixError(interp)));
}
} else {
/*
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 59856d0..005713d 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -174,9 +174,10 @@ Tcl_PutsObjCmd(
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
- if ((mode & TCL_WRITABLE) == 0) {
- Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr),
- "\" wasn't opened for writing", NULL);
+ if (!(mode & TCL_WRITABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't opened for writing",
+ TclGetString(chanObjPtr)));
return TCL_ERROR;
}
@@ -201,8 +202,8 @@ Tcl_PutsObjCmd(
error:
if (!TclChanCaughtErrorBypass(interp, chan)) {
- Tcl_AppendResult(interp, "error writing \"", TclGetString(chanObjPtr),
- "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s",
+ TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -244,9 +245,10 @@ Tcl_FlushObjCmd(
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
- if ((mode & TCL_WRITABLE) == 0) {
- Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr),
- "\" wasn't opened for writing", NULL);
+ if (!(mode & TCL_WRITABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't opened for writing",
+ TclGetString(chanObjPtr)));
return TCL_ERROR;
}
@@ -259,9 +261,9 @@ Tcl_FlushObjCmd(
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
- Tcl_AppendResult(interp, "error flushing \"",
- TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp),
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error flushing \"%s\": %s",
+ TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -306,9 +308,10 @@ Tcl_GetsObjCmd(
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
- if ((mode & TCL_READABLE) == 0) {
- Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr),
- "\" wasn't opened for reading", NULL);
+ if (!(mode & TCL_READABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't opened for reading",
+ TclGetString(chanObjPtr)));
return TCL_ERROR;
}
@@ -326,10 +329,9 @@ Tcl_GetsObjCmd(
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "error reading \"",
- TclGetString(chanObjPtr), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error reading \"%s\": %s",
+ TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -411,9 +413,10 @@ Tcl_ReadObjCmd(
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
- if ((mode & TCL_READABLE) == 0) {
- Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr),
- "\" wasn't opened for reading", NULL);
+ if (!(mode & TCL_READABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't opened for reading",
+ TclGetString(chanObjPtr)));
return TCL_ERROR;
}
i++; /* Consumed channel name. */
@@ -436,11 +439,11 @@ Tcl_ReadObjCmd(
if (strcmp(TclGetString(objv[i]), "nonewline") != 0) {
#endif
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "expected non-negative integer but got \"",
- TclGetString(objv[i]), "\"", NULL);
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
- return TCL_ERROR;
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected non-negative integer but got \"%s\"",
+ TclGetString(objv[i])));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
+ return TCL_ERROR;
#if TCL_MAJOR_VERSION < 9
}
newline = 1;
@@ -460,10 +463,9 @@ Tcl_ReadObjCmd(
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "error reading \"",
- TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp),
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error reading \"%s\": %s",
+ TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
@@ -552,9 +554,9 @@ Tcl_SeekObjCmd(
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
- Tcl_AppendResult(interp, "error during seek on \"",
- TclGetString(objv[1]), "\": ", Tcl_PosixError(interp),
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error during seek on \"%s\": %s",
+ TclGetString(objv[1]), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -679,9 +681,9 @@ Tcl_CloseObjCmd(
*/
if (!(dir & Tcl_GetChannelMode(chan))) {
- Tcl_AppendResult(interp, "Half-close of ", dirOptions[index],
- "-side not possible, side not opened or already closed",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "Half-close of %s-side not possible, side not opened"
+ " or already closed", dirOptions[index]));
return TCL_ERROR;
}
@@ -977,9 +979,9 @@ Tcl_ExecObjCmd(
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "error reading output from command: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error reading output from command: %s",
+ Tcl_PosixError(interp)));
Tcl_DecrRefCount(resultPtr);
}
return TCL_ERROR;
@@ -1048,9 +1050,10 @@ Tcl_FblockedObjCmd(
if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
- if ((mode & TCL_READABLE) == 0) {
- Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]),
- "\" wasn't opened for reading", NULL);
+ if (!(mode & TCL_READABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't opened for reading",
+ TclGetString(objv[1])));
return TCL_ERROR;
}
@@ -1174,7 +1177,7 @@ Tcl_OpenObjCmd(
return TCL_ERROR;
}
Tcl_RegisterChannel(interp, chan);
- Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
return TCL_OK;
}
@@ -1479,8 +1482,8 @@ Tcl_SocketObjCmd(
switch ((enum socketOptions) optionIndex) {
case SKT_ASYNC:
if (server == 1) {
- Tcl_AppendResult(interp,
- "cannot set -async option for server sockets", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot set -async option for server sockets", -1));
return TCL_ERROR;
}
async = 1;
@@ -1488,8 +1491,8 @@ Tcl_SocketObjCmd(
case SKT_MYADDR:
a++;
if (a >= objc) {
- Tcl_AppendResult(interp,
- "no argument given for -myaddr option", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no argument given for -myaddr option", -1));
return TCL_ERROR;
}
myaddr = TclGetString(objv[a]);
@@ -1499,8 +1502,8 @@ Tcl_SocketObjCmd(
a++;
if (a >= objc) {
- Tcl_AppendResult(interp,
- "no argument given for -myport option", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no argument given for -myport option", -1));
return TCL_ERROR;
}
myPortName = TclGetString(objv[a]);
@@ -1511,15 +1514,15 @@ Tcl_SocketObjCmd(
}
case SKT_SERVER:
if (async == 1) {
- Tcl_AppendResult(interp,
- "cannot set -async option for server sockets", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot set -async option for server sockets", -1));
return TCL_ERROR;
}
server = 1;
a++;
if (a >= objc) {
- Tcl_AppendResult(interp,
- "no argument given for -server option", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no argument given for -server option", -1));
return TCL_ERROR;
}
script = TclGetString(objv[a]);
@@ -1531,8 +1534,8 @@ Tcl_SocketObjCmd(
if (server) {
host = myaddr; /* NULL implies INADDR_ANY */
if (myport != 0) {
- Tcl_AppendResult(interp, "option -myport is not valid for servers",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "option -myport is not valid for servers", -1));
return TCL_ERROR;
}
} else if (a < objc) {
@@ -1599,9 +1602,9 @@ Tcl_SocketObjCmd(
return TCL_ERROR;
}
}
- Tcl_RegisterChannel(interp, chan);
- Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL);
+ Tcl_RegisterChannel(interp, chan);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
return TCL_OK;
}
@@ -1651,17 +1654,19 @@ Tcl_FcopyObjCmd(
if (TclGetChannelFromObj(interp, objv[1], &inChan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
- if ((mode & TCL_READABLE) == 0) {
- Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]),
- "\" wasn't opened for reading", NULL);
+ if (!(mode & TCL_READABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't opened for reading",
+ TclGetString(objv[1])));
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[2], &outChan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
- if ((mode & TCL_WRITABLE) == 0) {
- Tcl_AppendResult(interp, "channel \"", TclGetString(objv[2]),
- "\" wasn't opened for writing", NULL);
+ if (!(mode & TCL_WRITABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't opened for writing",
+ TclGetString(objv[2])));
return TCL_ERROR;
}
@@ -1745,14 +1750,14 @@ ChanPendingObjCmd(
switch ((enum options) index) {
case PENDING_INPUT:
- if ((mode & TCL_READABLE) == 0) {
+ if (!(mode & TCL_READABLE)) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
} else {
Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_InputBuffered(chan)));
}
break;
case PENDING_OUTPUT:
- if ((mode & TCL_WRITABLE) == 0) {
+ if (!(mode & TCL_WRITABLE)) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
} else {
Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan)));
@@ -1806,8 +1811,8 @@ ChanTruncateObjCmd(
return TCL_ERROR;
}
if (length < 0) {
- Tcl_AppendResult(interp,
- "cannot truncate to negative length of file", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot truncate to negative length of file", -1));
return TCL_ERROR;
}
} else {
@@ -1817,18 +1822,17 @@ ChanTruncateObjCmd(
length = Tcl_Tell(chan);
if (length == Tcl_WideAsLong(-1)) {
- Tcl_AppendResult(interp,
- "could not determine current location in \"",
- TclGetString(objv[1]), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not determine current location in \"%s\": %s",
+ TclGetString(objv[1]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
}
if (Tcl_TruncateChannel(chan, length) != TCL_OK) {
- Tcl_AppendResult(interp, "error during truncate on \"",
- TclGetString(objv[1]), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error during truncate on \"%s\": %s",
+ TclGetString(objv[1]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c
index 6f80c25..bfe6a10 100644
--- a/generic/tclIOGT.c
+++ b/generic/tclIOGT.c
@@ -284,8 +284,8 @@ TclChannelTransform(
dataPtr->self = Tcl_StackChannel(interp, &transformChannelType, dataPtr,
mode, chan);
if (dataPtr->self == NULL) {
- Tcl_AppendResult(interp, "\nfailed to stack channel \"",
- Tcl_GetChannelName(chan), "\"", NULL);
+ Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp),
+ "\nfailed to stack channel \"%s\"", Tcl_GetChannelName(chan));
Tcl_DecrRefCount(dataPtr->command);
ResultClear(&dataPtr->result);
ckfree(dataPtr);
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index 6fec40a..cb0282a 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -404,25 +404,25 @@ static int ForwardProc(Tcl_Event *evPtr, int mask);
static void SrcExitProc(ClientData clientData);
#define FreeReceivedError(p) \
- if ((p)->base.mustFree) { \
- ckfree((p)->base.msgStr); \
+ if ((p)->base.mustFree) { \
+ ckfree((p)->base.msgStr); \
}
#define PassReceivedErrorInterp(i,p) \
- if ((i) != NULL) { \
- Tcl_SetChannelErrorInterp((i), \
- Tcl_NewStringObj((p)->base.msgStr, -1)); \
- } \
+ if ((i) != NULL) { \
+ Tcl_SetChannelErrorInterp((i), \
+ Tcl_NewStringObj((p)->base.msgStr, -1)); \
+ } \
FreeReceivedError(p)
#define PassReceivedError(c,p) \
Tcl_SetChannelError((c), Tcl_NewStringObj((p)->base.msgStr, -1)); \
FreeReceivedError(p)
#define ForwardSetStaticError(p,emsg) \
- (p)->base.code = TCL_ERROR; \
- (p)->base.mustFree = 0; \
+ (p)->base.code = TCL_ERROR; \
+ (p)->base.mustFree = 0; \
(p)->base.msgStr = (char *) (emsg)
#define ForwardSetDynamicError(p,emsg) \
- (p)->base.code = TCL_ERROR; \
- (p)->base.mustFree = 1; \
+ (p)->base.code = TCL_ERROR; \
+ (p)->base.mustFree = 1; \
(p)->base.msgStr = (char *) (emsg)
static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr);
@@ -739,7 +739,8 @@ TclChanCreateObjCmd(
* Return handle as result of command.
*/
- Tcl_SetResult(interp, (char *)chanPtr->state->channelName, TCL_VOLATILE);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(chanPtr->state->channelName, -1));
return TCL_OK;
error:
@@ -774,13 +775,15 @@ TclChanCreateObjCmd(
*/
typedef struct ReflectEvent {
- Tcl_Event header;
- ReflectedChannel* rcPtr;
- int events;
+ Tcl_Event header;
+ ReflectedChannel *rcPtr;
+ int events;
} ReflectEvent;
static int
-ReflectEventRun (Tcl_Event* ev, int flags)
+ReflectEventRun(
+ Tcl_Event *ev,
+ int flags)
{
/* OWNER thread
*
@@ -789,14 +792,16 @@ ReflectEventRun (Tcl_Event* ev, int flags)
* accomplishing that.
*/
- ReflectEvent* e = (ReflectEvent*) ev;
+ ReflectEvent *e = (ReflectEvent *) ev;
- Tcl_NotifyChannel (e->rcPtr->chan, e->events);
+ Tcl_NotifyChannel(e->rcPtr->chan, e->events);
return 1;
}
static int
-ReflectEventDelete (Tcl_Event* ev, ClientData cd)
+ReflectEventDelete(
+ Tcl_Event *ev,
+ ClientData cd)
{
/* OWNER thread
*
@@ -805,11 +810,9 @@ ReflectEventDelete (Tcl_Event* ev, ClientData cd)
* invalid channel.
*/
- ReflectEvent* e = (ReflectEvent*) ev;
+ ReflectEvent *e = (ReflectEvent *) ev;
- if ((ev->proc != ReflectEventRun) ||
- ((cd != NULL) &&
- (cd != e->rcPtr))) {
+ if ((ev->proc != ReflectEventRun) || ((cd != NULL) && (cd != e->rcPtr))) {
return 0;
}
return 1;
@@ -867,8 +870,8 @@ TclChanPostEventObjCmd(
hPtr = Tcl_FindHashEntry(&rcmPtr->map, chanId);
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "can not find reflected channel named \"",
- chanId, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can not find reflected channel named \"%s\"", chanId));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanId, NULL);
return TCL_ERROR;
}
@@ -925,8 +928,9 @@ TclChanPostEventObjCmd(
*/
if (events & ~rcPtr->interest) {
- Tcl_AppendResult(interp, "tried to post events channel \"", chanId,
- "\" is not interested in", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "tried to post events channel \"%s\" is not interested in",
+ chanId));
return TCL_ERROR;
}
@@ -937,10 +941,11 @@ TclChanPostEventObjCmd(
#ifdef TCL_THREADS
if (rcPtr->owner == rcPtr->thread) {
#endif
- Tcl_NotifyChannel (chan, events);
+ Tcl_NotifyChannel(chan, events);
#ifdef TCL_THREADS
} else {
- ReflectEvent* ev = ckalloc (sizeof (ReflectEvent));
+ ReflectEvent *ev = ckalloc(sizeof(ReflectEvent));
+
ev->header.proc = ReflectEventRun;
ev->events = events;
ev->rcPtr = rcPtr;
@@ -957,7 +962,8 @@ TclChanPostEventObjCmd(
* The teardown of unprocessed events is currently coupled to the
* thread reflected channel map
*/
- (void) GetThreadReflectedChannelMap ();
+
+ (void) GetThreadReflectedChannelMap();
/* XXX Race condition !!
* XXX The destination thread may not exist anymore already.
@@ -965,8 +971,9 @@ TclChanPostEventObjCmd(
* XXX Can we detect this ? (check the validity of the owner threadid ?)
* XXX Actually, in that case the channel should be dead also !
*/
- Tcl_ThreadQueueEvent (rcPtr->owner, (Tcl_Event*) ev, TCL_QUEUE_TAIL);
- Tcl_ThreadAlert (rcPtr->owner);
+
+ Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev, TCL_QUEUE_TAIL);
+ Tcl_ThreadAlert(rcPtr->owner);
}
#endif
@@ -1156,8 +1163,11 @@ ReflectClose(
ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p);
result = p.base.code;
- /* Now squash the pending reflection events for this channel. */
- Tcl_DeleteEvents (ReflectEventDelete, rcPtr);
+ /*
+ * Now squash the pending reflection events for this channel.
+ */
+
+ Tcl_DeleteEvents(ReflectEventDelete, rcPtr);
if (result != TCL_OK) {
FreeReceivedError(&p);
@@ -1165,7 +1175,7 @@ ReflectClose(
}
#endif
- Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
+ Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
return EOK;
}
@@ -1177,7 +1187,7 @@ ReflectClose(
*/
if (rcPtr->methods == 0) {
- Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
+ Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
return EOK;
}
@@ -1192,10 +1202,13 @@ ReflectClose(
ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p);
result = p.base.code;
- /* Now squash the pending reflection events for this channel. */
- Tcl_DeleteEvents (ReflectEventDelete, rcPtr);
+ /*
+ * Now squash the pending reflection events for this channel.
+ */
+
+ Tcl_DeleteEvents(ReflectEventDelete, rcPtr);
- Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
+ Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
if (result != TCL_OK) {
PassReceivedErrorInterp(interp, &p);
@@ -1240,7 +1253,7 @@ ReflectClose(
}
#endif
- Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
+ Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
#ifdef TCL_THREADS
}
#endif
@@ -1348,7 +1361,7 @@ ReflectInput(
*errorCodePtr = EOK;
if (bytec > 0) {
- memcpy(buf, bytev, (size_t)bytec);
+ memcpy(buf, bytev, (size_t) bytec);
}
stop:
@@ -1549,12 +1562,13 @@ ReflectSeekWide(
Tcl_Preserve(rcPtr);
offObj = Tcl_NewWideIntObj(offset);
- baseObj = Tcl_NewStringObj((seekMode == SEEK_SET) ? "start" :
- ((seekMode == SEEK_CUR) ? "current" : "end"), -1);
+ baseObj = Tcl_NewStringObj(
+ (seekMode == SEEK_SET) ? "start" :
+ (seekMode == SEEK_CUR) ? "current" : "end", -1);
Tcl_IncrRefCount(offObj);
Tcl_IncrRefCount(baseObj);
- if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj)!=TCL_OK) {
+ if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj) != TCL_OK) {
Tcl_SetChannelError(rcPtr->chan, resObj);
goto invalid;
}
@@ -1760,7 +1774,9 @@ ReflectBlock(
*/
static void
-ReflectThread(ClientData clientData, int action)
+ReflectThread(
+ ClientData clientData,
+ int action)
{
ReflectedChannel *rcPtr = clientData;
@@ -1772,7 +1788,7 @@ ReflectThread(ClientData clientData, int action)
rcPtr->owner = NULL;
break;
default:
- Tcl_Panic ("Unknown thread action code.");
+ Tcl_Panic("Unknown thread action code.");
break;
}
}
@@ -2046,7 +2062,8 @@ EncodeEventMask(
}
if (listc < 1) {
- Tcl_AppendResult(interp, "bad ", objName, " list: is empty", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad %s list: is empty", objName));
return TCL_ERROR;
}
@@ -2807,7 +2824,7 @@ DeleteThreadReflectedChannelMap(
* actually.
*/
- Tcl_DeleteEvents (ReflectEventDelete, NULL);
+ Tcl_DeleteEvents(ReflectEventDelete, NULL);
/*
* Get the map of all channels handled by the current thread. This is a
@@ -2978,9 +2995,8 @@ ForwardProc(
Tcl_Interp *interp = rcPtr->interp;
ForwardParam *paramPtr = evPtr->param;
Tcl_Obj *resObj = NULL; /* Interp result of InvokeTclMethod */
- ReflectedChannelMap *rcmPtr;
- /* Map of reflected channels with handlers in
- * this interp. */
+ ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in
+ * this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
/*
@@ -3023,12 +3039,12 @@ ForwardProc(
rcmPtr = GetReflectedChannelMap(interp);
hPtr = Tcl_FindHashEntry(&rcmPtr->map,
- Tcl_GetChannelName(rcPtr->chan));
+ Tcl_GetChannelName(rcPtr->chan));
Tcl_DeleteHashEntry(hPtr);
rcmPtr = GetThreadReflectedChannelMap();
hPtr = Tcl_FindHashEntry(&rcmPtr->map,
- Tcl_GetChannelName(rcPtr->chan));
+ Tcl_GetChannelName(rcPtr->chan));
Tcl_DeleteHashEntry(hPtr);
FreeReflectedChannelArgs(rcPtr);
@@ -3063,7 +3079,7 @@ ForwardProc(
paramPtr->input.toRead = -1;
} else {
if (bytec > 0) {
- memcpy(paramPtr->input.buf, bytev, (size_t)bytec);
+ memcpy(paramPtr->input.buf, bytev, (size_t) bytec);
}
paramPtr->input.toRead = bytec;
}
@@ -3075,7 +3091,7 @@ ForwardProc(
case ForwardedOutput: {
Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *)
- paramPtr->output.buf, paramPtr->output.toWrite);
+ paramPtr->output.buf, paramPtr->output.toWrite);
Tcl_IncrRefCount(bufObj);
Tcl_Preserve(rcPtr);
@@ -3115,8 +3131,8 @@ ForwardProc(
case ForwardedSeek: {
Tcl_Obj *offObj = Tcl_NewWideIntObj(paramPtr->seek.offset);
Tcl_Obj *baseObj = Tcl_NewStringObj(
- (paramPtr->seek.seekMode==SEEK_SET) ? "start" :
- (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1);
+ (paramPtr->seek.seekMode==SEEK_SET) ? "start" :
+ (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1);
Tcl_IncrRefCount(offObj);
Tcl_IncrRefCount(baseObj);
@@ -3166,11 +3182,11 @@ ForwardProc(
case ForwardedBlock: {
Tcl_Obj *blockObj = Tcl_NewBooleanObj(!paramPtr->block.nonblocking);
- Tcl_IncrRefCount(blockObj);
+ Tcl_IncrRefCount(blockObj);
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL,
- &resObj) != TCL_OK) {
+ &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
}
Tcl_Release(rcPtr);
@@ -3186,7 +3202,7 @@ ForwardProc(
Tcl_IncrRefCount(valueObj);
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, "configure", optionObj, valueObj,
- &resObj) != TCL_OK) {
+ &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
}
Tcl_Release(rcPtr);
@@ -3201,8 +3217,8 @@ ForwardProc(
*/
Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->getOpt.name, -1);
- Tcl_IncrRefCount(optionObj);
+ Tcl_IncrRefCount(optionObj);
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, "cget", optionObj, NULL, &resObj)!=TCL_OK){
ForwardSetObjError(paramPtr, resObj);
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index 8f111b0..2b9efb9 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -363,33 +363,43 @@ static int ForwardProc(Tcl_Event *evPtr, int mask);
static void SrcExitProc(ClientData clientData);
#define FreeReceivedError(p) \
- if ((p)->base.mustFree) { \
- ckfree((p)->base.msgStr); \
- }
+ do { \
+ if ((p)->base.mustFree) { \
+ ckfree((p)->base.msgStr); \
+ } \
+ } while (0)
#define PassReceivedErrorInterp(i,p) \
- if ((i) != NULL) { \
- Tcl_SetChannelErrorInterp((i), \
- Tcl_NewStringObj((p)->base.msgStr, -1)); \
- } \
- FreeReceivedError(p)
+ do { \
+ if ((i) != NULL) { \
+ Tcl_SetChannelErrorInterp((i), \
+ Tcl_NewStringObj((p)->base.msgStr, -1)); \
+ } \
+ FreeReceivedError(p); \
+ } while (0)
#define PassReceivedError(c,p) \
- Tcl_SetChannelError((c), Tcl_NewStringObj((p)->base.msgStr, -1)); \
- FreeReceivedError(p)
+ do { \
+ Tcl_SetChannelError((c), \
+ Tcl_NewStringObj((p)->base.msgStr, -1)); \
+ FreeReceivedError(p); \
+ } while (0)
#define ForwardSetStaticError(p,emsg) \
- (p)->base.code = TCL_ERROR; \
- (p)->base.mustFree = 0; \
- (p)->base.msgStr = (char *) (emsg)
+ do { \
+ (p)->base.code = TCL_ERROR; \
+ (p)->base.mustFree = 0; \
+ (p)->base.msgStr = (char *) (emsg); \
+ } while (0)
#define ForwardSetDynamicError(p,emsg) \
- (p)->base.code = TCL_ERROR; \
- (p)->base.mustFree = 1; \
- (p)->base.msgStr = (char *) (emsg)
+ do { \
+ (p)->base.code = TCL_ERROR; \
+ (p)->base.mustFree = 1; \
+ (p)->base.msgStr = (char *) (emsg); \
+ } while (0)
static void ForwardSetObjError(ForwardParam *p,
Tcl_Obj *objPtr);
-
static ReflectedTransformMap * GetThreadReflectedTransformMap(void);
-static void DeleteThreadReflectedTransformMap(ClientData clientData);
-
+static void DeleteThreadReflectedTransformMap(
+ ClientData clientData);
#endif /* TCL_THREADS */
#define SetChannelErrorStr(c,msgStr) \
@@ -513,7 +523,6 @@ TclChanPushObjCmd(
int result; /* Result code for 'initialize' */
Tcl_Obj *resObj; /* Result data for 'initialize' */
int methods; /* Bitmask for supported methods. */
- Tcl_Obj *err; /* Error message */
ReflectedTransformMap *rtmPtr;
/* Map of reflected transforms with handlers
* in this interp. */
@@ -608,11 +617,10 @@ TclChanPushObjCmd(
while (listc > 0) {
if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames,
"method", TCL_EXACT, &methIndex) != TCL_OK) {
- TclNewLiteralStringObj(err, "chan handler \"");
- Tcl_AppendObjToObj(err, cmdObj);
- Tcl_AppendToObj(err, " initialize\" returned ", -1);
- Tcl_AppendObjToObj(err, Tcl_GetObjResult(interp));
- Tcl_SetObjResult(interp, err);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "chan handler \"%s initialize\" returned %s",
+ Tcl_GetString(cmdObj),
+ Tcl_GetString(Tcl_GetObjResult(interp))));
Tcl_DecrRefCount(resObj);
goto error;
}
@@ -695,13 +703,14 @@ TclChanPushObjCmd(
rtmPtr = GetThreadReflectedTransformMap();
hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew);
Tcl_SetHashValue(hPtr, rtPtr);
-#endif
+#endif /* TCL_THREADS */
/*
* Return the channel as the result of the command.
*/
- Tcl_AppendResult(interp, Tcl_GetChannelName(rtPtr->chan), NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ Tcl_GetChannelName(rtPtr->chan), -1));
return TCL_OK;
error:
@@ -710,7 +719,7 @@ TclChanPushObjCmd(
* structure.
*/
- Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
+ Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
return TCL_ERROR;
#undef CHAN
@@ -913,9 +922,9 @@ ReflectClose(
FreeReceivedError(&p);
}
}
-#endif
+#endif /* TCL_THREADS */
- Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
+ Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
return EOK;
}
@@ -931,11 +940,11 @@ ReflectClose(
if (!TransformDrain(rtPtr, &errorCode)) {
#ifdef TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
- Tcl_EventuallyFree (rtPtr,
+ Tcl_EventuallyFree(rtPtr,
(Tcl_FreeProc *) FreeReflectedTransform);
return errorCode;
}
-#endif
+#endif /* TCL_THREADS */
errorCodeSet = 1;
goto cleanup;
}
@@ -945,11 +954,11 @@ ReflectClose(
if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) {
#ifdef TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
- Tcl_EventuallyFree (rtPtr,
+ Tcl_EventuallyFree(rtPtr,
(Tcl_FreeProc *) FreeReflectedTransform);
return errorCode;
}
-#endif
+#endif /* TCL_THREADS */
errorCodeSet = 1;
goto cleanup;
}
@@ -966,7 +975,7 @@ ReflectClose(
ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p);
result = p.base.code;
- Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
+ Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
if (result != TCL_OK) {
PassReceivedErrorInterp(interp, &p);
@@ -974,7 +983,7 @@ ReflectClose(
}
return EOK;
}
-#endif
+#endif /* TCL_THREADS */
/*
* Do the actual invokation of "finalize" now; we're in the right thread.
@@ -1022,7 +1031,7 @@ ReflectClose(
if (hPtr) {
Tcl_DeleteHashEntry(hPtr);
}
-#endif
+#endif /* TCL_THREADS */
}
Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
@@ -1348,7 +1357,7 @@ ReflectSeekWide(
* transformation.
*/
- if ((rtPtr->methods & FLAG(METH_CLEAR))) {
+ if (rtPtr->methods & FLAG(METH_CLEAR)) {
TransformClear(rtPtr);
}
@@ -2140,7 +2149,7 @@ DeleteReflectedTransformMap(
ForwardingResult *resultPtr;
ForwardingEvent *evPtr;
ForwardParam *paramPtr;
-#endif
+#endif /* TCL_THREADS */
/*
* Delete all entries. The channels may have been closed already, or will
@@ -2232,8 +2241,7 @@ DeleteReflectedTransformMap(
Tcl_ConditionNotify(&resultPtr->done);
}
Tcl_MutexUnlock(&rtForwardMutex);
-
-#endif
+#endif /* TCL_THREADS */
}
#ifdef TCL_THREADS
@@ -2631,7 +2639,7 @@ ForwardProc(
break;
}
- case ForwardedDrain: {
+ case ForwardedDrain:
if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
paramPtr->transform.size = -1;
@@ -2656,9 +2664,8 @@ ForwardProc(
}
}
break;
- }
- case ForwardedFlush: {
+ case ForwardedFlush:
if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
paramPtr->transform.size = -1;
@@ -2684,12 +2691,10 @@ ForwardProc(
}
}
break;
- }
- case ForwardedClear: {
+ case ForwardedClear:
(void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL);
break;
- }
case ForwardedLimit:
if (InvokeTclMethod(rtPtr, "limit?", NULL, NULL, &resObj) != TCL_OK) {
@@ -2795,7 +2800,7 @@ ForwardSetObjError(
ForwardSetDynamicError(paramPtr, ckalloc(len));
memcpy(paramPtr->base.msgStr, msgStr, (unsigned) len);
}
-#endif
+#endif /* TCL_THREADS */
/*
*----------------------------------------------------------------------
@@ -3092,7 +3097,7 @@ TransformRead(
ckfree(p.transform.buf);
return 1;
}
-#endif
+#endif /* TCL_THREADS */
/* ASSERT: rtPtr->method & FLAG(METH_READ) */
/* ASSERT: rtPtr->mode & TCL_READABLE */
@@ -3153,7 +3158,7 @@ TransformWrite(
p.transform.size);
ckfree(p.transform.buf);
} else
-#endif
+#endif /* TCL_THREADS */
{
/* ASSERT: rtPtr->method & FLAG(METH_WRITE) */
/* ASSERT: rtPtr->mode & TCL_WRITABLE */
@@ -3215,7 +3220,7 @@ TransformDrain(
ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size);
ckfree(p.transform.buf);
} else
-#endif
+#endif /* TCL_THREADS */
{
if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj)!=TCL_OK) {
Tcl_SetChannelError(rtPtr->chan, resObj);
@@ -3270,7 +3275,7 @@ TransformFlush(
}
ckfree(p.transform.buf);
} else
-#endif
+#endif /* TCL_THREADS */
{
if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj)!=TCL_OK) {
Tcl_SetChannelError(rtPtr->chan, resObj);
@@ -3311,7 +3316,7 @@ TransformClear(
ForwardOpToOwnerThread(rtPtr, ForwardedClear, &p);
return;
}
-#endif
+#endif /* TCL_THREADS */
/* ASSERT: rtPtr->method & FLAG(METH_READ) */
/* ASSERT: rtPtr->mode & TCL_READABLE */
diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c
index 018f9f5..e603c91 100644
--- a/generic/tclIOSock.c
+++ b/generic/tclIOSock.c
@@ -64,8 +64,8 @@ TclSockGetPort(
return TCL_ERROR;
}
if (*portPtr > 0xFFFF) {
- Tcl_AppendResult(interp, "couldn't open socket: port number too high",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "couldn't open socket: port number too high", -1));
return TCL_ERROR;
}
return TCL_OK;
@@ -100,16 +100,20 @@ TclSockMinimumBuffers(
socklen_t len;
len = sizeof(int);
- getsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_SNDBUF, (char *)&current, &len);
+ getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF,
+ (char *) &current, &len);
if (current < size) {
len = sizeof(int);
- setsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_SNDBUF, (char *)&size, len);
+ setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF,
+ (char *) &size, len);
}
len = sizeof(int);
- getsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_RCVBUF, (char *)&current, &len);
+ getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF,
+ (char *) &current, &len);
if (current < size) {
len = sizeof(int);
- setsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len);
+ setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF,
+ (char *) &size, len);
}
return TCL_OK;
}
@@ -152,19 +156,18 @@ TclCreateSocketAddress(
Tcl_DString ds;
int result, i;
- TclFormatInt(portstring, port);
-
if (host != NULL) {
native = Tcl_UtfToExternalDString(NULL, host, -1, &ds);
}
-
+ TclFormatInt(portstring, port);
(void) memset(&hints, 0, sizeof(hints));
-
hints.ai_family = AF_UNSPEC;
+
/*
* Magic variable to enforce a certain address family - to be superseded
* by a TIP that adds explicit switches to [socket]
*/
+
if (interp != NULL) {
family = Tcl_GetVar(interp, "::tcl::unsupported::socketAF", 0);
if (family != NULL) {
@@ -182,7 +185,7 @@ TclCreateSocketAddress(
/*
* We found some problems when using AI_ADDRCONFIG, e.g. on systems that
* have no networking besides the loopback interface and want to resolve
- * localhost. See bugs 3385024, 3382419, 3382431. As the advantage of
+ * localhost. See [Bugs 3385024, 3382419, 3382431]. As the advantage of
* using AI_ADDRCONFIG in situations where it works, is probably low,
* we'll leave it out for now. After all, it is just an optimisation.
*
@@ -206,12 +209,11 @@ TclCreateSocketAddress(
}
if (result != 0) {
-#ifdef EAI_SYSTEM /* Doesn't exist on Windows */
- if (result == EAI_SYSTEM)
- *errorMsgPtr = Tcl_PosixError(interp);
- else
-#endif
- *errorMsgPtr = gai_strerror(result);
+ *errorMsgPtr =
+#ifdef EAI_SYSTEM /* Doesn't exist on Windows */
+ (result == EAI_SYSTEM) ? Tcl_PosixError(interp) :
+#endif /* EAI_SYSTEM */
+ gai_strerror(result);
return 0;
}
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 41a5aac..2d6d898 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -460,6 +460,7 @@ FsThrExitProc(
ckfree(fsRecPtr);
fsRecPtr = tmpFsRecPtr;
}
+ tsdPtr->filesystemList = NULL;
tsdPtr->initialized = 0;
}
@@ -647,23 +648,26 @@ TclFSEpochOk(
}
static void
-Claim()
+Claim(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
+
tsdPtr->claims++;
}
static void
-Disclaim()
+Disclaim(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
+
tsdPtr->claims--;
}
int
-TclFSEpoch()
+TclFSEpoch(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
+
return tsdPtr->filesystemEpoch;
}
@@ -1094,8 +1098,9 @@ Tcl_FSMatchInDirectory(
cwd = Tcl_FSGetCwd(NULL);
if (cwd == NULL) {
if (interp != NULL) {
- Tcl_SetResult(interp, "glob couldn't determine "
- "the current working directory", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "glob couldn't determine the current working directory",
+ -1));
}
return TCL_ERROR;
}
@@ -1572,8 +1577,8 @@ TclGetOpenModeEx(
*seekFlagPtr = 0;
*binaryPtr = 0;
if (interp != NULL) {
- Tcl_AppendResult(interp, "illegal access mode \"", modeString,
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "illegal access mode \"%s\"", modeString));
}
return -1;
}
@@ -1622,8 +1627,9 @@ TclGetOpenModeEx(
mode |= O_NOCTTY;
#else
if (interp != NULL) {
- Tcl_AppendResult(interp, "access mode \"", flag,
- "\" not supported by this system", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "access mode \"%s\" not supported by this system",
+ flag));
}
ckfree(modeArgv);
return -1;
@@ -1634,8 +1640,9 @@ TclGetOpenModeEx(
mode |= O_NONBLOCK;
#else
if (interp != NULL) {
- Tcl_AppendResult(interp, "access mode \"", flag,
- "\" not supported by this system", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "access mode \"%s\" not supported by this system",
+ flag));
}
ckfree(modeArgv);
return -1;
@@ -1648,9 +1655,10 @@ TclGetOpenModeEx(
} else {
if (interp != NULL) {
- Tcl_AppendResult(interp, "invalid access mode \"", flag,
- "\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, "
- "CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid access mode \"%s\": must be RDONLY, WRONLY, "
+ "RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK,"
+ " or TRUNC", flag));
}
ckfree(modeArgv);
return -1;
@@ -1661,8 +1669,9 @@ TclGetOpenModeEx(
if (!gotRW) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "access mode must include either"
- " RDONLY, WRONLY, or RDWR", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "access mode must include either RDONLY, WRONLY, or RDWR",
+ -1));
}
return -1;
}
@@ -1721,15 +1730,16 @@ Tcl_FSEvalFileEx(
if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
Tcl_SetErrno(errno);
- Tcl_AppendResult(interp, "couldn't read file \"",
- Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't read file \"%s\": %s",
+ Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
return result;
}
chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
if (chan == NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "couldn't read file \"",
- Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't read file \"%s\": %s",
+ Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
return result;
}
@@ -1763,8 +1773,9 @@ Tcl_FSEvalFileEx(
if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) {
Tcl_Close(interp, chan);
- Tcl_AppendResult(interp, "couldn't read file \"",
- Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't read file \"%s\": %s",
+ Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
goto end;
}
string = Tcl_GetString(objPtr);
@@ -1777,8 +1788,9 @@ Tcl_FSEvalFileEx(
if (Tcl_ReadChars(chan, objPtr, -1,
memcmp(string, "\xef\xbb\xbf", 3)) < 0) {
Tcl_Close(interp, chan);
- Tcl_AppendResult(interp, "couldn't read file \"",
- Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't read file \"%s\": %s",
+ Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
goto end;
}
@@ -1852,15 +1864,16 @@ TclNREvalFile(
if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
Tcl_SetErrno(errno);
- Tcl_AppendResult(interp, "couldn't read file \"",
- Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't read file \"%s\": %s",
+ Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
return TCL_ERROR;
}
chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
if (chan == NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "couldn't read file \"",
- Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't read file \"%s\": %s",
+ Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
return TCL_ERROR;
}
@@ -1894,8 +1907,9 @@ TclNREvalFile(
if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) {
Tcl_Close(interp, chan);
- Tcl_AppendResult(interp, "couldn't read file \"",
- Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't read file \"%s\": %s",
+ Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
@@ -1909,8 +1923,9 @@ TclNREvalFile(
if (Tcl_ReadChars(chan, objPtr, -1,
memcmp(string, "\xef\xbb\xbf", 3)) < 0) {
Tcl_Close(interp, chan);
- Tcl_AppendResult(interp, "couldn't read file \"",
- Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't read file \"%s\": %s",
+ Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
@@ -2246,9 +2261,9 @@ Tcl_FSOpenFileChannel(
if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt) 0, SEEK_END)
< (Tcl_WideInt) 0) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "could not seek to end of file "
- "while opening \"", Tcl_GetString(pathPtr), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not seek to end of file while opening \"%s\": %s",
+ Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
}
Tcl_Close(NULL, retVal);
return NULL;
@@ -2265,8 +2280,9 @@ Tcl_FSOpenFileChannel(
Tcl_SetErrno(ENOENT);
if (interp != NULL) {
- Tcl_AppendResult(interp, "couldn't open \"", Tcl_GetString(pathPtr),
- "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't open \"%s\": %s",
+ Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
}
return NULL;
}
@@ -2684,9 +2700,9 @@ Tcl_FSGetCwd(
Disclaim();
goto cdDidNotChange;
} else if (interp != NULL) {
- Tcl_AppendResult(interp,
- "error getting working directory name: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error getting working directory name: %s",
+ Tcl_PosixError(interp)));
}
}
Disclaim();
@@ -2760,9 +2776,9 @@ Tcl_FSGetCwd(
retCd = proc2(tsdPtr->cwdClientData);
if (retCd == NULL && interp != NULL) {
- Tcl_AppendResult(interp,
- "error getting working directory name: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error getting working directory name: %s",
+ Tcl_PosixError(interp)));
}
if (retCd == tsdPtr->cwdClientData) {
@@ -3152,8 +3168,9 @@ Tcl_LoadFile(
*/
if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
- Tcl_AppendResult(interp, "couldn't load library \"",
- Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't load library \"%s\": %s",
+ Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
return TCL_ERROR;
}
@@ -3203,7 +3220,7 @@ Tcl_LoadFile(
mustCopyToTempAnyway:
Tcl_ResetResult(interp);
-#endif
+#endif /* TCL_LOAD_FROM_MEMORY */
/*
* Get a temporary filename to use, first to copy the file into, and then
@@ -3223,8 +3240,8 @@ Tcl_LoadFile(
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
- Tcl_AppendResult(interp, "couldn't load from current filesystem",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "couldn't load from current filesystem", -1));
return TCL_ERROR;
}
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index b206b35..731d759 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -302,6 +302,10 @@ Tcl_GetIndexFromObjStruct(
entryPtr = NEXT_ENTRY(entryPtr, offset), idx++) {
for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
if (*p1 == '\0') {
+ if (p1 == key) {
+ /* empty keys never match */
+ continue;
+ }
index = idx;
goto done;
}
@@ -356,26 +360,31 @@ Tcl_GetIndexFromObjStruct(
* Produce a fancy error message.
*/
- int count;
+ int count = 0;
TclNewObj(resultPtr);
+ entryPtr = tablePtr;
+ while ((*entryPtr != NULL) && !**entryPtr) {
+ entryPtr = NEXT_ENTRY(entryPtr, offset);
+ }
Tcl_AppendStringsToObj(resultPtr,
(numAbbrev>1 && !(flags & TCL_EXACT) ? "ambiguous " : "bad "),
msg, " \"", key, NULL);
- if (STRING_AT(tablePtr, offset, 0) == NULL) {
+ if (*entryPtr == NULL) {
Tcl_AppendStringsToObj(resultPtr, "\": no valid options", NULL);
} else {
Tcl_AppendStringsToObj(resultPtr, "\": must be ",
- STRING_AT(tablePtr, offset, 0), NULL);
- for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0;
- *entryPtr != NULL;
- entryPtr = NEXT_ENTRY(entryPtr, offset), count++) {
+ *entryPtr, NULL);
+ entryPtr = NEXT_ENTRY(entryPtr, offset);
+ while (*entryPtr != NULL) {
if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""),
" or ", *entryPtr, NULL);
- } else {
+ } else if (**entryPtr) {
Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL);
+ count++;
}
+ entryPtr = NEXT_ENTRY(entryPtr, offset);
}
}
Tcl_SetObjResult(interp, resultPtr);
@@ -591,8 +600,9 @@ PrefixMatchObjCmd(
flags |= TCL_EXACT;
break;
case PRFMATCH_MESSAGE:
- if (i > (objc - 4)) {
- Tcl_AppendResult(interp, "missing message", NULL);
+ if (i > objc-4) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "missing value for -message", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
}
@@ -601,7 +611,8 @@ PrefixMatchObjCmd(
break;
case PRFMATCH_ERROR:
if (i > objc-4) {
- Tcl_AppendResult(interp, "missing error options", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "missing value for -error", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
}
@@ -611,8 +622,9 @@ PrefixMatchObjCmd(
return TCL_ERROR;
}
if ((errorLength % 2) != 0) {
- Tcl_AppendResult(interp, "error options must have an even"
- " number of elements", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "error options must have an even number of elements",
+ -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
return TCL_ERROR;
}
@@ -1165,8 +1177,8 @@ Tcl_ParseArgsObjv(
goto gotMatch;
}
if (matchPtr != NULL) {
- Tcl_AppendResult(interp, "ambiguous option \"", str, "\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "ambiguous option \"%s\"", str));
goto error;
}
matchPtr = infoPtr;
@@ -1178,8 +1190,8 @@ Tcl_ParseArgsObjv(
*/
if (remObjv == NULL) {
- Tcl_AppendResult(interp, "unrecognized argument \"", str,
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unrecognized argument \"%s\"", str));
goto error;
}
@@ -1204,9 +1216,9 @@ Tcl_ParseArgsObjv(
}
if (Tcl_GetIntFromObj(interp, objv[srcIndex],
(int *) infoPtr->dstPtr) == TCL_ERROR) {
- Tcl_AppendResult(interp, "expected integer argument for \"",
- infoPtr->keyStr, "\" but got \"",
- Tcl_GetString(objv[srcIndex]), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected integer argument for \"%s\" but got \"%s\"",
+ infoPtr->keyStr, Tcl_GetString(objv[srcIndex])));
goto error;
}
srcIndex++;
@@ -1237,9 +1249,9 @@ Tcl_ParseArgsObjv(
}
if (Tcl_GetDoubleFromObj(interp, objv[srcIndex],
(double *) infoPtr->dstPtr) == TCL_ERROR) {
- Tcl_AppendResult(interp, "expected floating-point argument ",
- "for \"", infoPtr->keyStr, "\" but got \"",
- Tcl_GetString(objv[srcIndex]), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected floating-point argument for \"%s\" but got \"%s\"",
+ infoPtr->keyStr, Tcl_GetString(objv[srcIndex])));
goto error;
}
srcIndex++;
@@ -1313,8 +1325,8 @@ Tcl_ParseArgsObjv(
*/
missingArg:
- Tcl_AppendResult(interp, "\"", str,
- "\" option requires an additional argument", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" option requires an additional argument", str));
error:
if (leftovers != NULL) {
ckfree(leftovers);
@@ -1352,6 +1364,7 @@ PrintUsage(
#define NUM_SPACES 20
static const char spaces[] = " ";
char tmp[TCL_DOUBLE_SPACE];
+ Tcl_Obj *msg;
/*
* First, compute the width of the widest option key, so that we can make
@@ -1375,39 +1388,39 @@ PrintUsage(
* Now add the option information, with pretty-printing.
*/
- Tcl_AppendResult(interp, "Command-specific options:", NULL);
+ msg = Tcl_NewStringObj("Command-specific options:", -1);
for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) {
if ((infoPtr->type == TCL_ARGV_HELP) && (infoPtr->keyStr == NULL)) {
- Tcl_AppendResult(interp, "\n", infoPtr->helpStr, NULL);
+ Tcl_AppendPrintfToObj(msg, "\n%s", infoPtr->helpStr);
continue;
}
- Tcl_AppendResult(interp, "\n ", infoPtr->keyStr, ":", NULL);
+ Tcl_AppendPrintfToObj(msg, "\n %s:", infoPtr->keyStr);
numSpaces = width + 1 - strlen(infoPtr->keyStr);
while (numSpaces > 0) {
if (numSpaces >= NUM_SPACES) {
- Tcl_AppendResult(interp, spaces, NULL);
+ Tcl_AppendToObj(msg, spaces, NUM_SPACES);
} else {
- Tcl_AppendResult(interp, spaces+NUM_SPACES-numSpaces, NULL);
+ Tcl_AppendToObj(msg, spaces, numSpaces);
}
numSpaces -= NUM_SPACES;
}
- Tcl_AppendResult(interp, infoPtr->helpStr, NULL);
+ Tcl_AppendToObj(msg, infoPtr->helpStr, -1);
switch (infoPtr->type) {
case TCL_ARGV_INT:
- sprintf(tmp, "%d", *((int *) infoPtr->dstPtr));
- Tcl_AppendResult(interp, "\n\t\tDefault value: ", tmp, NULL);
+ Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %d",
+ *((int *) infoPtr->dstPtr));
break;
case TCL_ARGV_FLOAT:
+ Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %g",
+ *((double *) infoPtr->dstPtr));
sprintf(tmp, "%g", *((double *) infoPtr->dstPtr));
- Tcl_AppendResult(interp, "\n\t\tDefault value: ", tmp, NULL);
break;
case TCL_ARGV_STRING: {
- char *string;
+ char *string = *((char **) infoPtr->dstPtr);
- string = *((char **) infoPtr->dstPtr);
if (string != NULL) {
- Tcl_AppendResult(interp, "\n\t\tDefault value: \"", string,
- "\"", NULL);
+ Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: \"%s\"",
+ string);
}
break;
}
@@ -1415,6 +1428,7 @@ PrintUsage(
break;
}
}
+ Tcl_SetObjResult(interp, msg);
}
/*
@@ -1426,8 +1440,8 @@ PrintUsage(
*
* Results:
* Returns TCL_ERROR if the value is an invalid completion code.
- * Otherwise, returns TCL_OK, and writes the completion code to
- * the pointer provided.
+ * Otherwise, returns TCL_OK, and writes the completion code to the
+ * pointer provided.
*
* Side effects:
* None.
@@ -1439,30 +1453,30 @@ int
TclGetCompletionCodeFromObj(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *value,
- int *code) /* Argument objects. */
+ int *codePtr) /* Argument objects. */
{
static const char *const returnCodes[] = {
"ok", "error", "return", "break", "continue", NULL
};
if ((value->typePtr != &indexType)
- && (TCL_OK == TclGetIntFromObj(NULL, value, code))) {
+ && TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) {
return TCL_OK;
}
- if (TCL_OK == Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL,
- TCL_EXACT, code)) {
+ if (Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL, TCL_EXACT,
+ codePtr) == TCL_OK) {
return TCL_OK;
}
+
/*
* Value is not a legal completion code.
*/
if (interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad completion code \"",
- TclGetString(value),
- "\": must be ok, error, return, break, "
- "continue, or an integer", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad completion code \"%s\": must be"
+ " ok, error, return, break, continue, or an integer",
+ TclGetString(value)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", NULL);
}
return TCL_ERROR;
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 5b6d14f..0b0f652 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -1043,18 +1043,18 @@ Tcl_InterpObjCmd(
iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "alias \"", aliasName, "\" in path \"",
- Tcl_GetString(objv[2]), "\" not found", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "alias \"%s\" in path \"%s\" not found",
+ aliasName, Tcl_GetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName,
NULL);
return TCL_ERROR;
}
aliasPtr = Tcl_GetHashValue(hPtr);
if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "target interpreter for alias \"",
- aliasName, "\" in path \"", Tcl_GetString(objv[2]),
- "\" is not my descendant", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "target interpreter for alias \"%s\" in path \"%s\" is "
+ "not my descendant", aliasName, Tcl_GetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"TARGETSHROUDED", NULL);
return TCL_ERROR;
@@ -1234,7 +1234,8 @@ Tcl_GetAlias(
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "alias \"%s\" not found", aliasName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL);
return TCL_ERROR;
}
@@ -1295,7 +1296,8 @@ Tcl_GetAliasObj(
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "alias \"%s\" not found", aliasName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL);
return TCL_ERROR;
}
@@ -1383,9 +1385,9 @@ TclPreventAliasLoop(
* [Bug #641195]
*/
- Tcl_AppendResult(interp, "cannot define or rename alias \"",
- Tcl_GetCommandName(cmdInterp, cmd),
- "\": interpreter deleted", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "cannot define or rename alias \"%s\": interpreter deleted",
+ Tcl_GetCommandName(cmdInterp, cmd)));
return TCL_ERROR;
}
cmdNamePtr = nextAliasPtr->objPtr;
@@ -1398,9 +1400,9 @@ TclPreventAliasLoop(
}
aliasCmdPtr = (Command *) aliasCmd;
if (aliasCmdPtr == cmdPtr) {
- Tcl_AppendResult(interp, "cannot define or rename alias \"",
- Tcl_GetCommandName(cmdInterp, cmd),
- "\": would create a loop", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "cannot define or rename alias \"%s\": would create a loop",
+ Tcl_GetCommandName(cmdInterp, cmd)));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"ALIASLOOP", NULL);
return TCL_ERROR;
@@ -1621,8 +1623,8 @@ AliasDelete(
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr));
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "alias \"", TclGetString(namePtr),
- "\" not found", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "alias \"%s\" not found", TclGetString(namePtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS",
TclGetString(namePtr), NULL);
return TCL_ERROR;
@@ -2154,17 +2156,19 @@ Tcl_GetInterpPath(
InterpInfo *iiPtr;
if (targetInterp == askingInterp) {
+ Tcl_SetObjResult(askingInterp, Tcl_NewObj());
return TCL_OK;
}
if (targetInterp == NULL) {
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
- if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) {
+ if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK){
return TCL_ERROR;
}
- Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&iiPtr->master.slaveTable,
- iiPtr->slave.slaveEntryPtr));
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(askingInterp),
+ Tcl_NewStringObj(Tcl_GetHashKey(&iiPtr->master.slaveTable,
+ iiPtr->slave.slaveEntryPtr), -1));
return TCL_OK;
}
@@ -2218,8 +2222,8 @@ GetInterp(
}
}
if (searchInterp == NULL) {
- Tcl_AppendResult(interp, "could not find interpreter \"",
- TclGetString(pathPtr), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not find interpreter \"%s\"", TclGetString(pathPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INTERP",
TclGetString(pathPtr), NULL);
}
@@ -2256,8 +2260,8 @@ SlaveBgerror(
if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length)
|| (length < 1)) {
- Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cmdPrefix must be list of length >= 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BGERRORFORMAT", NULL);
return TCL_ERROR;
@@ -2326,8 +2330,9 @@ SlaveCreate(
hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path,
&isNew);
if (isNew == 0) {
- Tcl_AppendResult(interp, "interpreter named \"", path,
- "\" already exists, cannot create", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "interpreter named \"%s\" already exists, cannot create",
+ path));
return NULL;
}
@@ -2860,8 +2865,8 @@ SlaveRecursionLimit(
if (objc) {
if (Tcl_IsSafe(interp)) {
- Tcl_AppendResult(interp, "permission denied: "
- "safe interpreters cannot change recursion limit", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("permission denied: "
+ "safe interpreters cannot change recursion limit", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
NULL);
return TCL_ERROR;
@@ -3320,8 +3325,8 @@ Tcl_LimitCheck(
if (iPtr->limit.cmdCount >= iPtr->cmdCount) {
iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
} else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "command count limit exceeded", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command count limit exceeded", -1));
Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL);
Tcl_Release(interp);
return TCL_ERROR;
@@ -3346,8 +3351,8 @@ Tcl_LimitCheck(
iPtr->limit.time.usec >= now.usec)) {
iPtr->limit.exceeded &= ~TCL_LIMIT_TIME;
} else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "time limit exceeded", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "time limit exceeded", -1));
Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL);
Tcl_Release(interp);
return TCL_ERROR;
@@ -4353,8 +4358,9 @@ SlaveCommandLimitCmd(
*/
if (interp == slaveInterp) {
- Tcl_AppendResult(interp,
- "limits on current interpreter inaccessible", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "limits on current interpreter inaccessible", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL);
return TCL_ERROR;
}
@@ -4450,8 +4456,8 @@ SlaveCommandLimitCmd(
return TCL_ERROR;
}
if (gran < 1) {
- Tcl_AppendResult(interp, "granularity must be at "
- "least 1", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "granularity must be at least 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", NULL);
return TCL_ERROR;
@@ -4467,8 +4473,8 @@ SlaveCommandLimitCmd(
return TCL_ERROR;
}
if (limit < 0) {
- Tcl_AppendResult(interp, "command limit value must be at "
- "least 0", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command limit value must be at least 0", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", NULL);
return TCL_ERROR;
@@ -4540,8 +4546,9 @@ SlaveTimeLimitCmd(
*/
if (interp == slaveInterp) {
- Tcl_AppendResult(interp,
- "limits on current interpreter inaccessible", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "limits on current interpreter inaccessible", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL);
return TCL_ERROR;
}
@@ -4658,8 +4665,8 @@ SlaveTimeLimitCmd(
return TCL_ERROR;
}
if (gran < 1) {
- Tcl_AppendResult(interp, "granularity must be at "
- "least 1", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "granularity must be at least 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", NULL);
return TCL_ERROR;
@@ -4675,13 +4682,13 @@ SlaveTimeLimitCmd(
return TCL_ERROR;
}
if (tmp < 0) {
- Tcl_AppendResult(interp, "milliseconds must be at least 0",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "milliseconds must be at least 0", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", NULL);
return TCL_ERROR;
}
- limitMoment.usec = ((long)tmp)*1000;
+ limitMoment.usec = ((long) tmp)*1000;
break;
case OPT_SEC:
secObj = objv[i+1];
@@ -4693,8 +4700,8 @@ SlaveTimeLimitCmd(
return TCL_ERROR;
}
if (tmp < 0) {
- Tcl_AppendResult(interp, "seconds must be at least 0",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "seconds must be at least 0", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", NULL);
return TCL_ERROR;
@@ -4711,15 +4718,17 @@ SlaveTimeLimitCmd(
*/
if (secObj != NULL && secLen == 0 && milliLen > 0) {
- Tcl_AppendResult(interp, "may only set -milliseconds "
- "if -seconds is not also being reset", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may only set -milliseconds if -seconds is not "
+ "also being reset", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADUSAGE", NULL);
return TCL_ERROR;
}
if (milliLen == 0 && (secObj == NULL || secLen > 0)) {
- Tcl_AppendResult(interp, "may only reset -milliseconds "
- "if -seconds is also being reset", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may only reset -milliseconds if -seconds is "
+ "also being reset", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADUSAGE", NULL);
return TCL_ERROR;
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index ce4d6a4..3fead6f 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -157,9 +157,8 @@ Tcl_LoadObjCmd(
}
}
if ((fullFileName[0] == 0) && (packageName == NULL)) {
- Tcl_SetResult(interp,
- "must specify either file name or package name",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "must specify either file name or package name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY",
NULL);
code = TCL_ERROR;
@@ -225,9 +224,9 @@ Tcl_LoadObjCmd(
* Can't have two different packages loaded from the same file.
*/
- Tcl_AppendResult(interp, "file \"", fullFileName,
- "\" is already loaded for package \"",
- pkgPtr->packageName, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file \"%s\" is already loaded for package \"%s\"",
+ fullFileName, pkgPtr->packageName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
"SPLITPERSONALITY", NULL);
code = TCL_ERROR;
@@ -263,8 +262,8 @@ Tcl_LoadObjCmd(
*/
if (fullFileName[0] == 0) {
- Tcl_AppendResult(interp, "package \"", packageName,
- "\" isn't loaded statically", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "package \"%s\" isn't loaded statically", packageName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC",
NULL);
code = TCL_ERROR;
@@ -321,9 +320,9 @@ Tcl_LoadObjCmd(
}
if (p == pkgGuess) {
Tcl_DecrRefCount(splitPtr);
- Tcl_AppendResult(interp,
- "couldn't figure out package name for ",
- fullFileName, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't figure out package name for %s",
+ fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
"WHATPACKAGE", NULL);
code = TCL_ERROR;
@@ -418,9 +417,9 @@ Tcl_LoadObjCmd(
if (Tcl_IsSafe(target)) {
if (pkgPtr->safeInitProc == NULL) {
- Tcl_AppendResult(interp,
- "can't use package in a safe interpreter: no ",
- pkgPtr->packageName, "_SafeInit procedure", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't use package in a safe interpreter: no"
+ " %s_SafeInit procedure", pkgPtr->packageName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE",
NULL);
code = TCL_ERROR;
@@ -429,9 +428,9 @@ Tcl_LoadObjCmd(
code = pkgPtr->safeInitProc(target);
} else {
if (pkgPtr->initProc == NULL) {
- Tcl_AppendResult(interp,
- "can't attach package to interpreter: no ",
- pkgPtr->packageName, "_Init procedure", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't attach package to interpreter: no %s_Init procedure",
+ pkgPtr->packageName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT",
NULL);
code = TCL_ERROR;
@@ -581,9 +580,8 @@ Tcl_UnloadObjCmd(
}
}
if ((fullFileName[0] == 0) && (packageName == NULL)) {
- Tcl_SetResult(interp,
- "must specify either file name or package name",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "must specify either file name or package name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY",
NULL);
code = TCL_ERROR;
@@ -655,8 +653,9 @@ Tcl_UnloadObjCmd(
* It's an error to try unload a static package.
*/
- Tcl_AppendResult(interp, "package \"", packageName,
- "\" is loaded statically and cannot be unloaded", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "package \"%s\" is loaded statically and cannot be unloaded",
+ packageName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC",
NULL);
code = TCL_ERROR;
@@ -667,8 +666,8 @@ Tcl_UnloadObjCmd(
* The DLL pointed by the provided filename has never been loaded.
*/
- Tcl_AppendResult(interp, "file \"", fullFileName,
- "\" has never been loaded", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file \"%s\" has never been loaded", fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED",
NULL);
code = TCL_ERROR;
@@ -696,8 +695,9 @@ Tcl_UnloadObjCmd(
* The package has not been loaded in this interpreter.
*/
- Tcl_AppendResult(interp, "file \"", fullFileName,
- "\" has never been loaded in this interpreter", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file \"%s\" has never been loaded in this interpreter",
+ fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED",
NULL);
code = TCL_ERROR;
@@ -712,8 +712,9 @@ Tcl_UnloadObjCmd(
if (Tcl_IsSafe(target)) {
if (pkgPtr->safeUnloadProc == NULL) {
- Tcl_AppendResult(interp, "file \"", fullFileName,
- "\" cannot be unloaded under a safe interpreter", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file \"%s\" cannot be unloaded under a safe interpreter",
+ fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
NULL);
code = TCL_ERROR;
@@ -722,8 +723,9 @@ Tcl_UnloadObjCmd(
unloadProc = pkgPtr->safeUnloadProc;
} else {
if (pkgPtr->unloadProc == NULL) {
- Tcl_AppendResult(interp, "file \"", fullFileName,
- "\" cannot be unloaded under a trusted interpreter", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file \"%s\" cannot be unloaded under a trusted interpreter",
+ fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
NULL);
code = TCL_ERROR;
@@ -862,8 +864,9 @@ Tcl_UnloadObjCmd(
}
}
#else
- Tcl_AppendResult(interp, "file \"", fullFileName,
- "\" cannot be unloaded: unloading disabled", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file \"%s\" cannot be unloaded: unloading disabled",
+ fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "DISABLED",
NULL);
code = TCL_ERROR;
diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c
index ac094e6..6b48aee 100644
--- a/generic/tclLoadNone.c
+++ b/generic/tclLoadNone.c
@@ -44,9 +44,9 @@ TclpDlopen(
* function which should be used for this
* file. */
{
- Tcl_SetResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"dynamic loading is not currently available on this system",
- TCL_STATIC);
+ -1));
return TCL_ERROR;
}
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 88b4e51..14139ec 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -16,11 +16,12 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-/**
- * On Windows, this file needs to be compiled twice, once with
- * TCL_ASCII_MAIN defined. This way both Tcl_Main and Tcl_MainExW
- * can be implemented, sharing the same source code.
+/*
+ * On Windows, this file needs to be compiled twice, once with TCL_ASCII_MAIN
+ * defined. This way both Tcl_Main and Tcl_MainExW can be implemented, sharing
+ * the same source code.
*/
+
#if defined(TCL_ASCII_MAIN)
# ifdef UNICODE
# undef UNICODE
@@ -40,12 +41,12 @@
#define DEFAULT_PRIMARY_PROMPT "% "
/*
- * This file can be compiled on Windows in UNICODE mode, as well as
- * on all other platforms using the native encoding. This is done
- * by using the normal Windows functions like _tcscmp, but on
- * platforms which don't have <tchar.h> we have to translate that
- * to strcmp here.
+ * This file can be compiled on Windows in UNICODE mode, as well as on all
+ * other platforms using the native encoding. This is done by using the normal
+ * Windows functions like _tcscmp, but on platforms which don't have <tchar.h>
+ * we have to translate that to strcmp here.
*/
+
#ifndef __WIN32__
# define TCHAR char
# define TEXT(arg) arg
@@ -128,10 +129,11 @@ typedef struct InteractiveState {
MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void);
static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr);
static void StdinProc(ClientData clientData, int mask);
-static void FreeMainInterp(ClientData clientData);
+static void FreeMainInterp(ClientData clientData);
#ifndef TCL_ASCII_MAIN
static Tcl_ThreadDataKey dataKey;
+
/*
*----------------------------------------------------------------------
*
@@ -333,8 +335,9 @@ Tcl_MainEx(
if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& (TEXT('-') != argv[3][0])) {
- Tcl_Obj *value = NewNativeObj(argv[2], -1);
- Tcl_SetStartupScript(NewNativeObj(argv[3], -1), Tcl_GetString(value));
+ Tcl_Obj *value = NewNativeObj(argv[2], -1);
+ Tcl_SetStartupScript(NewNativeObj(argv[3], -1),
+ Tcl_GetString(value));
Tcl_DecrRefCount(value);
argc -= 3;
argv += 3;
@@ -395,8 +398,9 @@ Tcl_MainEx(
/*
* Arrange for final deletion of the main interp
*/
- /* ARGH Munchhausen effect */
- Tcl_CreateExitHandler(FreeMainInterp, (ClientData)interp);
+
+ /* ARGH Munchhausen effect */
+ Tcl_CreateExitHandler(FreeMainInterp, interp);
}
/*
@@ -458,6 +462,7 @@ Tcl_MainEx(
mainLoopProc = TclGetMainLoop();
if (mainLoopProc == NULL) {
int length;
+
if (is.tty) {
Prompt(interp, &is);
if (Tcl_InterpDeleted(interp)) {
@@ -523,7 +528,8 @@ Tcl_MainEx(
Tcl_GetStringFromObj(is.commandPtr, &length);
Tcl_SetObjLength(is.commandPtr, --length);
- code = Tcl_RecordAndEvalObj(interp, is.commandPtr, TCL_EVAL_GLOBAL);
+ code = Tcl_RecordAndEvalObj(interp, is.commandPtr,
+ TCL_EVAL_GLOBAL);
is.input = Tcl_GetStdChannel(TCL_STDIN);
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_NewObj();
@@ -557,7 +563,8 @@ Tcl_MainEx(
Prompt(interp, &is);
}
- Tcl_CreateChannelHandler(is.input, TCL_READABLE, StdinProc, &is);
+ Tcl_CreateChannelHandler(is.input, TCL_READABLE,
+ StdinProc, &is);
}
mainLoopProc();
@@ -568,24 +575,23 @@ Tcl_MainEx(
}
is.input = Tcl_GetStdChannel(TCL_STDIN);
}
-#ifdef TCL_MEM_DEBUG
/*
* This code here only for the (unsupported and deprecated) [checkmem]
* command.
*/
+#ifdef TCL_MEM_DEBUG
if (tclMemDumpFileName != NULL) {
Tcl_SetMainLoop(NULL);
Tcl_DeleteInterp(interp);
}
-#endif
+#endif /* TCL_MEM_DEBUG */
}
done:
mainLoopProc = TclGetMainLoop();
- if ((exitCode == 0) && (mainLoopProc != NULL)
- && !Tcl_LimitExceeded(interp)) {
+ if ((exitCode == 0) && mainLoopProc && !Tcl_LimitExceeded(interp)) {
/*
* If everything has gone OK so far, call the main loop proc, if it
* exists. Packages (like Tk) can set it to start processing events at
@@ -605,21 +611,21 @@ Tcl_MainEx(
* exit. The Tcl_EvalObjEx call should never return.
*/
- if (!Tcl_InterpDeleted(interp)) {
- if (!Tcl_LimitExceeded(interp)) {
- Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode);
+ if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) {
+ Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode);
- Tcl_IncrRefCount(cmd);
- Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
- Tcl_DecrRefCount(cmd);
- }
+ Tcl_IncrRefCount(cmd);
+ Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
+ Tcl_DecrRefCount(cmd);
}
- /*
- * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual
- * is happening. Maybe interp has been deleted; maybe [exit] was
- * redefined, maybe we've blown up because of an exceeded limit. We
- * still want to cleanup and exit.
- */
+
+ /*
+ * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual is
+ * happening. Maybe interp has been deleted; maybe [exit] was redefined,
+ * maybe we've blown up because of an exceeded limit. We still want to
+ * cleanup and exit.
+ */
+
Tcl_Exit(exitCode);
}
@@ -637,7 +643,7 @@ Tcl_Main(
Tcl_FindExecutable(argv[0]);
Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp());
}
-#endif
+#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */
#ifndef TCL_ASCII_MAIN
@@ -711,6 +717,7 @@ TclGetMainLoop(void)
*
*----------------------------------------------------------------------
*/
+
MODULE_SCOPE int
TclFullFinalizationRequested(void)
{
@@ -727,7 +734,7 @@ TclFullFinalizationRequested(void)
Tcl_DStringFree(&ds);
}
return finalize;
-#endif
+#endif /* PURIFY */
}
#endif /* !TCL_ASCII_MAIN */
@@ -866,9 +873,8 @@ StdinProc(
static void
Prompt(
Tcl_Interp *interp, /* Interpreter to use for prompting. */
- InteractiveState *isPtr) /* InteractiveState. Filled
- * with PROMPT_NONE after a prompt is
- * printed. */
+ InteractiveState *isPtr) /* InteractiveState. Filled with PROMPT_NONE
+ * after a prompt is printed. */
{
Tcl_Obj *promptCmdPtr;
int code;
@@ -879,7 +885,7 @@ Prompt(
}
promptCmdPtr = Tcl_GetVar2Ex(interp,
- ((isPtr->prompt == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"),
+ (isPtr->prompt==PROMPT_CONTINUE ? "tcl_prompt2" : "tcl_prompt1"),
NULL, TCL_GLOBAL_ONLY);
if (Tcl_InterpDeleted(interp)) {
@@ -920,8 +926,8 @@ Prompt(
*
* FreeMainInterp --
*
- * Exit handler used to cleanup the main interpreter and ancillary startup
- * script storage at exit.
+ * Exit handler used to cleanup the main interpreter and ancillary
+ * startup script storage at exit.
*
*----------------------------------------------------------------------
*/
@@ -930,13 +936,13 @@ static void
FreeMainInterp(
ClientData clientData)
{
- Tcl_Interp *interp = (Tcl_Interp *) clientData;
+ Tcl_Interp *interp = clientData;
- /*if (TclInExit()) return;*/
+ /*if (TclInExit()) return;*/
- if (!Tcl_InterpDeleted(interp)) {
- Tcl_DeleteInterp(interp);
- }
+ if (!Tcl_InterpDeleted(interp)) {
+ Tcl_DeleteInterp(interp);
+ }
Tcl_SetStartupScript(NULL, NULL);
Tcl_Release(interp);
}
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 6a241f0..3c93400 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -687,9 +687,8 @@ Tcl_CreateNamespace(
parentPtr = NULL;
simpleName = "";
} else if (*name == '\0') {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "can't create namespace \"\": "
- "only global namespace can have empty name", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace"
+ " \"\": only global namespace can have empty name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
"CREATEGLOBAL", NULL);
return NULL;
@@ -725,8 +724,8 @@ Tcl_CreateNamespace(
Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL
#endif
) {
- Tcl_AppendResult(interp, "can't create namespace \"", name,
- "\": already exists", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create namespace \"%s\": already exists", name));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
"CREATEEXISTING", NULL);
return NULL;
@@ -1336,8 +1335,8 @@ Tcl_Export(
&exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
- Tcl_AppendResult(interp, "invalid export pattern \"", pattern,
- "\": pattern can't specify a namespace", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern"
+ " \"%s\": pattern can't specify a namespace", pattern));
Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL);
return TCL_ERROR;
}
@@ -1551,21 +1550,21 @@ Tcl_Import(
&importNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (importNsPtr == NULL) {
- Tcl_AppendResult(interp, "unknown namespace in import pattern \"",
- pattern, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown namespace in import pattern \"%s\"", pattern));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL);
return TCL_ERROR;
}
if (importNsPtr == nsPtr) {
if (pattern == simplePattern) {
- Tcl_AppendResult(interp,
- "no namespace specified in import pattern \"", pattern,
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "no namespace specified in import pattern \"%s\"",
+ pattern));
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL);
} else {
- Tcl_AppendResult(interp, "import pattern \"", pattern,
- "\" tries to import from namespace \"",
- importNsPtr->name, "\" into itself", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "import pattern \"%s\" tries to import from namespace"
+ " \"%s\" into itself", pattern, importNsPtr->name));
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL);
}
return TCL_ERROR;
@@ -1684,9 +1683,10 @@ DoImport(
dataPtr = linkCmd->objClientData;
linkCmd = dataPtr->realCmdPtr;
if (overwrite == linkCmd) {
- Tcl_AppendResult(interp, "import pattern \"", pattern,
- "\" would create a loop containing command \"",
- Tcl_DStringValue(&ds), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "import pattern \"%s\" would create a loop"
+ " containing command \"%s\"",
+ pattern, Tcl_DStringValue(&ds)));
Tcl_DStringFree(&ds);
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL);
return TCL_ERROR;
@@ -1726,8 +1726,8 @@ DoImport(
return TCL_OK;
}
}
- Tcl_AppendResult(interp, "can't import command \"", cmdName,
- "\": already exists", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't import command \"%s\": already exists", cmdName));
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL);
return TCL_ERROR;
}
@@ -1796,9 +1796,9 @@ Tcl_ForgetImport(
&sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (sourceNsPtr == NULL) {
- Tcl_AppendResult(interp,
- "unknown namespace in namespace forget pattern \"",
- pattern, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown namespace in namespace forget pattern \"%s\"",
+ pattern));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL);
return TCL_ERROR;
}
@@ -2402,8 +2402,8 @@ Tcl_FindNamespace(
}
if (flags & TCL_LEAVE_ERR_MSG) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown namespace \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL);
}
return NULL;
@@ -2589,8 +2589,8 @@ Tcl_FindCommand(
}
if (flags & TCL_LEAVE_ERR_MSG) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "unknown command \"", name, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown command \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL);
}
return NULL;
@@ -3170,9 +3170,9 @@ NamespaceDeleteCmd(
namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0);
if ((namespacePtr == NULL)
|| (((Namespace *) namespacePtr)->flags & NS_KILLED)) {
- Tcl_AppendResult(interp, "unknown namespace \"",
- TclGetString(objv[i]),
- "\" in namespace delete command", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown namespace \"%s\" in namespace delete command",
+ TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE",
TclGetString(objv[i]), NULL);
return TCL_ERROR;
@@ -3834,8 +3834,8 @@ NamespaceOriginCmd(
command = Tcl_GetCommandFromObj(interp, objv[1]);
if (command == NULL) {
- Tcl_AppendResult(interp, "invalid command name \"",
- TclGetString(objv[1]), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid command name \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 821befd..d9f5d60 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -81,6 +81,7 @@ static void ObjectRenamedTrace(ClientData clientData,
Tcl_Interp *interp, const char *oldName,
const char *newName, int flags);
static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr);
+static inline void SquelchCachedName(Object *oPtr);
static void SquelchedNsFirst(ClientData clientData);
static int PublicObjectCmd(ClientData clientData,
@@ -704,6 +705,27 @@ AllocObject(
/*
* ----------------------------------------------------------------------
*
+ * SquelchCachedName --
+ *
+ * Encapsulates how to throw away a cached object name. Called from
+ * object rename traces and at object destruction.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+SquelchCachedName(
+ Object *oPtr)
+{
+ if (oPtr->cachedNameObj) {
+ Tcl_DecrRefCount(oPtr->cachedNameObj);
+ oPtr->cachedNameObj = NULL;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* MyDeleted --
*
* This callback is triggered when the object's [my] command is deleted
@@ -778,10 +800,7 @@ ObjectRenamedTrace(
*/
if (flags & TCL_TRACE_RENAME) {
- if (oPtr->cachedNameObj) {
- TclDecrRefCount(oPtr->cachedNameObj);
- oPtr->cachedNameObj = NULL;
- }
+ SquelchCachedName(oPtr);
return;
}
@@ -1138,10 +1157,7 @@ ObjectNamespaceDeleted(
TclOODeleteChainCache(oPtr->chainCache);
}
- if (oPtr->cachedNameObj) {
- TclDecrRefCount(oPtr->cachedNameObj);
- oPtr->cachedNameObj = NULL;
- }
+ SquelchCachedName(oPtr);
if (oPtr->metadataPtr != NULL) {
Tcl_ObjectMetadataType *metadataTypePtr;
@@ -1566,8 +1582,9 @@ Tcl_NewObjectInstance(
if (nameStr && Tcl_FindCommand(interp, nameStr, NULL,
TCL_NAMESPACE_ONLY)) {
- Tcl_AppendResult(interp, "can't create object \"", nameStr,
- "\": command already exists with that name", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create object \"%s\": command already exists with"
+ " that name", nameStr));
Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
return NULL;
}
@@ -1633,8 +1650,8 @@ Tcl_NewObjectInstance(
*/
if (result != TCL_ERROR && Deleted(oPtr)) {
- Tcl_SetResult(interp, "object deleted in constructor",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "object deleted in constructor", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
result = TCL_ERROR;
}
@@ -1689,8 +1706,9 @@ TclNRNewObjectInstance(
if (nameStr && Tcl_FindCommand(interp, nameStr, NULL,
TCL_NAMESPACE_ONLY)) {
- Tcl_AppendResult(interp, "can't create object \"", nameStr,
- "\": command already exists with that name", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create object \"%s\": command already exists with"
+ " that name", nameStr));
Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
return TCL_ERROR;
}
@@ -1778,7 +1796,8 @@ FinalizeAlloc(
*/
if (result != TCL_ERROR && Deleted(oPtr)) {
- Tcl_SetResult(interp, "object deleted in constructor", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "object deleted in constructor", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
result = TCL_ERROR;
}
@@ -1835,7 +1854,8 @@ Tcl_CopyObjectInstance(
*/
if (IsRootClass(oPtr)) {
- Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not clone the class of classes", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
return NULL;
}
@@ -2498,9 +2518,9 @@ TclOOObjectCmdCore(
flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr);
TclDecrRefCount(mappedMethodName);
if (contextPtr == NULL) {
- Tcl_AppendResult(interp, "impossible to invoke method \"",
- TclGetString(methodNamePtr),
- "\": no defined method or unknown method", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "impossible to invoke method \"%s\": no defined method or"
+ " unknown method", TclGetString(methodNamePtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED",
TclGetString(methodNamePtr), NULL);
return TCL_ERROR;
@@ -2514,9 +2534,9 @@ TclOOObjectCmdCore(
contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
flags | (oPtr->flags & FILTER_HANDLING), NULL);
if (contextPtr == NULL) {
- Tcl_AppendResult(interp, "impossible to invoke method \"",
- TclGetString(methodNamePtr),
- "\": no defined method or unknown method", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "impossible to invoke method \"%s\": no defined method or"
+ " unknown method", TclGetString(methodNamePtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(methodNamePtr), NULL);
return TCL_ERROR;
@@ -2542,8 +2562,8 @@ TclOOObjectCmdCore(
}
}
if (contextPtr->index >= contextPtr->callPtr->numChain) {
- Tcl_SetResult(interp, "no valid method implementation",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no valid method implementation", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(methodNamePtr), NULL);
TclOODeleteContext(contextPtr);
@@ -2624,8 +2644,8 @@ Tcl_ObjectContextInvokeNext(
methodType = "method";
}
- Tcl_AppendResult(interp, "no next ", methodType, " implementation",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "no next %s implementation", methodType));
Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
return TCL_ERROR;
}
@@ -2693,8 +2713,8 @@ TclNRObjectContextInvokeNext(
methodType = "method";
}
- Tcl_AppendResult(interp, "no next ", methodType, " implementation",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "no next %s implementation", methodType));
Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
return TCL_ERROR;
}
@@ -2771,8 +2791,8 @@ Tcl_GetObjectFromObj(
return cmdPtr->objClientData;
notAnObject:
- Tcl_AppendResult(interp, TclGetString(objPtr),
- " does not refer to an object", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s does not refer to an object", TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr),
NULL);
return NULL;
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 35ad1eb..3637ede 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -168,8 +168,8 @@ TclOO_Class_Create(
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
- Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
- "\" is not a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "object \"%s\" is not a class", TclGetString(cmdnameObj)));
Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
return TCL_ERROR;
}
@@ -186,7 +186,8 @@ TclOO_Class_Create(
objName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)], &len);
if (len == 0) {
- Tcl_AppendResult(interp, "object name must not be empty", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "object name must not be empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
return TCL_ERROR;
}
@@ -232,8 +233,8 @@ TclOO_Class_CreateNs(
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
- Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
- "\" is not a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "object \"%s\" is not a class", TclGetString(cmdnameObj)));
Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
return TCL_ERROR;
}
@@ -250,14 +251,16 @@ TclOO_Class_CreateNs(
objName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)], &len);
if (len == 0) {
- Tcl_AppendResult(interp, "object name must not be empty", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "object name must not be empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
return TCL_ERROR;
}
nsName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)+1], &len);
if (len == 0) {
- Tcl_AppendResult(interp, "namespace name must not be empty", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "namespace name must not be empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
return TCL_ERROR;
}
@@ -301,8 +304,8 @@ TclOO_Class_New(
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
- Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
- "\" is not a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "object \"%s\" is not a class", TclGetString(cmdnameObj)));
Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
return TCL_ERROR;
}
@@ -504,6 +507,7 @@ TclOO_Object_Unknown(
Object *oPtr = contextPtr->oPtr;
const char **methodNames;
int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
+ Tcl_Obj *errorMsg;
/*
* If no method name, generate an error asking for a method name. (Only by
@@ -529,31 +533,34 @@ TclOO_Object_Unknown(
if (numMethodNames == 0) {
Tcl_Obj *tmpBuf = TclOOObjectName(interp, oPtr);
+ const char *piece;
- Tcl_AppendResult(interp, "object \"", TclGetString(tmpBuf), NULL);
if (contextPtr->callPtr->flags & PUBLIC_METHOD) {
- Tcl_AppendResult(interp, "\" has no visible methods", NULL);
+ piece = "visible methods";
} else {
- Tcl_AppendResult(interp, "\" has no methods", NULL);
+ piece = "methods";
}
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "object \"%s\" has no %s", TclGetString(tmpBuf), piece));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[skip]), NULL);
return TCL_ERROR;
}
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[skip]),
- "\": must be ", NULL);
+ errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ",
+ TclGetString(objv[skip]));
for (i=0 ; i<numMethodNames-1 ; i++) {
if (i) {
- Tcl_AppendResult(interp, ", ", NULL);
+ Tcl_AppendToObj(errorMsg, ", ", -1);
}
- Tcl_AppendResult(interp, methodNames[i], NULL);
+ Tcl_AppendToObj(errorMsg, methodNames[i], -1);
}
if (i) {
- Tcl_AppendResult(interp, " or ", NULL);
+ Tcl_AppendToObj(errorMsg, " or ", -1);
}
- Tcl_AppendResult(interp, methodNames[i], NULL);
+ Tcl_AppendToObj(errorMsg, methodNames[i], -1);
ckfree(methodNames);
+ Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[skip]), NULL);
return TCL_ERROR;
@@ -609,8 +616,9 @@ TclOO_Object_LinkVar(
*/
if (strstr(varName, "::") != NULL) {
- Tcl_AppendResult(interp, "variable name \"", varName,
- "\" illegal: must not contain namespace separator", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "variable name \"%s\" illegal: must not contain namespace"
+ " separator", varName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL);
return TCL_ERROR;
}
@@ -784,8 +792,9 @@ TclOONextObjCmd(
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
- Tcl_AppendResult(interp, TclGetString(objv[0]),
- " may only be called from inside a method", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s may only be called from inside a method",
+ TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
@@ -822,8 +831,9 @@ TclOONextToObjCmd(
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
- Tcl_AppendResult(interp, TclGetString(objv[0]),
- " may only be called from inside a method", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s may only be called from inside a method",
+ TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
@@ -843,8 +853,9 @@ TclOONextToObjCmd(
}
classPtr = ((Object *)object)->classPtr;
if (classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
- "\" is not a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not a class", TclGetString(objv[1])));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL);
return TCL_ERROR;
}
@@ -881,14 +892,15 @@ TclOONextToObjCmd(
struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
- Tcl_AppendResult(interp, "method implementation by \"",
- TclGetString(objv[1]), "\" not reachable from here",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "method implementation by \"%s\" not reachable from here",
+ TclGetString(objv[1])));
return TCL_ERROR;
}
}
- Tcl_AppendResult(interp, "method has no non-filter implementation by \"",
- TclGetString(objv[1]), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "method has no non-filter implementation by \"%s\"",
+ TclGetString(objv[1])));
return TCL_ERROR;
}
@@ -948,8 +960,9 @@ TclOOSelfObjCmd(
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
- Tcl_AppendResult(interp, TclGetString(objv[0]),
- " may only be called from inside a method", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s may only be called from inside a method",
+ TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
@@ -983,7 +996,8 @@ TclOOSelfObjCmd(
Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
if (clsPtr == NULL) {
- Tcl_AppendResult(interp, "method not defined by a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method not defined by a class", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
return TCL_ERROR;
}
@@ -1003,7 +1017,8 @@ TclOOSelfObjCmd(
return TCL_OK;
case SELF_FILTER:
if (!CurrentlyInvoked(contextPtr).isFilter) {
- Tcl_AppendResult(interp, "not inside a filtering context", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "not inside a filtering context", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
return TCL_ERROR;
} else {
@@ -1028,7 +1043,8 @@ TclOOSelfObjCmd(
case SELF_CALLER:
if ((framePtr->callerVarPtr == NULL) ||
!(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
- Tcl_AppendResult(interp, "caller is not an object", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "caller is not an object", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
} else {
@@ -1045,7 +1061,8 @@ TclOOSelfObjCmd(
* This should be unreachable code.
*/
- Tcl_AppendResult(interp, "method without declarer!", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method without declarer!", -1));
return TCL_ERROR;
}
@@ -1076,7 +1093,8 @@ TclOOSelfObjCmd(
* This should be unreachable code.
*/
- Tcl_AppendResult(interp, "method without declarer!", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method without declarer!", -1));
return TCL_ERROR;
}
@@ -1093,7 +1111,8 @@ TclOOSelfObjCmd(
return TCL_OK;
case SELF_TARGET:
if (!CurrentlyInvoked(contextPtr).isFilter) {
- Tcl_AppendResult(interp, "not inside a filtering context", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "not inside a filtering context", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
return TCL_ERROR;
} else {
@@ -1119,7 +1138,8 @@ TclOOSelfObjCmd(
* This should be unreachable code.
*/
- Tcl_AppendResult(interp, "method without declarer!", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method without declarer!", -1));
return TCL_ERROR;
}
result[0] = TclOOObjectName(interp, declarerPtr);
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 69cffb0..c022e6b 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -423,8 +423,8 @@ RenameDeleteMethod(
if (!useClass) {
if (!oPtr->methodsPtr) {
noSuchMethod:
- Tcl_AppendResult(interp, "method ", TclGetString(fromPtr),
- " does not exist", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "method %s does not exist", TclGetString(fromPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(fromPtr), NULL);
return TCL_ERROR;
@@ -438,14 +438,15 @@ RenameDeleteMethod(
&isNew);
if (hPtr == newHPtr) {
renameToSelf:
- Tcl_AppendResult(interp, "cannot rename method to itself",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot rename method to itself", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", NULL);
return TCL_ERROR;
} else if (!isNew) {
renameToExisting:
- Tcl_AppendResult(interp, "method called ",
- TclGetString(toPtr), " already exists", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "method called %s already exists",
+ TclGetString(toPtr)));
Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_OVER", NULL);
return TCL_ERROR;
}
@@ -513,7 +514,8 @@ TclOOUnknownDefinition(
const char *soughtStr, *matchedStr = NULL;
if (objc < 2) {
- Tcl_AppendResult(interp, "bad call of unknown handler", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad call of unknown handler", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", NULL);
return TCL_ERROR;
}
@@ -558,7 +560,8 @@ TclOOUnknownDefinition(
}
noMatch:
- Tcl_AppendResult(interp, "invalid command name \"",soughtStr,"\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid command name \"%s\"", soughtStr));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", soughtStr, NULL);
return TCL_ERROR;
}
@@ -646,9 +649,9 @@ InitDefineContext(
int result;
if (namespacePtr == NULL) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot process definitions; support namespace deleted",
- NULL);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -686,16 +689,17 @@ TclOOGetDefineCmdContext(
if ((iPtr->varFramePtr == NULL)
|| (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
- Tcl_AppendResult(interp, "this command may only be called from within"
- " the context of an ::oo::define or ::oo::objdefine command",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "this command may only be called from within the context of"
+ " an ::oo::define or ::oo::objdefine command", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return NULL;
}
object = iPtr->varFramePtr->clientData;
if (Tcl_ObjectDeleted(object)) {
- Tcl_AppendResult(interp, "this command cannot be called when the "
- "object has been deleted", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "this command cannot be called when the object has been"
+ " deleted", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return NULL;
}
@@ -736,7 +740,7 @@ GetClassInOuterContext(
return NULL;
}
if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, errMsg, NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(className), NULL);
return NULL;
@@ -816,8 +820,8 @@ TclOODefineObjCmd(
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, TclGetString(objv[1]),
- " does not refer to a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s does not refer to a class",TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
@@ -1161,14 +1165,14 @@ TclOODefineClassObjCmd(
return TCL_ERROR;
}
if (oPtr->flags & ROOT_OBJECT) {
- Tcl_AppendResult(interp,
- "may not modify the class of the root object class", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not modify the class of the root object class", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
if (oPtr->flags & ROOT_CLASS) {
- Tcl_AppendResult(interp,
- "may not modify the class of the class of classes", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not modify the class of the class of classes", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1194,9 +1198,10 @@ TclOODefineClassObjCmd(
*/
if ((oPtr->classPtr==NULL) == TclOOIsReachable(fPtr->classCls, clsPtr)) {
- Tcl_AppendResult(interp, "may not change a ",
- (oPtr->classPtr==NULL ? "non-" : ""), "class object into a ",
- (oPtr->classPtr==NULL ? "" : "non-"), "class object", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "may not change a %sclass object into a %sclass object",
+ (oPtr->classPtr==NULL ? "non-" : ""),
+ (oPtr->classPtr==NULL ? "" : "non-")));
Tcl_SetErrorCode(interp, "TCL", "OO", "TRANSMUTATION", NULL);
return TCL_ERROR;
}
@@ -1317,7 +1322,8 @@ TclOODefineDeleteMethodObjCmd(
return TCL_ERROR;
}
if (!isInstanceDeleteMethod && !oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1440,7 +1446,8 @@ TclOODefineExportObjCmd(
}
clsPtr = oPtr->classPtr;
if (!isInstanceExport && !clsPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1531,7 +1538,8 @@ TclOODefineForwardObjCmd(
return TCL_ERROR;
}
if (!isInstanceForward && !oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1588,7 +1596,8 @@ TclOODefineMethodObjCmd(
return TCL_ERROR;
}
if (!isInstanceMethod && !oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1639,7 +1648,8 @@ TclOODefineMixinObjCmd(
return TCL_ERROR;
}
if (!isInstanceMixin && !oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1653,7 +1663,8 @@ TclOODefineMixinObjCmd(
goto freeAndError;
}
if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) {
- Tcl_AppendResult(interp, "may not mix a class into itself", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not mix a class into itself", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
goto freeAndError;
}
@@ -1704,7 +1715,8 @@ TclOODefineRenameMethodObjCmd(
return TCL_ERROR;
}
if (!isInstanceRenameMethod && !oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1764,7 +1776,8 @@ TclOODefineUnexportObjCmd(
}
clsPtr = oPtr->classPtr;
if (!isInstanceUnexport && !clsPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1949,7 +1962,8 @@ ClassFilterGet(
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1984,7 +1998,8 @@ ClassFilterSet(
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ 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], &filterc,
@@ -2027,7 +2042,8 @@ ClassMixinGet(
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -2065,7 +2081,8 @@ ClassMixinSet(
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ 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], &mixinc,
@@ -2082,7 +2099,8 @@ ClassMixinSet(
goto freeAndError;
}
if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
- Tcl_AppendResult(interp, "may not mix a class into itself", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not mix a class into itself", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
goto freeAndError;
}
@@ -2128,7 +2146,8 @@ ClassSuperGet(
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -2165,12 +2184,13 @@ ClassSuperSet(
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (oPtr == oPtr->fPtr->objectCls->thisPtr) {
- Tcl_AppendResult(interp,
- "may not modify the superclass of the root object", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not modify the superclass of the root object", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &superc,
@@ -2196,15 +2216,15 @@ ClassSuperSet(
}
for (j=0 ; j<i ; j++) {
if (superclasses[j] == superclasses[i]) {
- Tcl_AppendResult(interp,
- "class should only be a direct superclass once",NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "class should only be a direct superclass once", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL);
goto failedAfterAlloc;
}
}
if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) {
- Tcl_AppendResult(interp,
- "attempt to form circular dependency graph", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to form circular dependency graph", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
failedAfterAlloc:
ckfree((char *) superclasses);
@@ -2265,7 +2285,8 @@ ClassVarsGet(
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -2301,7 +2322,8 @@ ClassVarsSet(
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ 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,
@@ -2313,15 +2335,16 @@ ClassVarsSet(
const char *varName = Tcl_GetString(varv[i]);
if (strstr(varName, "::") != NULL) {
- Tcl_AppendResult(interp, "invalid declared variable name \"",
- varName, "\": must not contain namespace separators",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid declared variable name \"%s\": must not %s",
+ varName, "contain namespace separators"));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
return TCL_ERROR;
}
if (Tcl_StringMatch(varName, "*(*)")) {
- Tcl_AppendResult(interp, "invalid declared variable name \"",
- varName, "\": must not refer to an array element", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid declared variable name \"%s\": must not %s",
+ varName, "refer to an array element"));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
return TCL_ERROR;
}
@@ -2591,15 +2614,16 @@ ObjVarsSet(
const char *varName = Tcl_GetString(varv[i]);
if (strstr(varName, "::") != NULL) {
- Tcl_AppendResult(interp, "invalid declared variable name \"",
- varName, "\": must not contain namespace separators",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid declared variable name \"%s\": must not %s",
+ varName, "contain namespace separators"));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
return TCL_ERROR;
}
if (Tcl_StringMatch(varName, "*(*)")) {
- Tcl_AppendResult(interp, "invalid declared variable name \"",
- varName, "\": must not refer to an array element", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid declared variable name \"%s\": must not %s",
+ varName, "refer to an array element"));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
return TCL_ERROR;
}
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index f298320..796442b 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -177,8 +177,8 @@ GetClassFromObj(
return NULL;
}
if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objPtr),
- "\" is not a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not a class", TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objPtr), NULL);
return NULL;
@@ -279,16 +279,16 @@ InfoObjectDefnCmd(
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
if (hPtr == NULL) {
unknownMethod:
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
- Tcl_AppendResult(interp,
- "definition not available for this kind of method", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "definition not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
@@ -390,17 +390,17 @@ InfoObjectForwardCmd(
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
if (hPtr == NULL) {
unknownMethod:
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
if (prefixObj == NULL) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"prefix argument list not available for this kind of method",
- NULL);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
@@ -491,7 +491,8 @@ InfoObjectIsACmd(
return TCL_ERROR;
}
if (o2Ptr->classPtr == NULL) {
- Tcl_AppendResult(interp, "non-classes cannot be mixins", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "non-classes cannot be mixins", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL);
return TCL_ERROR;
} else {
@@ -516,7 +517,8 @@ InfoObjectIsACmd(
return TCL_ERROR;
}
if (o2Ptr->classPtr == NULL) {
- Tcl_AppendResult(interp, "non-classes cannot be types", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "non-classes cannot be types", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL);
return TCL_ERROR;
}
@@ -651,8 +653,8 @@ InfoObjectMethodTypeCmd(
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
if (hPtr == NULL) {
unknownMethod:
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
@@ -878,8 +880,8 @@ InfoClassConstrCmd(
}
procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr);
if (procPtr == NULL) {
- Tcl_AppendResult(interp,
- "definition not available for this kind of method", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "definition not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
return TCL_ERROR;
}
@@ -937,16 +939,16 @@ InfoClassDefnCmd(
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
- Tcl_AppendResult(interp,
- "definition not available for this kind of method", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "definition not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
@@ -1006,8 +1008,8 @@ InfoClassDestrCmd(
}
procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr);
if (procPtr == NULL) {
- Tcl_AppendResult(interp,
- "definition not available for this kind of method", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "definition not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
return TCL_ERROR;
}
@@ -1085,17 +1087,17 @@ InfoClassForwardCmd(
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
if (prefixObj == NULL) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"prefix argument list not available for this kind of method",
- NULL);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
@@ -1269,8 +1271,8 @@ InfoClassMethodTypeCmd(
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
if (hPtr == NULL) {
unknownMethod:
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
@@ -1494,7 +1496,8 @@ InfoObjectCallCmd(
contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL);
if (contextPtr == NULL) {
- Tcl_AppendResult(interp, "cannot construct any call chain", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot construct any call chain", -1));
return TCL_ERROR;
}
Tcl_SetObjResult(interp,
@@ -1538,7 +1541,8 @@ InfoClassCallCmd(
callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD);
if (callPtr == NULL) {
- Tcl_AppendResult(interp, "cannot construct any call chain", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot construct any call chain", -1));
return TCL_ERROR;
}
Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr));
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 877c3db..60eaa6e 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -1329,8 +1329,8 @@ TclOONewForwardInstanceMethod(
return NULL;
}
if (prefixLen < 1) {
- Tcl_AppendResult(interp, "method forward prefix must be non-empty",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method forward prefix must be non-empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
return NULL;
}
@@ -1371,8 +1371,8 @@ TclOONewForwardMethod(
return NULL;
}
if (prefixLen < 1) {
- Tcl_AppendResult(interp, "method forward prefix must be non-empty",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method forward prefix must be non-empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
return NULL;
}
diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c
index 3b6ce37..55f2378 100644
--- a/generic/tclOOStubLib.c
+++ b/generic/tclOOStubLib.c
@@ -53,8 +53,9 @@ TclOOInitializeStubs(
if (clientData == NULL) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "Error loading ", packageName, " package; ",
- "package not present or incomplete", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error loading %s package; package not present or incomplete",
+ packageName));
return NULL;
} else {
const TclOOStubs * const stubsPtr = clientData;
@@ -76,9 +77,9 @@ TclOOInitializeStubs(
error:
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "Error loading ", packageName, " package",
- " (requested version '", version, "', loaded version '",
- actualVersion, "'): ", errMsg, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("Error loading %s package"
+ " (requested version '%s', loaded version '%s'): %s",
+ packageName, version, actualVersion, errMsg));
return NULL;
}
}
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 099b67d..74cb29e 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -4462,11 +4462,8 @@ Tcl_RepresentationCmd(
int objc,
Tcl_Obj *const objv[])
{
- char refcountBuffer[TCL_INTEGER_SPACE+1];
- char objPtrBuffer[TCL_INTEGER_SPACE+3];
- char internalRepBuffer[2*(TCL_INTEGER_SPACE+2)+2];
-#define TCLOBJ_TRUNCATE_STRINGREP 16
- char stringRepBuffer[TCLOBJ_TRUNCATE_STRINGREP+1];
+ char ptrBuffer[2*TCL_INTEGER_SPACE+6];
+ Tcl_Obj *descObj;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
@@ -4479,27 +4476,30 @@ Tcl_RepresentationCmd(
* "1872361827361287"
*/
- sprintf(refcountBuffer, "%d", objv[1]->refCount);
- sprintf(objPtrBuffer, "%p", (void *)objv[1]);
- Tcl_AppendResult(interp, "value is a ", objv[1]->typePtr ?
- objv[1]->typePtr->name : "pure string", " with a refcount of ",
- refcountBuffer, ", object pointer at ", objPtrBuffer, NULL);
+ sprintf(ptrBuffer, "%p", (void *) objv[1]);
+ descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d,"
+ " object pointer at %s",
+ objv[1]->typePtr ? objv[1]->typePtr->name : "pure string",
+ objv[1]->refCount, ptrBuffer);
+
if (objv[1]->typePtr) {
- sprintf(internalRepBuffer, "%p:%p",
- (void *)objv[1]->internalRep.twoPtrValue.ptr1,
- (void *)objv[1]->internalRep.twoPtrValue.ptr2);
- Tcl_AppendResult(interp, ", internal representation ",
- internalRepBuffer, NULL);
+ sprintf(ptrBuffer, "%p:%p",
+ (void *) objv[1]->internalRep.twoPtrValue.ptr1,
+ (void *) objv[1]->internalRep.twoPtrValue.ptr2);
+ Tcl_AppendPrintfToObj(descObj, ", internal representation %s",
+ ptrBuffer);
}
+
if (objv[1]->bytes) {
- strncpy(stringRepBuffer, objv[1]->bytes, TCLOBJ_TRUNCATE_STRINGREP);
- stringRepBuffer[TCLOBJ_TRUNCATE_STRINGREP] = 0;
- Tcl_AppendResult(interp, ", string representation \"",
- stringRepBuffer, objv[1]->length > TCLOBJ_TRUNCATE_STRINGREP ?
- "\"..." : "\".", NULL);
+ Tcl_AppendToObj(descObj, ", string representation \"", -1);
+ Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length,
+ 16, "...");
+ Tcl_AppendToObj(descObj, "\"", -1);
} else {
- Tcl_AppendResult(interp, ", no string representation.", NULL);
+ Tcl_AppendToObj(descObj, ", no string representation", -1);
}
+
+ Tcl_SetObjResult(interp, descObj);
return TCL_OK;
}
diff --git a/generic/tclParse.c b/generic/tclParse.c
index f0050c6..309e232 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -258,7 +258,8 @@ Tcl_ParseCommand(
if ((start == NULL) && (numBytes != 0)) {
if (interp != NULL) {
- Tcl_SetResult(interp, "can't parse a NULL pointer", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can't parse a NULL pointer", -1));
}
return TCL_ERROR;
}
@@ -568,14 +569,14 @@ Tcl_ParseCommand(
}
if (src[-1] == '"') {
if (interp != NULL) {
- Tcl_SetResult(interp, "extra characters after close-quote",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "extra characters after close-quote", -1));
}
parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
} else {
if (interp != NULL) {
- Tcl_SetResult(interp, "extra characters after close-brace",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "extra characters after close-brace", -1));
}
parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
}
@@ -1175,8 +1176,8 @@ ParseTokens(
}
if (numBytes == 0) {
if (parsePtr->interp != NULL) {
- Tcl_SetResult(parsePtr->interp,
- "missing close-bracket", TCL_STATIC);
+ Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
+ "missing close-bracket", -1));
}
parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
parsePtr->term = tokenPtr->start;
@@ -1411,8 +1412,8 @@ Tcl_ParseVarName(
}
if (numBytes == 0) {
if (parsePtr->interp != NULL) {
- Tcl_SetResult(parsePtr->interp,
- "missing close-brace for variable name", TCL_STATIC);
+ Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
+ "missing close-brace for variable name", -1));
}
parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE;
parsePtr->term = tokenPtr->start-1;
@@ -1479,8 +1480,8 @@ Tcl_ParseVarName(
}
if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')){
if (parsePtr->interp != NULL) {
- Tcl_SetResult(parsePtr->interp, "missing )",
- TCL_STATIC);
+ Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
+ "missing )", -1));
}
parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
parsePtr->term = src;
@@ -1755,7 +1756,8 @@ Tcl_ParseBraces(
goto error;
}
- Tcl_SetResult(parsePtr->interp, "missing close-brace", TCL_STATIC);
+ Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
+ "missing close-brace", -1));
/*
* Guess if the problem is due to comments by searching the source string
@@ -1777,8 +1779,8 @@ Tcl_ParseBraces(
break;
case '#' :
if (openBrace && TclIsSpaceProc(src[-1])) {
- Tcl_AppendResult(parsePtr->interp,
- ": possible unbalanced brace in comment", NULL);
+ Tcl_AppendToObj(Tcl_GetObjResult(parsePtr->interp),
+ ": possible unbalanced brace in comment", -1);
goto error;
}
break;
@@ -1857,7 +1859,8 @@ Tcl_ParseQuotedString(
}
if (*parsePtr->term != '"') {
if (parsePtr->interp != NULL) {
- Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC);
+ Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
+ "missing \"", -1));
}
parsePtr->errorType = TCL_PARSE_MISSING_QUOTE;
parsePtr->term = start;
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 8bae4fb..db07c0e 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -1492,9 +1492,8 @@ MakePathFromNormalized(
if (pathPtr->bytes == NULL) {
if (pathPtr->typePtr->updateStringProc == NULL) {
if (interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "can't find object"
- "string representation", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can't find object string representation", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF",
NULL);
}
@@ -2368,9 +2367,9 @@ SetFsPathFromAny(
dir = TclGetEnv("HOME", &dirString);
if (dir == NULL) {
if (interp) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "couldn't find HOME environment "
- "variable to expand path", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "couldn't find HOME environment variable to"
+ " expand path", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH",
"HOMELESS", NULL);
}
@@ -2387,9 +2386,8 @@ SetFsPathFromAny(
Tcl_DStringInit(&temp);
if (TclpGetUserHome(name+1, &temp) == NULL) {
if (interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "user \"", name+1,
- "\" doesn't exist", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "user \"%s\" doesn't exist", name+1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER",
NULL);
}
diff --git a/generic/tclPipe.c b/generic/tclPipe.c
index d0b136d..83fb818 100644
--- a/generic/tclPipe.c
+++ b/generic/tclPipe.c
@@ -106,9 +106,10 @@ FileForRedirect(
if (msg) {
Tcl_SetObjResult(interp, msg);
} else {
- Tcl_AppendResult(interp, "channel \"",
- Tcl_GetChannelName(chan), "\" wasn't opened for ",
- ((writing) ? "writing" : "reading"), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't opened for %s",
+ Tcl_GetChannelName(chan),
+ ((writing) ? "writing" : "reading")));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"BADCHAN", NULL);
}
@@ -141,9 +142,10 @@ FileForRedirect(
file = TclpOpenFile(name, flags);
Tcl_DStringFree(&nameString);
if (file == NULL) {
- Tcl_AppendResult(interp, "couldn't ",
- ((writing) ? "write" : "read"), " file \"", spec, "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't %s file \"%s\": %s",
+ (writing ? "write" : "read"), spec,
+ Tcl_PosixError(interp)));
return NULL;
}
*closePtr = 1;
@@ -151,8 +153,8 @@ FileForRedirect(
return file;
badLastArg:
- Tcl_AppendResult(interp, "can't specify \"", arg,
- "\" as last word in command", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't specify \"%s\" as last word in command", arg));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", NULL);
return NULL;
}
@@ -304,8 +306,8 @@ TclCleanupChildren(
msg =
"child process lost (is SIGCHLD ignored or trapped?)";
}
- Tcl_AppendResult(interp, "error waiting for process to exit: ",
- msg, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error waiting for process to exit: %s", msg));
}
continue;
}
@@ -335,16 +337,17 @@ TclCleanupChildren(
p = Tcl_SignalMsg(WTERMSIG(waitStatus));
Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL);
- Tcl_AppendResult(interp, "child killed: ", p, "\n", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "child killed: %s\n", p));
} else if (WIFSTOPPED(waitStatus)) {
p = Tcl_SignalMsg(WSTOPSIG(waitStatus));
Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL);
- Tcl_AppendResult(interp, "child suspended: ", p, "\n",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "child suspended: %s\n", p));
} else {
- Tcl_AppendResult(interp,
- "child wait status didn't make sense\n", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "child wait status didn't make sense\n", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"ODDWAITRESULT", msg1, NULL);
}
@@ -374,8 +377,9 @@ TclCleanupChildren(
result = TCL_ERROR;
Tcl_DecrRefCount(objPtr);
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "error reading stderr output file: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error reading stderr output file: %s",
+ Tcl_PosixError(interp)));
} else if (count > 0) {
anyErrorInfo = 1;
Tcl_SetObjResult(interp, objPtr);
@@ -393,7 +397,8 @@ TclCleanupChildren(
*/
if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) {
- Tcl_AppendResult(interp, "child process exited abnormally", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "child process exited abnormally", -1));
}
return result;
}
@@ -542,8 +547,8 @@ TclCreatePipeline(
}
if (*p == '\0') {
if ((i == (lastBar + 1)) || (i == (argc - 1))) {
- Tcl_SetResult(interp, "illegal use of | or |& in command",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "illegal use of | or |& in command", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"PIPESYNTAX", NULL);
goto error;
@@ -570,8 +575,9 @@ TclCreatePipeline(
if (*inputLiteral == '\0') {
inputLiteral = ((i + 1) == argc) ? NULL : argv[i + 1];
if (inputLiteral == NULL) {
- Tcl_AppendResult(interp, "can't specify \"", argv[i],
- "\" as last word in command", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't specify \"%s\" as last word in command",
+ argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"PIPESYNTAX", NULL);
goto error;
@@ -680,8 +686,9 @@ TclCreatePipeline(
*/
if (i != argc-1) {
- Tcl_AppendResult(interp, "must specify \"", argv[i],
- "\" as last word in command", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "must specify \"%s\" as last word in command",
+ argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"PIPESYNTAX", NULL);
goto error;
@@ -722,8 +729,8 @@ TclCreatePipeline(
* We had a bar followed only by redirections.
*/
- Tcl_SetResult(interp, "illegal use of | or |& in command",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "illegal use of | or |& in command", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX",
NULL);
goto error;
@@ -739,9 +746,9 @@ TclCreatePipeline(
inputFile = TclpCreateTempFile(inputLiteral);
if (inputFile == NULL) {
- Tcl_AppendResult(interp,
- "couldn't create input file for command: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't create input file for command: %s",
+ Tcl_PosixError(interp)));
goto error;
}
inputClose = 1;
@@ -752,9 +759,9 @@ TclCreatePipeline(
*/
if (TclpCreatePipe(&inputFile, inPipePtr) == 0) {
- Tcl_AppendResult(interp,
- "couldn't create input pipe for command: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't create input pipe for command: %s",
+ Tcl_PosixError(interp)));
goto error;
}
inputClose = 1;
@@ -781,9 +788,9 @@ TclCreatePipeline(
*/
if (TclpCreatePipe(outPipePtr, &outputFile) == 0) {
- Tcl_AppendResult(interp,
- "couldn't create output pipe for command: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't create output pipe for command: %s",
+ Tcl_PosixError(interp)));
goto error;
}
outputClose = 1;
@@ -821,9 +828,9 @@ TclCreatePipeline(
errorFile = TclpCreateTempFile(NULL);
if (errorFile == NULL) {
- Tcl_AppendResult(interp,
- "couldn't create error file for command: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't create error file for command: %s",
+ Tcl_PosixError(interp)));
goto error;
}
*errFilePtr = errorFile;
@@ -894,8 +901,8 @@ TclCreatePipeline(
} else {
argv[lastArg] = NULL;
if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) {
- Tcl_AppendResult(interp, "couldn't create pipe: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't create pipe: %s", Tcl_PosixError(interp)));
goto error;
}
}
@@ -1074,15 +1081,17 @@ Tcl_OpenCommandChannel(
if (flags & TCL_ENFORCE_MODE) {
if ((flags & TCL_STDOUT) && (outPipe == NULL)) {
- Tcl_AppendResult(interp, "can't read output from command:"
- " standard output was redirected", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can't read output from command:"
+ " standard output was redirected", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"BADREDIRECT", NULL);
goto error;
}
if ((flags & TCL_STDIN) && (inPipe == NULL)) {
- Tcl_AppendResult(interp, "can't write input to command:"
- " standard input was redirected", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can't write input to command:"
+ " standard input was redirected", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"BADREDIRECT", NULL);
goto error;
@@ -1093,8 +1102,8 @@ Tcl_OpenCommandChannel(
numPids, pidPtr);
if (channel == NULL) {
- Tcl_AppendResult(interp, "pipe for command could not be created",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "pipe for command could not be created", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL);
goto error;
}
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 382ffe3..9b6e942 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -154,8 +154,9 @@ Tcl_PkgProvideEx(
}
return TCL_OK;
}
- Tcl_AppendResult(interp, "conflicting versions provided for package \"",
- name, "\": ", pkgPtr->version, ", then ", version, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "conflicting versions provided for package \"%s\": %s, then %s",
+ name, pkgPtr->version, version));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL);
return TCL_ERROR;
}
@@ -284,9 +285,9 @@ Tcl_PkgRequireEx(
*/
tclEmptyStringRep = &tclEmptyString;
- Tcl_AppendResult(interp, "Cannot load package \"", name,
- "\" in standalone executable: This package is not "
- "compiled with stub support", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "Cannot load package \"%s\" in standalone executable:"
+ " This package is not compiled with stub support", name));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL);
return NULL;
}
@@ -374,9 +375,10 @@ PkgRequireCore(
*/
if (pkgPtr->clientData != NULL) {
- Tcl_AppendResult(interp, "circular package dependency: "
- "attempt to provide ", name, " ",
- (char *) pkgPtr->clientData, " requires ", name, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "circular package dependency:"
+ " attempt to provide %s %s requires %s",
+ name, (char *) pkgPtr->clientData, name));
AddRequirementsToResult(interp, reqc, reqv);
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL);
return NULL;
@@ -494,10 +496,10 @@ PkgRequireCore(
Tcl_ResetResult(interp);
if (pkgPtr->version == NULL) {
code = TCL_ERROR;
- Tcl_AppendResult(interp, "attempt to provide package ",
- name, " ", versionToProvide,
- " failed: no version of package ", name,
- " provided", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "attempt to provide package %s %s failed:"
+ " no version of package %s provided",
+ name, versionToProvide, name));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
NULL);
} else {
@@ -517,11 +519,11 @@ PkgRequireCore(
ckfree(vi);
if (res != 0) {
code = TCL_ERROR;
- Tcl_AppendResult(interp,
- "attempt to provide package ", name, " ",
- versionToProvide, " failed: package ",
- name, " ", pkgPtr->version,
- " provided instead", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "attempt to provide package %s %s failed:"
+ " package %s %s provided instead",
+ name, versionToProvide,
+ name, pkgPtr->version));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
"WRONGPROVIDE", NULL);
}
@@ -530,10 +532,10 @@ PkgRequireCore(
} else if (code != TCL_ERROR) {
Tcl_Obj *codePtr = Tcl_NewIntObj(code);
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "attempt to provide package ", name,
- " ", versionToProvide, " failed: bad return code: ",
- TclGetString(codePtr), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "attempt to provide package %s %s failed:"
+ " bad return code: %s",
+ name, versionToProvide, TclGetString(codePtr)));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
TclDecrRefCount(codePtr);
code = TCL_ERROR;
@@ -591,13 +593,9 @@ PkgRequireCore(
Tcl_DStringFree(&command);
if ((code != TCL_OK) && (code != TCL_ERROR)) {
- Tcl_Obj *codePtr = Tcl_NewIntObj(code);
-
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad return code: ",
- TclGetString(codePtr), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad return code: %d", code));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
- Tcl_DecrRefCount(codePtr);
code = TCL_ERROR;
}
if (code == TCL_ERROR) {
@@ -610,7 +608,8 @@ PkgRequireCore(
}
if (pkgPtr->version == NULL) {
- Tcl_AppendResult(interp, "can't find package ", name, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't find package %s", name));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL);
AddRequirementsToResult(interp, reqc, reqv);
return NULL;
@@ -628,8 +627,9 @@ PkgRequireCore(
ckfree(pkgVersionI);
if (!satisfies) {
- Tcl_AppendResult(interp, "version conflict for package \"", name,
- "\": have ", pkgPtr->version, ", need", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "version conflict for package \"%s\": have %s, need",
+ name, pkgPtr->version));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT",
NULL);
AddRequirementsToResult(interp, reqc, reqv);
@@ -721,10 +721,11 @@ Tcl_PkgPresentEx(
}
if (version != NULL) {
- Tcl_AppendResult(interp, "package ", name, " ", version,
- " is not present", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "package %s %s is not present", name, version));
} else {
- Tcl_AppendResult(interp, "package ", name, " is not present", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "package %s is not present", name));
}
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL);
return NULL;
@@ -850,7 +851,8 @@ Tcl_PackageObjCmd(
if (res == 0){
if (objc == 4) {
ckfree(argv3i);
- Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(availPtr->script, -1));
return TCL_OK;
}
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
@@ -955,7 +957,8 @@ Tcl_PackageObjCmd(
if (hPtr != NULL) {
pkgPtr = Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
- Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(pkgPtr->version, -1));
}
}
return TCL_OK;
@@ -1017,7 +1020,8 @@ Tcl_PackageObjCmd(
if (objc == 2) {
if (iPtr->packageUnknown != NULL) {
- Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(iPtr->packageUnknown, -1));
}
} else if (objc == 3) {
if (iPtr->packageUnknown != NULL) {
@@ -1351,8 +1355,8 @@ CheckVersionAndConvert(
error:
ckfree(ibuf);
- Tcl_AppendResult(interp, "expected version number but got \"", string,
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected version number but got \"%s\"", string));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL);
return TCL_ERROR;
}
@@ -1614,8 +1618,8 @@ CheckRequirement(
* More dashes found after the first. This is wrong.
*/
- Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"",
- string, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected versionMin-versionMax but got \"%s\"", string));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL);
return TCL_ERROR;
}
@@ -1667,19 +1671,17 @@ AddRequirementsToResult(
Tcl_Obj *const reqv[]) /* 0 means to use the latest version
* available. */
{
- if (reqc > 0) {
- int i;
+ Tcl_Obj *result = Tcl_GetObjResult(interp);
+ int i, length;
- for (i = 0; i < reqc; i++) {
- int length;
- const char *v = Tcl_GetStringFromObj(reqv[i], &length);
+ for (i = 0; i < reqc; i++) {
+ const char *v = Tcl_GetStringFromObj(reqv[i], &length);
- if ((length & 0x1) && (v[length/2] == '-')
- && (strncmp(v, v+((length+1)/2), length/2) == 0)) {
- Tcl_AppendResult(interp, " exactly ", v+((length+1)/2), NULL);
- } else {
- Tcl_AppendResult(interp, " ", v, NULL);
- }
+ if ((length & 0x1) && (v[length/2] == '-')
+ && (strncmp(v, v+((length+1)/2), length/2) == 0)) {
+ Tcl_AppendPrintfToObj(result, " exactly %s", v+((length+1)/2));
+ } else {
+ Tcl_AppendPrintfToObj(result, " %s", v);
}
}
}
@@ -1708,9 +1710,9 @@ AddRequirementsToDString(
Tcl_Obj *const reqv[]) /* 0 means to use the latest version
* available. */
{
- if (reqc > 0) {
- int i;
+ int i;
+ if (reqc > 0) {
for (i = 0; i < reqc; i++) {
TclDStringAppendLiteral(dsPtr, " ");
TclDStringAppendObj(dsPtr, reqv[i]);
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 537008c..933e7d2 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -152,22 +152,24 @@ Tcl_ProcObjCmd(
&nsPtr, &altNsPtr, &cxtNsPtr, &procName);
if (nsPtr == NULL) {
- Tcl_AppendResult(interp, "can't create procedure \"", fullName,
- "\": unknown namespace", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create procedure \"%s\": unknown namespace",
+ fullName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
if (procName == NULL) {
- Tcl_AppendResult(interp, "can't create procedure \"", fullName,
- "\": bad procedure name", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create procedure \"%s\": bad procedure name",
+ fullName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
if ((nsPtr != iPtr->globalNsPtr)
&& (procName != NULL) && (procName[0] == ':')) {
- Tcl_AppendResult(interp, "can't create procedure \"", procName,
- "\" in non-global namespace with name starting with \":\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create procedure \"%s\" in non-global namespace with"
+ " name starting with \":\"", procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
@@ -518,16 +520,17 @@ TclCreateProc(
}
if (fieldCount > 2) {
ckfree(fieldValues);
- Tcl_AppendResult(interp,
- "too many fields in argument specifier \"",
- argArray[i], "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "too many fields in argument specifier \"%s\"",
+ argArray[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
ckfree(fieldValues);
- Tcl_AppendResult(interp, "argument with no name", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "argument with no name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
@@ -553,16 +556,18 @@ TclCreateProc(
} while (*q != '\0');
q--;
if (*q == ')') { /* We have an array element. */
- Tcl_AppendResult(interp, "formal parameter \"",
- fieldValues[0], "\" is an array element", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "formal parameter \"%s\" is an array element",
+ fieldValues[0]));
ckfree(fieldValues);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
} else if ((*p == ':') && (*(p+1) == ':')) {
- Tcl_AppendResult(interp, "formal parameter \"",
- fieldValues[0], "\" is not a simple name", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "formal parameter \"%s\" is not a simple name",
+ fieldValues[0]));
ckfree(fieldValues);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
@@ -767,8 +772,7 @@ TclGetFrame(
return result;
levelError:
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL);
return -1;
}
@@ -900,8 +904,7 @@ TclObjGetFrame(
return result;
levelError:
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL);
return -1;
}
@@ -1879,10 +1882,9 @@ InterpProcNR2(
* transform to an error now.
*/
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "invoked \"",
- ((result == TCL_BREAK) ? "break" : "continue"),
- "\" outside of a loop", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invoked \"%s\" outside of a loop",
+ ((result == TCL_BREAK) ? "break" : "continue")));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL);
result = TCL_ERROR;
@@ -1999,8 +2001,8 @@ TclProcCompileProc(
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
if ((Interp *) *codePtr->interpHandle != iPtr) {
- Tcl_AppendResult(interp,
- "a precompiled script jumped interps", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "a precompiled script jumped interps", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"CROSSINTERPBYTECODE", NULL);
return TCL_ERROR;
@@ -2932,8 +2934,8 @@ Tcl_DisassembleObjCmd(
procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
if (procPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),
- "\" isn't a procedure", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't a procedure", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
@@ -2982,8 +2984,8 @@ Tcl_DisassembleObjCmd(
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),
- "\" is not a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not a class", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
@@ -3017,16 +3019,16 @@ Tcl_DisassembleObjCmd(
methodBody:
if (hPtr == NULL) {
unknownMethod:
- Tcl_AppendResult(interp, "unknown method \"",
- TclGetString(objv[3]), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[3])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[3]), NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
- Tcl_AppendResult(interp,
- "body not available for this kind of method", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "body not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"METHODTYPE", NULL);
return TCL_ERROR;
@@ -3061,7 +3063,8 @@ Tcl_DisassembleObjCmd(
if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags
& TCL_BYTECODE_PRECOMPILED) {
- Tcl_AppendResult(interp,"may not disassemble prebuilt bytecode",NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not disassemble prebuilt bytecode", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"BYTECODE", NULL);
return TCL_ERROR;
diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c
index 53d7153..6c1dc08 100644
--- a/generic/tclRegexp.c
+++ b/generic/tclRegexp.c
@@ -714,14 +714,14 @@ TclRegError(
int status) /* Status code to report. */
{
char buf[100]; /* ample in practice */
- char cbuf[100]; /* lots in practice */
+ char cbuf[TCL_INTEGER_SPACE];
size_t n;
const char *p;
Tcl_ResetResult(interp);
n = TclReError(status, NULL, buf, sizeof(buf));
p = (n > sizeof(buf)) ? "..." : "";
- Tcl_AppendResult(interp, msg, buf, p, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s%s%s", msg, buf, p));
sprintf(cbuf, "%d", status);
(void) TclReError(REG_ITOA, NULL, cbuf, sizeof(cbuf));
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 4443cc1..9707f20 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -380,12 +380,10 @@ Tcl_DiscardResult(
if (statePtr->result == statePtr->appendResult) {
ckfree(statePtr->appendResult);
+ } else if (statePtr->freeProc == TCL_DYNAMIC) {
+ ckfree(statePtr->result);
} else if (statePtr->freeProc) {
- if (statePtr->freeProc == TCL_DYNAMIC) {
- ckfree(statePtr->result);
- } else {
- statePtr->freeProc(statePtr->result);
- }
+ statePtr->freeProc(statePtr->result);
}
}
@@ -585,7 +583,7 @@ Tcl_GetObjResult(
* result, then reset the string result.
*/
- if (*(iPtr->result) != 0) {
+ if (iPtr->result[0] != 0) {
ResetObjResult(iPtr);
objResultPtr = iPtr->objResultPtr;
@@ -601,7 +599,7 @@ Tcl_GetObjResult(
iPtr->freeProc = 0;
}
iPtr->result = iPtr->resultSpace;
- iPtr->resultSpace[0] = 0;
+ iPtr->result[0] = 0;
}
return iPtr->objResultPtr;
}
@@ -1106,9 +1104,7 @@ Tcl_SetObjErrorCode(
*
* Tcl_GetErrorLine --
*
- * Results:
- *
- * Side effects:
+ * Returns the line number associated with the current error.
*
*----------------------------------------------------------------------
*/
@@ -1125,9 +1121,7 @@ Tcl_GetErrorLine(
*
* Tcl_SetErrorLine --
*
- * Results:
- *
- * Side effects:
+ * Sets the line number associated with the current error.
*
*----------------------------------------------------------------------
*/
@@ -1274,7 +1268,8 @@ TclProcessReturn(
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
- Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr);
+ Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO],
+ &valuePtr);
if (valuePtr != NULL) {
int infoLen;
@@ -1285,7 +1280,8 @@ TclProcessReturn(
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
- Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK], &valuePtr);
+ Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK],
+ &valuePtr);
if (valuePtr != NULL) {
int len, valueObjc;
Tcl_Obj **valueObjv;
@@ -1298,26 +1294,36 @@ TclProcessReturn(
Tcl_IncrRefCount(newObj);
iPtr->errorStack = newObj;
}
+
/*
* List extraction done after duplication to avoid moving the rug
* if someone does [return -errorstack [info errorstack]]
*/
- if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc, &valueObjv) == TCL_ERROR) {
+
+ if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc,
+ &valueObjv) == TCL_ERROR) {
return TCL_ERROR;
}
iPtr->resetErrorStack = 0;
Tcl_ListObjLength(interp, iPtr->errorStack, &len);
- /* reset while keeping the list intrep as much as possible */
- Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc, valueObjv);
+
+ /*
+ * Reset while keeping the list intrep as much as possible.
+ */
+
+ Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc,
+ valueObjv);
}
- Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], &valuePtr);
+ Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE],
+ &valuePtr);
if (valuePtr != NULL) {
Tcl_SetObjErrorCode(interp, valuePtr);
} else {
Tcl_SetErrorCode(interp, "NONE", NULL);
}
- Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], &valuePtr);
+ Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE],
+ &valuePtr);
if (valuePtr != NULL) {
TclGetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
}
@@ -1390,10 +1396,9 @@ TclMergeReturnOptions(
* Value is not a legal dictionary.
*/
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad ", compare,
- " value: expected dictionary but got \"",
- TclGetString(objv[1]), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad %s value: expected dictionary but got \"%s\"",
+ compare, TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS",
NULL);
goto error;
@@ -1422,7 +1427,8 @@ TclMergeReturnOptions(
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
if (valuePtr != NULL) {
- if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, valuePtr, &code)) {
+ if (TclGetCompletionCodeFromObj(interp, valuePtr,
+ &code) == TCL_ERROR) {
goto error;
}
Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]);
@@ -1440,10 +1446,9 @@ TclMergeReturnOptions(
* Value is not a legal level.
*/
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad -level value: "
- "expected non-negative integer but got \"",
- TclGetString(valuePtr), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad -level value: expected non-negative integer but got"
+ " \"%s\"", TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", NULL);
goto error;
}
@@ -1462,10 +1467,10 @@ TclMergeReturnOptions(
/*
* Value is not a list, which is illegal for -errorcode.
*/
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad -errorcode value: "
- "expected a list but got \"",
- TclGetString(valuePtr), "\"", NULL);
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad -errorcode value: expected a list but got \"%s\"",
+ TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_ERRORCODE",
NULL);
goto error;
@@ -1484,10 +1489,10 @@ TclMergeReturnOptions(
/*
* Value is not a list, which is illegal for -errorstack.
*/
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad -errorstack value: "
- "expected a list but got \"", TclGetString(valuePtr),
- "\"", NULL);
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad -errorstack value: expected a list but got \"%s\"",
+ TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK",
NULL);
goto error;
@@ -1496,10 +1501,10 @@ TclMergeReturnOptions(
/*
* Errorstack must always be an even-sized list
*/
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp,
- "forbidden odd-sized list for -errorstack: \"",
- TclGetString(valuePtr), "\"", NULL);
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "forbidden odd-sized list for -errorstack: \"%s\"",
+ TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT",
"ODDSIZEDLIST_ERRORSTACK", NULL);
goto error;
@@ -1601,7 +1606,8 @@ Tcl_GetReturnOptions(
*
* TclNoErrorStack --
*
- * Removes the -errorstack entry from an options dict to avoid reference cycles
+ * Removes the -errorstack entry from an options dict to avoid reference
+ * cycles.
*
* Results:
* The (unshared) argument options dict, modified in -place.
@@ -1610,12 +1616,13 @@ Tcl_GetReturnOptions(
*/
Tcl_Obj *
-TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options)
+TclNoErrorStack(
+ Tcl_Interp *interp,
+ Tcl_Obj *options)
{
Tcl_Obj **keys = GetKeys();
Tcl_DictObjRemove(interp, options, keys[KEY_ERRORSTACK]);
-
return options;
}
@@ -1650,9 +1657,8 @@ Tcl_SetReturnOptions(
Tcl_IncrRefCount(options);
if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv)
|| (objc % 2)) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "expected dict but got \"",
- TclGetString(options), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected dict but got \"%s\"", TclGetString(options)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", NULL);
code = TCL_ERROR;
} else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv,
diff --git a/generic/tclScan.c b/generic/tclScan.c
index d21bfaf..ef7eedf 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -261,6 +261,10 @@ ValidateFormat(
int objIndex, xpgSize, nspace = numVars;
int *nassign = TclStackAlloc(interp, nspace * sizeof(int));
char buf[TCL_UTF_MAX+1];
+ Tcl_Obj *errorMsg; /* Place to build an error messages. Note that
+ * these are messy operations because we do
+ * not want to use the formatting engine;
+ * we're inside there! */
/*
* Initialize an array that records the number of times a variable is
@@ -328,9 +332,9 @@ ValidateFormat(
gotSequential = 1;
if (gotXpg) {
mixedXPG:
- Tcl_SetResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot mix \"%\" and \"%n$\" conversion specifiers",
- TCL_STATIC);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", NULL);
goto error;
}
@@ -375,9 +379,9 @@ ValidateFormat(
switch (ch) {
case 'c':
if (flags & SCAN_WIDTH) {
- Tcl_SetResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"field width may not be specified in %c conversion",
- TCL_STATIC);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL);
goto error;
}
@@ -389,9 +393,11 @@ ValidateFormat(
if (flags & (SCAN_LONGER|SCAN_BIG)) {
invalidFieldSize:
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
- Tcl_AppendResult(interp,
- "field size modifier may not be specified in %", buf,
- " conversion", NULL);
+ errorMsg = Tcl_NewStringObj(
+ "field size modifier may not be specified in %", -1);
+ Tcl_AppendToObj(errorMsg, buf, -1);
+ Tcl_AppendToObj(errorMsg, " conversion", -1);
+ Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", NULL);
goto error;
}
@@ -409,8 +415,8 @@ ValidateFormat(
break;
case 'u':
if (flags & SCAN_BIG) {
- Tcl_SetResult(interp,
- "unsigned bignum scans are invalid", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unsigned bignum scans are invalid", -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL);
goto error;
}
@@ -446,15 +452,18 @@ ValidateFormat(
}
break;
badSet:
- Tcl_SetResult(interp, "unmatched [ in format string",
- TCL_STATIC);
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unmatched [ in format string", -1));
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL);
goto error;
default:
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
- Tcl_AppendResult(interp, "bad scan conversion character \"", buf,
- "\"", NULL);
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL);
+ errorMsg = Tcl_NewStringObj(
+ "bad scan conversion character \"", -1);
+ Tcl_AppendToObj(errorMsg, buf, -1);
+ Tcl_AppendToObj(errorMsg, "\"", -1);
+ Tcl_SetObjResult(interp, errorMsg);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL);
goto error;
}
if (!(flags & SCAN_SUPPRESS)) {
@@ -498,9 +507,9 @@ ValidateFormat(
}
for (i = 0; i < numVars; i++) {
if (nassign[i] > 1) {
- Tcl_SetResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"variable is assigned by multiple \"%n$\" conversion specifiers",
- TCL_STATIC);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "POLYASSIGNED", NULL);
goto error;
} else if (!xpgSize && (nassign[i] == 0)) {
@@ -509,9 +518,9 @@ ValidateFormat(
* and/or numVars != 0), then too many vars were given
*/
- Tcl_SetResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"variable is not assigned by any conversion specifiers",
- TCL_STATIC);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", NULL);
goto error;
}
@@ -522,13 +531,13 @@ ValidateFormat(
badIndex:
if (gotXpg) {
- Tcl_SetResult(interp, "\"%n$\" argument index out of range",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"%n$\" argument index out of range", -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", NULL);
} else {
- Tcl_SetResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"different numbers of variable names and field specifiers",
- TCL_STATIC);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", NULL);
}
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 3f06be0..5dc95f9 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -15,11 +15,6 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-#ifndef _WIN64
-/* See [Bug 2935503]: file mtime sets wrong time */
-# define _USE_32BIT_TIME_T
-#endif
-
#undef STATIC_BUILD
#ifndef USE_TCL_STUBS
# define USE_TCL_STUBS
@@ -313,11 +308,8 @@ static int TestexitmainloopCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestpanicCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestfinexitObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
static int TestparserObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -638,7 +630,6 @@ Tcltest_Init(
Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
- Tcl_CreateObjCommand(interp, "testfinexit", TestfinexitObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL);
Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
NULL, NULL);
@@ -870,6 +861,7 @@ TestasyncCmd(
|| (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) {
return TCL_ERROR;
}
+ Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
@@ -878,6 +870,7 @@ TestasyncCmd(
}
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1));
+ Tcl_MutexUnlock(&asyncTestMutex);
return code;
#ifdef TCL_THREADS
} else if (strcmp(argv[1], "marklater") == 0) {
@@ -887,6 +880,7 @@ TestasyncCmd(
if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {
return TCL_ERROR;
}
+ Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
@@ -895,11 +889,13 @@ TestasyncCmd(
INT2PTR(id), TCL_THREAD_STACK_DEFAULT,
TCL_THREAD_NOFLAGS) != TCL_OK) {
Tcl_SetResult(interp, "can't create thread", TCL_STATIC);
+ Tcl_MutexUnlock(&asyncTestMutex);
return TCL_ERROR;
}
break;
}
}
+ Tcl_MutexUnlock(&asyncTestMutex);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create, delete, int, mark, or marklater", NULL);
@@ -4547,47 +4543,6 @@ TestpanicCmd(
return TCL_OK;
}
-/*
- *----------------------------------------------------------------------
- *
- * TestfinexitObjCmd --
- *
- * Calls a variant of [exit] including the full finalization path.
- *
- * Results:
- * Error, or doesn't return.
- *
- * Side effects:
- * Exits application.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-TestfinexitObjCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- int value;
-
- if ((objc != 1) && (objc != 2)) {
- Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
- return TCL_ERROR;
- }
-
- if (objc == 1) {
- value = 0;
- } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
- return TCL_ERROR;
- }
- Tcl_Finalize();
- TclpExit(value);
- /*NOTREACHED*/
- return TCL_ERROR; /* Better not ever reach this! */
-}
-
static int
TestfileCmd(
ClientData dummy, /* Not used. */
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index 36adaad..6b17825 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -829,8 +829,9 @@ Tcl_AfterObjCmd(
if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
const char *arg = Tcl_GetString(objv[1]);
- Tcl_AppendResult(interp, "bad argument \"", arg,
- "\": must be cancel, idle, info, or an integer", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad argument \"%s\": must be"
+ " cancel, idle, info, or an integer", arg));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
arg, NULL);
return TCL_ERROR;
@@ -968,8 +969,8 @@ Tcl_AfterObjCmd(
if (afterPtr == NULL) {
const char *eventStr = TclGetString(objv[2]);
- Tcl_AppendResult(interp, "event \"", eventStr, "\" doesn't exist",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "event \"%s\" doesn't exist", eventStr));
Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL);
return TCL_ERROR;
} else {
diff --git a/generic/tclTomMathStubLib.c b/generic/tclTomMathStubLib.c
index e7e4aea..a3bc4b3 100644
--- a/generic/tclTomMathStubLib.c
+++ b/generic/tclTomMathStubLib.c
@@ -73,10 +73,10 @@ TclTomMathInitializeStubs(
tclTomMathStubsPtr = stubsPtr;
return actualVersion;
}
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "error loading ", packageName,
- " (requested version ", version, ", actual version ",
- actualVersion, "): ", errMsg, NULL);
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error loading %s (requested version %s, actual version %s): %s",
+ packageName, version, actualVersion, errMsg));
return NULL;
}
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 529c38a..519f201 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -366,8 +366,9 @@ Tcl_TraceObjCmd(
return TCL_OK;
badVarOps:
- Tcl_AppendResult(interp, "bad operations \"", flagOps,
- "\": should be one or more of rwua", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad operations \"%s\": should be one or more of rwua",
+ flagOps));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL);
return TCL_ERROR;
}
@@ -434,9 +435,9 @@ TraceExecutionObjCmd(
return result;
}
if (listLen == 0) {
- Tcl_SetResult(interp, "bad operation list \"\": must be "
- "one or more of enter, leave, enterstep, or leavestep",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad operation list \"\": must be one or more of"
+ " enter, leave, enterstep, or leavestep", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
NULL);
return TCL_ERROR;
@@ -677,8 +678,9 @@ TraceCommandObjCmd(
return result;
}
if (listLen == 0) {
- Tcl_SetResult(interp, "bad operation list \"\": must be "
- "one or more of delete or rename", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad operation list \"\": must be one or more of"
+ " delete or rename", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
NULL);
return TCL_ERROR;
@@ -875,8 +877,9 @@ TraceVariableObjCmd(
return result;
}
if (listLen == 0) {
- Tcl_SetResult(interp, "bad operation list \"\": must be "
- "one or more of array, read, unset, or write", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad operation list \"\": must be one or more of"
+ " array, read, unset, or write", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
NULL);
return TCL_ERROR;
@@ -2715,7 +2718,8 @@ TclCallVarTraces(
if (disposeFlags & TCL_TRACE_RESULT_OBJECT) {
Tcl_SetObjResult((Tcl_Interp *)iPtr, (Tcl_Obj *) result);
} else {
- Tcl_SetResult((Tcl_Interp *)iPtr, result, TCL_STATIC);
+ Tcl_SetObjResult((Tcl_Interp *)iPtr,
+ Tcl_NewStringObj(result, -1));
}
Tcl_AddErrorInfo((Tcl_Interp *)iPtr, "");
diff --git a/generic/tclUniData.c b/generic/tclUniData.c
index 2fabe58..5c88639 100644
--- a/generic/tclUniData.c
+++ b/generic/tclUniData.c
@@ -882,7 +882,7 @@ static const unsigned char groupMap[] = {
18, 18, 18, 18, 7, 7, 7, 5, 6, 85, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 7, 7, 7, 5, 6, 0, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85,
85, 85, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
- 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
86, 86, 111, 111, 111, 111, 86, 111, 111, 111, 86, 86, 86, 86, 86,
86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 3379f6c..13e54ec 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -26,9 +26,9 @@ static ProcessGlobalValue executableName = {
};
/*
- * The following values are used in the flags arguments of Tcl*Scan*Element and
- * Tcl*Convert*Element. The values TCL_DONT_USE_BRACES and TCL_DONT_QUOTE_HASH
- * are defined in tcl.h, like so:
+ * The following values are used in the flags arguments of Tcl*Scan*Element
+ * and Tcl*Convert*Element. The values TCL_DONT_USE_BRACES and
+ * TCL_DONT_QUOTE_HASH are defined in tcl.h, like so:
*
#define TCL_DONT_USE_BRACES 1
#define TCL_DONT_QUOTE_HASH 8
@@ -54,8 +54,8 @@ static ProcessGlobalValue executableName = {
* conversion is most appropriate for Tcl*Convert*Element() to perform, and
* sets two bits of the flags value to indicate the mode selected.
*
- * CONVERT_NONE The element needs no quoting. Its literal string
- * is suitable as is.
+ * CONVERT_NONE The element needs no quoting. Its literal string is
+ * suitable as is.
* CONVERT_BRACE The conversion should be enclosing the literal string
* in braces.
* CONVERT_ESCAPE The conversion should be using backslashes to escape
@@ -63,19 +63,19 @@ static ProcessGlobalValue executableName = {
* CONVERT_MASK A mask value used to extract the conversion mode from
* the flags argument.
* Also indicates a strange conversion mode where all
- * special characters are escaped with backslashes
- * *except for braces*. This is a strange and unnecessary
+ * special characters are escaped with backslashes
+ * *except for braces*. This is a strange and unnecessary
* case, but it's part of the historical way in which
- * lists have been formatted in Tcl. To experiment with
+ * lists have been formatted in Tcl. To experiment with
* removing this case, set the value of COMPAT to 0.
*
- * One last flag value is used only by callers of TclScanElement(). The flag
+ * One last flag value is used only by callers of TclScanElement(). The flag
* value produced by a call to Tcl*Scan*Element() will never leave this bit
* set.
*
- * CONVERT_ANY The caller of TclScanElement() declares it can make
- * no promise about what public flags will be passed to
- * the matching call of TclConvertElement(). As such,
+ * CONVERT_ANY The caller of TclScanElement() declares it can make no
+ * promise about what public flags will be passed to the
+ * matching call of TclConvertElement(). As such,
* TclScanElement() has to determine the worst case
* destination buffer length over all possibilities, and
* in other cases this means an overestimate of the
@@ -129,17 +129,17 @@ const Tcl_ObjType tclEndOffsetType = {
/*
* * STRING REPRESENTATION OF LISTS * * *
*
- * The next several routines implement the conversions of strings to and
- * from Tcl lists. To understand their operation, the rules of parsing
- * and generating the string representation of lists must be known. Here
- * we describe them in one place.
+ * The next several routines implement the conversions of strings to and from
+ * Tcl lists. To understand their operation, the rules of parsing and
+ * generating the string representation of lists must be known. Here we
+ * describe them in one place.
*
- * A list is made up of zero or more elements. Any string is a list if
- * it is made up of alternating substrings of element-separating ASCII
- * whitespace and properly formatted elements.
+ * A list is made up of zero or more elements. Any string is a list if it is
+ * made up of alternating substrings of element-separating ASCII whitespace
+ * and properly formatted elements.
*
- * The ASCII characters which can make up the whitespace between list
- * elements are:
+ * The ASCII characters which can make up the whitespace between list elements
+ * are:
*
* \u0009 \t TAB
* \u000A \n NEWLINE
@@ -158,69 +158,68 @@ const Tcl_ObjType tclEndOffsetType = {
* * Unlike command parsing, the BACKSLASH NEWLINE sequence is not
* considered to be a whitespace character.
*
- * * Other Unicode whitespace characters (recognized by
- * [string is space] or Tcl_UniCharIsSpace()) do not play any role
- * as element separators in Tcl lists.
+ * * Other Unicode whitespace characters (recognized by [string is space]
+ * or Tcl_UniCharIsSpace()) do not play any role as element separators
+ * in Tcl lists.
*
* * The NUL byte ought not appear, as it is not in strings properly
* encoded for Tcl, but if it is present, it is not treated as
- * separating whitespace, or a string terminator. It is just
- * another character in a list element.
- *
- * The interpretaton of a formatted substring as a list element follows
- * rules similar to the parsing of the words of a command in a Tcl script.
- * Backslash substitution plays a key role, and is defined exactly as it is
- * in command parsing. The same routine, TclParseBackslash() is used in both
- * command parsing and list parsing.
- *
- * NOTE: This means that if and when backslash substitution rules ever
- * change for command parsing, the interpretation of strings as lists also
- * changes.
+ * separating whitespace, or a string terminator. It is just another
+ * character in a list element.
+ *
+ * The interpretaton of a formatted substring as a list element follows rules
+ * similar to the parsing of the words of a command in a Tcl script. Backslash
+ * substitution plays a key role, and is defined exactly as it is in command
+ * parsing. The same routine, TclParseBackslash() is used in both command
+ * parsing and list parsing.
+ *
+ * NOTE: This means that if and when backslash substitution rules ever change
+ * for command parsing, the interpretation of strings as lists also changes.
*
* Backslash substitution replaces an "escape sequence" of one or more
* characters starting with
* \u005c \ BACKSLASH
- * with a single character. The one character escape sequent case happens
- * only when BACKSLASH is the last character in the string. In all other
- * cases, the escape sequence is at least two characters long.
+ * with a single character. The one character escape sequent case happens only
+ * when BACKSLASH is the last character in the string. In all other cases, the
+ * escape sequence is at least two characters long.
*
- * The formatted substrings are interpreted as element values according to
- * the following cases:
+ * The formatted substrings are interpreted as element values according to the
+ * following cases:
*
* * If the first character of a formatted substring is
* \u007b { OPEN BRACE
* then the end of the substring is the matching
* \u007d } CLOSE BRACE
- * character, where matching is determined by counting nesting levels,
- * and not including any brace characters that are contained within a
- * backslash escape sequence in the nesting count. Having found the
- * matching brace, all characters between the braces are the string
- * value of the element. If no matching close brace is found before the
- * end of the string, the string is not a Tcl list. If the character
- * following the close brace is not an element separating whitespace
- * character, or the end of the string, then the string is not a Tcl list.
- *
- * NOTE: this differs from a brace-quoted word in the parsing of a
- * Tcl command only in its treatment of the backslash-newline sequence.
- * In a list element, the literal characters in the backslash-newline
- * sequence become part of the element value. In a script word,
- * conversion to a single SPACE character is done.
+ * character, where matching is determined by counting nesting levels, and
+ * not including any brace characters that are contained within a backslash
+ * escape sequence in the nesting count. Having found the matching brace,
+ * all characters between the braces are the string value of the element.
+ * If no matching close brace is found before the end of the string, the
+ * string is not a Tcl list. If the character following the close brace is
+ * not an element separating whitespace character, or the end of the string,
+ * then the string is not a Tcl list.
+ *
+ * NOTE: this differs from a brace-quoted word in the parsing of a Tcl
+ * command only in its treatment of the backslash-newline sequence. In a
+ * list element, the literal characters in the backslash-newline sequence
+ * become part of the element value. In a script word, conversion to a
+ * single SPACE character is done.
*
* NOTE: Most list element values can be represented by a formatted
- * substring using brace quoting. The exceptions are any element value
- * that includes an unbalanced brace not in a backslash escape sequence,
- * and any value that ends with a backslash not itself in a backslash
- * escape sequence.
+ * substring using brace quoting. The exceptions are any element value that
+ * includes an unbalanced brace not in a backslash escape sequence, and any
+ * value that ends with a backslash not itself in a backslash escape
+ * sequence.
*
* * If the first character of a formatted substring is
* \u0022 " QUOTE
* then the end of the substring is the next QUOTE character, not counting
* any QUOTE characters that are contained within a backslash escape
- * sequence. If no next QUOTE is found before the end of the string, the
- * string is not a Tcl list. If the character following the closing QUOTE
- * is not an element separating whitespace character, or the end of the
- * string, then the string is not a Tcl list. Having found the limits
- * of the substring, the element value is produced by performing backslash
+ * sequence. If no next QUOTE is found before the end of the string, the
+ * string is not a Tcl list. If the character following the closing QUOTE is
+ * not an element separating whitespace character, or the end of the string,
+ * then the string is not a Tcl list. Having found the limits of the
+ * substring, the element value is produced by performing backslash
* substitution on the character sequence between the open and close QUOTEs.
*
* NOTE: Any element value can be represented by this style of formatting,
@@ -231,7 +230,7 @@ const Tcl_ObjType tclEndOffsetType = {
* of the substring, the element value is produced by performing backslash
* substitution on it.
*
- * NOTE: Any element value can be represented by this style of formatting,
+ * NOTE: Any element value can be represented by this style of formatting,
* given suitable choice of backslash escape sequences, with one exception.
* The empty string cannot be represented as a list element without the use
* of either braces or quotes to delimit it.
@@ -239,32 +238,32 @@ const Tcl_ObjType tclEndOffsetType = {
* This collection of parsing rules is implemented in the routine
* TclFindElement().
*
- * In order to produce lists that can be parsed by these rules, we need
- * the ability to distinguish between characters that are part of a list
- * element value from characters providing syntax that define the structure
- * of the list. This means that our code that generates lists must at a
- * minimum be able to produce escape sequences for the 10 characters
- * identified above that have significance to a list parser.
+ * In order to produce lists that can be parsed by these rules, we need the
+ * ability to distinguish between characters that are part of a list element
+ * value from characters providing syntax that define the structure of the
+ * list. This means that our code that generates lists must at a minimum be
+ * able to produce escape sequences for the 10 characters identified above
+ * that have significance to a list parser.
*
- * * * CANONICAL LISTS * * * * *
+ * * * CANONICAL LISTS * * * * *
*
* In addition to the basic rules for parsing strings into Tcl lists, there
* are additional properties to be met by the set of list values that are
* generated by Tcl. Such list values are often said to be in "canonical
* form":
*
- * * When any canonical list is evaluated as a Tcl script, it is a script
- * of either zero commands (an empty list) or exactly one command. The
- * command word is exactly the first element of the list, and each argument
- * word is exactly one of the following elements of the list. This means
- * that any characters that have special meaning during script evaluation
- * need special treatment when canonical lists are produced:
+ * * When any canonical list is evaluated as a Tcl script, it is a script of
+ * either zero commands (an empty list) or exactly one command. The command
+ * word is exactly the first element of the list, and each argument word is
+ * exactly one of the following elements of the list. This means that any
+ * characters that have special meaning during script evaluation need
+ * special treatment when canonical lists are produced:
*
* * Whitespace between elements may not include NEWLINE.
* * The command terminating character,
* \u003b ; SEMICOLON
- * must be BRACEd, QUOTEd, or escaped so that it does not terminate
- * the command prematurely.
+ * must be BRACEd, QUOTEd, or escaped so that it does not terminate the
+ * command prematurely.
* * Any of the characters that begin substitutions in scripts,
* \u0024 $ DOLLAR
* \u005b [ OPEN BRACKET
@@ -274,11 +273,10 @@ const Tcl_ObjType tclEndOffsetType = {
* \u0023 # HASH
* that HASH character must be BRACEd, QUOTEd, or escaped so that it
* does not convert the command into a comment.
- * * Any list element that contains the character sequence
- * BACKSLASH NEWLINE cannot be formatted with BRACEs. The
- * BACKSLASH character must be represented by an escape
- * sequence, and unless QUOTEs are used, the NEWLINE must
- * be as well.
+ * * Any list element that contains the character sequence BACKSLASH
+ * NEWLINE cannot be formatted with BRACEs. The BACKSLASH character
+ * must be represented by an escape sequence, and unless QUOTEs are
+ * used, the NEWLINE must be as well.
*
* * It is also guaranteed that one can use a canonical list as a building
* block of a larger script within command substitution, as in this example:
@@ -289,66 +287,66 @@ const Tcl_ObjType tclEndOffsetType = {
*
* * Finally it is guaranteed that enclosing a canonical list in braces
* produces a new value that is also a canonical list. This new list has
- * length 1, and its only element is the original canonical list. This
- * same guarantee also makes it possible to construct scripts where an
- * argument word is given a list value by enclosing the canonical form
- * of that list in braces:
+ * length 1, and its only element is the original canonical list. This same
+ * guarantee also makes it possible to construct scripts where an argument
+ * word is given a list value by enclosing the canonical form of that list
+ * in braces:
* set script "puts {[list $one $two $three]}"; eval $script
* This sort of coding was once fairly common, though it's become more
* idiomatic to see the following instead:
* set script [list puts [list $one $two $three]]; eval $script
- * In order to support this guarantee, every canonical list must have
+ * In order to support this guarantee, every canonical list must have
* balance when counting those braces that are not in escape sequences.
*
* Within these constraints, the canonical list generation routines
- * TclScanElement() and TclConvertElement() attempt to generate the string
- * for any list that is easiest to read. When an element value is itself
+ * TclScanElement() and TclConvertElement() attempt to generate the string for
+ * any list that is easiest to read. When an element value is itself
* acceptable as the formatted substring, it is usually used (CONVERT_NONE).
- * When some quoting or escaping is required, use of BRACEs (CONVERT_BRACE)
- * is usually preferred over the use of escape sequences (CONVERT_ESCAPE).
- * There are some exceptions to both of these preferences for reasons of
- * code simplicity, efficiency, and continuation of historical habits.
- * Canonical lists never use the QUOTE formatting to delimit their elements
- * because that form of quoting does not nest, which makes construction of
- * nested lists far too much trouble. Canonical lists always use only a
- * single SPACE character for element-separating whitespace.
+ * When some quoting or escaping is required, use of BRACEs (CONVERT_BRACE) is
+ * usually preferred over the use of escape sequences (CONVERT_ESCAPE). There
+ * are some exceptions to both of these preferences for reasons of code
+ * simplicity, efficiency, and continuation of historical habits. Canonical
+ * lists never use the QUOTE formatting to delimit their elements because that
+ * form of quoting does not nest, which makes construction of nested lists far
+ * too much trouble. Canonical lists always use only a single SPACE character
+ * for element-separating whitespace.
*
* * * FUTURE CONSIDERATIONS * * *
*
* When a list element requires quoting or escaping due to a CLOSE BRACKET
* character or an internal QUOTE character, a strange formatting mode is
- * recommended. For example, if the value "a{b]c}d" is converted by the
- * usual modes:
+ * recommended. For example, if the value "a{b]c}d" is converted by the usual
+ * modes:
*
* CONVERT_BRACE: a{b]c}d => {a{b]c}d}
* CONVERT_ESCAPE: a{b]c}d => a\{b\]c\}d
*
- * we get perfectly usable formatted list elements. However, this is not
- * what Tcl releases have been producing. Instead, we have:
+ * we get perfectly usable formatted list elements. However, this is not what
+ * Tcl releases have been producing. Instead, we have:
*
* CONVERT_MASK: a{b]c}d => a{b\]c}d
*
- * where the CLOSE BRACKET is escaped, but the BRACEs are not. The same
- * effect can be seen replacing ] with " in this example. There does not
- * appear to be any functional or aesthetic purpose for this strange
- * additional mode. The sole purpose I can see for preserving it is to
- * keep generating the same formatted lists programmers have become accustomed
- * to, and perhaps written tests to expect. That is, compatibility only.
- * The additional code complexity required to support this mode is significant.
- * The lines of code supporting it are delimited in the routines below with
- * #if COMPAT directives. This makes it easy to experiment with eliminating
- * this formatting mode simply with "#define COMPAT 0" above. I believe
- * this is worth considering.
+ * where the CLOSE BRACKET is escaped, but the BRACEs are not. The same effect
+ * can be seen replacing ] with " in this example. There does not appear to be
+ * any functional or aesthetic purpose for this strange additional mode. The
+ * sole purpose I can see for preserving it is to keep generating the same
+ * formatted lists programmers have become accustomed to, and perhaps written
+ * tests to expect. That is, compatibility only. The additional code
+ * complexity required to support this mode is significant. The lines of code
+ * supporting it are delimited in the routines below with #if COMPAT
+ * directives. This makes it easy to experiment with eliminating this
+ * formatting mode simply with "#define COMPAT 0" above. I believe this is
+ * worth considering.
*
- * Another consideration is the treatment of QUOTE characters in list elements.
- * TclConvertElement() must have the ability to produce the escape sequence
- * \" so that when a list element begins with a QUOTE we do not confuse
- * that first character with a QUOTE used as list syntax to define list
- * structure. However, that is the only place where QUOTE characters need
- * quoting. In this way, handling QUOTE could really be much more like
- * the way we handle HASH which also needs quoting and escaping only in
- * particular situations. Following up this could increase the set of
- * list elements that can use the CONVERT_NONE formatting mode.
+ * Another consideration is the treatment of QUOTE characters in list
+ * elements. TclConvertElement() must have the ability to produce the escape
+ * sequence \" so that when a list element begins with a QUOTE we do not
+ * confuse that first character with a QUOTE used as list syntax to define
+ * list structure. However, that is the only place where QUOTE characters need
+ * quoting. In this way, handling QUOTE could really be much more like the way
+ * we handle HASH which also needs quoting and escaping only in particular
+ * situations. Following up this could increase the set of list elements that
+ * can use the CONVERT_NONE formatting mode.
*
* More speculative is that the demands of canonical list form require brace
* balance for the list as a whole, while the current implementation achieves
@@ -366,15 +364,15 @@ const Tcl_ObjType tclEndOffsetType = {
*
* Given 'bytes' pointing to 'numBytes' bytes, scan through them and
* count the number of whitespace runs that could be list element
- * separators. If 'numBytes' is -1, scan to the terminating '\0'.
- * Not a full list parser. Typically used to get a quick and dirty
- * overestimate of length size in order to allocate space for an
- * actual list parser to operate with.
+ * separators. If 'numBytes' is -1, scan to the terminating '\0'. Not a
+ * full list parser. Typically used to get a quick and dirty overestimate
+ * of length size in order to allocate space for an actual list parser to
+ * operate with.
*
* Results:
- * Returns the largest number of list elements that could possibly
- * be in this string, interpreted as a Tcl list. If 'endPtr' is not
- * NULL, writes a pointer to the end of the string scanned there.
+ * Returns the largest number of list elements that could possibly be in
+ * this string, interpreted as a Tcl list. If 'endPtr' is not NULL,
+ * writes a pointer to the end of the string scanned there.
*
* Side effects:
* None.
@@ -395,16 +393,25 @@ TclMaxListLength(
goto done;
}
- /* No list element before leading white space */
+ /*
+ * No list element before leading white space.
+ */
+
count += 1 - TclIsSpaceProc(*bytes);
- /* Count white space runs as potential element separators */
+ /*
+ * Count white space runs as potential element separators.
+ */
+
while (numBytes) {
if ((numBytes == -1) && (*bytes == '\0')) {
break;
}
if (TclIsSpaceProc(*bytes)) {
- /* Space run started; bump count */
+ /*
+ * Space run started; bump count.
+ */
+
count++;
do {
bytes++;
@@ -413,16 +420,22 @@ TclMaxListLength(
if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) {
break;
}
- /* (*bytes) is non-space; return to counting state */
+
+ /*
+ * (*bytes) is non-space; return to counting state.
+ */
}
bytes++;
numBytes -= (numBytes != -1);
}
- /* No list element following trailing white space */
+ /*
+ * No list element following trailing white space.
+ */
+
count -= TclIsSpaceProc(bytes[-1]);
- done:
+ done:
if (endPtr) {
*endPtr = bytes;
}
@@ -449,18 +462,18 @@ TclMaxListLength(
* that's part of the element. If this is the last argument in the list,
* then *nextPtr will point just after the last character in the list
* (i.e., at the character at list+listLength). If sizePtr is non-NULL,
- * *sizePtr is filled in with the number of bytes in the element. If
- * the element is in braces, then *elementPtr will point to the character
+ * *sizePtr is filled in with the number of bytes in the element. If the
+ * element is in braces, then *elementPtr will point to the character
* after the opening brace and *sizePtr will not include either of the
* braces. If there isn't an element in the list, *sizePtr will be zero,
* and both *elementPtr and *nextPtr will point just after the last
* character in the list. If literalPtr is non-NULL, *literalPtr is set
- * to a boolean value indicating whether the substring returned as
- * the values of **elementPtr and *sizePtr is the literal value of
- * a list element. If not, a call to TclCopyAndCollapse() is needed
- * to produce the actual value of the list element. Note: this function
- * does NOT collapse backslash sequences, but uses *literalPtr to tell
- * callers when it is required for them to do so.
+ * to a boolean value indicating whether the substring returned as the
+ * values of **elementPtr and *sizePtr is the literal value of a list
+ * element. If not, a call to TclCopyAndCollapse() is needed to produce
+ * the actual value of the list element. Note: this function does NOT
+ * collapse backslash sequences, but uses *literalPtr to tell callers
+ * when it is required for them to do so.
*
* Side effects:
* None.
@@ -587,9 +600,10 @@ TclFindElement(
/*
* A backslash sequence not within a brace quoted element
* means the value of the element is different from the
- * substring we are parsing. A call to TclCopyAndCollapse()
- * is needed to produce the element value. Inform the caller.
+ * substring we are parsing. A call to TclCopyAndCollapse() is
+ * needed to produce the element value. Inform the caller.
*/
+
literal = 0;
}
TclParseBackslash(p, limit - p, &numChars, NULL);
@@ -655,16 +669,16 @@ TclFindElement(
if (p == limit) {
if (openBraces != 0) {
if (interp != NULL) {
- Tcl_SetResult(interp, "unmatched open brace in list",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unmatched open brace in list", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE",
NULL);
}
return TCL_ERROR;
} else if (inQuotes) {
if (interp != NULL) {
- Tcl_SetResult(interp, "unmatched open quote in list",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unmatched open quote in list", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE",
NULL);
}
@@ -697,9 +711,9 @@ TclFindElement(
*
* Results:
* Count bytes get copied from src to dst. Along the way, backslash
- * sequences are substituted in the copy. After scanning count bytes
- * from src, a null character is placed at the end of dst. Returns
- * the number of bytes that got written to dst.
+ * sequences are substituted in the copy. After scanning count bytes from
+ * src, a null character is placed at the end of dst. Returns the number
+ * of bytes that got written to dst.
*
* Side effects:
* None.
@@ -717,6 +731,7 @@ TclCopyAndCollapse(
while (count > 0) {
char c = *src;
+
if (c == '\\') {
int numRead;
int backslashCount = TclParseBackslash(src, count, &numRead, dst);
@@ -780,12 +795,11 @@ Tcl_SplitList(
int length, size, i, result, elSize;
/*
- * Allocate enough space to work in. A (const char *) for each
- * (possible) list element plus one more for terminating NULL,
- * plus as many bytes as in the original string value, plus one
- * more for a terminating '\0'. Space used to hold element separating
- * white space in the original string gets re-purposed to hold '\0'
- * characters in the argv array.
+ * Allocate enough space to work in. A (const char *) for each (possible)
+ * list element plus one more for terminating NULL, plus as many bytes as
+ * in the original string value, plus one more for a terminating '\0'.
+ * Space used to hold element separating white space in the original
+ * string gets re-purposed to hold '\0' characters in the argv array.
*/
size = TclMaxListLength(list, -1, &end) + 1;
@@ -810,8 +824,8 @@ Tcl_SplitList(
if (i >= size) {
ckfree(argv);
if (interp != NULL) {
- Tcl_SetResult(interp, "internal error in Tcl_SplitList",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "internal error in Tcl_SplitList", -1));
Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList",
NULL);
}
@@ -844,9 +858,9 @@ Tcl_SplitList(
* enclosing braces) to make the string into a valid Tcl list element.
*
* Results:
- * The return value is an overestimate of the number of bytes that
- * will be needed by Tcl_ConvertElement to produce a valid list element
- * from src. The word at *flagPtr is filled in with a value needed by
+ * The return value is an overestimate of the number of bytes that will
+ * be needed by Tcl_ConvertElement to produce a valid list element from
+ * src. The word at *flagPtr is filled in with a value needed by
* Tcl_ConvertElement when doing the actual conversion.
*
* Side effects:
@@ -876,10 +890,10 @@ Tcl_ScanElement(
* to the first null byte.
*
* Results:
- * The return value is an overestimate of the number of bytes that
- * will be needed by Tcl_ConvertCountedElement to produce a valid list
- * element from src. The word at *flagPtr is filled in with a value
- * needed by Tcl_ConvertCountedElement when doing the actual conversion.
+ * The return value is an overestimate of the number of bytes that will
+ * be needed by Tcl_ConvertCountedElement to produce a valid list element
+ * from src. The word at *flagPtr is filled in with a value needed by
+ * Tcl_ConvertCountedElement when doing the actual conversion.
*
* Side effects:
* None.
@@ -906,24 +920,24 @@ Tcl_ScanCountedElement(
*
* TclScanElement --
*
- * This function is a companion function to TclConvertElement. It
- * scans a string to see what needs to be done to it (e.g. add
- * backslashes or enclosing braces) to make the string into a valid Tcl
- * list element. If length is -1, then the string is scanned from src up
- * to the first null byte. A NULL value for src is treated as an
- * empty string. The incoming value of *flagPtr is a report from the
- * caller what additional flags it will pass to TclConvertElement().
+ * This function is a companion function to TclConvertElement. It scans a
+ * string to see what needs to be done to it (e.g. add backslashes or
+ * enclosing braces) to make the string into a valid Tcl list element. If
+ * length is -1, then the string is scanned from src up to the first null
+ * byte. A NULL value for src is treated as an empty string. The incoming
+ * value of *flagPtr is a report from the caller what additional flags it
+ * will pass to TclConvertElement().
*
* Results:
- * The recommended formatting mode for the element is determined and
- * a value is written to *flagPtr indicating that recommendation. This
+ * The recommended formatting mode for the element is determined and a
+ * value is written to *flagPtr indicating that recommendation. This
* recommendation is combined with the incoming flag values in *flagPtr
* set by the caller to determine how many bytes will be needed by
* TclConvertElement() in which to write the formatted element following
- * the recommendation modified by the flag values. This number of bytes
- * is the return value of the routine. In some situations it may be
- * an overestimate, but so long as the caller passes the same flags
- * to TclConvertElement(), it will be large enough.
+ * the recommendation modified by the flag values. This number of bytes
+ * is the return value of the routine. In some situations it may be an
+ * overestimate, but so long as the caller passes the same flags to
+ * TclConvertElement(), it will be large enough.
*
* Side effects:
* None.
@@ -941,7 +955,7 @@ TclScanElement(
const char *p = src;
int nestingLevel = 0; /* Brace nesting count */
int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something
- needs protection or escape. */
+ * 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
@@ -953,10 +967,13 @@ TclScanElement(
int preferEscape = 0; /* Use preferences to track whether to use */
int preferBrace = 0; /* CONVERT_MASK mode. */
int braceCount = 0; /* Count of all braces '{' '}' seen. */
-#endif
+#endif /* COMPAT */
if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) {
- /* Empty string element must be brace quoted. */
+ /*
+ * Empty string element must be brace quoted.
+ */
+
*flagPtr = CONVERT_BRACE;
return 2;
}
@@ -966,10 +983,11 @@ TclScanElement(
* Must escape or protect so leading character of value is not
* misinterpreted as list element delimiting syntax.
*/
+
forbidNone = 1;
#if COMPAT
preferBrace = 1;
-#endif
+#endif /* COMPAT */
}
while (length) {
@@ -978,18 +996,21 @@ TclScanElement(
case '{': /* TYPE_BRACE */
#if COMPAT
braceCount++;
-#endif
+#endif /* COMPAT */
extra++; /* Escape '{' => '\{' */
nestingLevel++;
break;
case '}': /* TYPE_BRACE */
#if COMPAT
braceCount++;
-#endif
+#endif /* COMPAT */
extra++; /* Escape '}' => '\}' */
nestingLevel--;
if (nestingLevel < 0) {
- /* Unbalanced braces! Cannot format with brace quoting. */
+ /*
+ * Unbalanced braces! Cannot format with brace quoting.
+ */
+
requireEscape = 1;
}
break;
@@ -1002,7 +1023,7 @@ TclScanElement(
break;
#else
/* FLOW THROUGH */
-#endif
+#endif /* COMPAT */
case '[': /* TYPE_SUBS */
case '$': /* TYPE_SUBS */
case ';': /* TYPE_COMMAND_END */
@@ -1016,18 +1037,25 @@ TclScanElement(
extra++; /* Escape sequences all one byte longer. */
#if COMPAT
preferBrace = 1;
-#endif
+#endif /* COMPAT */
break;
case '\\': /* TYPE_SUBS */
extra++; /* Escape '\' => '\\' */
if ((length == 1) || ((length == -1) && (p[1] == '\0'))) {
- /* Final backslash. Cannot format with brace quoting. */
+ /*
+ * Final backslash. Cannot format with brace quoting.
+ */
+
requireEscape = 1;
break;
}
if (p[1] == '\n') {
extra++; /* Escape newline => '\n', one byte longer */
- /* Backslash newline sequence. Brace quoting not permitted. */
+
+ /*
+ * Backslash newline sequence. Brace quoting not permitted.
+ */
+
requireEscape = 1;
length -= (length > 0);
p++;
@@ -1041,7 +1069,7 @@ TclScanElement(
forbidNone = 1;
#if COMPAT
preferBrace = 1;
-#endif
+#endif /* COMPAT */
break;
case '\0': /* TYPE_SUBS */
if (length == -1) {
@@ -1055,22 +1083,33 @@ TclScanElement(
p++;
}
- endOfString:
+ endOfString:
if (nestingLevel != 0) {
- /* Unbalanced braces! Cannot format with brace quoting. */
+ /*
+ * Unbalanced braces! Cannot format with brace quoting.
+ */
+
requireEscape = 1;
}
- /* We need at least as many bytes as are in the element value... */
+ /*
+ * We need at least as many bytes as are in the element value...
+ */
+
bytesNeeded = p - src;
if (requireEscape) {
/*
- * We must use escape sequences. Add all the extra bytes needed
- * to have room to create them.
+ * We must use escape sequences. Add all the extra bytes needed to
+ * have room to create them.
*/
+
bytesNeeded += extra;
- /* Make room to escape leading #, if needed. */
+
+ /*
+ * Make room to escape leading #, if needed.
+ */
+
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
bytesNeeded++;
}
@@ -1080,12 +1119,13 @@ TclScanElement(
if (*flagPtr & CONVERT_ANY) {
/*
* The caller has not let us know what flags it will pass to
- * TclConvertElement() so compute the max size we might need for
- * any possible choice. Normally the formatting using escape
- * sequences is the longer one, and a minimum "extra" value of 2
- * makes sure we don't request too small a buffer in those edge
- * cases where that's not true.
+ * TclConvertElement() so compute the max size we might need for any
+ * possible choice. Normally the formatting using escape sequences is
+ * the longer one, and a minimum "extra" value of 2 makes sure we
+ * don't request too small a buffer in those edge cases where that's
+ * not true.
*/
+
if (extra < 2) {
extra = 2;
}
@@ -1093,59 +1133,78 @@ TclScanElement(
*flagPtr |= TCL_DONT_USE_BRACES;
}
if (forbidNone) {
- /* We must request some form of quoting of escaping... */
+ /*
+ * We must request some form of quoting of escaping...
+ */
+
#if COMPAT
if (preferEscape && !preferBrace) {
/*
- * If we are quoting solely due to ] or internal " characters
- * use the CONVERT_MASK mode where we escape all special
- * characters except for braces. "extra" counted space needed
- * to escape braces too, so substract "braceCount" to get our
- * actual needs.
+ * If we are quoting solely due to ] or internal " characters use
+ * the CONVERT_MASK mode where we escape all special characters
+ * except for braces. "extra" counted space needed to escape
+ * braces too, so substract "braceCount" to get our actual needs.
*/
+
bytesNeeded += (extra - braceCount);
/* Make room to escape leading #, if needed. */
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
bytesNeeded++;
}
+
/*
* If the caller reports it will direct TclConvertElement() to
* use full escapes on the element, add back the bytes needed to
* escape the braces.
*/
+
if (*flagPtr & TCL_DONT_USE_BRACES) {
bytesNeeded += braceCount;
}
*flagPtr = CONVERT_MASK;
goto overflowCheck;
}
-#endif
+#endif /* COMPAT */
if (*flagPtr & TCL_DONT_USE_BRACES) {
/*
* If the caller reports it will direct TclConvertElement() to
* use escapes, add the extra bytes needed to have room for them.
*/
+
bytesNeeded += extra;
- /* Make room to escape leading #, if needed. */
+
+ /*
+ * Make room to escape leading #, if needed.
+ */
+
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
bytesNeeded++;
}
} else {
- /* Add 2 bytes for room for the enclosing braces. */
+ /*
+ * Add 2 bytes for room for the enclosing braces.
+ */
+
bytesNeeded += 2;
}
*flagPtr = CONVERT_BRACE;
goto overflowCheck;
}
- /* So far, no need to quote or escape anything. */
+ /*
+ * So far, no need to quote or escape anything.
+ */
+
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
- /* If we need to quote a leading #, make room to enclose in braces. */
+ /*
+ * If we need to quote a leading #, make room to enclose in braces.
+ */
+
bytesNeeded += 2;
}
*flagPtr = CONVERT_NONE;
- overflowCheck:
+ overflowCheck:
if (bytesNeeded < 0) {
Tcl_Panic("TclScanElement: string length overflow");
}
@@ -1220,9 +1279,9 @@ Tcl_ConvertCountedElement(
*
* TclConvertElement --
*
- * This is a companion function to TclScanElement. Given the
- * information produced by TclScanElement, this function converts
- * a string to a list element equal to that string.
+ * This is a companion function to TclScanElement. Given the information
+ * produced by TclScanElement, this function converts a string to a list
+ * element equal to that string.
*
* Results:
* Information is copied to *dst in the form of a list element identical
@@ -1236,7 +1295,8 @@ Tcl_ConvertCountedElement(
*----------------------------------------------------------------------
*/
-int TclConvertElement(
+int
+TclConvertElement(
register const char *src, /* Source information for list element. */
int length, /* Number of bytes in src, or -1. */
char *dst, /* Place to put list-ified element. */
@@ -1245,19 +1305,28 @@ int TclConvertElement(
int conversion = flags & CONVERT_MASK;
char *p = dst;
- /* Let the caller demand we use escape sequences rather than braces. */
+ /*
+ * Let the caller demand we use escape sequences rather than braces.
+ */
+
if ((flags & TCL_DONT_USE_BRACES) && (conversion & CONVERT_BRACE)) {
conversion = CONVERT_ESCAPE;
}
- /* No matter what the caller demands, empty string must be braced! */
- if ((src == NULL) || (length == 0) || ((*src == '\0') && (length == -1))) {
+ /*
+ * No matter what the caller demands, empty string must be braced!
+ */
+
+ if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) {
src = tclEmptyStringRep;
length = 0;
conversion = CONVERT_BRACE;
}
- /* Escape leading hash as needed and requested. */
+ /*
+ * Escape leading hash as needed and requested.
+ */
+
if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) {
if (conversion == CONVERT_ESCAPE) {
p[0] = '\\';
@@ -1270,7 +1339,10 @@ int TclConvertElement(
}
}
- /* No escape or quoting needed. Copy the literal string value. */
+ /*
+ * No escape or quoting needed. Copy the literal string value.
+ */
+
if (conversion == CONVERT_NONE) {
if (length == -1) {
/* TODO: INT_MAX overflow? */
@@ -1284,7 +1356,10 @@ int TclConvertElement(
}
}
- /* Formatted string is original string enclosed in braces. */
+ /*
+ * Formatted string is original string enclosed in braces.
+ */
+
if (conversion == CONVERT_BRACE) {
*p = '{';
p++;
@@ -1304,7 +1379,10 @@ int TclConvertElement(
/* conversion == CONVERT_ESCAPE or CONVERT_MASK */
- /* Formatted string is original string converted to escape sequences. */
+ /*
+ * Formatted string is original string converted to escape sequences.
+ */
+
for ( ; length; src++, length -= (length > 0)) {
switch (*src) {
case ']':
@@ -1320,13 +1398,12 @@ int TclConvertElement(
case '{':
case '}':
#if COMPAT
- if (conversion == CONVERT_ESCAPE) {
-#endif
+ if (conversion == CONVERT_ESCAPE)
+#endif /* COMPAT */
+ {
*p = '\\';
p++;
-#if COMPAT
}
-#endif
break;
case '\f':
*p = '\\';
@@ -1362,13 +1439,15 @@ int TclConvertElement(
if (length == -1) {
return p - dst;
}
+
/*
- * If we reach this point, there's an embedded NULL in the
- * string range being processed, which should not happen when
- * the encoding rules for Tcl strings are properly followed.
- * If the day ever comes when we stop tolerating such things,
- * this is where to put the Tcl_Panic().
+ * If we reach this point, there's an embedded NULL in the string
+ * range being processed, which should not happen when the
+ * encoding rules for Tcl strings are properly followed. If the
+ * day ever comes when we stop tolerating such things, this is
+ * where to put the Tcl_Panic().
*/
+
break;
}
*p = *src;
@@ -1402,17 +1481,18 @@ Tcl_Merge(
int argc, /* How many strings to merge. */
const char *const *argv) /* Array of string values. */
{
-# define LOCAL_SIZE 20
+#define LOCAL_SIZE 20
int localFlags[LOCAL_SIZE], *flagPtr = NULL;
int i, bytesNeeded = 0;
char *result, *dst;
const int maxFlags = UINT_MAX / sizeof(int);
+ /*
+ * Handle empty list case first, so logic of the general case can be
+ * simpler.
+ */
+
if (argc == 0) {
- /*
- * Handle empty list case first, so logic of the general case
- * can be simpler.
- */
result = ckalloc(1);
result[0] = '\0';
return result;
@@ -1426,17 +1506,17 @@ Tcl_Merge(
flagPtr = localFlags;
} else if (argc > maxFlags) {
/*
- * We cannot allocate a large enough flag array to format this
- * list in one pass. We could imagine converting this routine
- * to a multi-pass implementation, but for sizeof(int) == 4,
- * the limit is a max of 2^30 list elements and since each element
- * is at least one byte formatted, and requires one byte space
- * between it and the next one, that a minimum space requirement
- * of 2^31 bytes, which is already INT_MAX. If we tried to format
- * a list of > maxFlags elements, we're just going to overflow
- * the size limits on the formatted string anyway, so just issue
- * that same panic early.
+ * We cannot allocate a large enough flag array to format this list in
+ * one pass. We could imagine converting this routine to a multi-pass
+ * implementation, but for sizeof(int) == 4, the limit is a max of
+ * 2^30 list elements and since each element is at least one byte
+ * formatted, and requires one byte space between it and the next one,
+ * that a minimum space requirement of 2^31 bytes, which is already
+ * INT_MAX. If we tried to format a list of > maxFlags elements, we're
+ * just going to overflow the size limits on the formatted string
+ * anyway, so just issue that same panic early.
*/
+
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
} else {
flagPtr = ckalloc(argc * sizeof(int));
@@ -1511,9 +1591,10 @@ Tcl_Backslash(
*----------------------------------------------------------------------
*
* TclTrimRight --
- * Takes two counted strings in the Tcl encoding which must both be
- * null terminated. Conceptually trims from the right side of the
- * first string all characters found in the second string.
+ *
+ * Takes two counted strings in the Tcl encoding which must both be null
+ * terminated. Conceptually trims from the right side of the first string
+ * all characters found in the second string.
*
* Results:
* The number of bytes to be removed from the end of the string.
@@ -1526,10 +1607,10 @@ Tcl_Backslash(
int
TclTrimRight(
- const char *bytes, /* String to be trimmed... */
- int numBytes, /* ...and its length in bytes */
- const char *trim, /* String of trim characters... */
- int numTrim) /* ...and its length in bytes */
+ const char *bytes, /* String to be trimmed... */
+ int numBytes, /* ...and its length in bytes */
+ const char *trim, /* String of trim characters... */
+ int numTrim) /* ...and its length in bytes */
{
const char *p = bytes + numBytes;
int pInc;
@@ -1538,12 +1619,18 @@ TclTrimRight(
Tcl_Panic("TclTrimRight works only on null-terminated strings");
}
- /* Empty strings -> nothing to do */
+ /*
+ * Empty strings -> nothing to do.
+ */
+
if ((numBytes == 0) || (numTrim == 0)) {
return 0;
}
- /* Outer loop: iterate over string to be trimmed */
+ /*
+ * Outer loop: iterate over string to be trimmed.
+ */
+
do {
Tcl_UniChar ch1;
const char *q = trim;
@@ -1552,7 +1639,10 @@ TclTrimRight(
p = Tcl_UtfPrev(p, bytes);
pInc = TclUtfToUniChar(p, &ch1);
- /* Inner loop: scan trim string for match to current character */
+ /*
+ * Inner loop: scan trim string for match to current character.
+ */
+
do {
Tcl_UniChar ch2;
int qInc = TclUtfToUniChar(q, &ch2);
@@ -1566,7 +1656,10 @@ TclTrimRight(
} while (bytesLeft);
if (bytesLeft == 0) {
- /* No match; trim task done; *p is last non-trimmed char */
+ /*
+ * No match; trim task done; *p is last non-trimmed char.
+ */
+
p += pInc;
break;
}
@@ -1579,9 +1672,10 @@ TclTrimRight(
*----------------------------------------------------------------------
*
* TclTrimLeft --
- * Takes two counted strings in the Tcl encoding which must both be
- * null terminated. Conceptually trims from the left side of the
- * first string all characters found in the second string.
+ *
+ * Takes two counted strings in the Tcl encoding which must both be null
+ * terminated. Conceptually trims from the left side of the first string
+ * all characters found in the second string.
*
* Results:
* The number of bytes to be removed from the start of the string.
@@ -1594,10 +1688,10 @@ TclTrimRight(
int
TclTrimLeft(
- const char *bytes, /* String to be trimmed... */
- int numBytes, /* ...and its length in bytes */
- const char *trim, /* String of trim characters... */
- int numTrim) /* ...and its length in bytes */
+ const char *bytes, /* String to be trimmed... */
+ int numBytes, /* ...and its length in bytes */
+ const char *trim, /* String of trim characters... */
+ int numTrim) /* ...and its length in bytes */
{
const char *p = bytes;
@@ -1605,19 +1699,28 @@ TclTrimLeft(
Tcl_Panic("TclTrimLeft works only on null-terminated strings");
}
- /* Empty strings -> nothing to do */
+ /*
+ * Empty strings -> nothing to do.
+ */
+
if ((numBytes == 0) || (numTrim == 0)) {
return 0;
}
- /* Outer loop: iterate over string to be trimmed */
+ /*
+ * Outer loop: iterate over string to be trimmed.
+ */
+
do {
Tcl_UniChar ch1;
int pInc = TclUtfToUniChar(p, &ch1);
const char *q = trim;
int bytesLeft = numTrim;
- /* Inner loop: scan trim string for match to current character */
+ /*
+ * Inner loop: scan trim string for match to current character.
+ */
+
do {
Tcl_UniChar ch2;
int qInc = TclUtfToUniChar(q, &ch2);
@@ -1631,7 +1734,10 @@ TclTrimLeft(
} while (bytesLeft);
if (bytesLeft == 0) {
- /* No match; trim task done; *p is first non-trimmed char */
+ /*
+ * No match; trim task done; *p is first non-trimmed char.
+ */
+
break;
}
@@ -1673,14 +1779,20 @@ Tcl_Concat(
int i, needSpace = 0, bytesNeeded = 0;
char *result, *p;
- /* Dispose of the empty result corner case first to simplify later code */
+ /*
+ * Dispose of the empty result corner case first to simplify later code.
+ */
+
if (argc == 0) {
result = (char *) ckalloc(1);
result[0] = '\0';
return result;
}
- /* First allocate the result buffer at the size required */
+ /*
+ * First allocate the result buffer at the size required.
+ */
+
for (i = 0; i < argc; i++) {
bytesNeeded += strlen(argv[i]);
if (bytesNeeded < 0) {
@@ -1689,13 +1801,18 @@ Tcl_Concat(
}
if (bytesNeeded + argc - 1 < 0) {
/*
- * Panic test could be tighter, but not going to bother for
- * this legacy routine.
+ * Panic test could be tighter, but not going to bother for this
+ * legacy routine.
*/
+
Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
}
- /* All element bytes + (argc - 1) spaces + 1 terminating NULL */
- result = (char *) ckalloc((unsigned) (bytesNeeded + argc));
+
+ /*
+ * All element bytes + (argc - 1) spaces + 1 terminating NULL.
+ */
+
+ result = ckalloc((unsigned) (bytesNeeded + argc));
for (p = result, i = 0; i < argc; i++) {
int trim, elemLength;
@@ -1704,26 +1821,35 @@ Tcl_Concat(
element = argv[i];
elemLength = strlen(argv[i]);
- /* Trim away the leading whitespace */
+ /*
+ * Trim away the leading whitespace.
+ */
+
trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE);
element += trim;
elemLength -= trim;
/*
- * Trim away the trailing whitespace. Do not permit trimming
- * to expose a final backslash character.
+ * Trim away the trailing whitespace. Do not permit trimming to expose
+ * a final backslash character.
*/
trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE);
trim -= trim && (element[elemLength - trim - 1] == '\\');
elemLength -= trim;
- /* If we're left with empty element after trimming, do nothing */
+ /*
+ * If we're left with empty element after trimming, do nothing.
+ */
+
if (elemLength == 0) {
continue;
}
- /* Append to the result with space if needed */
+ /*
+ * Append to the result with space if needed.
+ */
+
if (needSpace) {
*p++ = ' ';
}
@@ -1802,9 +1928,10 @@ Tcl_ConcatObj(
/*
* Something cannot be determined to be safe, so build the concatenation
* the slow way, using the string representations.
+ *
+ * First try to pre-allocate the size required.
*/
- /* First try to pre-allocate the size required */
for (i = 0; i < objc; i++) {
element = TclGetStringFromObj(objv[i], &elemLength);
bytesNeeded += elemLength;
@@ -1812,11 +1939,13 @@ Tcl_ConcatObj(
break;
}
}
+
/*
- * Does not matter if this fails, will simply try later to build up
- * the string with each Append reallocating as needed with the usual
- * string append algorithm. When that fails it will report the error.
+ * Does not matter if this fails, will simply try later to build up the
+ * string with each Append reallocating as needed with the usual string
+ * append algorithm. When that fails it will report the error.
*/
+
TclNewObj(resPtr);
Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1);
Tcl_SetObjLength(resPtr, 0);
@@ -1826,26 +1955,35 @@ Tcl_ConcatObj(
element = TclGetStringFromObj(objv[i], &elemLength);
- /* Trim away the leading whitespace */
+ /*
+ * Trim away the leading whitespace.
+ */
+
trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE);
element += trim;
elemLength -= trim;
/*
- * Trim away the trailing whitespace. Do not permit trimming
- * to expose a final backslash character.
+ * Trim away the trailing whitespace. Do not permit trimming to expose
+ * a final backslash character.
*/
trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE);
trim -= trim && (element[elemLength - trim - 1] == '\\');
elemLength -= trim;
- /* If we're left with empty element after trimming, do nothing */
+ /*
+ * If we're left with empty element after trimming, do nothing.
+ */
+
if (elemLength == 0) {
continue;
}
- /* Append to the result with space if needed */
+ /*
+ * Append to the result with space if needed.
+ */
+
if (needSpace) {
Tcl_AppendToObj(resPtr, " ", 1);
}
@@ -2249,6 +2387,7 @@ TclByteArrayMatch(
/*
* Matches ranges of form [a-z] or [z-a].
*/
+
break;
}
} else if (startChar == ch1) {
@@ -2295,9 +2434,9 @@ TclByteArrayMatch(
*
* TclStringMatchObj --
*
- * See if a particular string matches a particular pattern.
- * Allows case insensitivity. This is the generic multi-type handler
- * for the various matching algorithms.
+ * See if a particular string matches a particular pattern. Allows case
+ * insensitivity. This is the generic multi-type handler for the various
+ * matching algorithms.
*
* Results:
* The return value is 1 if string matches pattern, and 0 otherwise. The
@@ -2657,24 +2796,8 @@ Tcl_DStringResult(
Tcl_DString *dsPtr) /* Dynamic string that is to become the
* result of interp. */
{
- Interp *iPtr = (Interp *) interp;
-
Tcl_ResetResult(interp);
-
- if (dsPtr->string != dsPtr->staticSpace) {
- iPtr->result = dsPtr->string;
- iPtr->freeProc = TCL_DYNAMIC;
- } else if (dsPtr->length < TCL_RESULT_SIZE) {
- iPtr->result = iPtr->resultSpace;
- memcpy(iPtr->result, dsPtr->string, dsPtr->length + 1);
- } else {
- Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE);
- }
-
- dsPtr->string = dsPtr->staticSpace;
- dsPtr->length = 0;
- dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
- dsPtr->staticSpace[0] = '\0';
+ Tcl_SetObjResult(interp, TclDStringToObj(dsPtr));
}
/*
@@ -2710,6 +2833,39 @@ Tcl_DStringGetResult(
}
/*
+ * Do more efficient transfer when we know the result is a Tcl_Obj. When
+ * there's no st`ring result, we only have to deal with two cases:
+ *
+ * 1. When the string rep is the empty string, when we don't copy but
+ * instead use the staticSpace in the DString to hold an empty string.
+
+ * 2. When the string rep is not there or there's a real string rep, when
+ * we use Tcl_GetString to fetch (or generate) the string rep - which
+ * we know to have been allocated with ckalloc() - and use it to
+ * populate the DString space. Then, we free the internal rep. and set
+ * the object's string representation back to the canonical empty
+ * string.
+ */
+
+ if (!iPtr->result[0] && iPtr->objResultPtr
+ && !Tcl_IsShared(iPtr->objResultPtr)) {
+ if (iPtr->objResultPtr->bytes == tclEmptyStringRep) {
+ dsPtr->string = dsPtr->staticSpace;
+ dsPtr->string[0] = 0;
+ dsPtr->length = 0;
+ dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
+ } else {
+ dsPtr->string = Tcl_GetString(iPtr->objResultPtr);
+ dsPtr->length = iPtr->objResultPtr->length;
+ dsPtr->spaceAvl = dsPtr->length + 1;
+ TclFreeIntRep(iPtr->objResultPtr);
+ iPtr->objResultPtr->bytes = tclEmptyStringRep;
+ iPtr->objResultPtr->length = 0;
+ }
+ return;
+ }
+
+ /*
* If the string result is empty, move the object result to the string
* result, then reset the object result.
*/
@@ -2947,12 +3103,12 @@ Tcl_PrintDouble(
* Tcl 8.4 implements the first of these, which gives rise to
* anomalies in formatting:
*
- * % expr 0.1
- * 0.10000000000000001
- * % expr 0.01
- * 0.01
- * % expr 1e-7
- * 9.9999999999999995e-08
+ * % expr 0.1
+ * 0.10000000000000001
+ * % expr 0.01
+ * 0.01
+ * % expr 1e-7
+ * 9.9999999999999995e-08
*
* For human readability, it appears better to choose the second rule,
* and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer
@@ -2965,8 +3121,8 @@ Tcl_PrintDouble(
*/
digits = TclDoubleDigits(value, *precisionPtr,
- TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */,
- &exponent, &signum, &end);
+ TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */,
+ &exponent, &signum, &end);
}
if (signum) {
*dst++ = '-';
@@ -3222,10 +3378,10 @@ TclNeedSpace(
*/
int
-TclFormatInt(buffer, n)
- char *buffer; /* Points to the storage into which the
+TclFormatInt(
+ char *buffer, /* Points to the storage into which the
* formatted characters are written. */
- long n; /* The integer to format. */
+ long n) /* The integer to format. */
{
long intVal;
int i;
@@ -3243,9 +3399,9 @@ TclFormatInt(buffer, n)
}
/*
- * Check whether "n" is the maximum negative value. This is
- * -2^(m-1) for an m-bit word, and has no positive equivalent;
- * negating it produces the same value.
+ * Check whether "n" is the maximum negative value. This is -2^(m-1) for
+ * an m-bit word, and has no positive equivalent; negating it produces the
+ * same value.
*/
intVal = -n; /* [Bug 3390638] Workaround for*/
@@ -3277,6 +3433,7 @@ TclFormatInt(buffer, n)
for (j = 0; j < i; j++, i--) {
char tmp = buffer[i];
+
buffer[i] = buffer[j];
buffer[j] = tmp;
}
@@ -3382,16 +3539,10 @@ TclGetIntForIndex(
parseError:
if (interp != NULL) {
- /*
- * The result might not be empty; this resets it which should be both
- * a cheap operation, and of little problem because this is an
- * error-generation path anyway.
- */
-
bytes = Tcl_GetString(objPtr);
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad index \"", bytes,
- "\": must be integer?[+-]integer? or end?[+-]integer?", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad index \"%s\": must be integer?[+-]integer? or"
+ " end?[+-]integer?", bytes));
if (!strncmp(bytes, "end-", 4)) {
bytes += 4;
}
@@ -3426,10 +3577,10 @@ static void
UpdateStringOfEndOffset(
register Tcl_Obj *objPtr)
{
- char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1];
+ char buffer[TCL_INTEGER_SPACE + 5];
register int len;
- memcpy(buffer, "end", sizeof("end") + 1);
+ memcpy(buffer, "end", 4);
len = sizeof("end") - 1;
if (objPtr->internalRep.longValue != 0) {
buffer[len++] = '-';
@@ -3483,9 +3634,8 @@ SetEndOffsetFromAny(
if ((*bytes != 'e') || (strncmp(bytes, "end",
(size_t)((length > 3) ? 3 : length)) != 0)) {
if (interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad index \"", bytes,
- "\": must be end?[+-]integer?", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad index \"%s\": must be end?[+-]integer?", bytes));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
}
return TCL_ERROR;
@@ -3519,9 +3669,8 @@ SetEndOffsetFromAny(
badIndexFormat:
if (interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad index \"", bytes,
- "\": must be end?[+-]integer?", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad index \"%s\": must be end?[+-]integer?", bytes));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
}
return TCL_ERROR;
@@ -3597,8 +3746,8 @@ TclCheckBadOctal(
* be added to an existing error message as extra info.
*/
- Tcl_AppendResult(interp, " (looks like invalid octal number)",
- NULL);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ " (looks like invalid octal number)", -1);
}
return 1;
}
@@ -3750,7 +3899,7 @@ TclSetProcessGlobalValue(
if (NULL != pgvPtr->value) {
ckfree(pgvPtr->value);
} else {
- Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr);
+ Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr);
}
bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes);
pgvPtr->value = ckalloc(pgvPtr->numBytes + 1);
@@ -4214,7 +4363,7 @@ TclReToGlob(
invalidGlob:
if (interp != NULL) {
- Tcl_AppendResult(interp, msg, NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL);
}
Tcl_DStringFree(dsPtr);
diff --git a/generic/tclVar.c b/generic/tclVar.c
index e92dc5f..e31e9cf 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -3065,7 +3065,8 @@ ArrayStartSearchCmd(
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
- Tcl_AppendResult(interp, "\"", varName, "\" isn't an array", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't an array", varName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL);
return TCL_ERROR;
}
@@ -3160,8 +3161,8 @@ ArrayAnyMoreCmd(
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
- Tcl_AppendResult(interp, "\"", TclGetString(varNameObj),
- "\" isn't an array", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't an array", TclGetString(varNameObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
TclGetString(varNameObj), NULL);
return TCL_ERROR;
@@ -3266,8 +3267,8 @@ ArrayNextElementCmd(
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
- Tcl_AppendResult(interp, "\"", TclGetString(varNameObj),
- "\" isn't an array", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't an array", TclGetString(varNameObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
TclGetString(varNameObj), NULL);
return TCL_ERROR;
@@ -3376,8 +3377,8 @@ ArrayDoneSearchCmd(
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
- Tcl_AppendResult(interp, "\"", TclGetString(varNameObj),
- "\" isn't an array", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't an array", TclGetString(varNameObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
TclGetString(varNameObj), NULL);
return TCL_ERROR;
@@ -4019,8 +4020,8 @@ ArrayStatsCmd(
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
- Tcl_AppendResult(interp, "\"", TclGetString(varNameObj),
- "\" isn't an array", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't an array", TclGetString(varNameObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
TclGetString(varNameObj), NULL);
return TCL_ERROR;
@@ -4028,7 +4029,8 @@ ArrayStatsCmd(
stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr);
if (stats == NULL) {
- Tcl_SetResult(interp, "error reading array statistics", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "error reading array statistics", -1));
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1));
@@ -4317,10 +4319,10 @@ ObjMakeUpvar(
|| (varFramePtr == NULL)
|| !HasLocalVars(varFramePtr)
|| (strstr(TclGetString(myNamePtr), "::") != NULL))) {
- Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
- TclGetString(myNamePtr), "\": upvar won't create "
+ Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
+ "bad variable name \"%s\": upvar won't create "
"namespace variable that refers to procedure variable",
- NULL);
+ TclGetString(myNamePtr)));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL);
return TCL_ERROR;
}
@@ -4418,9 +4420,10 @@ TclPtrObjMakeUpvar(
* myName looks like an array reference.
*/
- Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
- myName, "\": upvar won't create a scalar variable "
- "that looks like an array element", NULL);
+ Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
+ "bad variable name \"%s\": upvar won't create a"
+ " scalar variable that looks like an array element",
+ myName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT",
NULL);
return TCL_ERROR;
@@ -4447,15 +4450,15 @@ TclPtrObjMakeUpvar(
}
if (varPtr == otherPtr) {
- Tcl_SetResult((Tcl_Interp *) iPtr,
- "can't upvar from variable to itself", TCL_STATIC);
+ Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_NewStringObj(
+ "can't upvar from variable to itself", -1));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "SELF", NULL);
return TCL_ERROR;
}
if (TclIsVarTraced(varPtr)) {
- Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
- "\" has traces: can't use for upvar", NULL);
+ Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
+ "variable \"%s\" has traces: can't use for upvar", myName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "TRACED", NULL);
return TCL_ERROR;
} else if (!TclIsVarUndefined(varPtr)) {
@@ -4469,8 +4472,8 @@ TclPtrObjMakeUpvar(
*/
if (!TclIsVarLink(varPtr)) {
- Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
- "\" already exists", NULL);
+ Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
+ "variable \"%s\" already exists", myName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "EXISTS", NULL);
return TCL_ERROR;
}
@@ -4968,8 +4971,8 @@ Tcl_UpvarObjCmd(
* for this particular case.
*/
- Tcl_AppendResult(interp, "bad level \"", TclGetString(levelObj), "\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad level \"%s\"", TclGetString(levelObj)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "LEVEL", NULL);
return TCL_ERROR;
}
@@ -4978,8 +4981,8 @@ Tcl_UpvarObjCmd(
* We've now finished with parsing levels; skip to the variable names.
*/
- objc -= hasLevel+1;
- objv += hasLevel+1;
+ objc -= hasLevel + 1;
+ objv += hasLevel + 1;
/*
* Iterate over each (other variable, local variable) pair. Divide the
@@ -5060,8 +5063,8 @@ SetArraySearchObj(
return TCL_OK;
syntax:
- Tcl_AppendResult(interp, "illegal search identifier \"", string, "\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "illegal search identifier \"%s\"", string));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL);
return TCL_ERROR;
}
@@ -5126,10 +5129,9 @@ ParseSearchId(
*/
if (strcmp(string+offset, varName) != 0) {
- Tcl_AppendResult(interp, "search identifier \"", string,
- "\" isn't for variable \"", varName, "\"", NULL);
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string,
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "search identifier \"%s\" isn't for variable \"%s\"",
+ string, varName));
goto badLookup;
}
@@ -5153,7 +5155,8 @@ ParseSearchId(
}
}
}
- Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't find search \"%s\"", string));
badLookup:
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL);
return NULL;
@@ -5894,8 +5897,8 @@ ObjFindNamespaceVar(
Tcl_DecrRefCount(simpleNamePtr);
}
if ((varPtr == NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "unknown variable \"", name, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown variable \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", name, NULL);
}
return (Tcl_Var) varPtr;
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index a4ce05b..20130d1 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -144,10 +144,15 @@ typedef struct {
#define OUT_HEADER 0x4
/*
- * Size of buffers allocated by default. Should be enough...
+ * Size of buffers allocated by default, and the range it can be set to. The
+ * same sorts of values apply to streams, except with different limits (they
+ * permit byte-level activity). Channels always use bytes unless told to use
+ * larger buffers.
*/
#define DEFAULT_BUFFER_SIZE 4096
+#define MIN_NONSTREAM_BUFFER_SIZE 16
+#define MAX_BUFFER_SIZE 65536
/*
* Prototypes for private procedures defined later in this file:
@@ -182,7 +187,7 @@ static inline int ResultCopy(ZlibChannelData *cd, char *buf,
static int ResultGenerate(ZlibChannelData *cd, int n, int flush,
int *errorCodePtr);
static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp,
- int mode, int format, int level,
+ int mode, int format, int level, int limit,
Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr,
Tcl_Obj *compDictObj);
static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr);
@@ -770,8 +775,8 @@ Tcl_ZlibStreamInit(
TclDStringAppendObj(&cmdname, Tcl_GetObjResult(interp));
if (Tcl_GetCommandInfo(interp, Tcl_DStringValue(&cmdname),
&cmdinfo) == 1) {
- Tcl_SetResult(interp,
- "BUG: Stream command name already exists", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "BUG: Stream command name already exists", -1));
Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", NULL);
Tcl_DStringFree(&cmdname);
goto error;
@@ -1153,8 +1158,8 @@ Tcl_ZlibStreamPut(
if (zshPtr->streamEnd) {
if (zshPtr->interp) {
- Tcl_SetResult(zshPtr->interp,
- "already past compressed stream end", TCL_STATIC);
+ Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
+ "already past compressed stream end", -1));
Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", NULL);
}
return TCL_ERROR;
@@ -1295,7 +1300,7 @@ Tcl_ZlibStreamGet(
* panic for out of memory if we just kept growing the buffer.
*/
- count = 65536;
+ count = MAX_BUFFER_SIZE;
}
/*
@@ -1378,9 +1383,9 @@ Tcl_ZlibStreamGet(
if (zshPtr->stream.avail_in > 0) {
if (zshPtr->interp) {
- Tcl_SetResult(zshPtr->interp,
- "Unexpected zlib internal state during decompression",
- TCL_STATIC);
+ Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
+ "unexpected zlib internal state during"
+ " decompression", -1));
Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "STATE",
NULL);
}
@@ -2023,7 +2028,8 @@ ZlibCmd(
(int *) &buffersize) != TCL_OK) {
return TCL_ERROR;
}
- if (buffersize < 16 || buffersize > 65536) {
+ if (buffersize < MIN_NONSTREAM_BUFFER_SIZE
+ || buffersize > MAX_BUFFER_SIZE) {
goto badBuffer;
}
}
@@ -2041,7 +2047,8 @@ ZlibCmd(
(int *) &buffersize) != TCL_OK) {
return TCL_ERROR;
}
- if (buffersize < 16 || buffersize > 65536) {
+ if (buffersize < MIN_NONSTREAM_BUFFER_SIZE
+ || buffersize > MAX_BUFFER_SIZE) {
goto badBuffer;
}
}
@@ -2071,7 +2078,8 @@ ZlibCmd(
(int *) &buffersize) != TCL_OK) {
return TCL_ERROR;
}
- if (buffersize < 16 || buffersize > 65536) {
+ if (buffersize < MIN_NONSTREAM_BUFFER_SIZE
+ || buffersize > MAX_BUFFER_SIZE) {
goto badBuffer;
}
break;
@@ -2109,14 +2117,16 @@ ZlibCmd(
return TCL_ERROR;
badLevel:
- Tcl_AppendResult(interp, "level must be 0 to 9", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL);
if (extraInfoStr) {
Tcl_AddErrorInfo(interp, extraInfoStr);
}
return TCL_ERROR;
badBuffer:
- Tcl_AppendResult(interp, "buffer size must be 32 to 65536", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "buffer size must be %d to %d",
+ MIN_NONSTREAM_BUFFER_SIZE, MAX_BUFFER_SIZE));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL);
return TCL_ERROR;
}
@@ -2219,8 +2229,7 @@ ZlibStreamSubcmd(
format = TCL_ZLIB_FORMAT_GZIP;
break;
default:
- Tcl_AppendResult(interp, "IMPOSSIBLE", NULL);
- return TCL_ERROR;
+ Tcl_Panic("should be unreachable");
}
/*
@@ -2251,7 +2260,7 @@ ZlibStreamSubcmd(
} else if (Tcl_GetIntFromObj(interp, levelObj, &level) != TCL_OK) {
return TCL_ERROR;
} else if (level < 0 || level > 9) {
- Tcl_AppendResult(interp, "level must be 0 to 9", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9",-1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL);
Tcl_AddErrorInfo(interp, "\n (in -level option)");
return TCL_ERROR;
@@ -2340,8 +2349,7 @@ ZlibPushSubcmd(
format = TCL_ZLIB_FORMAT_GZIP;
break;
default:
- Tcl_AppendResult(interp, "IMPOSSIBLE", NULL);
- return TCL_ERROR;
+ Tcl_Panic("should be unreachable");
}
if (TclGetChannelFromObj(interp, objv[3], &chan, &chanMode, 0) != TCL_OK){
@@ -2353,15 +2361,14 @@ ZlibPushSubcmd(
*/
if (mode == TCL_ZLIB_STREAM_DEFLATE && !(chanMode & TCL_WRITABLE)) {
- Tcl_AppendResult(interp,
- "compression may only be applied to writable channels", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "compression may only be applied to writable channels", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", NULL);
return TCL_ERROR;
}
if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) {
- Tcl_AppendResult(interp,
- "decompression may only be applied to readable channels",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "decompression may only be applied to readable channels",-1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", NULL);
return TCL_ERROR;
}
@@ -2376,78 +2383,68 @@ ZlibPushSubcmd(
&option) != TCL_OK) {
return TCL_ERROR;
}
+ if (++i > objc-1) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "value missing for %s option", pushOptions[option]));
+ Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
+ return TCL_ERROR;
+ }
switch ((enum pushOptions) option) {
case poHeader:
- if (++i > objc-1) {
- Tcl_AppendResult(interp, "value missing for -header option",
- NULL);
- Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
- return TCL_ERROR;
- }
headerObj = objv[i];
if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) {
- Tcl_AddErrorInfo(interp, "\n (in -header option)");
- return TCL_ERROR;
+ goto genericOptionError;
}
break;
case poLevel:
- if (++i > objc-1) {
- Tcl_AppendResult(interp,
- "value missing for -level option", NULL);
- Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
- return TCL_ERROR;
- }
if (Tcl_GetIntFromObj(interp, objv[i], (int*) &level) != TCL_OK) {
- Tcl_AddErrorInfo(interp, "\n (in -level option)");
- return TCL_ERROR;
+ goto genericOptionError;
}
if (level < 0 || level > 9) {
- Tcl_AppendResult(interp, "level must be 0 to 9", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "level must be 0 to 9", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL",
NULL);
- Tcl_AddErrorInfo(interp, "\n (in -level option)");
- return TCL_ERROR;
+ goto genericOptionError;
}
break;
case poLimit:
- if (++i > objc-1) {
- Tcl_AppendResult(interp, "value missing for -limit option",
- NULL);
- Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
- return TCL_ERROR;
- }
if (Tcl_GetIntFromObj(interp, objv[i], (int*) &limit) != TCL_OK) {
- Tcl_AddErrorInfo(interp, "\n (in -limit option)");
- return TCL_ERROR;
+ goto genericOptionError;
}
- if (limit < 1) {
- limit = 1;
+ if (limit < 1 || limit > MAX_BUFFER_SIZE) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "read ahead limit must be 1 to %d",
+ MAX_BUFFER_SIZE));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL);
+ goto genericOptionError;
}
break;
case poDictionary:
- if (++i > objc-1) {
- Tcl_AppendResult(interp,
- "value missing for -dictionary option", NULL);
- Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
- return TCL_ERROR;
- }
if (format == TCL_ZLIB_FORMAT_GZIP) {
- Tcl_AppendResult(interp, "a compression dictionary may not "
- "be set in the gzip format", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "a compression dictionary may not be set in the "
+ "gzip format", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL);
- return TCL_ERROR;
+ goto genericOptionError;
}
compDictObj = objv[i];
break;
}
}
- if (ZlibStackChannelTransform(interp, mode, format, level, chan,
+ if (ZlibStackChannelTransform(interp, mode, format, level, limit, chan,
headerObj, compDictObj) == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[3]);
return TCL_OK;
+
+ genericOptionError:
+ Tcl_AddErrorInfo(interp, "\n (in ");
+ Tcl_AddErrorInfo(interp, pushOptions[option]);
+ Tcl_AddErrorInfo(interp, " option)");
+ return TCL_ERROR;
}
/*
@@ -2633,25 +2630,28 @@ ZlibStreamAddCmd(
break;
case ao_buffer: /* -buffer */
if (i == objc-2) {
- Tcl_AppendResult(interp, "\"-buffer\" option must be "
- "followed by integer decompression buffersize", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-buffer\" option must be followed by integer "
+ "decompression buffersize", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[++i], &buffersize) != TCL_OK) {
return TCL_ERROR;
}
- if (buffersize < 1 || buffersize > 65536) {
- Tcl_AppendResult(interp, "buffer size must be 32 to 65536",
- NULL);
+ if (buffersize < 1 || buffersize > MAX_BUFFER_SIZE) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "buffer size must be 1 to %d",
+ MAX_BUFFER_SIZE));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL);
return TCL_ERROR;
}
break;
case ao_dictionary:
if (i == objc-2) {
- Tcl_AppendResult(interp, "\"-dictionary\" option must be "
- "followed by compression dictionary bytes", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-dictionary\" option must be followed by"
+ " compression dictionary bytes", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
return TCL_ERROR;
}
@@ -2660,8 +2660,9 @@ ZlibStreamAddCmd(
}
if (flush == -2) {
- Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and "
- "\"-finalize\" options are mutually exclusive", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-flush\", \"-fullflush\" and \"-finalize\" options"
+ " are mutually exclusive", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL);
return TCL_ERROR;
}
@@ -2753,8 +2754,9 @@ ZlibStreamPutCmd(
break;
case po_dictionary:
if (i == objc-2) {
- Tcl_AppendResult(interp, "\"-dictionary\" option must be "
- "followed by compression dictionary bytes", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-dictionary\" option must be followed by"
+ " compression dictionary bytes", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
return TCL_ERROR;
}
@@ -2762,8 +2764,9 @@ ZlibStreamPutCmd(
break;
}
if (flush == -2) {
- Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and "
- "\"-finalize\" options are mutually exclusive", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-flush\", \"-fullflush\" and \"-finalize\" options"
+ " are mutually exclusive", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL);
return TCL_ERROR;
}
@@ -2808,8 +2811,8 @@ ZlibStreamHeaderCmd(
return TCL_ERROR;
} else if (zshPtr->mode != TCL_ZLIB_STREAM_INFLATE
|| zshPtr->format != TCL_ZLIB_FORMAT_GZIP) {
- Tcl_AppendResult(interp,
- "only gunzip streams can produce header information", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "only gunzip streams can produce header information", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOP", NULL);
return TCL_ERROR;
}
@@ -2871,9 +2874,9 @@ ZlibTransformClose(
* Note: when close is called from FinalizeIOSubsystem
* then interp may be NULL */
if (!TclInThreadExit() && interp) {
- Tcl_AppendResult(interp,
- "error while finalizing file: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error while finalizing file: %s",
+ Tcl_PosixError(interp)));
}
result = TCL_ERROR;
break;
@@ -3176,8 +3179,9 @@ ZlibTransformSetOption( /* not used */
} else if (value[0] == 's' && strcmp(value, "sync") == 0) {
flushType = Z_SYNC_FLUSH;
} else {
- Tcl_AppendResult(interp, "unknown -flush type \"", value,
- "\": must be full or sync", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown -flush type \"%s\": must be full or sync",
+ value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", NULL);
return TCL_ERROR;
}
@@ -3205,8 +3209,9 @@ ZlibTransformSetOption( /* not used */
if (Tcl_WriteRaw(cd->parent, cd->outBuffer,
cd->outStream.next_out - (Bytef *) cd->outBuffer)<0) {
- Tcl_AppendResult(interp, "problem flushing channel: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "problem flushing channel: %s",
+ Tcl_PosixError(interp)));
return TCL_ERROR;
}
}
@@ -3219,8 +3224,8 @@ ZlibTransformSetOption( /* not used */
if (Tcl_GetInt(interp, value, &newLimit) != TCL_OK) {
return TCL_ERROR;
} else if (newLimit < 1 || newLimit > 65535) {
- Tcl_AppendResult(interp, "-limit must be between 1 and 65535",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "-limit must be between 1 and 65535", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "READLIMIT", NULL);
return TCL_ERROR;
}
@@ -3506,6 +3511,8 @@ ZlibStackChannelTransform(
* decompressing transforms. */
int level, /* What compression level to use. Ignored for
* decompressing transforms. */
+ int limit, /* The limit on the number of bytes to read
+ * ahead; always at least 1. */
Tcl_Channel channel, /* The channel to attach to. */
Tcl_Obj *gzipHeaderDictPtr, /* A description of header to use, or NULL to
* use a default. Ignored if not compressing
@@ -3526,7 +3533,7 @@ ZlibStackChannelTransform(
memset(cd, 0, sizeof(ZlibChannelData));
cd->mode = mode;
cd->format = format;
- cd->readAheadLimit = 1;
+ cd->readAheadLimit = limit;
if (format == TCL_ZLIB_FORMAT_GZIP || format == TCL_ZLIB_FORMAT_AUTO) {
if (mode == TCL_ZLIB_STREAM_DEFLATE) {
@@ -3865,7 +3872,7 @@ Tcl_ZlibStreamInit(
Tcl_Obj *dictObj,
Tcl_ZlibStream *zshandle)
{
- Tcl_SetResult(interp, "unimplemented", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
return TCL_ERROR;
}
@@ -3931,7 +3938,7 @@ Tcl_ZlibDeflate(
int level,
Tcl_Obj *gzipHeaderDictObj)
{
- Tcl_SetResult(interp, "unimplemented", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
return TCL_ERROR;
}
@@ -3944,7 +3951,7 @@ Tcl_ZlibInflate(
int bufferSize,
Tcl_Obj *gzipHeaderDictObj)
{
- Tcl_SetResult(interp, "unimplemented", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
return TCL_ERROR;
}
@@ -3973,7 +3980,7 @@ Tcl_ZlibStreamSetCompressionDictionary(
Tcl_ZlibStream zhandle,
Tcl_Obj *compressionDictionaryObj)
{
- Tcl_SetResult(interp, "unimplemented", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
return TCL_ERROR;
}
diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl
index fef4f24..ce8276b 100644
--- a/library/dde/pkgIndex.tcl
+++ b/library/dde/pkgIndex.tcl
@@ -1,7 +1,7 @@
-if {![package vsatisfies [package provide Tcl] 8.5]} return
-if {[info sharedlibextension] ne ".dll"} return
+if {([info commands ::tcl::pkgconfig] eq "")
+ || ([info sharedlibextension] ne ".dll")} return
if {[::tcl::pkgconfig get debug]} {
- package ifneeded dde 1.4.0 [list load [file join $dir tcldde14g.dll] dde]
+ package ifneeded dde 1.4.0b1 [list load [file join $dir tcldde14g.dll] dde]
} else {
- package ifneeded dde 1.4.0 [list load [file join $dir tcldde14.dll] dde]
+ package ifneeded dde 1.4.0b1 [list load [file join $dir tcldde14.dll] dde]
}
diff --git a/library/http/http.tcl b/library/http/http.tcl
index b5ce82b..2653c3e 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -419,7 +419,6 @@ proc http::geturl {url args} {
# Note that the RE actually combines the user and password parts, as
# recommended in RFC 3986. Indeed, that RFC states that putting passwords
# in URLs is a Really Bad Idea, something with which I would agree utterly.
- # Also note that we do not currently support IPv6 addresses.
#
# From a validation perspective, we need to ensure that the parts of the
# URL that are going to the server are correctly encoded. This is only
@@ -434,7 +433,10 @@ proc http::geturl {url args} {
[^@/\#?]+ # <userinfo part of authority>
) @
)?
- ( [^/:\#?]+ ) # <host part of authority>
+ ( # <host part of authority>
+ [^/:\#?]+ | # host name or IPv4 address
+ \[ [^/\#?]+ \] # IPv6 address in square brackets
+ )
(?: : (\d+) )? # <port part of authority>
)?
( / [^\#]*)? # <path> (including query)
@@ -448,6 +450,7 @@ proc http::geturl {url args} {
return -code error "Unsupported URL: $url"
}
# Phase two: validate
+ set host [string trim $host {[]}]; # strip square brackets from IPv6 address
if {$host eq ""} {
# Caller has to provide a host name; we do not have a "default host"
# that would enable us to handle relative URLs.
diff --git a/library/init.tcl b/library/init.tcl
index d8de540..51c7f29 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -689,13 +689,14 @@ proc auto_execok name {
}
}
- foreach dir [split $path {;}] {
- # Skip already checked directories
- if {[info exists checked($dir)] || ($dir eq "")} {
- continue
- }
- set checked($dir) {}
- foreach ext $execExtensions {
+ foreach ext $execExtensions {
+ unset -nocomplain checked
+ foreach dir [split $path {;}] {
+ # Skip already checked directories
+ if {[info exists checked($dir)] || ($dir eq "")} {
+ continue
+ }
+ set checked($dir) {}
set file [file join $dir ${name}${ext}]
if {[file exists $file] && ![file isdirectory $file]} {
return [set auto_execs($name) [list $file]]
diff --git a/library/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl
index f71b09f..55af4b3 100755
--- a/library/reg/pkgIndex.tcl
+++ b/library/reg/pkgIndex.tcl
@@ -1,5 +1,5 @@
-if {![package vsatisfies [package provide Tcl] 8.5]} return
-if {[info sharedlibextension] ne ".dll"} return
+if {([info commands ::tcl::pkgconfig] eq "")
+ || ([info sharedlibextension] ne ".dll")} return
if {[::tcl::pkgconfig get debug]} {
package ifneeded registry 1.3.0 \
[list load [file join $dir tclreg13g.dll] registry]
diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c
index 9193c1a..f266443 100644
--- a/macosx/tclMacOSXFCmd.c
+++ b/macosx/tclMacOSXFCmd.c
@@ -148,8 +148,9 @@ TclMacOSXGetFileAttribute(
result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
- Tcl_AppendResult(interp, "could not read \"", TclGetString(fileName),
- "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read \"%s\": %s",
+ TclGetString(fileName), Tcl_PosixError(interp)));
return TCL_ERROR;
}
@@ -159,8 +160,8 @@ TclMacOSXGetFileAttribute(
*/
errno = EISDIR;
- Tcl_AppendResult(interp, "invalid attribute: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid attribute: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
@@ -175,8 +176,9 @@ TclMacOSXGetFileAttribute(
result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0);
if (result != 0) {
- Tcl_AppendResult(interp, "could not read attributes of \"",
- TclGetString(fileName), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read attributes of \"%s\": %s",
+ TclGetString(fileName), Tcl_PosixError(interp)));
return TCL_ERROR;
}
@@ -199,10 +201,11 @@ TclMacOSXGetFileAttribute(
}
return TCL_OK;
#else
- Tcl_AppendResult(interp, "Mac OS X file attributes not supported", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "Mac OS X file attributes not supported", -1));
Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL);
return TCL_ERROR;
-#endif
+#endif /* HAVE_GETATTRLIST */
}
/*
@@ -241,8 +244,9 @@ TclMacOSXSetFileAttribute(
result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
- Tcl_AppendResult(interp, "could not read \"", TclGetString(fileName),
- "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read \"%s\": %s",
+ TclGetString(fileName), Tcl_PosixError(interp)));
return TCL_ERROR;
}
@@ -252,8 +256,8 @@ TclMacOSXSetFileAttribute(
*/
errno = EISDIR;
- Tcl_AppendResult(interp, "invalid attribute: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid attribute: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
@@ -268,8 +272,9 @@ TclMacOSXSetFileAttribute(
result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0);
if (result != 0) {
- Tcl_AppendResult(interp, "could not read attributes of \"",
- TclGetString(fileName), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read attributes of \"%s\": %s",
+ TclGetString(fileName), Tcl_PosixError(interp)));
return TCL_ERROR;
}
@@ -306,9 +311,9 @@ TclMacOSXSetFileAttribute(
&finfo.data, sizeof(finfo.data), 0);
if (result != 0) {
- Tcl_AppendResult(interp, "could not set attributes of \"",
- TclGetString(fileName), "\": ", Tcl_PosixError(interp),
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not set attributes of \"%s\": %s",
+ TclGetString(fileName), Tcl_PosixError(interp)));
return TCL_ERROR;
}
} else {
@@ -328,8 +333,8 @@ TclMacOSXSetFileAttribute(
*/
if (newRsrcForkSize != 0) {
- Tcl_AppendResult(interp,
- "setting nonzero rsrclength not supported", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "setting nonzero rsrclength not supported", -1));
Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL);
return TCL_ERROR;
}
@@ -360,17 +365,17 @@ TclMacOSXSetFileAttribute(
Tcl_DStringFree(&ds);
if (result != 0) {
- Tcl_AppendResult(interp,
- "could not truncate resource fork of \"",
- TclGetString(fileName), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not truncate resource fork of \"%s\": %s",
+ TclGetString(fileName), Tcl_PosixError(interp)));
return TCL_ERROR;
}
}
}
return TCL_OK;
#else
- Tcl_AppendResult(interp, "Mac OS X file attributes not supported", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "Mac OS X file attributes not supported", -1));
Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL);
return TCL_ERROR;
#endif
@@ -640,8 +645,8 @@ SetOSTypeFromAny(
if (Tcl_DStringLength(&ds) > 4) {
if (interp) {
- Tcl_AppendResult(interp, "expected Macintosh OS type but got \"",
- string, "\": ", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected Macintosh OS type but got \"%s\": ", string));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "MAC_OSTYPE", NULL);
}
result = TCL_ERROR;
diff --git a/tests/assocd.test b/tests/assocd.test
index 1ca1c9b..d1489b3 100644
--- a/tests/assocd.test
+++ b/tests/assocd.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testgetassocdata [llength [info commands testgetassocdata]]
testConstraint testsetassocdata [llength [info commands testsetassocdata]]
testConstraint testdelassocdata [llength [info commands testdelassocdata]]
diff --git a/tests/async.test b/tests/async.test
index 35dda88..cb67cc2 100644
--- a/tests/async.test
+++ b/tests/async.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testasync [llength [info commands testasync]]
testConstraint threaded [::tcl::pkgconfig get threaded]
diff --git a/tests/basic.test b/tests/basic.test
index e072bea..7435571 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -18,6 +18,9 @@
package require tcltest 2
namespace import -force ::tcltest::*
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
testConstraint testcreatecommand [llength [info commands testcreatecommand]]
diff --git a/tests/chanio.test b/tests/chanio.test
index fbc9854..9bb11f7 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -29,6 +29,9 @@ namespace eval ::tcl::test::io {
variable msg
variable expected
+ ::tcltest::loadTestedCommands
+ catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]
testConstraint openpipe 1
diff --git a/tests/clock.test b/tests/clock.test
index fd74512..0202fc7 100644
--- a/tests/clock.test
+++ b/tests/clock.test
@@ -17,11 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
}
if {[testConstraint win]} {
- if {[catch {package require registry 1.1}]
- && [catch {load {} Registry}]
- && [catch {
+ if {[catch {
::tcltest::loadTestedCommands
- load $::reglib Registry
+ package require registry
}]} {
namespace eval ::tcl::clock {variable NoRegistry {}}
}
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index 291df8d..2ecf626 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -15,6 +15,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testchmod [llength [info commands testchmod]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
diff --git a/tests/cmdIL.test b/tests/cmdIL.test
index 4b1002a..efb0bce 100644
--- a/tests/cmdIL.test
+++ b/tests/cmdIL.test
@@ -13,6 +13,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
testConstraint testobj [llength [info commands testobj]]
diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test
index 86aa6e1..69d7171 100644
--- a/tests/cmdInfo.test
+++ b/tests/cmdInfo.test
@@ -18,6 +18,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testcmdinfo [llength [info commands testcmdinfo]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test
index bb19151..bae26a0 100644
--- a/tests/compExpr-old.test
+++ b/tests/compExpr-old.test
@@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
testConstraint testmathfunctions 0
} else {
diff --git a/tests/compExpr.test b/tests/compExpr.test
index 8e27f1f..14c875d 100644
--- a/tests/compExpr.test
+++ b/tests/compExpr.test
@@ -13,6 +13,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
testConstraint testmathfunctions 0
} else {
diff --git a/tests/compile.test b/tests/compile.test
index d6048be..4d91940 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -14,6 +14,9 @@
package require tcltest 2
namespace import -force ::tcltest::*
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint exec [llength [info commands exec]]
testConstraint memory [llength [info commands memory]]
testConstraint testevalex [llength [info commands testevalex]]
diff --git a/tests/coroutine.test b/tests/coroutine.test
index 7f40a7b..8272717 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -14,6 +14,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testnrelevels [llength [info commands testnrelevels]]
testConstraint memory [llength [info commands memory]]
diff --git a/tests/dcall.test b/tests/dcall.test
index 8977c31..3df0ac8 100644
--- a/tests/dcall.test
+++ b/tests/dcall.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testdcall [llength [info commands testdcall]]
test dcall-1.1 {deletion callbacks} testdcall {
diff --git a/tests/dstring.test b/tests/dstring.test
index bcc304d..06121a3 100644
--- a/tests/dstring.test
+++ b/tests/dstring.test
@@ -16,6 +16,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testdstring [llength [info commands testdstring]]
if {[testConstraint testdstring]} {
testdstring free
diff --git a/tests/encoding.test b/tests/encoding.test
index b4ee7c3..0374e2d 100644
--- a/tests/encoding.test
+++ b/tests/encoding.test
@@ -15,6 +15,11 @@ namespace eval ::tcl::test::encoding {
namespace import -force ::tcltest::*
+catch {
+ ::tcltest::loadTestedCommands
+ package require -exact Tcltest [info patchlevel]
+}
+
proc toutf {args} {
variable x
lappend x "toutf $args"
@@ -31,7 +36,6 @@ proc runtests {} {
testConstraint testencoding [llength [info commands testencoding]]
testConstraint exec [llength [info commands exec]]
testConstraint testgetdefenc [llength [info commands testgetdefenc]]
-testConstraint testfinexit [llength [info commands testfinexit]]
# TclInitEncodingSubsystem is tested by the rest of this file
# TclFinalizeEncodingSubsystem is not currently tested
@@ -418,13 +422,14 @@ test encoding-24.1 {EscapeFreeProc on open channels} exec {
gets $f
}
} {}
-test encoding-24.2 {EscapeFreeProc on open channels} {exec testfinexit} {
+test encoding-24.2 {EscapeFreeProc on open channels} {exec} {
# Bug #524674 output
viewable [runInSubprocess {
encoding system cp1252; # Bug #2891556 crash revelator
fconfigure stdout -encoding iso2022-jp
puts ab\u4e4e\u68d9g
- testfinexit
+ set env(TCL_FINALIZE_ON_EXIT) 1
+ exit
}]
} "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)"
test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
diff --git a/tests/event.test b/tests/event.test
index 0ee7558..0d1b06c 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -12,6 +12,13 @@
package require tcltest 2
namespace import -force ::tcltest::*
+catch {
+ ::tcltest::loadTestedCommands
+ package require -exact Tcltest [info patchlevel]
+ set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
+}
+
+
testConstraint testfilehandler [llength [info commands testfilehandler]]
testConstraint testexithandler [llength [info commands testexithandler]]
testConstraint testfilewait [llength [info commands testfilewait]]
@@ -427,6 +434,7 @@ catch {rename bgerror {}}
test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
+ puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; exit"
flush $child
@@ -440,6 +448,7 @@ odd 41
test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
+ puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
@@ -453,6 +462,7 @@ even 4
}
test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
+ puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 4"
puts $child "testexithandler create 16; exit"
@@ -466,6 +476,7 @@ odd 41
}
test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
+ puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 6"
puts $child "testexithandler create 16; exit"
@@ -479,6 +490,7 @@ odd 41
}
test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
+ puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
flush $child
diff --git a/tests/execute.test b/tests/execute.test
index 012b3a7..94af158 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -19,6 +19,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
diff --git a/tests/expr-old.test b/tests/expr-old.test
index c05a925..4f3cb2e 100644
--- a/tests/expr-old.test
+++ b/tests/expr-old.test
@@ -18,6 +18,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testexprlong [llength [info commands testexprlong]]
testConstraint testexprdouble [llength [info commands testexprdouble]]
testConstraint testexprstring [llength [info commands testexprstring]]
diff --git a/tests/expr.test b/tests/expr.test
index 6679569..6ad7208 100644
--- a/tests/expr.test
+++ b/tests/expr.test
@@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testmathfunctions [expr {
([catch {expr T1()} msg] != 1) || ($msg ne {invalid command name "tcl::mathfunc::T1"})
}]
diff --git a/tests/fCmd.test b/tests/fCmd.test
index 72b7da9..325b374 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -15,6 +15,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
cd [temporaryDirectory]
testConstraint testsetplatform [llength [info commands testsetplatform]]
diff --git a/tests/fileName.test b/tests/fileName.test
index 251f12c..6dd1cb4 100644
--- a/tests/fileName.test
+++ b/tests/fileName.test
@@ -15,6 +15,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testtranslatefilename [llength [info commands testtranslatefilename]]
testConstraint linkDirectory 1
@@ -196,7 +199,7 @@ test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} {
test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split //foo
-} "[file split //] foo"
+} "/ foo"
test filename-4.14 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split foo//bar
@@ -433,11 +436,11 @@ test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} {
test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join //a b
-} "[file split //]a/b"
+} "/a/b"
test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /// a b
-} "[file split //]a/b"
+} "/a/b"
test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
diff --git a/tests/fileSystem.test b/tests/fileSystem.test
index 9950dde..38ecbee 100644
--- a/tests/fileSystem.test
+++ b/tests/fileSystem.test
@@ -19,6 +19,17 @@ namespace eval ::tcl::test::fileSystem {
file delete -force [file join dir.dir linkinside.file]
}
+testConstraint loaddll 0
+catch {
+ ::tcltest::loadTestedCommands
+ package require -exact Tcltest [info patchlevel]
+ set ::ddever [package require dde]
+ set ::ddelib [lindex [package ifneeded dde $::ddever] 1]
+ set ::regver [package require registry]
+ set ::reglib [lindex [package ifneeded registry $::regver] 1]
+ testConstraint loaddll 0
+}
+
# Test for commands defined in Tcltest executable
testConstraint testfilesystem [llength [info commands ::testfilesystem]]
testConstraint testsetplatform [llength [info commands ::testsetplatform]]
@@ -305,7 +316,7 @@ test filesystem-1.39 {file normalisation with volume relative} -setup {
file norm [string range $drv 0 1]
} -cleanup {
cd $old
-} -match glob -result {*[^/]}
+} -match regexp -result {.*[^/]}
test filesystem-1.40 {file normalisation with repeated separators} {
testPathEqual [file norm foo////bar] [file norm foo/bar]
} ok
@@ -473,7 +484,7 @@ test filesystem-6.22 {empty file name} {file pathtype ""} relative
test filesystem-6.23 {empty file name} {file readable ""} 0
test filesystem-6.24 {empty file name} -returnCodes error -body {
file readlink ""
-} -result {could not readlink "": no such file or directory}
+} -result {could not read link "": no such file or directory}
test filesystem-6.25 {empty file name} -returnCodes error -body {
file rename "" ""
} -result {error renaming "": no such file or directory}
@@ -501,13 +512,12 @@ if {[testConstraint testfilesystem]} {
test filesystem-7.1.1 {load from vfs} -setup {
set dir [pwd]
-} -constraints {win testsimplefilesystem} -body {
+} -constraints {win testsimplefilesystem loaddll} -body {
# This may cause a crash on exit
- cd [file dirname [info nameof]]
- set dde [lindex [glob *dde*[info sharedlib]] 0]
+ cd [file dirname $::reglib]
testsimplefilesystem 1
# This loads dde via a complex copy-to-temp operation
- load simplefs:/$dde dde
+ load simplefs:/[file tail $::ddelib] dde
testsimplefilesystem 0
return ok
# The real result of this test is what happens when Tcl exits.
@@ -516,14 +526,13 @@ test filesystem-7.1.1 {load from vfs} -setup {
} -result ok
test filesystem-7.1.2 {load from vfs, and then unload again} -setup {
set dir [pwd]
-} -constraints {win testsimplefilesystem} -body {
+} -constraints {win testsimplefilesystem loaddll} -body {
# This may cause a crash on exit
- cd [file dirname [info nameof]]
- set reg [lindex [glob tclreg*[info sharedlib]] 0]
+ cd [file dirname $::reglib]
testsimplefilesystem 1
# This loads reg via a complex copy-to-temp operation
- load simplefs:/$reg Registry
- unload simplefs:/$reg
+ load simplefs:/[file tail $::reglib] Registry
+ unload simplefs:/[file tail $::reglib]
testsimplefilesystem 0
return ok
# The real result of this test is what happens when Tcl exits.
diff --git a/tests/format.test b/tests/format.test
index 2d53eba..27eac31 100644
--- a/tests/format.test
+++ b/tests/format.test
@@ -549,10 +549,7 @@ test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} {
list [format %08x $a] [expr {$a == $b}]
} {aaaaaaab 1}
-test format-19.1 {
- regression test - tcl-core message by Brian Griffin on
- 26 0ctober 2004
-} -body {
+test format-19.1 {regression test - tcl-core message by Brian Griffin on 26 0ctober 2004} -body {
set x 0x8fedc654
list [expr { ~ $x }] [format %08x [expr { ~$x }]]
} -match regexp -result {-2414724693 f*701239ab}
@@ -569,7 +566,7 @@ test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body {
format %s $x
# After this, obj in $x should be a dict with a non-NULL bytes field
tcl::unsupported::representation $x
-} -match glob -result {value is a dict with *, string representation "*".}
+} -match glob -result {value is a dict with *, string representation "*"}
# cleanup
catch {unset a}
diff --git a/tests/get.test b/tests/get.test
index 40ec98f..d51ec6d 100644
--- a/tests/get.test
+++ b/tests/get.test
@@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testgetint [llength [info commands testgetint]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
diff --git a/tests/http.test b/tests/http.test
index 37d4a05..bde5795 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -135,6 +135,7 @@ set fullurl http://user:pass@[info hostname]:$port/a/b/c
set binurl //[info hostname]:$port/binary
set posturl //[info hostname]:$port/post
set badposturl //[info hostname]:$port/droppost
+set ipv6url http://\[::1\]:$port/
test http-3.4 {http::geturl} -body {
set token [http::geturl $url]
http::data $token
@@ -390,6 +391,20 @@ Connection close
Content-Type {text/plain;charset=utf-8}
Accept-Encoding .*
Content-Length 5}
+test http-3.29 "http::geturl $ipv6url" -body {
+ # We only want to see if the URL gets parsed correctly. This is
+ # the case if http::geturl succeeds or returns a socket related
+ # error. If the parsing is wrong, we'll get a parse error.
+ # It'd be better to separate the URL parser from http::geturl, so
+ # that it can be tested without also trying to make a connection.
+ set error [catch {http::geturl $ipv6url -validate 1} token]
+ if {$error && [string match "couldn't open socket: *" $token]} {
+ set error 0
+ }
+ set error
+} -cleanup {
+ catch { http::cleanup $token }
+} -result 0
test http-4.1 {http::Event} -body {
set token [http::geturl $url -keepalive 0]
diff --git a/tests/indexObj.test b/tests/indexObj.test
index 479cc3b..646cb02 100644
--- a/tests/indexObj.test
+++ b/tests/indexObj.test
@@ -13,6 +13,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testindexobj [llength [info commands testindexobj]]
testConstraint testparseargs [llength [info commands testparseargs]]
diff --git a/tests/info.test b/tests/info.test
index 3323281..7dd63b7 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -20,6 +20,9 @@ if {{::tcltest} ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.
@@ -231,7 +234,6 @@ test info-6.11 {info default option} {
}
} {0 {} 1 27}
-
test info-7.1 {info exists option} -body {
set value foo
info exists value
@@ -731,8 +733,6 @@ proc etrace {} {
return $res
}
-##
-
test info-22.0 {info frame, levels} {!singleTestInterp} {
info frame
} 7
@@ -763,7 +763,7 @@ test info-22.7 {info frame, global, absolute} {!singleTestInterp} {
} {type source line 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0}
test info-22.8 {info frame, basic trace} -match glob -body {
join [lrange [etrace] 0 2] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
+} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest}
* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
unset -nocomplain msg
@@ -803,7 +803,7 @@ test info-23.5 {eval'd info frame, dynamic} -cleanup {unset script} -body {
test info-23.6 {eval'd info frame, trace} -match glob -cleanup {unset script} -body {
set script {etrace}
join [lrange [eval $script] 0 2] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
+} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
* {type source line 805 file info.test cmd {eval $script} proc ::tcltest::RunTest}}
@@ -1318,7 +1318,7 @@ test info-37.0 {eval pure list, single line} -match glob -body {
}]
eval $cmd
return $res
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
+} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 2 cmd etrace proc ::tcltest::RunTest}
* {type eval line 1 cmd foreac proc ::tcltest::RunTest}} -cleanup {unset foo cmd res b c}
@@ -1359,7 +1359,7 @@ test info-38.1 {location information for uplevel, dv, direct-var} -match glob -b
etrace
}
join [lrange [uplevel \#0 $script] 0 2] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
+} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::tcltest::RunTest}
* {type source line 1361 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y}
@@ -1378,7 +1378,7 @@ test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match g
etrace
}
join [lrange [control y $script] 0 3] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
+} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1380 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y}
@@ -1395,7 +1395,7 @@ test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match g
test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body {
join [lrange [datav] 0 4] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
+} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1353 file info.test cmd {control y $script} proc ::datav level 1}
@@ -1412,7 +1412,7 @@ test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glo
testConstraint testevalex [llength [info commands testevalex]]
test info-38.7 {location information for arg substitution} -constraints testevalex -match glob -body {
join [lrange [testevalex {return -level 0 [etrace]}] 0 3] \n
-} -result {* {type source line 728 file info.test cmd {info frame \$level} proc ::etrace level 0}
+} -result {* {type source line 730 file info.test cmd {info frame \$level} proc ::etrace level 0}
* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
* {type source line 1414 file info.test cmd {testevalex {return -level 0 \[etrace]}} proc ::tcltest::RunTest}
* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
diff --git a/tests/interp.test b/tests/interp.test
index ab91f77..0af9887 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -15,6 +15,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testinterpdelete [llength [info commands testinterpdelete]]
set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload}
diff --git a/tests/io.test b/tests/io.test
index f3c39f4..9621138 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -17,6 +17,10 @@ if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
+
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index cf913ff..5eb0206 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -18,6 +18,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Custom constraints used in this file
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testchannel [llength [info commands testchannel]]
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
index 7da4329..db9a2cb 100644
--- a/tests/ioTrans.test
+++ b/tests/ioTrans.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Custom constraints used in this file
testConstraint testchannel [llength [info commands testchannel]]
testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
diff --git a/tests/iogt.test b/tests/iogt.test
index 60d7ab8..d4c31d2 100644
--- a/tests/iogt.test
+++ b/tests/iogt.test
@@ -14,6 +14,10 @@ if {[catch {package require tcltest 2.1}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
return
}
+
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
namespace eval ::tcl::test::iogt {
namespace import ::tcltest::*
diff --git a/tests/lindex.test b/tests/lindex.test
index 07abff8..b86e2e0 100644
--- a/tests/lindex.test
+++ b/tests/lindex.test
@@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
set minus -
testConstraint testevalex [llength [info commands testevalex]]
diff --git a/tests/link.test b/tests/link.test
index 60d0799..00e490c 100644
--- a/tests/link.test
+++ b/tests/link.test
@@ -16,6 +16,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testlink [llength [info commands testlink]]
foreach i {int real bool string} {
diff --git a/tests/listObj.test b/tests/listObj.test
index 53017b1..8b24aa9 100644
--- a/tests/listObj.test
+++ b/tests/listObj.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testobj [llength [info commands testobj]]
catch {unset x}
diff --git a/tests/load.test b/tests/load.test
index b7c1a59..78bf64c 100644
--- a/tests/load.test
+++ b/tests/load.test
@@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Figure out what extension is used for shared libraries on this
# platform.
if {![info exists ext]} {
@@ -197,7 +200,7 @@ test load-9.1 {Tcl_StaticPackage, load already-loaded package into another inter
[child1 eval { info loaded {} }] \
[child2 eval { info loaded {} }]
} \
- -result {{{{} Loadninepointone} {{} Tcltest}} {{{} Loadninepointone} {{} Tcltest}}} \
+ -match glob -result {{{{} Loadninepointone} {* Tcltest}} {{{} Loadninepointone} {* Tcltest}}} \
-cleanup { interp delete child1 ; interp delete child2 }
test load-10.1 {load from vfs} \
diff --git a/tests/lset.test b/tests/lset.test
index 3f4914d..1c1300b 100644
--- a/tests/lset.test
+++ b/tests/lset.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
proc failTrace {name1 name2 op} {
error "trace failed"
}
diff --git a/tests/misc.test b/tests/misc.test
index fe19ebe..6ddc718 100644
--- a/tests/misc.test
+++ b/tests/misc.test
@@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testhashsystemhash [llength [info commands testhashsystemhash]]
test misc-1.1 {error in variable ref. in command in array reference} {
diff --git a/tests/namespace.test b/tests/namespace.test
index f07d8cf..1d46bf0 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -16,6 +16,9 @@ package require tcltest 2
namespace import -force ::tcltest::*
testConstraint memory [llength [info commands memory]]
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
#
# REMARK: the tests for 'namespace upvar' are not done here. They are to be
# found in the file 'upvar.test'.
diff --git a/tests/notify.test b/tests/notify.test
index ba52c50..d2b9123 100755
--- a/tests/notify.test
+++ b/tests/notify.test
@@ -18,6 +18,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testevent [llength [info commands testevent]]
test notify-1.1 {Tcl_QueueEvent and delivery of a single event} \
diff --git a/tests/nre.test b/tests/nre.test
index 295f02e..b8ef2e0 100644
--- a/tests/nre.test
+++ b/tests/nre.test
@@ -14,6 +14,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testnrelevels [llength [info commands testnrelevels]]
#
diff --git a/tests/obj.test b/tests/obj.test
index 126d5ca..71a39b4 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testobj [llength [info commands testobj]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]
diff --git a/tests/parse.test b/tests/parse.test
index 3523975..0f76d64 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -16,6 +16,9 @@ if {[catch {package require tcltest 2.0.2}]} {
namespace eval ::tcl::test::parse {
namespace import ::tcltest::*
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testparser [llength [info commands testparser]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
testConstraint testevalex [llength [info commands testevalex]]
diff --git a/tests/parseExpr.test b/tests/parseExpr.test
index cd0342a..7910974 100644
--- a/tests/parseExpr.test
+++ b/tests/parseExpr.test
@@ -13,6 +13,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Note that the Tcl expression parser (tclCompExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
# for example, that a math function actually exists, or that the operands
diff --git a/tests/parseOld.test b/tests/parseOld.test
index 132481c..0edcbf0 100644
--- a/tests/parseOld.test
+++ b/tests/parseOld.test
@@ -18,6 +18,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testwordend [llength [info commands testwordend]]
# Save the argv value for restoration later
diff --git a/tests/platform.test b/tests/platform.test
index 92ca7ab..aab7c78 100644
--- a/tests/platform.test
+++ b/tests/platform.test
@@ -14,6 +14,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testCPUID [llength [info commands testcpuid]]
test platform-1.1 {TclpSetVariables: tcl_platform} {
diff --git a/tests/reg.test b/tests/reg.test
index abfc9ca..a0ea850 100644
--- a/tests/reg.test
+++ b/tests/reg.test
@@ -13,6 +13,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# All tests require the testregexp command, return if this
# command doesn't exist
diff --git a/tests/registry.test b/tests/registry.test
index 400277f..77588e3 100644
--- a/tests/registry.test
+++ b/tests/registry.test
@@ -17,13 +17,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
testConstraint reg 0
if {[testConstraint win]} {
- catch {
- # Is the registry extension already static to this shell?
- if [catch {load {} Registry; set ::reglib {}}] {
- # try the location given to use on the commandline to tcltest
+ if {![catch {
::tcltest::loadTestedCommands
- load $::reglib Registry
- }
+ set ::regver [package require registry 1.3.0]
+ }]} {
testConstraint reg 1
}
}
@@ -34,6 +31,9 @@ testConstraint english [expr {
&& [string match "English*" [testlocale all ""]]
}]
+test registry-1.0 {check if we are testing the right dll} {win reg} {
+ set ::regver
+} {1.3.0}
test registry-1.1 {argument parsing for registry command} {win reg} {
list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
@@ -505,7 +505,7 @@ test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} {
registry delete HKEY_CURRENT_USER\\TclFoobar
set result
} "foo ba r baz"
-test registry-6.21 {GetValue: very long value names and values} {pcOnly} {
+test registry-6.21 {GetValue: very long value names and values} {pcOnly reg} {
registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383] [string repeat x 16383] multi_sz
set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383]]
registry delete HKEY_CURRENT_USER\\TclFoobar
diff --git a/tests/rename.test b/tests/rename.test
index 9ac49b4..1fa0441 100644
--- a/tests/rename.test
+++ b/tests/rename.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testdel [llength [info commands testdel]]
# Must eliminate the "unknown" command while the test is running, especially
diff --git a/tests/resolver.test b/tests/resolver.test
index bb9f59d..e73ea50 100644
--- a/tests/resolver.test
+++ b/tests/resolver.test
@@ -15,6 +15,9 @@ if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testinterpresolver [llength [info commands testinterpresolver]]
test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup {
diff --git a/tests/result.test b/tests/result.test
index f080654..3391ce1 100644
--- a/tests/result.test
+++ b/tests/result.test
@@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Some tests require the testsaveresult command
testConstraint testsaveresult [llength [info commands testsaveresult]]
diff --git a/tests/set.test b/tests/set.test
index 9e0ddc0..1d88553 100644
--- a/tests/set.test
+++ b/tests/set.test
@@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testset2 [llength [info commands testset2]]
catch {unset x}
diff --git a/tests/string.test b/tests/string.test
index b3326ae..e86c0de 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Some tests require the testobj command
testConstraint testobj [expr {[info commands testobj] != {}}]
@@ -1773,10 +1776,10 @@ test string-26.3.1 {tcl::prefix, bad args} -body {
} -returnCodes 1 -result {error options must have an even number of elements}
test string-26.3.2 {tcl::prefix, bad args} -body {
tcl::prefix match -error str1 str2
-} -returnCodes 1 -result {missing error options}
+} -returnCodes 1 -result {missing value for -error}
test string-26.4 {tcl::prefix, bad args} -body {
tcl::prefix match -message str1 str2
-} -returnCodes 1 -result {missing message}
+} -returnCodes 1 -result {missing value for -message}
test string-26.5 {tcl::prefix} {
tcl::prefix match {apa bepa cepa depa} cepa
} cepa
diff --git a/tests/stringComp.test b/tests/stringComp.test
index ff18819..56fb69d 100644
--- a/tests/stringComp.test
+++ b/tests/stringComp.test
@@ -20,6 +20,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Some tests require the testobj command
testConstraint testobj [expr {[info commands testobj] != {}}]
diff --git a/tests/stringObj.test b/tests/stringObj.test
index d93bb82..6f331d3 100644
--- a/tests/stringObj.test
+++ b/tests/stringObj.test
@@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testobj [llength [info commands testobj]]
testConstraint testdstring [llength [info commands testdstring]]
diff --git a/tests/tailcall.test b/tests/tailcall.test
index e9ec188..2d04f82 100644
--- a/tests/tailcall.test
+++ b/tests/tailcall.test
@@ -14,6 +14,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testnrelevels [llength [info commands testnrelevels]]
#
diff --git a/tests/thread.test b/tests/thread.test
index 44789fa..f2735da 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Some tests require the testthread command
testConstraint testthread [expr {[info commands testthread] != {}}]
diff --git a/tests/trace.test b/tests/trace.test
index 693dbad..0f48dcf 100644
--- a/tests/trace.test
+++ b/tests/trace.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test
index e8148e9..2453e01 100644
--- a/tests/unixFCmd.test
+++ b/tests/unixFCmd.test
@@ -14,6 +14,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testchmod [llength [info commands testchmod]]
# These tests really need to be run from a writable directory, which
diff --git a/tests/unixFile.test b/tests/unixFile.test
index 0ea0ec1..8147f48 100644
--- a/tests/unixFile.test
+++ b/tests/unixFile.test
@@ -14,6 +14,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testfindexecutable [llength [info commands testfindexecutable]]
set oldpwd [pwd]
diff --git a/tests/unload.test b/tests/unload.test
index a103cc5..5a374c4 100644
--- a/tests/unload.test
+++ b/tests/unload.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Figure out what extension is used for shared libraries on this
# platform.
if {![info exists ext]} {
diff --git a/tests/upvar.test b/tests/upvar.test
index cd78c31..e2c9ffd 100644
--- a/tests/upvar.test
+++ b/tests/upvar.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testupvar [llength [info commands testupvar]]
test upvar-1.1 {reading variables with upvar} {
diff --git a/tests/utf.test b/tests/utf.test
index fcd2a73..c41cfe3 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -13,6 +13,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
catch {unset x}
test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
diff --git a/tests/util.test b/tests/util.test
index 1da533c..0e50483 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -12,6 +12,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint controversialNaN 1
testConstraint testdstring [llength [info commands testdstring]]
testConstraint testconcatobj [llength [info commands testconcatobj]]
diff --git a/tests/var.test b/tests/var.test
index f2923de..ed7e930 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -19,6 +19,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testupvar [llength [info commands testupvar]]
testConstraint testgetvarfullname [llength [info commands testgetvarfullname]]
testConstraint testsetnoerr [llength [info commands testsetnoerr]]
diff --git a/tests/winDde.test b/tests/winDde.test
index 83f3598..8d9bd12 100644
--- a/tests/winDde.test
+++ b/tests/winDde.test
@@ -15,16 +15,15 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
-if [catch {
- # Is the dde extension already static to this shell?
- if [catch {load {} Dde; set ::ddelib {}}] {
- # try the location given to use on the commandline to tcltest
- ::tcltest::loadTestedCommands
- load $::ddelib Dde
+testConstraint debug [::tcl::pkgconfig get debug]
+testConstraint dde 0
+if {[testConstraint win]} {
+ if {![catch {
+ ::tcltest::loadTestedCommands
+ set ::ddever [package require dde 1.4.0b1]
+ set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} {
+ testConstraint dde 1
}
- testConstraint dde 1
-}] {
- testConstraint dde 0
}
@@ -39,9 +38,7 @@ proc createChildProcess {ddeServerName args} {
set f [open $::scriptName w+]
puts $f [list set ddeServerName $ddeServerName]
- if {$::ddelib != ""} {
- puts $f [list load $::ddelib Dde]
- }
+ puts $f [list load $::ddelib dde]
puts $f {
# DDE child server -
#
@@ -105,6 +102,9 @@ proc createChildProcess {ddeServerName args} {
}
# -------------------------------------------------------------------------
+test winDde-1.0 {check if we are testing the right dll} {win dde} {
+ set ::ddever
+} {1.4.0b1}
test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
list [dde servername foobar] [dde servername] [dde servername self]
@@ -140,33 +140,43 @@ test winDde-3.2 {DDE execute -async locally} -constraints dde -body {
set \xe1
} -result foo
test winDde-3.3 {DDE request locally} -constraints dde -body {
- set a ""
- dde execute TclEval self [list set a foo]
- dde request TclEval self a
+ set \xe1 ""
+ dde execute TclEval self [list set \xe1 foo]
+ dde request TclEval self \xe1
} -result foo
test winDde-3.4 {DDE eval locally} -constraints dde -body {
set \xe1 ""
dde eval self set \xe1 foo
} -result foo
test winDde-3.5 {DDE request locally} -constraints dde -body {
- set a ""
- dde execute TclEval self [list set a foo]
- dde request -binary TclEval self a
+ set \xe1 ""
+ dde execute TclEval self [list set \xe1 foo]
+ dde request -binary TclEval self \xe1
} -result "foo\x00"
# Set variable a to A with diaeresis (unicode C4) by relying on the fact
# that utf8 is sent (e.g. "c3 84" on the wire)
test winDde-3.6 {DDE request utf8} -constraints dde -body {
- set a "not set"
- dde execute TclEval self "set a \xc4"
- scan $a %c
+ set \xe1 "not set"
+ dde execute TclEval self "set \xe1 \xc4"
+ scan [set \xe1] %c
} -result 196
# Set variable a to A with diaeresis (unicode C4) using binary execute
# and compose utf-8 (e.g. "c3 84" ) manualy
test winDde-3.7 {DDE request binary} -constraints dde -body {
- set a "not set"
- dde execute -binary TclEval self [list set a \xc3\x84\x00]
- scan $a %c
+ set \xe1 "not set"
+ dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00]
+ scan [set \xe1] %c
} -result 196
+test winDde-3.8 {DDE poke locally} -constraints {dde debug} -body {
+ set \xe1 ""
+ dde poke TclEval self \xe1 \xc4
+ dde request TclEval self \xe1
+} -result \xc4
+test winDde-3.9 {DDE poke -binary locally} -constraints {dde debug} -body {
+ set \xe1 ""
+ dde poke -binary TclEval self \xe1 \xc3\x84\x00
+ dde request TclEval self \xe1
+} -result \xc4
# -------------------------------------------------------------------------
@@ -190,24 +200,34 @@ test winDde-4.2 {DDE execute async remotely} -constraints {dde stdio} -body {
set \xe1
} -result ""
test winDde-4.3 {DDE request remotely} -constraints {dde stdio} -body {
- set a ""
+ set \xe1 ""
set name ch\xEDld-4.3
set child [createChildProcess $name]
dde execute TclEval $name [list set a foo]
- set a [dde request TclEval $name a]
+ set \xe1 [dde request TclEval $name a]
dde execute TclEval $name {set done 1}
update
- set a
+ set \xe1
} -result foo
test winDde-4.4 {DDE eval remotely} -constraints {dde stdio} -body {
- set a ""
+ set \xe1 ""
set name ch\xEDld-4.4
set child [createChildProcess $name]
- set a [dde eval $name set a foo]
+ set \xe1 [dde eval $name set \xe1 foo]
dde execute TclEval $name {set done 1}
update
- set a
+ set \xe1
} -result foo
+test winDde-4.5 {DDE poke remotely} -constraints {dde debug stdio} -body {
+ set \xe1 ""
+ set name ch\xEDld-4.5
+ set child [createChildProcess $name]
+ dde poke TclEval $name \xe1 foo
+ set \xe1 [dde request TclEval $name \xe1]
+ dde execute TclEval $name {set done 1}
+ update
+ set \xe1
+} -result foo
# -------------------------------------------------------------------------
diff --git a/tests/winFCmd.test b/tests/winFCmd.test
index b49356d..28a0e9f 100644
--- a/tests/winFCmd.test
+++ b/tests/winFCmd.test
@@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Initialise the test constraints
testConstraint winVista 0
diff --git a/tests/winFile.test b/tests/winFile.test
index ad34624..fba9bcb 100644
--- a/tests/winFile.test
+++ b/tests/winFile.test
@@ -16,6 +16,9 @@ if {[catch {package require tcltest 2.0.2}]} {
}
namespace import -force ::tcltest::*
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint notNTFS 0
testConstraint win2000 0
diff --git a/tests/winNotify.test b/tests/winNotify.test
index f9c75a3..3e9aa29 100644
--- a/tests/winNotify.test
+++ b/tests/winNotify.test
@@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testeventloop [expr {[info commands testeventloop] != {}}]
# There is no explicit test for InitNotifier or NotifierExitHandler
diff --git a/tests/winPipe.test b/tests/winPipe.test
index 62d7d0d..d2e804d 100644
--- a/tests/winPipe.test
+++ b/tests/winPipe.test
@@ -16,6 +16,12 @@ package require tcltest
namespace import -force ::tcltest::*
unset -nocomplain path
+catch {
+ ::tcltest::loadTestedCommands
+ package require -exact Tcltest [info patchlevel]
+ set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
+}
+
set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
set cat32 [file join $bindir cat32.exe]
@@ -23,6 +29,8 @@ testConstraint exec [llength [info commands exec]]
testConstraint cat32 [file exists $cat32]
testConstraint AllocConsole [catch {puts console1 ""}]
testConstraint RealConsole [expr {![testConstraint AllocConsole]}]
+testConstraint testexcept [llength [info commands testexcept]]
+
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
append big $big
@@ -190,30 +198,34 @@ test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} {
vwait x
list $result $x [contents $path(stderr)]
} "{$big} 1 stderr32"
-test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec} {
+test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
+ puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept float_underflow"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGFPE}
-test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec} {
+test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
+ puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept access_violation"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGSEGV}
-test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec} {
+test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
+ puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept illegal_instruction"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGILL}
-test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec} {
+test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
+ puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept ctrl+c"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
diff --git a/tests/winTime.test b/tests/winTime.test
index 278db32..add8f98 100644
--- a/tests/winTime.test
+++ b/tests/winTime.test
@@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testwinclock [llength [info commands testwinclock]]
# The next two tests will crash on Windows if the check for negative
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 2e47714..4d5595d 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -856,7 +856,7 @@ install-libraries: libraries
@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm;
- @echo "Installing library encoding files to $(SCRIPT_INSTALL_DIR)/encoding/";
+ @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/";
@for i in $(TOP_DIR)/library/encoding/*.enc ; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/encoding; \
done;
@@ -867,7 +867,7 @@ install-libraries: libraries
fi
install-tzdata: ${NATIVE_TCLSH}
- @echo "Installing time zone data"
+ @echo "Installing time zone files to $(SCRIPT_INSTALL_DIR)/tzdata/"
@${NATIVE_TCLSH} $(TOOL_DIR)/installData.tcl \
$(TOP_DIR)/library/tzdata "$(SCRIPT_INSTALL_DIR)"/tzdata
@@ -894,17 +894,17 @@ install-doc: doc
else true; \
fi; \
done;
- @echo "Installing and cross-linking top-level (.1) docs";
+ @echo "Installing and cross-linking top-level (.1) docs to $(MAN1_INSTALL_DIR)/";
@for i in $(TOP_DIR)/doc/*.1; do \
$(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN1_INSTALL_DIR)"; \
done
- @echo "Installing and cross-linking C API (.3) docs";
+ @echo "Installing and cross-linking C API (.3) docs to $(MAN3_INSTALL_DIR)/";
@for i in $(TOP_DIR)/doc/*.3; do \
$(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN3_INSTALL_DIR)"; \
done
- @echo "Installing and cross-linking command (.n) docs";
+ @echo "Installing and cross-linking command (.n) docs to $(MANN_INSTALL_DIR)/";
@for i in $(TOP_DIR)/doc/*.n; do \
$(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MANN_INSTALL_DIR)"; \
done
@@ -1701,7 +1701,7 @@ packages: configure-packages ${STUB_LIB_FILE}
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
echo "Building package '$$pkg'"; \
- ( cd $(PKG_DIR)/$$pkg; $(MAKE) --no-print-directory; ) || exit $$?; \
+ ( cd $(PKG_DIR)/$$pkg; $(MAKE); ) || exit $$?; \
fi; \
fi; \
done
@@ -1712,7 +1712,7 @@ install-packages: packages
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
echo "Installing package '$$pkg'"; \
- ( cd $(PKG_DIR)/$$pkg; $(MAKE) --no-print-directory install \
+ ( cd $(PKG_DIR)/$$pkg; $(MAKE) install \
"DESTDIR=$(INSTALL_ROOT)"; ) || exit $$?; \
fi; \
fi; \
@@ -1723,10 +1723,8 @@ test-packages: tcltest packages
if [ -d $$i ]; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
- echo ""; \
- echo ""; \
echo "Testing package '$$pkg'"; \
- ( cd $(PKG_DIR)/$$pkg; $(MAKE) --no-print-directory \
+ ( cd $(PKG_DIR)/$$pkg; $(MAKE) \
"@LD_LIBRARY_PATH_VAR@=../..:$${@LD_LIBRARY_PATH_VAR@}" \
"TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" \
"TCLLIBPATH=../../pkgs" test \
@@ -1740,7 +1738,7 @@ clean-packages:
if [ -d $$i ]; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
- ( cd $(PKG_DIR)/$$pkg; $(MAKE) --no-print-directory clean; ) \
+ ( cd $(PKG_DIR)/$$pkg; $(MAKE) clean; ) \
fi; \
fi; \
done
@@ -1750,7 +1748,7 @@ distclean-packages:
if [ -d $$i ]; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
- ( cd $(PKG_DIR)/$$pkg; $(MAKE) --no-print-directory distclean; ) \
+ ( cd $(PKG_DIR)/$$pkg; $(MAKE) distclean; ) \
fi; \
rm -rf $(PKG_DIR)/$$pkg; \
fi; \
@@ -1764,7 +1762,7 @@ dist-packages: configure-packages
if [ -d $$i ]; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
- ( cd $(PKG_DIR)/$$pkg; $(MAKE) --no-print-directory dist \
+ ( cd $(PKG_DIR)/$$pkg; $(MAKE) dist \
"DIST_ROOT=$(DISTROOT)/pkgs"; ) || exit $$?; \
fi; \
fi; \
@@ -1930,7 +1928,6 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M
$(UNIX_DIR)/tcl.pc.in $(DISTDIR)/unix
chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in
chmod 775 $(DISTDIR)/unix/ldAix
- chmod +x $(DISTDIR)/unix/install-sh
mkdir $(DISTDIR)/generic
cp -p $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic
cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic
diff --git a/unix/configure b/unix/configure
index 2e36ad2..18611f0 100755
--- a/unix/configure
+++ b/unix/configure
@@ -19437,8 +19437,8 @@ _ACEOF
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)"/TclTOC.html'
- EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources" && mkdir -p "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"'
- EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"'
+ EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"'
+ EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."'
# Don't use AC_DEFINE for the following as the framework version define
# needs to go into the Makefile even when using autoheader, so that we
diff --git a/unix/configure.in b/unix/configure.in
index 79a546d..dc0d543 100644
--- a/unix/configure.in
+++ b/unix/configure.in
@@ -220,7 +220,7 @@ AC_CHECK_FUNC(realpath, , [AC_DEFINE(NO_REALPATH, 1, [Do we have realpath()])])
SC_TCL_IPV6
-#--------------------------------------------------------------------
+#--------------------------------------------------------------------
# Look for thread-safe variants of some library functions.
#--------------------------------------------------------------------
@@ -398,7 +398,7 @@ AC_CHECK_TYPE([intptr_t], [
for tcl_cv_intptr_t in "int" "long" "long long" none; do
if test "$tcl_cv_intptr_t" != none; then
AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT],
- [[sizeof (void *) <= sizeof ($tcl_cv_intptr_t)]])],
+ [[sizeof (void *) <= sizeof ($tcl_cv_intptr_t)]])],
[tcl_ok=yes], [tcl_ok=no])
test "$tcl_ok" = yes && break; fi
done])
@@ -414,7 +414,7 @@ AC_CHECK_TYPE([uintptr_t], [
none; do
if test "$tcl_cv_uintptr_t" != none; then
AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT],
- [[sizeof (void *) <= sizeof ($tcl_cv_uintptr_t)]])],
+ [[sizeof (void *) <= sizeof ($tcl_cv_uintptr_t)]])],
[tcl_ok=yes], [tcl_ok=no])
test "$tcl_ok" = yes && break; fi
done])
@@ -681,7 +681,7 @@ AC_ARG_WITH(tzdata,
# Any directories that get added here must also be added to the
# search path in ::tcl::clock::Initialize (library/clock.tcl).
#
-case $tcl_ok in
+case $tcl_ok in
no)
AC_MSG_RESULT([supplied by OS vendor])
;;
@@ -708,7 +708,7 @@ case $tcl_ok in
fi
;;
*)
- AC_MSG_ERROR([invalid argument: $tcl_ok])
+ AC_MSG_ERROR([invalid argument: $tcl_ok])
;;
esac
if test $tcl_ok = yes
@@ -782,7 +782,7 @@ TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX}
eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}"
# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed
-# since on some platforms TCL_LIB_FILE contains shell escapes.
+# since on some platforms TCL_LIB_FILE contains shell escapes.
# (See also: TCL_TRIM_DOTS).
eval "TCL_LIB_FILE=${TCL_LIB_FILE}"
@@ -841,8 +841,8 @@ if test "$FRAMEWORK_BUILD" = "1" ; then
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)"/TclTOC.html'
- EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources" && mkdir -p "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"'
- EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"'
+ EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"'
+ EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."'
# Don't use AC_DEFINE for the following as the framework version define
# needs to go into the Makefile even when using autoheader, so that we
diff --git a/unix/install-sh b/unix/install-sh
index c68581d..7c34c3f 100755
--- a/unix/install-sh
+++ b/unix/install-sh
@@ -156,8 +156,8 @@ while test $# -ne 0; do
-s) stripcmd=$stripprog;;
- -S) stripcmd="$stripprog $2"
- shift;;
+ -S) stripcmd="$stripprog $2"
+ shift;;
-t) dst_arg=$2
shift;;
diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c
index d86e7fd..f8fe6d3 100644
--- a/unix/tclLoadDl.c
+++ b/unix/tclLoadDl.c
@@ -112,8 +112,9 @@ TclpDlopen(
const char *errorStr = dlerror();
- Tcl_AppendResult(interp, "couldn't load file \"",
- Tcl_GetString(pathPtr), "\": ", errorStr, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't load file \"%s\": %s",
+ Tcl_GetString(pathPtr), errorStr));
return TCL_ERROR;
}
newHandle = ckalloc(sizeof(*newHandle));
@@ -175,9 +176,8 @@ FindSymbol(
}
Tcl_DStringFree(&ds);
if (proc == NULL && interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "cannot find symbol \"", symbol, "\": ",
- dlerror(), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "cannot find symbol \"%s\": %s", symbol, dlerror()));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol,
NULL);
}
diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c
index 31d15b2..95735a4 100644
--- a/unix/tclLoadDyld.c
+++ b/unix/tclLoadDyld.c
@@ -16,42 +16,36 @@
#include "tclInt.h"
#ifndef MODULE_SCOPE
-#define MODULE_SCOPE extern
+# define MODULE_SCOPE extern
#endif
-#ifndef TCL_DYLD_USE_DLFCN
/*
* Use preferred dlfcn API on 10.4 and later
*/
-# if !defined(NO_DLFCN_H) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1040
-# define TCL_DYLD_USE_DLFCN 1
-# else
+
+#ifndef TCL_DYLD_USE_DLFCN
+# ifdef NO_DLFCN_H
# define TCL_DYLD_USE_DLFCN 0
+# else
+# define TCL_DYLD_USE_DLFCN 1
# endif
#endif
-#ifndef TCL_DYLD_USE_NSMODULE
+
/*
* Use deprecated NSModule API only to support 10.3 and earlier:
*/
-# if MAC_OS_X_VERSION_MIN_REQUIRED < 1040
-# define TCL_DYLD_USE_NSMODULE 1
-# else
-# define TCL_DYLD_USE_NSMODULE 0
-# endif
+
+#ifndef TCL_DYLD_USE_NSMODULE
+# define TCL_DYLD_USE_NSMODULE 0
#endif
-#if TCL_DYLD_USE_DLFCN
-#include <dlfcn.h>
-#if defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1040
/*
- * Support for weakly importing dlfcn API.
+ * Use includes for the API we're using.
*/
-extern void *dlopen(const char *path, int mode) WEAK_IMPORT_ATTRIBUTE;
-extern void *dlsym(void *handle, const char *symbol) WEAK_IMPORT_ATTRIBUTE;
-extern int dlclose(void *handle) WEAK_IMPORT_ATTRIBUTE;
-extern char *dlerror(void) WEAK_IMPORT_ATTRIBUTE;
-#endif
-#endif
+
+#if TCL_DYLD_USE_DLFCN
+# include <dlfcn.h>
+#endif /* TCL_DYLD_USE_DLFCN */
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
#include <mach-o/dyld.h>
@@ -60,38 +54,23 @@ extern char *dlerror(void) WEAK_IMPORT_ATTRIBUTE;
#include <mach-o/arch.h>
#include <libkern/OSByteOrder.h>
#include <mach/mach.h>
-#include <stdbool.h>
typedef struct Tcl_DyldModuleHandle {
struct Tcl_DyldModuleHandle *nextPtr;
NSModule module;
} Tcl_DyldModuleHandle;
-#endif /* TCL_DYLD_USE_NSMODULE */
+#endif /* TCL_DYLD_USE_NSMODULE || TCL_LOAD_FROM_MEMORY */
-typedef struct Tcl_DyldLoadHandle {
-#if TCL_DYLD_USE_DLFCN
+typedef struct {
void *dlHandle;
-#endif
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
const struct mach_header *dyldLibHeader;
Tcl_DyldModuleHandle *modulePtr;
#endif
} Tcl_DyldLoadHandle;
-#if (TCL_DYLD_USE_DLFCN && MAC_OS_X_VERSION_MIN_REQUIRED < 1040) || \
- defined(TCL_LOAD_FROM_MEMORY)
-MODULE_SCOPE long tclMacOSXDarwinRelease;
-#endif
-
-#ifdef TCL_DEBUG_LOAD
-#define TclLoadDbgMsg(m, ...) \
- do { \
- fprintf(stderr, "%s:%d: %s(): " m ".\n", \
- strrchr(__FILE__, '/')+1, __LINE__, __func__, \
- ##__VA_ARGS__); \
- } while (0)
-#else
-#define TclLoadDbgMsg(m, ...)
+#if TCL_DYLD_USE_DLFCN || defined(TCL_LOAD_FROM_MEMORY)
+MODULE_SCOPE long tclMacOSXDarwinRelease;
#endif
/*
@@ -102,7 +81,6 @@ static void * FindSymbol(Tcl_Interp *interp,
Tcl_LoadHandle loadHandle, const char *symbol);
static void UnloadFile(Tcl_LoadHandle handle);
-#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
/*
*----------------------------------------------------------------------
*
@@ -120,6 +98,7 @@ static void UnloadFile(Tcl_LoadHandle handle);
*----------------------------------------------------------------------
*/
+#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
static const char *
DyldOFIErrorMsg(
int err)
@@ -141,7 +120,7 @@ DyldOFIErrorMsg(
return "unknown error";
}
}
-#endif /* TCL_DYLD_USE_NSMODULE */
+#endif /* TCL_DYLD_USE_NSMODULE || TCL_LOAD_FROM_MEMORY */
/*
*----------------------------------------------------------------------
@@ -176,9 +155,7 @@ TclpDlopen(
{
Tcl_DyldLoadHandle *dyldLoadHandle;
Tcl_LoadHandle newHandle;
-#if TCL_DYLD_USE_DLFCN
void *dlHandle = NULL;
-#endif
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
const struct mach_header *dyldLibHeader = NULL;
Tcl_DyldModuleHandle *modulePtr = NULL;
@@ -187,11 +164,10 @@ TclpDlopen(
NSLinkEditErrors editError;
int errorNumber;
const char *errorName, *objFileImageErrMsg = NULL;
-#endif
+#endif /* TCL_DYLD_USE_NSMODULE */
const char *errMsg = NULL;
int result;
Tcl_DString ds;
- char *fileName = NULL;
const char *nativePath, *nativeFileName = NULL;
/*
@@ -201,46 +177,36 @@ TclpDlopen(
*/
nativePath = Tcl_FSGetNativePath(pathPtr);
+ nativeFileName = Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr),
+ -1, &ds);
#if TCL_DYLD_USE_DLFCN
-#if MAC_OS_X_VERSION_MIN_REQUIRED < 1040
- if (tclMacOSXDarwinRelease >= 8)
-#endif
- {
/*
* Use (RTLD_NOW|RTLD_LOCAL) always, see [Bug #3216070]
*/
- dlHandle = dlopen(nativePath, RTLD_NOW | RTLD_LOCAL);
- if (!dlHandle) {
- /*
- * Let the OS loader examine the binary search path for whatever
- * string the user gave us which hopefully refers to a file on the
- * binary path.
- */
- fileName = Tcl_GetString(pathPtr);
- nativeFileName = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
- /*
- * Use (RTLD_NOW|RTLD_LOCAL) always, see [Bug #3216070]
- */
- dlHandle = dlopen(nativeFileName, RTLD_NOW | RTLD_LOCAL);
- }
- if (dlHandle) {
- TclLoadDbgMsg("dlopen() successful");
- } else {
+ dlHandle = dlopen(nativePath, RTLD_NOW | RTLD_LOCAL);
+ if (!dlHandle) {
+ /*
+ * Let the OS loader examine the binary search path for whatever string
+ * the user gave us which hopefully refers to a file on the binary
+ * path.
+ *
+ * Use (RTLD_NOW|RTLD_LOCAL) always, see [Bug #3216070]
+ */
+
+ dlHandle = dlopen(nativeFileName, RTLD_NOW | RTLD_LOCAL);
+ if (!dlHandle) {
errMsg = dlerror();
- TclLoadDbgMsg("dlopen() failed: %s", errMsg);
}
}
- if (!dlHandle)
#endif /* TCL_DYLD_USE_DLFCN */
- {
+
+ if (!dlHandle) {
#if TCL_DYLD_USE_NSMODULE
dyldLibHeader = NSAddImage(nativePath,
NSADDIMAGE_OPTION_RETURN_ON_ERROR);
- if (dyldLibHeader) {
- TclLoadDbgMsg("NSAddImage() successful");
- } else {
+ if (!dyldLibHeader) {
NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg);
if (editError == NSLinkEditFileAccessError) {
/*
@@ -249,20 +215,12 @@ TclpDlopen(
* which hopefully refers to a file on the binary path.
*/
- if (!fileName) {
- fileName = Tcl_GetString(pathPtr);
- nativeFileName = Tcl_UtfToExternalDString(NULL, fileName,
- -1, &ds);
- }
dyldLibHeader = NSAddImage(nativeFileName,
NSADDIMAGE_OPTION_WITH_SEARCHING |
NSADDIMAGE_OPTION_RETURN_ON_ERROR);
- if (dyldLibHeader) {
- TclLoadDbgMsg("NSAddImage() successful");
- } else {
+ if (!dyldLibHeader) {
NSLinkEditError(&editError, &errorNumber, &errorName,
&errMsg);
- TclLoadDbgMsg("NSAddImage() failed: %s", errMsg);
}
} else if ((editError == NSLinkEditFileFormatError
&& errorNumber == EBADMACHO)
@@ -279,8 +237,6 @@ TclpDlopen(
err = NSCreateObjectFileImageFromFile(nativePath,
&dyldObjFileImage);
if (err == NSObjectFileImageSuccess && dyldObjFileImage) {
- TclLoadDbgMsg("NSCreateObjectFileImageFromFile() "
- "successful");
module = NSLinkModule(dyldObjFileImage, nativePath,
NSLINKMODULE_OPTION_BINDNOW
| NSLINKMODULE_OPTION_RETURN_ON_ERROR);
@@ -289,37 +245,29 @@ TclpDlopen(
modulePtr = ckalloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = NULL;
- TclLoadDbgMsg("NSLinkModule() successful");
} else {
NSLinkEditError(&editError, &errorNumber, &errorName,
&errMsg);
- TclLoadDbgMsg("NSLinkModule() failed: %s", errMsg);
}
} else {
objFileImageErrMsg = DyldOFIErrorMsg(err);
- TclLoadDbgMsg("NSCreateObjectFileImageFromFile() failed: "
- "%s", objFileImageErrMsg);
}
}
}
#endif /* TCL_DYLD_USE_NSMODULE */
}
- if (0
-#if TCL_DYLD_USE_DLFCN
- || dlHandle
-#endif
+
+ if (dlHandle
#if TCL_DYLD_USE_NSMODULE
|| dyldLibHeader || modulePtr
-#endif
+#endif /* TCL_DYLD_USE_NSMODULE */
) {
dyldLoadHandle = ckalloc(sizeof(Tcl_DyldLoadHandle));
-#if TCL_DYLD_USE_DLFCN
dyldLoadHandle->dlHandle = dlHandle;
-#endif
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
dyldLoadHandle->dyldLibHeader = dyldLibHeader;
dyldLoadHandle->modulePtr = modulePtr;
-#endif
+#endif /* TCL_DYLD_USE_NSMODULE || TCL_LOAD_FROM_MEMORY */
newHandle = ckalloc(sizeof(*newHandle));
newHandle->clientData = dyldLoadHandle;
newHandle->findSymbolProcPtr = &FindSymbol;
@@ -328,18 +276,23 @@ TclpDlopen(
*loadHandle = newHandle;
result = TCL_OK;
} else {
- Tcl_AppendResult(interp, errMsg, NULL);
+ Tcl_Obj *errObj = Tcl_NewObj();
+
+ if (errMsg != NULL) {
+ Tcl_AppendToObj(errObj, errMsg, -1);
+ }
#if TCL_DYLD_USE_NSMODULE
if (objFileImageErrMsg) {
- Tcl_AppendResult(interp, "\nNSCreateObjectFileImageFromFile() "
- "error: ", objFileImageErrMsg, NULL);
+ Tcl_AppendPrintfToObj(errObj,
+ "\nNSCreateObjectFileImageFromFile() error: %s",
+ objFileImageErrMsg);
}
-#endif
+#endif /* TCL_DYLD_USE_NSMODULE */
+ Tcl_SetObjResult(interp, errObj);
result = TCL_ERROR;
}
- if(fileName) {
- Tcl_DStringFree(&ds);
- }
+
+ Tcl_DStringFree(&ds);
return result;
}
@@ -372,18 +325,14 @@ FindSymbol(
const char *native;
native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
-#if TCL_DYLD_USE_DLFCN
if (dyldLoadHandle->dlHandle) {
+#if TCL_DYLD_USE_DLFCN
proc = dlsym(dyldLoadHandle->dlHandle, native);
- if (proc) {
- TclLoadDbgMsg("dlsym() successful");
- } else {
+ if (!proc) {
errMsg = dlerror();
- TclLoadDbgMsg("dlsym() failed: %s", errMsg);
}
- } else
#endif /* TCL_DYLD_USE_DLFCN */
- {
+ } else {
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
NSSymbol nsSymbol = NULL;
Tcl_DString newName;
@@ -400,13 +349,12 @@ FindSymbol(
native, NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW |
NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR);
if (nsSymbol) {
- TclLoadDbgMsg("NSLookupSymbolInImage() successful");
-#ifdef DYLD_SUPPORTS_DYLIB_UNLOADING
/*
* Until dyld supports unloading of MY_DYLIB binaries, the
* following is not needed.
*/
+#ifdef DYLD_SUPPORTS_DYLIB_UNLOADING
NSModule module = NSModuleForSymbol(nsSymbol);
Tcl_DyldModuleHandle *modulePtr = dyldLoadHandle->modulePtr;
@@ -429,32 +377,21 @@ FindSymbol(
const char *errorName;
NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg);
- TclLoadDbgMsg("NSLookupSymbolInImage() failed: %s", errMsg);
}
} else if (dyldLoadHandle->modulePtr) {
nsSymbol = NSLookupSymbolInModule(
dyldLoadHandle->modulePtr->module, native);
- if (nsSymbol) {
- TclLoadDbgMsg("NSLookupSymbolInModule() successful");
- } else {
- TclLoadDbgMsg("NSLookupSymbolInModule() failed");
- }
}
if (nsSymbol) {
proc = NSAddressOfSymbol(nsSymbol);
- if (proc) {
- TclLoadDbgMsg("NSAddressOfSymbol() successful");
- } else {
- TclLoadDbgMsg("NSAddressOfSymbol() failed");
- }
}
Tcl_DStringFree(&newName);
#endif /* TCL_DYLD_USE_NSMODULE */
}
Tcl_DStringFree(&ds);
if (errMsg && (interp != NULL)) {
- Tcl_AppendResult(interp, "cannot find symbol \"", symbol, "\": ",
- errMsg, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "cannot find symbol \"%s\": %s", symbol, errMsg));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol,
NULL);
}
@@ -489,34 +426,19 @@ UnloadFile(
{
Tcl_DyldLoadHandle *dyldLoadHandle = loadHandle->clientData;
-#if TCL_DYLD_USE_DLFCN
if (dyldLoadHandle->dlHandle) {
- int result;
-
- result = dlclose(dyldLoadHandle->dlHandle);
- if (!result) {
- TclLoadDbgMsg("dlclose() successful");
- } else {
- TclLoadDbgMsg("dlclose() failed: %s", dlerror());
- }
- } else
+#if TCL_DYLD_USE_DLFCN
+ (void) dlclose(dyldLoadHandle->dlHandle);
#endif /* TCL_DYLD_USE_DLFCN */
- {
+ } else {
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
Tcl_DyldModuleHandle *modulePtr = dyldLoadHandle->modulePtr;
while (modulePtr != NULL) {
- void *ptr;
- bool result;
+ void *ptr = modulePtr;
- result = NSUnLinkModule(modulePtr->module,
+ (void) NSUnLinkModule(modulePtr->module,
NSUNLINKMODULE_OPTION_RESET_LAZY_REFERENCES);
- if (result) {
- TclLoadDbgMsg("NSUnLinkModule() successful");
- } else {
- TclLoadDbgMsg("NSUnLinkModule() failed");
- }
- ptr = modulePtr;
modulePtr = modulePtr->nextPtr;
ckfree(ptr);
}
@@ -556,7 +478,6 @@ TclGuessPackageName(
return 0;
}
-#ifdef TCL_LOAD_FROM_MEMORY
/*
*----------------------------------------------------------------------
*
@@ -573,6 +494,7 @@ TclGuessPackageName(
*----------------------------------------------------------------------
*/
+#ifdef TCL_LOAD_FROM_MEMORY
MODULE_SCOPE void *
TclpLoadMemoryGetBuffer(
Tcl_Interp *interp, /* Used for error reporting. */
@@ -597,6 +519,7 @@ TclpLoadMemoryGetBuffer(
}
return buffer;
}
+#endif /* TCL_LOAD_FROM_MEMORY */
/*
*----------------------------------------------------------------------
@@ -616,6 +539,7 @@ TclpLoadMemoryGetBuffer(
*----------------------------------------------------------------------
*/
+#ifdef TCL_LOAD_FROM_MEMORY
MODULE_SCOPE int
TclpLoadMemory(
Tcl_Interp *interp, /* Used for error reporting. */
@@ -658,7 +582,7 @@ TclpLoadMemory(
# define mh_size sizeof(struct mach_header_64)
# define mh_magic MH_MAGIC_64
# define arch_abi CPU_ARCH_ABI64
-#endif
+#endif /* __LP64__ */
if ((size_t) codeSize >= sizeof(struct fat_header)
&& fh->magic == OSSwapHostToBigInt32(FAT_MAGIC)) {
@@ -668,7 +592,6 @@ TclpLoadMemory(
* Fat binary, try to find mach_header for our architecture
*/
- TclLoadDbgMsg("Fat binary, %d archs", fh_nfat_arch);
if ((size_t) codeSize >= sizeof(struct fat_header) +
fh_nfat_arch * sizeof(struct fat_arch)) {
void *fatarchs = (char*)buffer + sizeof(struct fat_header);
@@ -681,22 +604,15 @@ TclpLoadMemory(
fa = NXFindBestFatArch(arch->cputype | arch_abi,
arch->cpusubtype, fatarchs, fh_nfat_arch);
if (fa) {
- TclLoadDbgMsg("NXFindBestFatArch() successful: "
- "local cputype %d subtype %d, "
- "fat cputype %d subtype %d",
- arch->cputype | arch_abi, arch->cpusubtype,
- fa->cputype, fa->cpusubtype);
- mh = (void*)((char*)buffer + fa->offset);
+ mh = (void *)((char *) buffer + fa->offset);
ms = fa->size;
} else {
- TclLoadDbgMsg("NXFindBestFatArch() failed");
err = NSObjectFileImageInappropriateFile;
}
if (fh->magic != FAT_MAGIC) {
swap_fat_arch(fatarchs, fh_nfat_arch, arch->byteorder);
}
} else {
- TclLoadDbgMsg("Fat binary header failure");
err = NSObjectFileImageInappropriateFile;
}
} else {
@@ -704,26 +620,18 @@ TclpLoadMemory(
* Thin binary
*/
- TclLoadDbgMsg("Thin binary");
mh = buffer;
ms = codeSize;
}
if (ms && !(ms >= mh_size && mh->magic == mh_magic &&
mh->filetype == MH_BUNDLE)) {
- TclLoadDbgMsg("Inappropriate file: magic %x filetype %d",
- mh->magic, mh->filetype);
err = NSObjectFileImageInappropriateFile;
}
if (err == NSObjectFileImageSuccess) {
err = NSCreateObjectFileImageFromMemory(buffer, codeSize,
&dyldObjFileImage);
- if (err == NSObjectFileImageSuccess) {
- TclLoadDbgMsg("NSCreateObjectFileImageFromMemory() "
- "successful");
- } else {
+ if (err != NSObjectFileImageSuccess) {
objFileImageErrMsg = DyldOFIErrorMsg(err);
- TclLoadDbgMsg("NSCreateObjectFileImageFromMemory() failed: %s",
- objFileImageErrMsg);
}
} else {
objFileImageErrMsg = DyldOFIErrorMsg(err);
@@ -738,8 +646,9 @@ TclpLoadMemory(
if (dyldObjFileImage == NULL) {
vm_deallocate(mach_task_self(), (vm_address_t) buffer, size);
if (objFileImageErrMsg != NULL) {
- Tcl_AppendResult(interp, "NSCreateObjectFileImageFromMemory() "
- "error: ", objFileImageErrMsg, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "NSCreateObjectFileImageFromMemory() error: ",
+ objFileImageErrMsg));
}
return TCL_ERROR;
}
@@ -751,16 +660,13 @@ TclpLoadMemory(
module = NSLinkModule(dyldObjFileImage, "[Memory Based Bundle]",
NSLINKMODULE_OPTION_BINDNOW | NSLINKMODULE_OPTION_RETURN_ON_ERROR);
NSDestroyObjectFileImage(dyldObjFileImage);
- if (module) {
- TclLoadDbgMsg("NSLinkModule() successful");
- } else {
+ if (!module) {
NSLinkEditErrors editError;
int errorNumber;
const char *errorName, *errMsg;
NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg);
- TclLoadDbgMsg("NSLinkModule() failed: %s", errMsg);
- Tcl_AppendResult(interp, errMsg, NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
return TCL_ERROR;
}
@@ -772,9 +678,7 @@ TclpLoadMemory(
modulePtr->module = module;
modulePtr->nextPtr = NULL;
dyldLoadHandle = ckalloc(sizeof(Tcl_DyldLoadHandle));
-#if TCL_DYLD_USE_DLFCN
dyldLoadHandle->dlHandle = NULL;
-#endif
dyldLoadHandle->dyldLibHeader = NULL;
dyldLoadHandle->modulePtr = modulePtr;
newHandle = ckalloc(sizeof(*newHandle));
diff --git a/unix/tclLoadNext.c b/unix/tclLoadNext.c
index c74a29a..06df2db 100644
--- a/unix/tclLoadNext.c
+++ b/unix/tclLoadNext.c
@@ -16,10 +16,9 @@
/* Static procedures defined within this file */
-static void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle,
- const char* symbol);
-static void UnloadFile(Tcl_LoadHandle loadHandle);
-
+static void * FindSymbol(Tcl_Interp *interp,
+ Tcl_LoadHandle loadHandle, const char* symbol);
+static void UnloadFile(Tcl_LoadHandle loadHandle);
/*
*----------------------------------------------------------------------
@@ -93,15 +92,15 @@ TclpDlopen(
char *data;
int len, maxlen;
- NXGetMemoryBuffer(errorStream,&data,&len,&maxlen);
- Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ",
- data, NULL);
+ NXGetMemoryBuffer(errorStream, &data, &len, &maxlen);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't load file \"%s\": %s", fileName, data));
NXCloseMemory(errorStream, NX_FREEBUFFER);
return TCL_ERROR;
}
NXCloseMemory(errorStream, NX_FREEBUFFER);
- newHandle = ckalloc(sizeof(*newHandle));
+ newHandle = ckalloc(sizeof(Tcl_LoadHandle));
newHandle->clientData = INT2PTR(1);
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
@@ -127,25 +126,25 @@ TclpDlopen(
*----------------------------------------------------------------------
*/
-static void*
+static void *
FindSymbol(
Tcl_Interp *interp,
Tcl_LoadHandle loadHandle,
const char *symbol)
{
Tcl_PackageInitProc *proc = NULL;
- if (symbol) {
+
+ if (symbol) {
char sym[strlen(symbol) + 2];
sym[0] = '_';
sym[1] = 0;
strcat(sym, symbol);
- rld_lookup(NULL, sym, (unsigned long *)&proc);
+ rld_lookup(NULL, sym, (unsigned long *) &proc);
}
if (proc == NULL && interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "cannot find symbol \"", symbol,
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "cannot find symbol \"%s\"", symbol));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL);
}
return proc;
diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c
index fbd4d5f..6e76b55 100644
--- a/unix/tclLoadOSF.c
+++ b/unix/tclLoadOSF.c
@@ -35,12 +35,14 @@
#include "tclInt.h"
#include <sys/types.h>
#include <loader.h>
-
-/* Static functions defined within this file */
-static void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle,
- const char* symbol);
-static void UnloadFile(Tcl_LoadHandle handle);
+/*
+ * Static functions defined within this file.
+ */
+
+static void * FindSymbol(Tcl_Interp *interp,
+ Tcl_LoadHandle loadHandle, const char* symbol);
+static void UnloadFile(Tcl_LoadHandle handle);
/*
*----------------------------------------------------------------------
@@ -103,8 +105,9 @@ TclpDlopen(
}
if (lm == LDR_NULL_MODULE) {
- Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't load file \"%s\": %s",
+ fileName, Tcl_PosixError(interp)));
return TCL_ERROR;
}
@@ -155,10 +158,11 @@ FindSymbol(
Tcl_LoadHandle loadHandle,
const char *symbol)
{
- void* retval = ldr_lookup_package((char *)loadHandle, symbol);
+ void *retval = ldr_lookup_package((char *) loadHandle, symbol);
+
if (retval == NULL && interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "cannot find symbol\"", symbol, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "cannot find symbol \"%s\"", symbol));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL);
}
return retval;
diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c
index eddd80a..7b80bcc 100644
--- a/unix/tclLoadShl.c
+++ b/unix/tclLoadShl.c
@@ -22,14 +22,14 @@
#endif
#include "tclInt.h"
-
-/* Static functions defined within this file */
-static void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle,
- const char* symbol);
-static void
-UnloadFile(Tcl_LoadHandle handle);
+/*
+ * Static functions defined within this file.
+ */
+static void * FindSymbol(Tcl_Interp *interp,
+ Tcl_LoadHandle loadHandle, const char *symbol);
+static void UnloadFile(Tcl_LoadHandle handle);
/*
*----------------------------------------------------------------------
@@ -100,8 +100,9 @@ TclpDlopen(
}
if (handle == NULL) {
- Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't load file \"%s\": %s",
+ fileName, Tcl_PosixError(interp)));
return TCL_ERROR;
}
newHandle = ckalloc(sizeof(*newHandle));
@@ -136,7 +137,7 @@ FindSymbol(
{
Tcl_DString newName;
Tcl_PackageInitProc *proc = NULL;
- shl_t handle = (shl_t)(loadHandle->clientData);
+ shl_t handle = (shl_t) loadHandle->clientData;
/*
* Some versions of the HP system software still use "_" at the beginning
@@ -155,9 +156,9 @@ FindSymbol(
Tcl_DStringFree(&newName);
}
if (proc == NULL && interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "cannot find symbol\"", symbol, "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "cannot find symbol \"%s\": %s",
+ symbol, Tcl_PosixError(interp)));
}
return proc;
}
@@ -186,9 +187,8 @@ UnloadFile(
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
- shl_t handle;
+ shl_t handle = (shl_t) loadHandle->clientData;
- handle = (shl_t) (loadHandle -> clientData);
shl_unload(handle);
ckfree(loadHandle);
}
diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c
index 3845c44..9ee37f1 100644
--- a/unix/tclUnixChan.c
+++ b/unix/tclUnixChan.c
@@ -136,10 +136,10 @@ typedef struct TtyAttrs {
#endif /* !SUPPORTS_TTY */
#define UNSUPPORTED_OPTION(detail) \
- if (interp) { \
- Tcl_AppendResult(interp, (detail), \
- " not supported for this platform", NULL); \
- Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); \
+ if (interp) { \
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf( \
+ "%s not supported for this platform", (detail))); \
+ Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); \
}
/*
@@ -697,9 +697,9 @@ TtySetOptionProc(
return TCL_ERROR;
} else {
if (interp) {
- Tcl_AppendResult(interp, "bad value for -handshake: "
- "must be one of xonxoff, rtscts, dtrdsr or none",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad value for -handshake: must be one of"
+ " xonxoff, rtscts, dtrdsr or none", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
@@ -720,8 +720,9 @@ TtySetOptionProc(
return TCL_ERROR;
} else if (argc != 2) {
if (interp) {
- Tcl_AppendResult(interp, "bad value for -xchar: "
- "should be a list of two elements", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad value for -xchar: should be a list of"
+ " two elements", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
@@ -773,8 +774,9 @@ TtySetOptionProc(
}
if ((argc % 2) == 1) {
if (interp) {
- Tcl_AppendResult(interp, "bad value for -ttycontrol: "
- "should be a list of signal,value pairs", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad value for -ttycontrol: should be a list of"
+ " signal,value pairs", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
@@ -822,9 +824,9 @@ TtySetOptionProc(
#endif /* SETBREAK */
} else {
if (interp) {
- Tcl_AppendResult(interp, "bad signal \"", argv[i],
- "\" for -ttycontrol: must be "
- "DTR, RTS or BREAK", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad signal \"%s\" for -ttycontrol: must be"
+ " DTR, RTS or BREAK", argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
@@ -1388,8 +1390,8 @@ TtyParseMode(
stopPtr, &end);
if ((i != 4) || (mode[end] != '\0')) {
if (interp != NULL) {
- Tcl_AppendResult(interp, bad, ": should be baud,parity,data,stop",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s: should be baud,parity,data,stop", bad));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL);
}
return TCL_ERROR;
@@ -1412,13 +1414,14 @@ TtyParseMode(
#endif /* PAREXT|USE_TERMIO */
== NULL) {
if (interp != NULL) {
- Tcl_AppendResult(interp, bad, " parity: should be ",
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s parity: should be %s", bad,
#if defined(PAREXT) || defined(USE_TERMIO)
- "n, o, e, m, or s",
+ "n, o, e, m, or s"
#else
- "n, o, or e",
+ "n, o, or e"
#endif /* PAREXT|USE_TERMIO */
- NULL);
+ ));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL);
}
return TCL_ERROR;
@@ -1426,15 +1429,16 @@ TtyParseMode(
*parityPtr = parity;
if ((*dataPtr < 5) || (*dataPtr > 8)) {
if (interp != NULL) {
- Tcl_AppendResult(interp, bad, " data: should be 5, 6, 7, or 8",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s data: should be 5, 6, 7, or 8", bad));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL);
}
return TCL_ERROR;
}
if ((*stopPtr < 0) || (*stopPtr > 2)) {
if (interp != NULL) {
- Tcl_AppendResult(interp, bad, " stop: should be 1 or 2", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s stop: should be 1 or 2", bad));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL);
}
return TCL_ERROR;
@@ -1583,8 +1587,9 @@ TclpOpenFileChannel(
if (fd < 0) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr),
- "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't open \"%s\": %s",
+ TclGetString(pathPtr), Tcl_PosixError(interp)));
}
return NULL;
}
@@ -1842,15 +1847,15 @@ Tcl_GetOpenFile(
if (chan == NULL) {
return TCL_ERROR;
}
- if ((forWriting) && ((chanMode & TCL_WRITABLE) == 0)) {
- Tcl_AppendResult(interp, "\"", chanID, "\" wasn't opened for writing",
- NULL);
+ if (forWriting && !(chanMode & TCL_WRITABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" wasn't opened for writing", chanID));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NOT_WRITABLE",
NULL);
return TCL_ERROR;
- } else if ((!forWriting) && ((chanMode & TCL_READABLE) == 0)) {
- Tcl_AppendResult(interp, "\"", chanID, "\" wasn't opened for reading",
- NULL);
+ } else if (!forWriting && !(chanMode & TCL_READABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" wasn't opened for reading", chanID));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NOT_READABLE",
NULL);
return TCL_ERROR;
@@ -1881,8 +1886,8 @@ Tcl_GetOpenFile(
f = fdopen(fd, (forWriting ? "w" : "r"));
if (f == NULL) {
- Tcl_AppendResult(interp, "cannot get a FILE * for \"", chanID,
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "cannot get a FILE * for \"%s\"", chanID));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL",
"FILE_FAILURE", NULL);
return TCL_ERROR;
@@ -1892,8 +1897,8 @@ Tcl_GetOpenFile(
}
}
- Tcl_AppendResult(interp, "\"", chanID,
- "\" cannot be used to get a FILE *", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" cannot be used to get a FILE *", chanID));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NO_DESCRIPTOR",
NULL);
return TCL_ERROR;
diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c
index 3818121..359e253 100644
--- a/unix/tclUnixCompat.c
+++ b/unix/tclUnixCompat.c
@@ -364,7 +364,7 @@ TclpGetGrNam(
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-#ifdef HAVE_GETGRNAM_R_5
+#if defined(HAVE_GETGRNAM_R_5)
struct group *grPtr = NULL;
/*
diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c
index a695e9c..d3cc6bf 100644
--- a/unix/tclUnixFCmd.c
+++ b/unix/tclUnixFCmd.c
@@ -1320,9 +1320,9 @@ GetGroupAttribute(
if (result != 0) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "could not read \"",
- TclGetString(fileName), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read \"%s\": %s",
+ TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -1374,9 +1374,9 @@ GetOwnerAttribute(
if (result != 0) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "could not read \"",
- TclGetString(fileName), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read \"%s\": %s",
+ TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -1425,9 +1425,9 @@ GetPermissionsAttribute(
if (result != 0) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "could not read \"",
- TclGetString(fileName), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read \"%s\": %s",
+ TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -1478,9 +1478,10 @@ SetGroupAttribute(
if (groupPtr == NULL) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "could not set group for file \"",
- TclGetString(fileName), "\": group \"", string,
- "\" does not exist", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not set group for file \"%s\":"
+ " group \"%s\" does not exist",
+ TclGetString(fileName), string));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SETGRP",
"NO_GROUP", NULL);
}
@@ -1494,9 +1495,9 @@ SetGroupAttribute(
if (result != 0) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "could not set group for file \"",
- TclGetString(fileName), "\": ", Tcl_PosixError(interp),
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not set group for file \"%s\": %s",
+ TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -1544,9 +1545,10 @@ SetOwnerAttribute(
if (pwPtr == NULL) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "could not set owner for file \"",
- TclGetString(fileName), "\": user \"", string,
- "\" does not exist", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not set owner for file \"%s\":"
+ " user \"%s\" does not exist",
+ TclGetString(fileName), string));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SETOWN",
"NO_USER", NULL);
}
@@ -1560,9 +1562,9 @@ SetOwnerAttribute(
if (result != 0) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "could not set owner for file \"",
- TclGetString(fileName), "\": ", Tcl_PosixError(interp),
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not set owner for file \"%s\": %s",
+ TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -1630,9 +1632,9 @@ SetPermissionsAttribute(
result = TclpObjStat(fileName, &buf);
if (result != 0) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "could not read \"",
- TclGetString(fileName), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read \"%s\": %s",
+ TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -1640,8 +1642,9 @@ SetPermissionsAttribute(
if (GetModeFromPermString(NULL, modeStringPtr, &newMode) != TCL_OK) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "unknown permission string format \"",
- modeStringPtr, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown permission string format \"%s\"",
+ modeStringPtr));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PERMISSION", NULL);
}
return TCL_ERROR;
@@ -1652,9 +1655,9 @@ SetPermissionsAttribute(
result = chmod(native, newMode); /* INTL: Native. */
if (result != 0) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "could not set permissions for file \"",
- TclGetString(fileName), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not set permissions for file \"%s\": %s",
+ TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -2239,14 +2242,14 @@ GetReadOnlyAttribute(
if (result != 0) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "could not read \"",
- TclGetString(fileName), "\": ", Tcl_PosixError(interp),
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read \"%s\": %s",
+ TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
- *attributePtrPtr = Tcl_NewBooleanObj((statBuf.st_flags&UF_IMMUTABLE) != 0);
+ *attributePtrPtr = Tcl_NewBooleanObj(statBuf.st_flags&UF_IMMUTABLE);
return TCL_OK;
}
@@ -2286,9 +2289,9 @@ SetReadOnlyAttribute(
if (result != 0) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "could not read \"",
- TclGetString(fileName), "\": ", Tcl_PosixError(interp),
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read \"%s\": %s",
+ TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -2303,9 +2306,9 @@ SetReadOnlyAttribute(
result = chflags(native, statBuf.st_flags); /* INTL: Native. */
if (result != 0) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "could not set flags for file \"",
- TclGetString(fileName), "\": ", Tcl_PosixError(interp),
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not set flags for file \"%s\": %s",
+ TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c
index c213050..38504d9 100644
--- a/unix/tclUnixFile.c
+++ b/unix/tclUnixFile.c
@@ -310,10 +310,9 @@ TclpMatchInDirectory(
if (d == NULL) {
Tcl_DStringFree(&ds);
if (interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "couldn't read directory \"",
- Tcl_DStringValue(&dsOrig), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't read directory \"%s\": %s",
+ Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp)));
}
Tcl_DStringFree(&dsOrig);
Tcl_DecrRefCount(fileNamePtr);
@@ -471,7 +470,7 @@ NativeMatchType(
#ifndef MAC_OSX_TCL
|| ((types->perm & TCL_GLOB_PERM_HIDDEN) &&
(*nativeName != '.'))
-#endif
+#endif /* MAC_OSX_TCL */
) {
return 0;
}
@@ -489,12 +488,10 @@ NativeMatchType(
* check that here:
*/
- if (types->type & TCL_GLOB_TYPE_LINK) {
- if (TclOSlstat(nativeEntry, &buf) == 0) {
- if (S_ISLNK(buf.st_mode)) {
- return 1;
- }
- }
+ if ((types->type & TCL_GLOB_TYPE_LINK)
+ && (TclOSlstat(nativeEntry, &buf) == 0)
+ && S_ISLNK(buf.st_mode)) {
+ return 1;
}
return 0;
}
@@ -517,12 +514,10 @@ NativeMatchType(
*/
} else {
#ifdef S_ISLNK
- if (types->type & TCL_GLOB_TYPE_LINK) {
- if (TclOSlstat(nativeEntry, &buf) == 0) {
- if (S_ISLNK(buf.st_mode)) {
- goto filetypeOK;
- }
- }
+ if ((types->type & TCL_GLOB_TYPE_LINK)
+ && (TclOSlstat(nativeEntry, &buf) == 0)
+ && S_ISLNK(buf.st_mode)) {
+ goto filetypeOK;
}
#endif /* S_ISLNK */
return 0;
@@ -718,9 +713,9 @@ TclpGetNativeCwd(
if (getcwd(buffer, MAXPATHLEN+1) == NULL) { /* INTL: Native. */
return NULL;
}
-#endif
+#endif /* USEGETWD */
- if ((clientData == NULL) || strcmp(buffer, (const char*)clientData)) {
+ if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) {
char *newCd = ckalloc(strlen(buffer) + 1);
strcpy(newCd, buffer);
@@ -768,12 +763,12 @@ TclpGetCwd(
if (getwd(buffer) == NULL) /* INTL: Native. */
#else
if (getcwd(buffer, MAXPATHLEN+1) == NULL) /* INTL: Native. */
-#endif
+#endif /* USEGETWD */
{
if (interp != NULL) {
- Tcl_AppendResult(interp,
- "error getting working directory name: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error getting working directory name: %s",
+ Tcl_PosixError(interp)));
}
return NULL;
}
@@ -824,7 +819,7 @@ TclpReadlink(
return Tcl_DStringValue(linkPtr);
#else
return NULL;
-#endif
+#endif /* !DJGPP */
}
/*
@@ -858,7 +853,7 @@ TclpObjStat(
#ifdef S_IFLNK
-Tcl_Obj*
+Tcl_Obj *
TclpObjLink(
Tcl_Obj *pathPtr,
Tcl_Obj *toPtr,
@@ -1180,10 +1175,17 @@ TclpUtime(
{
return utime(Tcl_FSGetNativePath(pathPtr), tval);
}
+
#ifdef __CYGWIN__
-int TclOSstat(const char *name, Tcl_StatBuf *statBuf) {
+
+int
+TclOSstat(
+ const char *name,
+ Tcl_StatBuf *statBuf)
+{
struct stat buf;
int result = stat(name, &buf);
+
statBuf->st_mode = buf.st_mode;
statBuf->st_ino = buf.st_ino;
statBuf->st_dev = buf.st_dev;
@@ -1197,9 +1199,15 @@ int TclOSstat(const char *name, Tcl_StatBuf *statBuf) {
statBuf->st_ctime = buf.st_ctime;
return result;
}
-int TclOSlstat(const char *name, Tcl_StatBuf *statBuf) {
+
+int
+TclOSlstat(
+ const char *name,
+ Tcl_StatBuf *statBuf)
+{
struct stat buf;
int result = lstat(name, &buf);
+
statBuf->st_mode = buf.st_mode;
statBuf->st_ino = buf.st_ino;
statBuf->st_dev = buf.st_dev;
@@ -1213,7 +1221,7 @@ int TclOSlstat(const char *name, Tcl_StatBuf *statBuf) {
statBuf->st_ctime = buf.st_ctime;
return result;
}
-#endif
+#endif /* CYGWIN */
/*
* Local Variables:
diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c
index c1bc430..b87af1b 100644
--- a/unix/tclUnixNotfy.c
+++ b/unix/tclUnixNotfy.c
@@ -96,7 +96,7 @@ typedef struct ThreadSpecificData {
* that an event is ready to be processed
* by sending this event. */
void *hwnd; /* Messaging window. */
-#else /* !__CYGWIN__ */
+#else
Tcl_Condition waitCV; /* Any other thread alerts a notifier that an
* event is ready to be processed by signaling
* this condition variable. */
@@ -104,7 +104,7 @@ typedef struct ThreadSpecificData {
int eventReady; /* True if an event is ready to be processed.
* Used as condition flag together with waitCV
* above. */
-#endif
+#endif /* TCL_THREADS */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
@@ -187,25 +187,12 @@ static Tcl_ThreadId notifierThread;
static void NotifierThreadProc(ClientData clientData);
#endif
static int FileHandlerEventProc(Tcl_Event *evPtr, int flags);
-
+
/*
- *----------------------------------------------------------------------
- *
- * Tcl_InitNotifier --
- *
- * Initializes the platform specific notifier state.
- *
- * Results:
- * Returns a handle to the notifier state for this thread.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
+ * Import of Windows API when building threaded with Cygwin.
*/
#if defined(TCL_THREADS) && defined(__CYGWIN__)
-
typedef struct {
void *hwnd;
unsigned int *message;
@@ -217,34 +204,60 @@ typedef struct {
} MSG;
typedef struct {
- unsigned int style;
- void *lpfnWndProc;
- int cbClsExtra;
- int cbWndExtra;
- void *hInstance;
- void *hIcon;
- void *hCursor;
- void *hbrBackground;
- void *lpszMenuName;
- void *lpszClassName;
+ unsigned int style;
+ void *lpfnWndProc;
+ int cbClsExtra;
+ int cbWndExtra;
+ void *hInstance;
+ void *hIcon;
+ void *hCursor;
+ void *hbrBackground;
+ void *lpszMenuName;
+ void *lpszClassName;
} WNDCLASS;
-extern unsigned char __stdcall PeekMessageW(MSG *, void *, int, int, int);
-extern unsigned char __stdcall GetMessageW(MSG *, void *, int, int);
-extern unsigned char __stdcall TranslateMessage(const MSG *);
-extern int __stdcall DispatchMessageW(const MSG *);
-extern void __stdcall PostQuitMessage(int);
-extern void * __stdcall CreateWindowExW(void *, void *, void *, DWORD, int, int, int, int, void *, void *, void *, void *);
-extern unsigned char __stdcall DestroyWindow(void *);
-extern unsigned char __stdcall PostMessageW(void *, unsigned int, void *, void *);
-extern void *__stdcall RegisterClassW(const WNDCLASS *);
-extern DWORD __stdcall DefWindowProcW(void *, int, void *, void *);
-extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char, void *);
-extern void __stdcall CloseHandle(void *);
-extern void __stdcall MsgWaitForMultipleObjects(DWORD, void *, unsigned char, DWORD, DWORD);
-extern unsigned char __stdcall ResetEvent(void *);
+extern void __stdcall CloseHandle(void *);
+extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char,
+ void *);
+extern void * __stdcall CreateWindowExW(void *, void *, void *, DWORD, int,
+ int, int, int, void *, void *, void *, void *);
+extern DWORD __stdcall DefWindowProcW(void *, int, void *, void *);
+extern unsigned char __stdcall DestroyWindow(void *);
+extern int __stdcall DispatchMessageW(const MSG *);
+extern unsigned char __stdcall GetMessageW(MSG *, void *, int, int);
+extern void __stdcall MsgWaitForMultipleObjects(DWORD, void *,
+ unsigned char, DWORD, DWORD);
+extern unsigned char __stdcall PeekMessageW(MSG *, void *, int, int, int);
+extern unsigned char __stdcall PostMessageW(void *, unsigned int, void *,
+ void *);
+extern void __stdcall PostQuitMessage(int);
+extern void *__stdcall RegisterClassW(const WNDCLASS *);
+extern unsigned char __stdcall ResetEvent(void *);
+extern unsigned char __stdcall TranslateMessage(const MSG *);
-#endif
+/*
+ * Threaded-cygwin specific functions in this file:
+ */
+
+static DWORD __stdcall NotifierProc(void *hwnd, unsigned int message,
+ void *wParam, void *lParam);
+#endif /* TCL_THREADS && __CYGWIN__ */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_InitNotifier --
+ *
+ * Initializes the platform specific notifier state.
+ *
+ * Results:
+ * Returns a handle to the notifier state for this thread.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
ClientData
Tcl_InitNotifier(void)
@@ -403,11 +416,11 @@ Tcl_AlertNotifier(
Tcl_MutexLock(&notifierMutex);
tsdPtr->eventReady = 1;
-#ifdef __CYGWIN__
+# ifdef __CYGWIN__
PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
-#else
+# else
Tcl_ConditionNotify(&tsdPtr->waitCV);
-#endif
+# endif /* __CYGWIN__ */
Tcl_MutexUnlock(&notifierMutex);
#endif /* TCL_THREADS */
}
@@ -732,12 +745,12 @@ NotifierProc(
* Process all of the runnable events.
*/
- tsdPtr->eventReady = 1;
+ tsdPtr->eventReady = 1;
Tcl_ServiceAll();
return 0;
}
-#endif /* __CYGWIN__ */
-
+#endif /* TCL_THREADS && __CYGWIN__ */
+
/*
*----------------------------------------------------------------------
*
@@ -768,9 +781,9 @@ Tcl_WaitForEvent(
Tcl_Time vTime;
#ifdef TCL_THREADS
int waitForFiles;
-# ifdef __CYGWIN__
- MSG msg;
-# endif
+# ifdef __CYGWIN__
+ MSG msg;
+# endif /* __CYGWIN__ */
#else
/*
* Impl. notes: timeout & timeoutPtr are used if, and only if threads
@@ -792,8 +805,8 @@ Tcl_WaitForEvent(
if (timePtr != NULL) {
/*
* TIP #233 (Virtualized Time). Is virtual time in effect? And do
- * we actually have something to scale? If yes to both then we call
- * the handler to do this scaling.
+ * we actually have something to scale? If yes to both then we
+ * call the handler to do this scaling.
*/
if (timePtr->sec != 0 || timePtr->usec != 0) {
@@ -807,17 +820,17 @@ Tcl_WaitForEvent(
timeoutPtr = &timeout;
} else if (tsdPtr->numFdBits == 0) {
/*
- * If there are no threads, no timeout, and no fds registered, then
- * there are no events possible and we must avoid deadlock. Note
- * that this is not entirely correct because there might be a
- * signal that could interrupt the select call, but we don't handle
- * that case if we aren't using threads.
+ * If there are no threads, no timeout, and no fds registered,
+ * then there are no events possible and we must avoid deadlock.
+ * Note that this is not entirely correct because there might be a
+ * signal that could interrupt the select call, but we don't
+ * handle that case if we aren't using threads.
*/
return -1;
} else {
timeoutPtr = NULL;
-#endif /* TCL_THREADS */
+#endif /* !TCL_THREADS */
}
#ifdef TCL_THREADS
@@ -828,7 +841,7 @@ Tcl_WaitForEvent(
#ifdef __CYGWIN__
if (!tsdPtr->hwnd) {
- WNDCLASS class;
+ WNDCLASS class;
class.style = 0;
class.cbClsExtra = 0;
@@ -842,24 +855,24 @@ Tcl_WaitForEvent(
class.hCursor = NULL;
RegisterClassW(&class);
- tsdPtr->hwnd = CreateWindowExW(NULL, class.lpszClassName, class.lpszClassName,
- 0, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL);
+ tsdPtr->hwnd = CreateWindowExW(NULL, class.lpszClassName,
+ class.lpszClassName, 0, 0, 0, 0, 0, NULL, NULL,
+ TclWinGetTclInstance(), NULL);
tsdPtr->event = CreateEventW(NULL, 1 /* manual */,
0 /* !signaled */, NULL);
- }
-
-#endif
+ }
+#endif /* __CYGWIN */
Tcl_MutexLock(&notifierMutex);
if (timePtr != NULL && timePtr->sec == 0 && (timePtr->usec == 0
#if defined(__APPLE__) && defined(__LP64__)
/*
- * On 64-bit Darwin, pthread_cond_timedwait() appears to have a
- * bug that causes it to wait forever when passed an absolute
- * time which has already been exceeded by the system time; as
- * a workaround, when given a very brief timeout, just do a
- * poll. [Bug 1457797]
+ * On 64-bit Darwin, pthread_cond_timedwait() appears to have
+ * a bug that causes it to wait forever when passed an
+ * absolute time which has already been exceeded by the system
+ * time; as a workaround, when given a very brief timeout,
+ * just do a poll. [Bug 1457797]
*/
|| timePtr->usec < 10
#endif /* __APPLE__ && __LP64__ */
@@ -883,8 +896,8 @@ Tcl_WaitForEvent(
if (waitForFiles) {
/*
* Add the ThreadSpecificData structure of this thread to the list
- * of ThreadSpecificData structures of all threads that are waiting
- * on file events.
+ * of ThreadSpecificData structures of all threads that are
+ * waiting on file events.
*/
tsdPtr->nextPtr = waitingListPtr;
@@ -895,7 +908,7 @@ Tcl_WaitForEvent(
waitingListPtr = tsdPtr;
tsdPtr->onList = 1;
- if (write(triggerPipe, "", 1) != 1) {
+ if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) {
Tcl_Panic("Tcl_WaitForEvent: %s",
"unable to write to triggerPipe");
}
@@ -909,6 +922,7 @@ Tcl_WaitForEvent(
#ifdef __CYGWIN__
if (!PeekMessageW(&msg, NULL, 0, 0, 0)) {
DWORD timeout;
+
if (timePtr) {
timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
} else {
@@ -920,7 +934,7 @@ Tcl_WaitForEvent(
}
#else
Tcl_ConditionWait(&tsdPtr->waitCV, &notifierMutex, timePtr);
-#endif
+#endif /* __CYGWIN__ */
}
tsdPtr->eventReady = 0;
@@ -929,17 +943,20 @@ Tcl_WaitForEvent(
/*
* Retrieve and dispatch the message.
*/
+
DWORD result = GetMessageW(&msg, NULL, 0, 0);
+
if (result == 0) {
PostQuitMessage(msg.wParam);
/* What to do here? */
- } else if (result != (DWORD)-1) {
+ } else if (result != (DWORD) -1) {
TranslateMessage(&msg);
DispatchMessageW(&msg);
}
}
ResetEvent(tsdPtr->event);
-#endif
+#endif /* __CYGWIN__ */
+
if (waitForFiles && tsdPtr->onList) {
/*
* Remove the ThreadSpecificData structure of this thread from the
@@ -958,7 +975,7 @@ Tcl_WaitForEvent(
}
tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
tsdPtr->onList = 0;
- if (write(triggerPipe, "", 1) != 1) {
+ if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) {
Tcl_Panic("Tcl_WaitForEvent: %s",
"unable to write to triggerPipe");
}
@@ -1211,9 +1228,9 @@ NotifierThreadProc(
tsdPtr->pollState = 0;
}
#ifdef __CYGWIN__
- PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
-#else /* __CYGWIN__ */
- Tcl_ConditionNotify(&tsdPtr->waitCV);
+ PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
+#else
+ Tcl_ConditionNotify(&tsdPtr->waitCV);
#endif /* __CYGWIN__ */
}
}
@@ -1255,7 +1272,7 @@ NotifierThreadProc(
}
#endif /* TCL_THREADS */
-#endif /* HAVE_COREFOUNDATION */
+#endif /* !HAVE_COREFOUNDATION */
/*
* Local Variables:
diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c
index d01624c..654c9d8 100644
--- a/unix/tclUnixPipe.c
+++ b/unix/tclUnixPipe.c
@@ -211,7 +211,7 @@ TclpCreateTempFile(
if (contents != NULL) {
native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring);
- if (write(fd, native, strlen(native)) == -1) {
+ if (write(fd, native, Tcl_DStringLength(&dstring)) == -1) {
close(fd);
Tcl_DStringFree(&dstring);
return NULL;
@@ -267,35 +267,34 @@ TclpTempFileName(void)
}
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------------
*
* TclpTempFileNameForLibrary --
*
- * Constructs a file name in the native file system where a
- * dynamically loaded library may be placed.
+ * Constructs a file name in the native file system where a dynamically
+ * loaded library may be placed.
*
* Results:
- * Returns the constructed file name. If an error occurs,
- * returns NULL and leaves an error message in the interpreter
- * result.
+ * Returns the constructed file name. If an error occurs, returns NULL
+ * and leaves an error message in the interpreter result.
*
- * On Unix, it works to load a shared object from a file of any
- * name, so this function is merely a thin wrapper around
- * TclpTempFileName().
+ * On Unix, it works to load a shared object from a file of any name, so this
+ * function is merely a thin wrapper around TclpTempFileName().
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------------
*/
-Tcl_Obj*
-TclpTempFileNameForLibrary(Tcl_Interp* interp, /* Tcl interpreter */
- Tcl_Obj* path) /* Path name of the library
- * in the VFS */
+Tcl_Obj *
+TclpTempFileNameForLibrary(
+ Tcl_Interp *interp, /* Tcl interpreter. */
+ Tcl_Obj *path) /* Path name of the library in the VFS. */
{
- Tcl_Obj* retval;
- retval = TclpTempFileName();
+ Tcl_Obj *retval = TclpTempFileName();
+
if (retval == NULL) {
- Tcl_AppendResult(interp, "couldn't create temporary file: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't create temporary file: %s",
+ Tcl_PosixError(interp)));
}
return retval;
}
@@ -442,8 +441,8 @@ TclpCreateProcess(
*/
if (TclpCreatePipe(&errPipeIn, &errPipeOut) == 0) {
- Tcl_AppendResult(interp, "couldn't create pipe: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't create pipe: %s", Tcl_PosixError(interp)));
goto error;
}
@@ -463,8 +462,9 @@ TclpCreateProcess(
/*
* After vfork(), do not call code in the child that changes global state,
* because it is using the parent's memory space at that point and writes
- * might corrupt the parent: so ensure standard channels are initialized in
- * the parent, otherwise SetupStdFile() might initialize them in the child.
+ * might corrupt the parent: so ensure standard channels are initialized
+ * in the parent, otherwise SetupStdFile() might initialize them in the
+ * child.
*/
if (!inputFile) {
@@ -495,7 +495,7 @@ TclpCreateProcess(
|| (joinThisError &&
((dup2(1,2) == -1) || (fcntl(2, F_SETFD, 0) != 0)))) {
sprintf(errSpace,
- "%dforked process couldn't set up input/output: ", errno);
+ "%dforked process couldn't set up input/output", errno);
len = strlen(errSpace);
if (len != (size_t) write(fd, errSpace, len)) {
Tcl_Panic("TclpCreateProcess: unable to write to errPipeOut");
@@ -509,11 +509,11 @@ TclpCreateProcess(
RestoreSignals();
execvp(newArgv[0], newArgv); /* INTL: Native. */
- sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, argv[0]);
+ sprintf(errSpace, "%dcouldn't execute \"%.150s\"", errno, argv[0]);
len = strlen(errSpace);
- if (len != (size_t) write(fd, errSpace, len)) {
+ if (len != (size_t) write(fd, errSpace, len)) {
Tcl_Panic("TclpCreateProcess: unable to write to errPipeOut");
- }
+ }
_exit(1);
}
@@ -528,8 +528,8 @@ TclpCreateProcess(
TclStackFree(interp, dsArray);
if (pid == -1) {
- Tcl_AppendResult(interp, "couldn't fork child process: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't fork child process: %s", Tcl_PosixError(interp)));
goto error;
}
@@ -546,9 +546,11 @@ TclpCreateProcess(
count = read(fd, errSpace, (size_t) (sizeof(errSpace) - 1));
if (count > 0) {
char *end;
+
errSpace[count] = 0;
errno = strtol(errSpace, &end, 10);
- Tcl_AppendResult(interp, end, Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s: %s",
+ end, Tcl_PosixError(interp)));
goto error;
}
@@ -832,8 +834,8 @@ Tcl_CreatePipe(
int fileNums[2];
if (pipe(fileNums) < 0) {
- Tcl_AppendResult(interp, "pipe creation failed: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("pipe creation failed: %s",
+ Tcl_PosixError(interp)));
return TCL_ERROR;
}
@@ -874,8 +876,8 @@ TclGetAndDetachPids(
{
PipeState *pipePtr;
const Tcl_ChannelType *chanTypePtr;
+ Tcl_Obj *pidsObj;
int i;
- char buf[TCL_INTEGER_SPACE];
/*
* Punt if the channel is not a command channel.
@@ -886,12 +888,14 @@ TclGetAndDetachPids(
return;
}
- pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan);
+ pipePtr = Tcl_GetChannelInstanceData(chan);
+ TclNewObj(pidsObj);
for (i = 0; i < pipePtr->numPids; i++) {
- TclFormatInt(buf, (long) TclpGetPid(pipePtr->pidPtr[i]));
- Tcl_AppendElement(interp, buf);
- Tcl_DetachPids(1, &(pipePtr->pidPtr[i]));
+ Tcl_ListObjAppendElement(NULL, pidsObj, Tcl_NewIntObj(
+ PTR2INT(pipePtr->pidPtr[i])));
+ Tcl_DetachPids(1, &pipePtr->pidPtr[i]);
}
+ Tcl_SetObjResult(interp, pidsObj);
if (pipePtr->numPids > 0) {
ckfree(pipePtr->pidPtr);
pipePtr->numPids = 0;
@@ -1275,7 +1279,7 @@ Tcl_PidObjCmd(
Tcl_Channel chan;
PipeState *pipePtr;
int i;
- Tcl_Obj *resultPtr, *longObjPtr;
+ Tcl_Obj *resultPtr;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
@@ -1301,11 +1305,11 @@ Tcl_PidObjCmd(
* Extract the process IDs from the pipe structure.
*/
- pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan);
+ pipePtr = Tcl_GetChannelInstanceData(chan);
resultPtr = Tcl_NewObj();
for (i = 0; i < pipePtr->numPids; i++) {
- longObjPtr = Tcl_NewLongObj((long) TclpGetPid(pipePtr->pidPtr[i]));
- Tcl_ListObjAppendElement(NULL, resultPtr, longObjPtr);
+ Tcl_ListObjAppendElement(NULL, resultPtr,
+ Tcl_NewIntObj(PTR2INT(TclpGetPid(pipePtr->pidPtr[i]))));
}
Tcl_SetObjResult(interp, resultPtr);
}
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index 1e9d4eb..102c620 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -21,10 +21,10 @@
#define CLEAR_BITS(var, bits) ((var) &= ~(bits))
/* "sock" + a pointer in hex + \0 */
-#define SOCK_CHAN_LENGTH 4 + sizeof(void*) * 2 + 1
-#define SOCK_TEMPLATE "sock%lx"
+#define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1)
+#define SOCK_TEMPLATE "sock%lx"
-#undef SOCKET /* Possible conflict with win32 SOCKET */
+#undef SOCKET /* Possible conflict with win32 SOCKET */
/*
* This is needed to comply with the strict aliasing rules of GCC, but it also
@@ -58,19 +58,23 @@ struct TcpState {
/*
* Only needed for server sockets
*/
- Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */
- ClientData acceptProcData; /* The data for the accept proc. */
+
+ Tcl_TcpAcceptProc *acceptProc;
+ /* Proc to call on accept. */
+ ClientData acceptProcData; /* The data for the accept proc. */
+
/*
* Only needed for client sockets
*/
- struct addrinfo *addrlist; /* addresses to connect to */
- struct addrinfo *addr; /* iterator over addrlist */
- struct addrinfo *myaddrlist; /* local address */
- struct addrinfo *myaddr; /* iterator over myaddrlist */
- int filehandlers; /* Caches FileHandlers that get set up while
- * an async socket is not yet connected */
- int status; /* Cache status of async socket */
- int cachedBlocking; /* Cache blocking mode of async socket */
+
+ struct addrinfo *addrlist; /* Addresses to connect to. */
+ struct addrinfo *addr; /* Iterator over addrlist. */
+ struct addrinfo *myaddrlist;/* Local address. */
+ struct addrinfo *myaddr; /* Iterator over myaddrlist. */
+ int filehandlers; /* Caches FileHandlers that get set up while
+ * an async socket is not yet connected. */
+ int status; /* Cache status of async socket. */
+ int cachedBlocking; /* Cache blocking mode of async socket. */
};
/*
@@ -90,9 +94,7 @@ struct TcpState {
#ifndef SOMAXCONN
# define SOMAXCONN 100
-#endif /* SOMAXCONN */
-
-#if (SOMAXCONN < 100)
+#elif (SOMAXCONN < 100)
# undef SOMAXCONN
# define SOMAXCONN 100
#endif /* SOMAXCONN < 100 */
@@ -217,7 +219,7 @@ InitializeHostName(
if (native == NULL) {
native = tclEmptyStringRep;
}
-#else
+#else /* !NO_UNAME */
/*
* Uname doesn't exist; try gethostname instead.
*
@@ -242,7 +244,7 @@ InitializeHostName(
if (gethostname(buffer, sizeof(buffer)) > -1) { /* INTL: Native. */
native = buffer;
}
-#endif
+#endif /* NO_UNAME */
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
*lengthPtr = strlen(native);
@@ -344,7 +346,7 @@ TcpBlockModeProc(
* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
- TcpState *statePtr = (TcpState *) instanceData;
+ TcpState *statePtr = instanceData;
if (mode == TCL_MODE_BLOCKING) {
CLEAR_BITS(statePtr->flags, TCP_ASYNC_SOCKET);
@@ -443,7 +445,7 @@ TcpInputProc(
* buffer? */
int *errorCodePtr) /* Where to store error code. */
{
- TcpState *statePtr = (TcpState *) instanceData;
+ TcpState *statePtr = instanceData;
int bytesRead;
*errorCodePtr = 0;
@@ -493,7 +495,7 @@ TcpOutputProc(
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
- TcpState *statePtr = (TcpState *) instanceData;
+ TcpState *statePtr = instanceData;
int written;
*errorCodePtr = 0;
@@ -532,7 +534,7 @@ TcpCloseProc(
ClientData instanceData, /* The socket to close. */
Tcl_Interp *interp) /* For error reporting - unused. */
{
- TcpState *statePtr = (TcpState *) instanceData;
+ TcpState *statePtr = instanceData;
int errorCode = 0;
TcpFdList *fds;
@@ -593,7 +595,7 @@ TcpClose2Proc(
Tcl_Interp *interp, /* For error reporting. */
int flags) /* Flags that indicate which side to close. */
{
- TcpState *statePtr = (TcpState *) instanceData;
+ TcpState *statePtr = instanceData;
int errorCode = 0;
int sd;
@@ -610,8 +612,8 @@ TcpClose2Proc(
break;
default:
if (interp) {
- Tcl_AppendResult(interp,
- "Socket close2proc called bidirectionally", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "socket close2proc called bidirectionally", -1));
}
return TCL_ERROR;
}
@@ -653,7 +655,7 @@ TcpGetOptionProc(
Tcl_DString *dsPtr) /* Where to store the computed value;
* initialized by caller. */
{
- TcpState *statePtr = (TcpState *) instanceData;
+ TcpState *statePtr = instanceData;
char host[NI_MAXHOST], port[NI_MAXSERV];
size_t len = 0;
int reverseDNS = 0;
@@ -670,7 +672,7 @@ TcpGetOptionProc(
if (statePtr->status == 0) {
ret = getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR,
- (char *)&err, &optlen);
+ (char *) &err, &optlen);
if (ret < 0) {
err = errno;
}
@@ -688,9 +690,8 @@ TcpGetOptionProc(
reverseDNS = NI_NUMERICHOST;
}
- if ((len == 0) ||
- ((len > 1) && (optionName[1] == 'p') &&
- (strncmp(optionName, "-peername", len) == 0))) {
+ if ((len == 0) || ((len > 1) && (optionName[1] == 'p') &&
+ (strncmp(optionName, "-peername", len) == 0))) {
address peername;
socklen_t size = sizeof(peername);
@@ -721,16 +722,16 @@ TcpGetOptionProc(
if (len) {
if (interp) {
- Tcl_AppendResult(interp, "can't get peername: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't get peername: %s",
+ Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
}
}
- if ((len == 0) ||
- ((len > 1) && (optionName[1] == 's') &&
+ if ((len == 0) || ((len > 1) && (optionName[1] == 's') &&
(strncmp(optionName, "-sockname", len) == 0))) {
TcpFdList *fds;
address sockname;
@@ -772,7 +773,7 @@ TcpGetOptionProc(
sockname.sa6.sin6_addr.s6_addr[15] == 0)) {
flags |= NI_NUMERICHOST;
}
-#endif
+#endif /* NEED_FAKE_RFC2553 */
}
getnameinfo(&sockname.sa, size, host, sizeof(host), port,
sizeof(port), flags);
@@ -787,8 +788,8 @@ TcpGetOptionProc(
Tcl_DStringEndSublist(dsPtr);
} else {
if (interp) {
- Tcl_AppendResult(interp, "can't get sockname: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't get sockname: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -825,7 +826,7 @@ TcpWatchProc(
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
- TcpState *statePtr = (TcpState *) instanceData;
+ TcpState *statePtr = instanceData;
if (statePtr->acceptProc != NULL) {
/*
@@ -842,8 +843,7 @@ TcpWatchProc(
statePtr->filehandlers = mask;
} else if (mask) {
Tcl_CreateFileHandler(statePtr->fds.fd, mask,
- (Tcl_FileProc *) Tcl_NotifyChannel,
- (ClientData) statePtr->channel);
+ (Tcl_FileProc *) Tcl_NotifyChannel, statePtr->channel);
} else {
Tcl_DeleteFileHandler(statePtr->fds.fd);
}
@@ -874,7 +874,7 @@ TcpGetHandleProc(
int direction, /* Not used. */
ClientData *handlePtr) /* Where to store the handle. */
{
- TcpState *statePtr = (TcpState *) instanceData;
+ TcpState *statePtr = instanceData;
*handlePtr = INT2PTR(statePtr->fds.fd);
return TCL_OK;
@@ -946,12 +946,11 @@ CreateClientSocket(
}
for (state->addr = state->addrlist; state->addr != NULL;
- state->addr = state->addr->ai_next) {
-
+ state->addr = state->addr->ai_next) {
status = -1;
for (state->myaddr = state->myaddrlist; state->myaddr != NULL;
- state->myaddr = state->myaddr->ai_next) {
+ state->myaddr = state->myaddr->ai_next) {
int reuseaddr;
/*
@@ -967,6 +966,7 @@ CreateClientSocket(
* Close the socket if it is still open from the last unsuccessful
* iteration.
*/
+
if (state->fds.fd >= 0) {
close(state->fds.fd);
state->fds.fd = -1;
@@ -991,7 +991,8 @@ CreateClientSocket(
TclSockMinimumBuffers(INT2PTR(state->fds.fd), SOCKET_BUFSIZE);
if (async) {
- status = TclUnixSetBlockingMode(state->fds.fd, TCL_MODE_NONBLOCKING);
+ status = TclUnixSetBlockingMode(state->fds.fd,
+ TCL_MODE_NONBLOCKING);
if (status < 0) {
continue;
}
@@ -1001,7 +1002,7 @@ CreateClientSocket(
(void) setsockopt(state->fds.fd, SOL_SOCKET, SO_REUSEADDR,
(char *) &reuseaddr, sizeof(reuseaddr));
status = bind(state->fds.fd, state->myaddr->ai_addr,
- state->myaddr->ai_addrlen);
+ state->myaddr->ai_addrlen);
if (status < 0) {
continue;
}
@@ -1014,24 +1015,25 @@ CreateClientSocket(
*/
status = connect(state->fds.fd, state->addr->ai_addr,
- state->addr->ai_addrlen);
+ state->addr->ai_addrlen);
if (status < 0 && errno == EINPROGRESS) {
Tcl_CreateFileHandler(state->fds.fd,
- TCL_WRITABLE | TCL_EXCEPTION,
- TcpAsyncCallback, state);
+ TCL_WRITABLE|TCL_EXCEPTION, TcpAsyncCallback, state);
return TCL_OK;
reenter:
Tcl_DeleteFileHandler(state->fds.fd);
+
/*
* Read the error state from the socket to see if the async
* connection has succeeded or failed. As this clears the
* error condition, we cache the status in the socket state
* struct for later retrieval by [fconfigure -error].
*/
+
optlen = sizeof(int);
getsockopt(state->fds.fd, SOL_SOCKET, SO_ERROR,
- (char *)&status, &optlen);
+ (char *) &status, &optlen);
state->status = status;
}
if (status == 0) {
@@ -1047,6 +1049,7 @@ out:
/*
* An asynchonous connection has finally succeeded or failed.
*/
+
TcpWatchProc(state, state->filehandlers);
TclUnixSetBlockingMode(state->fds.fd, state->cachedBlocking);
@@ -1058,17 +1061,18 @@ out:
* hurt that this is also called in the successful case and will save
* the event mechanism one roundtrip through select().
*/
- Tcl_NotifyChannel(state->channel, TCL_WRITABLE);
+ Tcl_NotifyChannel(state->channel, TCL_WRITABLE);
} else if (status != 0) {
/*
* Failure for either a synchronous connection, or an async one that
* failed before it could enter background mode, e.g. because an
* invalid -myaddr was given.
*/
+
if (interp != NULL) {
- Tcl_AppendResult(interp, "couldn't open socket: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't open socket: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -1111,13 +1115,16 @@ Tcl_OpenTcpClient(
/*
* Do the name lookups for the local and remote addresses.
*/
- if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg) ||
- !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, &errorMsg)) {
+
+ if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg)
+ || !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1,
+ &errorMsg)) {
if (addrlist != NULL) {
freeaddrinfo(addrlist);
}
if (interp != NULL) {
- Tcl_AppendResult(interp, "couldn't open socket: ", errorMsg, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't open socket: %s", errorMsg));
}
return NULL;
}
@@ -1141,10 +1148,10 @@ Tcl_OpenTcpClient(
return NULL;
}
- sprintf(channelName, SOCK_TEMPLATE, (long)state);
+ sprintf(channelName, SOCK_TEMPLATE, (long) state);
- state->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
- state, (TCL_READABLE | TCL_WRITABLE));
+ state->channel = Tcl_CreateChannel(&tcpChannelType, channelName, state,
+ (TCL_READABLE | TCL_WRITABLE));
if (Tcl_SetChannelOption(interp, state->channel, "-translation",
"auto crlf") == TCL_ERROR) {
Tcl_Close(NULL, state->channel);
@@ -1257,6 +1264,7 @@ Tcl_OpenTcpServer(
* Try to record and return the most meaningful error message, i.e. the
* one from the first socket that went the farthest before it failed.
*/
+
enum { LOOKUP, SOCKET, BIND, LISTEN } howfar = LOOKUP;
int my_errno = 0;
@@ -1267,7 +1275,7 @@ Tcl_OpenTcpServer(
for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) {
sock = socket(addrPtr->ai_family, addrPtr->ai_socktype,
- addrPtr->ai_protocol);
+ addrPtr->ai_protocol);
if (sock == -1) {
if (howfar < SOCKET) {
howfar = SOCKET;
@@ -1318,7 +1326,7 @@ Tcl_OpenTcpServer(
(void) setsockopt(sock, IPPROTO_IPV6, IPV6_V6ONLY,
&v6only, sizeof(v6only));
}
-#endif
+#endif /* IPV6_V6ONLY */
status = bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen);
if (status == -1) {
@@ -1360,7 +1368,7 @@ Tcl_OpenTcpServer(
memset(statePtr, 0, sizeof(TcpState));
statePtr->acceptProc = acceptProc;
statePtr->acceptProcData = acceptProcData;
- sprintf(channelName, SOCK_TEMPLATE, (long)statePtr);
+ sprintf(channelName, SOCK_TEMPLATE, (long) statePtr);
newfds = &statePtr->fds;
} else {
newfds = ckalloc(sizeof(TcpFdList));
@@ -1389,13 +1397,15 @@ Tcl_OpenTcpServer(
return statePtr->channel;
}
if (interp != NULL) {
- Tcl_AppendResult(interp, "couldn't open socket: ", NULL);
+ Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", -1);
+
if (errorMsg == NULL) {
errno = my_errno;
- Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL);
+ Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), -1);
} else {
- Tcl_AppendResult(interp, errorMsg, NULL);
+ Tcl_AppendToObj(errorObj, errorMsg, -1);
}
+ Tcl_SetObjResult(interp, errorObj);
}
if (sock != -1) {
close(sock);
@@ -1434,7 +1444,7 @@ TcpAccept(
char host[NI_MAXHOST], port[NI_MAXSERV];
len = sizeof(addr);
- newsock = accept(fds->fd, &(addr.sa), &len);
+ newsock = accept(fds->fd, &addr.sa, &len);
if (newsock < 0) {
return;
}
@@ -1451,7 +1461,7 @@ TcpAccept(
newSockState->flags = 0;
newSockState->fds.fd = newsock;
- sprintf(channelName, SOCK_TEMPLATE, (long)newSockState);
+ sprintf(channelName, SOCK_TEMPLATE, (long) newSockState);
newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
newSockState, (TCL_READABLE | TCL_WRITABLE));
@@ -1459,7 +1469,7 @@ TcpAccept(
"auto crlf");
if (fds->statePtr->acceptProc != NULL) {
- getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port),
+ getnameinfo(&addr.sa, len, host, sizeof(host), port, sizeof(port),
NI_NUMERICHOST|NI_NUMERICSERV);
fds->statePtr->acceptProc(fds->statePtr->acceptProcData,
newSockState->channel, host, atoi(port));
diff --git a/win/Makefile.in b/win/Makefile.in
index d5a335d..84dcaf7 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -137,10 +137,9 @@ TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${LIBSUFFIX}
ZLIB_DLL_FILE = zlib1.dll
SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@
-STATIC_LIBRARIES = $(TCL_LIB_FILE) $(REG_LIB_FILE) $(DDE_LIB_FILE)
+STATIC_LIBRARIES = $(TCL_LIB_FILE)
TCLSH = tclsh$(VER)${EXESUFFIX}
-TCLTEST = tcltest${EXEEXT}
CAT32 = cat32$(EXEEXT)
MAN2TCL = man2tcl$(EXEEXT)
@@ -403,7 +402,7 @@ TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n]
all: binaries libraries doc packages
-tcltest: $(TCLTEST)
+tcltest: $(TCLSH) $(TEST_DLL_FILE)
binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ $(DDE_DLL_FILE) $(REG_DLL_FILE) $(TCLSH)
@@ -416,11 +415,6 @@ $(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES)
tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
@VC_MANIFEST_EMBED_EXE@
-$(TCLTEST): testMain.$(OBJEXT) ${TEST_DLL_FILE} @LIBRARIES@ $(TCL_STUB_LIB_FILE) $(CAT32) tclsh.$(RES)
- $(CC) $(CFLAGS) testMain.$(OBJEXT) ${TEST_LIB_FILE} $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
- tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
- @VC_MANIFEST_EMBED_EXE@
-
cat32.$(OBJEXT): cat.c
$(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME)
@@ -440,9 +434,9 @@ ${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) @ZLIB_DLL_FILE@
@MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS)
@VC_MANIFEST_EMBED_DLL@
-${TCL_LIB_FILE}: ${TCL_OBJS}
+${TCL_LIB_FILE}: ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS}
@$(RM) ${TCL_LIB_FILE}
- @MAKE_LIB@ ${TCL_OBJS}
+ @MAKE_LIB@ ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS}
@POST_MAKE_LIB@
# assume GNU make
@@ -451,31 +445,11 @@ ${TCL_LIB_FILE}: ${TCL_OBJS}
# targets have to depend on tcl<x>.lib, this ensures that linking of tcl<x>.dll
# does not execute concurrently with the renaming and recompiling of tcl<x>.lib
-${DDE_DLL_FILE}: ${DDE_OBJS} ${DDE_LIB_FILE} ${TCL_STUB_LIB_FILE}
- @-$(RM) ${DDE_DLL_FILE} ${DDE_LIB_FILE}.sav
- @-$(COPY) ${DDE_LIB_FILE} ${DDE_LIB_FILE}.sav
+${DDE_DLL_FILE}: ${DDE_OBJS} ${TCL_STUB_LIB_FILE}
@MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
- @-$(RM) ${DDE_LIB_FILE}
- @-$(COPY) ${DDE_LIB_FILE}.sav ${DDE_LIB_FILE}
- @-$(RM) ${DDE_LIB_FILE}.sav
-${DDE_LIB_FILE}: ${DDE_OBJS}
- @$(RM) ${DDE_LIB_FILE}
- @MAKE_LIB@ ${DDE_OBJS}
- @POST_MAKE_LIB@
-
-${REG_DLL_FILE}: ${REG_OBJS} ${REG_LIB_FILE} ${TCL_STUB_LIB_FILE}
- @-$(RM) ${REG_DLL_FILE} ${REG_LIB_FILE}.sav
- @-$(COPY) ${REG_LIB_FILE} ${REG_LIB_FILE}.sav
+${REG_DLL_FILE}: ${REG_OBJS} ${TCL_STUB_LIB_FILE}
@MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
- @-$(RM) ${REG_LIB_FILE}
- @-$(COPY) ${REG_LIB_FILE}.sav ${REG_LIB_FILE}
- @-$(RM) ${REG_LIB_FILE}.sav
-
-${REG_LIB_FILE}: ${REG_OBJS}
- @$(RM) ${REG_LIB_FILE}
- @MAKE_LIB@ ${REG_OBJS}
- @POST_MAKE_LIB@
${TEST_DLL_FILE}: ${TCLTEST_OBJS} ${TCL_STUB_LIB_FILE}
@$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE}
@@ -719,17 +693,19 @@ install-private-headers: libraries
test: test-tcl test-packages
-test-tcl: binaries $(TCLTEST)
+test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE)
TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
- ./$(TCLTEST) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \
- -load "set ::ddelib [file normalize ${DDE_DLL_FILE}]; \
- set ::reglib [file normalize ${REG_DLL_FILE}]" | ./$(CAT32)
+ ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \
+ -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \
+ package ifneeded dde 1.4.0b1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
+ package ifneeded registry 1.3.0 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32)
-# Useful target to launch a built tcltest with the proper path,...
-runtest: binaries $(TCLTEST)
+# Useful target to launch a built tclsh with the proper path,...
+runtest: binaries $(TCLSH) $(TEST_DLL_FILE)
@TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
- ./$(TCLTEST) $(TESTFLAGS) -load "set ::ddelib [file normalize ${DDE_DLL_FILE}]; \
- set ::reglib [file normalize ${REG_DLL_FILE}]" $(SCRIPT)
+ ./$(TCLSH) $(TESTFLAGS) -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \
+ package ifneeded dde 1.4.0b1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
+ package ifneeded registry 1.3.0 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT)
# This target can be used to run tclsh from the build directory via
# `make shell SCRIPT=foo.tcl`
@@ -753,7 +729,7 @@ cleanhelp:
clean: cleanhelp clean-packages
$(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out
- $(RM) $(TCLSH) $(TCLTEST) $(CAT32)
+ $(RM) $(TCLSH) $(CAT32)
$(RM) *.pch *.ilk *.pdb
distclean: distclean-packages clean
diff --git a/win/README b/win/README
index 98ba19f..8b257b1 100644
--- a/win/README
+++ b/win/README
@@ -24,28 +24,28 @@ In order to compile Tcl for Windows, you need the following:
or
- Linux + MinGW-w64 (any distribution e.g. Ubuntu)
- (for either 32-bit or 64-bit executables)
+ Linux + MinGW-w64 [http://mingw-w64.sourceforge.net/]
+ (win32 or win64)
or
Cygwin + MinGW-w64 [http://cygwin.com/install.html]
- (for either 32-bit or 64-bit executables)
+ (win32 or win64)
or
Darwin + MinGW-w64 [http://mingw-w64.sourceforge.net/]
- (for either 32-bit or 64-bit executables)
+ (win32 or win64)
or
Msys + MinGW-w64 [http://mingw-w64.sourceforge.net/]
- (for either 32-bit or 64-bit executables)
+ (win32 or win64)
or
- Msys + Mingw [http://www.mingw.org/download.shtml]
- (32-bit executables only)
+ Msys + MinGW [http://www.mingw.org/download.shtml]
+ (win32 only)
In practice, this release is built with Visual C++ 6.0 and the TEA
@@ -67,20 +67,20 @@ configure/build process works just like the UNIX one, so you will want
to refer to ../unix/README for available configure options.
If you want 64-bit executables (x86_64), you need to configure using
-the --enable-64bit option. Then make sure that the x86_64-w64-mingw32
+the --enable-64bit option. Make sure that the x86_64-w64-mingw32
compiler is present. For Cygwin this compiler can be found in the
"mingw64-x86_64-gcc-core" package, which can be installed through
the normal Cygwin install process. If you only want 32-bit executables,
-the "mingw64-i686-gcc-core" package is what you need. If your Linux
-distribution does not have a MinGW-w64 package, you can download one
-from [https://sourceforge.net/projects/mingw-w64/files/]
+the "mingw64-i686-gcc-core" package is what you need. For Linux, Darwin
+and Msys, you can download a suitable win32 or win64 compiler from
+[https://sourceforge.net/projects/mingw-w64/files/]
Use the Makefile "install" target to install Tcl. It will install it
according to the prefix options you provided in the correct directory
structure.
-Note that in order to run tclsh86.exe, you must ensure that tcl86.dll is on
-your path, in the system directory, or in the directory containing
+Note that in order to run tclsh85.exe, you must ensure that tcl85.dll is
+on your path, in the system directory, or in the directory containing
tclsh86.exe.
Note: Tcl no longer provides support for Win32s.
diff --git a/win/coffbase.txt b/win/coffbase.txt
index 7d19420..bdf5506 100644
--- a/win/coffbase.txt
+++ b/win/coffbase.txt
@@ -24,6 +24,7 @@ blt 0x10680000 0x00080000
iocpsock 0x10700000 0x00080000
tls 0x10780000 0x00100000
winico 0x10880000 0x00010000
+sample 0x108B0000 0x00010000
tile 0x10900000 0x00080000
memchan 0x109D0000 0x00010000
tdom 0x109E0000 0x00080000
@@ -32,6 +33,7 @@ tkvideo 0x10B00000 0x00010000
tclsdl 0x10B20000 0x00080000
vqtcl 0x10C00000 0x00010000
tdbc 0x10C40000 0x00010000
+thread 0x10C80000 0x00020000
;
; insert new packages here
;
diff --git a/win/configure b/win/configure
index fed0959..f5a23fe 100755
--- a/win/configure
+++ b/win/configure
@@ -840,18 +840,18 @@ if test -n "$ac_init_help"; then
Optional Features:
--disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
--enable-FEATURE[=ARG] include FEATURE [ARG=yes]
- --enable-threads build with threads
- --enable-shared build and link with shared libraries --enable-shared
+ --enable-threads build with threads (default: on)
+ --enable-shared build and link with shared libraries (default: on)
--enable-64bit enable 64bit support (where applicable)
--enable-wince enable Win/CE support (where applicable)
- --enable-symbols build with debugging symbols --disable-symbols
+ --enable-symbols build with debugging symbols (default: off)
--enable-embedded-manifest
embed manifest if possible (default: yes)
Optional Packages:
--with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
--without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
- --with-encoding encoding for configuration values
+ --with-encoding encoding for configuration values
--with-celib=DIR use Windows/CE support library from DIR
Some influential environment variables:
@@ -3068,8 +3068,8 @@ else
fi;
if test "$tcl_ok" = "yes"; then
- echo "$as_me:$LINENO: result: yes" >&5
-echo "${ECHO_T}yes" >&6
+ echo "$as_me:$LINENO: result: yes (default)" >&5
+echo "${ECHO_T}yes (default)" >&6
TCL_THREADS=1
cat >>confdefs.h <<\_ACEOF
#define TCL_THREADS 1
@@ -3598,8 +3598,8 @@ echo $ECHO_N "checking compiler flags... $ECHO_C" >&6
MAKE_EXE="\${CC} -o \$@"
LIBPREFIX="lib"
- extra_ldflags="$extra_ldflags -pipe"
extra_cflags="$extra_cflags -pipe"
+ extra_ldflags="$extra_ldflags -pipe"
if test "${SHARED_BUILD}" = "0" ; then
# static
diff --git a/win/configure.in b/win/configure.in
index 2377938..d17f815 100644
--- a/win/configure.in
+++ b/win/configure.in
@@ -219,7 +219,7 @@ if test "$tcl_cv_intrinsics" = "yes"; then
[Defined when the compilers supports intrinsics])
fi
-# See if the <wspiapi.h> header file is present
+# See if the <wspiapi.h> header file is present
AC_CACHE_CHECK(for wspiapi.h,
tcl_cv_wspiapi_h,
diff --git a/win/makefile.vc b/win/makefile.vc
index 96ae7f6..ba5b710 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -13,10 +13,9 @@
# Copyright (c) 2003-2008 Pat Thoyts.
#------------------------------------------------------------------------------
-# Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR)
-# or with the MS Platform SDK (MSSDK). Visual Studio .NET 2003 and 2005 define
-# VCINSTALLDIR instead.
-!if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(MSSDK) && !defined(VCINSTALLDIR)
+# Check to see we are configured to build with MSVC (MSDEVDIR, MSVCDIR or
+# VCINSTALLDIR) or with the MS Platform SDK (MSSDK or WindowsSDKDir)
+!if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(VCINSTALLDIR) && !defined(MSSDK) && !defined(WINDOWSSDKDIR)
MSG = ^
You need to run vcvars32.bat from Developer Studio or setenv.bat from the^
Platform SDK first to setup the environment. Jump to this line to read^
@@ -72,57 +71,62 @@ the build instructions.
# Sets where to install Tcl from the built binaries.
# C:\Progra~1\Tcl is assumed when not specified.
#
-# OPTS=static,msvcrt,staticpkg,nothreads,symbols,profile,loimpact,unchecked,pdbs,none
+# OPTS=loimpact,msvcrt,nothreads,pdbs,profile,static,staticpkg,symbols,thrdalloc,tclalloc,unchecked,none
# Sets special options for the core. The default is for none.
# Any combination of the above may be used (comma separated).
# 'none' will over-ride everything to nothing.
#
-# static = Builds a static library of the core instead of a
-# dll. The shell will be static (and large), as well.
-# msvcrt = Affects the static option only to switch it from
+# loimpact = Adds a flag for how NT treats the heap to keep memory
+# in use, low. This is said to impact alloc performance.
+# msvcrt = Affects the static option only to switch it from
# using libcmt(d) as the C runtime [by default] to
# msvcrt(d). This is useful for static embedding
# support.
+# nothreads= Turns off full multithreading support.
+# pdbs = Build detached symbols for release builds.
+# profile = Adds profiling hooks. Map file is assumed.
+# static = Builds a static library of the core instead of a
+# dll. The static library will contain the dde and reg
+# extensions. External applications who want to use
+# this, need to link with the stub library as well as
+# the static Tcl library.The shell will be static (and
+# large), as well.
# staticpkg = Affects the static option only to switch
# tclshXX.exe to have the dde and reg extension linked
# inside it.
-# nothreads = Turns off full multithreading support.
+# symbols = Debug build. Links to the debug C runtime, disables
+# optimizations and creates pdb symbols files.
# thrdalloc = Use the thread allocator (shared global free pool)
# This is the default on threaded builds.
# tclalloc = Use the old non-thread allocator
-# symbols = Debug build. Links to the debug C runtime, disables
-# optimizations and creates pdb symbols files.
-# pdbs = Build detached symbols for release builds.
-# profile = Adds profiling hooks. Map file is assumed.
-# loimpact = Adds a flag for how NT treats the heap to keep memory
-# in use, low. This is said to impact alloc performance.
-# unchecked = Allows a symbols build to not use the debug
+# unchecked= Allows a symbols build to not use the debug
# enabled runtime (msvcrt.dll not msvcrtd.dll
# or libcmt.lib not libcmtd.lib).
#
-# STATS=memdbg,compdbg,none
+# STATS=compdbg,memdbg,none
# Sets optional memory and bytecode compiler debugging code added
# to the core. The default is for none. Any combination of the
# above may be used (comma separated). 'none' will over-ride
# everything to nothing.
#
-# memdbg = Enables the debugging memory allocator.
# compdbg = Enables byte compilation logging.
+# memdbg = Enables the debugging memory allocator.
#
-# CHECKS=nodep,fullwarn,64bit,none
+# CHECKS=64bit,fullwarn,nodep,none
# Sets special macros for checking compatability.
#
-# nodep = Turns off compatability macros to ensure the core
-# isn't being built with deprecated functions.
+# 64bit = Enable 64bit portability warnings (if available)
# fullwarn = Builds with full compiler and link warnings enabled.
# Very verbose.
-# 64bit = Enable 64bit portability warnings (if available)
+# nodep = Turns off compatability macros to ensure the core
+# isn't being built with deprecated functions.
#
-# MACHINE=(IX86|IA64|AMD64|ALPHA)
+# MACHINE=(ALPHA|AMD64|IA64|IX86)
# Set the machine type used for the compiler, linker, and
# resource compiler. This hook is needed to tell the tools
# when alternate platforms are requested. IX86 is the default
-# when not specified.
+# when not specified. If the CPU environment variable has been
+# set (ie: recent Platform SDK) then MACHINE is set from CPU.
#
# TMP_DIR=<path>
# OUT_DIR=<path>
@@ -179,7 +183,7 @@ Please `cd` to its location first.
!error $(MSG)
!endif
-PROJECT = tcl
+PROJECT = tcl
!include "rules.vc"
STUBPREFIX = $(PROJECT)stub
@@ -232,10 +236,12 @@ INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include
TCLSHOBJS = \
$(TMP_DIR)\tclAppInit.obj \
+!if !$(STATIC_BUILD)
!if $(TCL_USE_STATIC_PACKAGES)
$(TMP_DIR)\tclWinReg.obj \
$(TMP_DIR)\tclWinDde.obj \
!endif
+!endif
$(TMP_DIR)\tclsh.res
TCLTESTOBJS = \
@@ -244,10 +250,12 @@ TCLTESTOBJS = \
$(TMP_DIR)\tclTestProcBodyObj.obj \
$(TMP_DIR)\tclThreadTest.obj \
$(TMP_DIR)\tclWinTest.obj \
+!if !$(STATIC_BUILD)
!if $(TCL_USE_STATIC_PACKAGES)
$(TMP_DIR)\tclWinReg.obj \
$(TMP_DIR)\tclWinDde.obj \
!endif
+!endif
$(TMP_DIR)\testMain.obj
COREOBJS = \
@@ -429,11 +437,13 @@ PLATFORMOBJS = \
$(TMP_DIR)\tclWinSock.obj \
$(TMP_DIR)\tclWinThrd.obj \
$(TMP_DIR)\tclWinTime.obj \
-!if !$(STATIC_BUILD)
+!if $(STATIC_BUILD)
+ $(TMP_DIR)\tclWinReg.obj \
+ $(TMP_DIR)\tclWinDde.obj \
+!else
$(TMP_DIR)\tcl.res
!endif
-
TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS)
TCLSTUBOBJS = \
@@ -565,27 +575,27 @@ install: install-binaries install-libraries install-docs install-pkgs
test: test-core test-pkgs
test-core: setup $(TCLTEST) dlls $(CAT32)
- set TCL_LIBRARY=$(ROOT:\=/)/../library
+ set TCL_LIBRARY=$(ROOT:\=/)/library
!if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE"
- $(DEBUGGER) $(TCLTEST) "$(ROOT)/tests/all.tcl" $(TESTFLAGS) -loadfile <<
- set ::ddelib [file normalize $(TCLDDELIB:\=/)]
- set ::reglib [file normalize $(TCLREGLIB:\=/)]
+ $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile <<
+ package ifneeded dde 1.4.0b1 [list load "$(TCLDDELIB:\=/)" dde]
+ package ifneeded registry 1.3.0 [list load "$(TCLREGLIB:\=/)" registry]
<<
!else
@echo Please wait while the tests are collected...
- $(TCLTEST) "$(ROOT)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log
- set ::ddelib [file normalize $(TCLDDELIB:\=/)]
- set ::reglib [file normalize $(TCLREGLIB:\=/)]
+ $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log
+ package ifneeded dde 1.4.0b1 "$(TCLDDELIB:\=/)" dde]
+ package ifneeded registry 1.3.0 "$(TCLREGLIB:\=/)" registry]
<<
type tests.log | more
!endif
runtest: setup $(TCLTEST) dlls $(CAT32)
- set TCL_LIBRARY=$(ROOT)/library
+ set TCL_LIBRARY=$(ROOT:\=/)/library
$(DEBUGGER) $(TCLTEST) $(SCRIPT)
runshell: setup $(TCLSH) dlls
- set TCL_LIBRARY=$(ROOT)/library
+ set TCL_LIBRARY=$(ROOT:\=/)/library
$(DEBUGGER) $(TCLSH) $(SCRIPT)
setup:
@@ -820,7 +830,6 @@ install-docs:
@$(CPY) "$(HELPCNT)" "$(DOC_INSTALL_DIR)\"
!endif
-#"
#---------------------------------------------------------------------
# Build tclConfig.sh for the TEA build system.
#---------------------------------------------------------------------
@@ -1159,15 +1168,15 @@ install-libraries: tclConfig install-msgs install-tzdata
install-tzdata:
@echo Installing time zone data
- @set TCL_LIBRARY=$(ROOT)/library
- @$(TCLSH_NATIVE) "$(ROOT)/tools/installData.tcl" \
- "$(ROOT)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata"
+ @set TCL_LIBRARY=$(ROOT:\=/)/library
+ @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \
+ "$(ROOT:\=/)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata"
install-msgs:
@echo Installing message catalogs
- @set TCL_LIBRARY=$(ROOT)/library
- @$(TCLSH_NATIVE) "$(ROOT)/tools/installData.tcl" \
- "$(ROOT)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs"
+ @set TCL_LIBRARY=$(ROOT:\=/)/library
+ @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \
+ "$(ROOT:\=/)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs"
#---------------------------------------------------------------------
# Clean up
diff --git a/win/nmakehlp.c b/win/nmakehlp.c
index b5e0788..2868857 100644
--- a/win/nmakehlp.c
+++ b/win/nmakehlp.c
@@ -14,8 +14,13 @@
#define _CRT_SECURE_NO_DEPRECATE
#include <windows.h>
+#define NO_SHLWAPI_GDI
+#define NO_SHLWAPI_STREAM
+#define NO_SHLWAPI_REG
+#include <shlwapi.h>
#pragma comment (lib, "user32.lib")
#pragma comment (lib, "kernel32.lib")
+#pragma comment (lib, "shlwapi.lib")
#include <stdio.h>
#include <math.h>
@@ -37,12 +42,13 @@
/* protos */
-int CheckForCompilerFeature(const char *option);
-int CheckForLinkerFeature(const char *option);
-int IsIn(const char *string, const char *substring);
-int SubstituteFile(const char *substs, const char *filename);
-const char * GetVersionFromFile(const char *filename, const char *match);
-DWORD WINAPI ReadFromPipe(LPVOID args);
+static int CheckForCompilerFeature(const char *option);
+static int CheckForLinkerFeature(const char *option);
+static int IsIn(const char *string, const char *substring);
+static int SubstituteFile(const char *substs, const char *filename);
+static int QualifyPath(const char *path);
+static const char *GetVersionFromFile(const char *filename, const char *match);
+static DWORD WINAPI ReadFromPipe(LPVOID args);
/* globals */
@@ -149,10 +155,21 @@ main(
}
printf("%s\n", GetVersionFromFile(argv[2], argv[3]));
return 0;
+ case 'Q':
+ if (argc != 3) {
+ chars = snprintf(msg, sizeof(msg) - 1,
+ "usage: %s -Q path\n"
+ "Emit the fully qualified path\n"
+ "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
+ &dwWritten, NULL);
+ return 2;
+ }
+ return QualifyPath(argv[2]);
}
}
chars = snprintf(msg, sizeof(msg) - 1,
- "usage: %s -c|-l|-f|-g|-V ...\n"
+ "usage: %s -c|-f|-l|-Q|-s|-V ...\n"
"This is a little helper app to equalize shell differences between WinNT and\n"
"Win9x and get nmake.exe to accomplish its job.\n",
argv[0]);
@@ -160,7 +177,7 @@ main(
return 2;
}
-int
+static int
CheckForCompilerFeature(
const char *option)
{
@@ -245,7 +262,7 @@ CheckForCompilerFeature(
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS|
FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID)&msg[chars],
(300-chars), 0);
- WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg,lstrlen(msg), &err,NULL);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL);
return 2;
}
@@ -294,7 +311,7 @@ CheckForCompilerFeature(
|| strstr(Err.buffer, "D2021") != NULL);
}
-int
+static int
CheckForLinkerFeature(
const char *option)
{
@@ -373,7 +390,7 @@ CheckForLinkerFeature(
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS|
FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID)&msg[chars],
(300-chars), 0);
- WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg,lstrlen(msg), &err,NULL);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL);
return 2;
}
@@ -419,7 +436,7 @@ CheckForLinkerFeature(
strstr(Err.buffer, "LNK4044") != NULL);
}
-DWORD WINAPI
+static DWORD WINAPI
ReadFromPipe(
LPVOID args)
{
@@ -444,7 +461,7 @@ ReadFromPipe(
return 0; /* makes the compiler happy */
}
-int
+static int
IsIn(
const char *string,
const char *substring)
@@ -459,7 +476,7 @@ IsIn(
* package provide or package ifneeded.
*/
-const char *
+static const char *
GetVersionFromFile(
const char *filename,
const char *match)
@@ -565,7 +582,7 @@ list_free(list_item_t **listPtrPtr)
* <<
*/
-int
+static int
SubstituteFile(
const char *substitutions,
const char *filename)
@@ -641,6 +658,30 @@ SubstituteFile(
fclose(fp);
return 0;
}
+
+/*
+ * QualifyPath --
+ *
+ * This composes the current working directory with a provided path
+ * and returns the fully qualified and normalized path.
+ * Mostly needed to setup paths for testing.
+ */
+
+static int
+QualifyPath(
+ const char *szPath)
+{
+ char szCwd[MAX_PATH + 1];
+ char szTmp[MAX_PATH + 1];
+ char *p;
+ GetCurrentDirectory(MAX_PATH, szCwd);
+ while ((p = strchr(szPath, '/')) && *p)
+ *p = '\\';
+ PathCombine(szTmp, szCwd, szPath);
+ PathCanonicalize(szCwd, szTmp);
+ printf("%s\n", szCwd);
+ return 0;
+}
/*
* Local variables:
diff --git a/win/rules.vc b/win/rules.vc
index f2ee135..f09e2ea 100644
--- a/win/rules.vc
+++ b/win/rules.vc
@@ -8,7 +8,7 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Copyright (c) 2001-2003 David Gravereaux.
-# Copyright (c) 2003-2007 Patrick Thoyts
+# Copyright (c) 2003-2008 Patrick Thoyts
#------------------------------------------------------------------------------
!ifndef _RULES_VC
@@ -243,9 +243,9 @@ TCL_USE_STATIC_PACKAGES = 1
TCL_USE_STATIC_PACKAGES = 0
!endif
!if [nmakehlp -f $(OPTS) "nothreads"]
+!message *** Compile explicitly for non-threaded tcl
TCL_THREADS = 0
!else
-!message *** Doing threads
TCL_THREADS = 1
USE_THREAD_ALLOC= 1
!endif
@@ -287,7 +287,7 @@ LOIMPACT = 0
USE_THREAD_ALLOC = 1
!endif
!if [nmakehlp -f $(OPTS) "tclalloc"]
-!message *** Doing thrdalloc
+!message *** Doing tclalloc
USE_THREAD_ALLOC = 0
!endif
!if [nmakehlp -f $(OPTS) "unchecked"]
@@ -598,7 +598,7 @@ TCLSTUBLIB = "$(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib"
TCLIMPLIB = "$(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib"
TCL_LIBRARY = $(_TCLDIR)\lib
TCLREGLIB = "$(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib"
-TCLDDELIB = "$(_TCLDIR)\lib\tcldde13$(SUFX:t=).lib"
+TCLDDELIB = "$(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib"
COFFBASE = \must\have\tcl\sources\to\build\this\target
TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target
TCL_INCLUDES = -I"$(_TCLDIR)\include"
@@ -611,7 +611,7 @@ TCLSTUBLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib"
TCLIMPLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX).lib"
TCL_LIBRARY = $(_TCLDIR)\library
TCLREGLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib"
-TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde13$(SUFX:t=).lib"
+TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib"
COFFBASE = "$(_TCLDIR)\win\coffbase.txt"
TCLTOOLSDIR = $(_TCLDIR)\tools
TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win"
diff --git a/win/tcl.m4 b/win/tcl.m4
index bbea9a3..5e8e135 100644
--- a/win/tcl.m4
+++ b/win/tcl.m4
@@ -211,7 +211,7 @@ AC_DEFUN([SC_LOAD_TKCONFIG], [
AC_DEFUN([SC_ENABLE_SHARED], [
AC_MSG_CHECKING([how to build libraries])
AC_ARG_ENABLE(shared,
- [ --enable-shared build and link with shared libraries [--enable-shared]],
+ [ --enable-shared build and link with shared libraries (default: on)],
[tcl_ok=$enableval], [tcl_ok=yes])
if test "${enable_shared+set}" = set; then
@@ -250,11 +250,11 @@ AC_DEFUN([SC_ENABLE_SHARED], [
AC_DEFUN([SC_ENABLE_THREADS], [
AC_MSG_CHECKING(for building with threads)
- AC_ARG_ENABLE(threads, [ --enable-threads build with threads],
+ AC_ARG_ENABLE(threads, [ --enable-threads build with threads (default: on)],
[tcl_ok=$enableval], [tcl_ok=yes])
if test "$tcl_ok" = "yes"; then
- AC_MSG_RESULT(yes)
+ AC_MSG_RESULT([yes (default)])
TCL_THREADS=1
AC_DEFINE(TCL_THREADS)
# USE_THREAD_ALLOC tells us to try the special thread-based
@@ -297,7 +297,7 @@ AC_DEFUN([SC_ENABLE_THREADS], [
AC_DEFUN([SC_ENABLE_SYMBOLS], [
AC_MSG_CHECKING([for build with symbols])
- AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols [--disable-symbols]], [tcl_ok=$enableval], [tcl_ok=no])
+ AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols (default: off)], [tcl_ok=$enableval], [tcl_ok=no])
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
@@ -533,8 +533,8 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
MAKE_EXE="\${CC} -o \[$]@"
LIBPREFIX="lib"
- extra_ldflags="$extra_ldflags -pipe"
extra_cflags="$extra_cflags -pipe"
+ extra_ldflags="$extra_ldflags -pipe"
if test "${SHARED_BUILD}" = "0" ; then
# static
@@ -1071,7 +1071,7 @@ AC_DEFUN([SC_BUILD_TCLSH], [
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_CFG_ENCODING], [
- AC_ARG_WITH(encoding, [ --with-encoding encoding for configuration values], with_tcencoding=${withval})
+ AC_ARG_WITH(encoding, [ --with-encoding encoding for configuration values], with_tcencoding=${withval})
if test x"${with_tcencoding}" != x ; then
AC_DEFINE_UNQUOTED(TCL_CFGVAL_ENCODING,"${with_tcencoding}")
diff --git a/win/tclWinChan.c b/win/tclWinChan.c
index 517aa20..52b9e32 100644
--- a/win/tclWinChan.c
+++ b/win/tclWinChan.c
@@ -940,8 +940,9 @@ TclpOpenFileChannel(
}
TclWinConvertError(err);
if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr),
- "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't open \"%s\": %s",
+ TclGetString(pathPtr), Tcl_PosixError(interp)));
}
return NULL;
}
@@ -959,9 +960,9 @@ TclpOpenFileChannel(
if (handle == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "couldn't reopen serial \"",
- TclGetString(pathPtr), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't reopen serial \"%s\": %s",
+ TclGetString(pathPtr), Tcl_PosixError(interp)));
}
return NULL;
}
@@ -995,8 +996,9 @@ TclpOpenFileChannel(
*/
channel = NULL;
- Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr),
- "\": bad file type", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't open \"%s\": bad file type",
+ TclGetString(pathPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "BAD_TYPE",
NULL);
break;
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
index e40e114..23b3a8e 100644
--- a/win/tclWinDde.c
+++ b/win/tclWinDde.c
@@ -17,7 +17,13 @@
#include <dde.h>
#include <ddeml.h>
-#ifndef UNICODE
+#ifdef UNICODE
+# if !defined(NDEBUG)
+ /* test POKE server Implemented for UNICODE in debug mode only */
+# undef CBF_FAIL_POKES
+# define CBF_FAIL_POKES 0
+# endif
+#else
# undef CP_WINUNICODE
# define CP_WINUNICODE CP_WINANSI
# undef Tcl_WinTCharToUtf
@@ -90,7 +96,7 @@ static DWORD ddeInstance; /* The application instance handle given to us
* by DdeInitialize. */
static int ddeIsServer = 0;
-#define TCL_DDE_VERSION "1.4.0"
+#define TCL_DDE_VERSION "1.4.0b1"
#define TCL_DDE_PACKAGE_NAME "dde"
#define TCL_DDE_SERVICE_NAME TEXT("TclEval")
#define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT")
@@ -157,7 +163,8 @@ Dde_Init(
#ifdef UNICODE
if (TclWinGetPlatformId() < VER_PLATFORM_WIN32_NT) {
- Tcl_AppendResult(interp, "Win32s and Windows 9x are not supported platforms", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "Win32s and Windows 9x are not supported platforms", -1));
return TCL_ERROR;
}
#endif
@@ -785,6 +792,53 @@ DdeServerProc(
}
return ddeReturn;
+#if !CBF_FAIL_POKES
+ case XTYP_POKE:
+ /*
+ * This is a poke for a Tcl variable, only implemented in
+ * debug/UNICODE mode.
+ */
+ ddeReturn = DDE_FNOTPROCESSED;
+
+ if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) {
+ return ddeReturn;
+ }
+
+ for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
+ && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
+ /*
+ * Empty loop body.
+ */
+ }
+
+ if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) {
+ Tcl_DString ds;
+ Tcl_Obj *variableObjPtr;
+
+ len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
+ Tcl_DStringInit(&dString);
+ Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
+ utilString = (TCHAR *) Tcl_DStringValue(&dString);
+ DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
+ CP_WINUNICODE);
+ Tcl_WinTCharToUtf(utilString, -1, &ds);
+ utilString = (TCHAR *) DdeAccessData(hData, &dlen);
+ if (uFmt == CF_TEXT) {
+ variableObjPtr = Tcl_NewStringObj((char *)utilString, -1);
+ } else {
+ variableObjPtr = Tcl_NewUnicodeObj(utilString, -1);
+ }
+
+ Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
+ variableObjPtr, TCL_GLOBAL_ONLY);
+
+ Tcl_DStringFree(&ds);
+ Tcl_DStringFree(&dString);
+ ddeReturn = (HDDEDATA) DDE_FACK;
+ }
+ return ddeReturn;
+
+#endif
case XTYP_EXECUTE: {
/*
* Execute this script. The results will be saved into a list object
@@ -947,8 +1001,12 @@ MakeDdeConnection(
if (ddeConv == (HCONV) NULL) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "no registered server named \"",
- name, "\"", NULL);
+ Tcl_DString dString;
+
+ Tcl_WinTCharToUtf(name, -1, &dString);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "no registered server named \"%s\"", Tcl_DStringValue(&dString)));
+ Tcl_DStringFree(&dString);
Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL);
}
return TCL_ERROR;
@@ -1424,7 +1482,11 @@ DdeObjCmd(
serviceName = DdeSetServerName(interp, serviceName, flags,
handlerPtr);
if (serviceName != NULL) {
+#ifdef UNICODE
Tcl_SetObjResult(interp, Tcl_NewUnicodeObj((Tcl_UniChar *) serviceName, -1));
+#else
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(serviceName, -1));
+#endif
} else {
Tcl_ResetResult(interp);
}
@@ -1483,8 +1545,13 @@ DdeObjCmd(
break;
}
case DDE_REQUEST: {
- const char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2],
+#ifdef UNICODE
+ const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2],
+ &length);
+#else
+ const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2],
&length);
+#endif
if (length == 0) {
Tcl_SetObjResult(interp,
@@ -1537,8 +1604,13 @@ DdeObjCmd(
break;
}
case DDE_POKE: {
- const char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2],
+#ifdef UNICODE
+ const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2],
&length);
+#else
+ const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2],
+ &length);
+#endif
BYTE *dataString;
if (length == 0) {
@@ -1638,9 +1710,9 @@ DdeObjCmd(
*/
if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) {
- Tcl_SetResult(riPtr->interp, "permission denied: "
- "a handler procedure must be defined for use in "
- "a safe interp", TCL_STATIC);
+ Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj(
+ "permission denied: a handler procedure must be"
+ " defined for use in a safe interp", -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK",
NULL);
result = TCL_ERROR;
diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c
index 77a5b82..80fad3e 100644
--- a/win/tclWinFCmd.c
+++ b/win/tclWinFCmd.c
@@ -1530,8 +1530,8 @@ StatError(
* error. */
{
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "could not read \"", TclGetString(fileName),
- "\": ", Tcl_PosixError(interp), (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s",
+ TclGetString(fileName), Tcl_PosixError(interp)));
}
/*
@@ -1649,9 +1649,9 @@ ConvertFileNameFormat(
if (splitPath == NULL || pathc == 0) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "could not read \"",
- Tcl_GetString(fileName), "\": no such file or directory",
- (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read \"%s\": no such file or directory",
+ Tcl_GetString(fileName)));
errno = ENOENT;
Tcl_PosixError(interp);
}
@@ -1941,9 +1941,9 @@ CannotSetAttribute(
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
- Tcl_AppendResult(interp, "cannot set attribute \"",
- tclpFileAttrStrings[objIndex], "\" for file \"",
- Tcl_GetString(fileName), "\": attribute is readonly", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "cannot set attribute \"%s\" for file \"%s\": attribute is readonly",
+ tclpFileAttrStrings[objIndex], Tcl_GetString(fileName)));
errno = EINVAL;
Tcl_PosixError(interp);
return TCL_ERROR;
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index 1f56060..a44a257 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -1048,10 +1048,9 @@ TclpMatchInDirectory(
TclWinConvertError(err);
if (interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "couldn't read directory \"",
- Tcl_DStringValue(&dsOrig), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't read directory \"%s\": %s",
+ Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp)));
}
Tcl_DStringFree(&dsOrig);
return TCL_ERROR;
@@ -1866,8 +1865,9 @@ TclpGetCwd(
if (GetCurrentDirectory(MAX_PATH, buffer) == 0) {
TclWinConvertError(GetLastError());
if (interp != NULL) {
- Tcl_AppendResult(interp, "error getting working directory name: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error getting working directory name: %s",
+ Tcl_PosixError(interp)));
}
return NULL;
}
diff --git a/win/tclWinInt.h b/win/tclWinInt.h
index 882b811..22ad8e9 100644
--- a/win/tclWinInt.h
+++ b/win/tclWinInt.h
@@ -33,6 +33,12 @@
# define TCL_I_MODIFIER ""
#endif
+#ifdef _WIN64
+# define TCL_I_MODIFIER "I"
+#else
+# define TCL_I_MODIFIER ""
+#endif
+
/*
* Declarations of functions that are not accessible by way of the
* stubs table.
diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c
index b59ccba..6294086 100644
--- a/win/tclWinLoad.c
+++ b/win/tclWinLoad.c
@@ -91,9 +91,8 @@ TclpDlopen(
if (hInstance == NULL) {
DWORD lastError = GetLastError();
-
- Tcl_AppendResult(interp, "couldn't load library \"",
- Tcl_GetString(pathPtr), "\": ", NULL);
+ Tcl_Obj *errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ",
+ Tcl_GetString(pathPtr));
/*
* Check for possible DLL errors. This doesn't work quite right,
@@ -109,29 +108,30 @@ TclpDlopen(
case ERROR_DLL_NOT_FOUND:
Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_NOT_FOUND", NULL);
notFoundMsg:
- Tcl_AppendResult(interp, "this library or a dependent library"
- " could not be found in library path", NULL);
+ Tcl_AppendToObj(errMsg, "this library or a dependent library"
+ " could not be found in library path", -1);
break;
case ERROR_PROC_NOT_FOUND:
Tcl_SetErrorCode(interp, "WIN_LOAD", "PROC_NOT_FOUND", NULL);
- Tcl_AppendResult(interp, "A function specified in the import"
- " table could not be resolved by the system. Windows"
- " is not telling which one, I'm sorry.", NULL);
+ Tcl_AppendToObj(errMsg, "A function specified in the import"
+ " table could not be resolved by the system. Windows"
+ " is not telling which one, I'm sorry.", -1);
break;
case ERROR_INVALID_DLL:
Tcl_SetErrorCode(interp, "WIN_LOAD", "INVALID_DLL", NULL);
- Tcl_AppendResult(interp, "this library or a dependent library"
- " is damaged", NULL);
+ Tcl_AppendToObj(errMsg, "this library or a dependent library"
+ " is damaged", -1);
break;
case ERROR_DLL_INIT_FAILED:
Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", NULL);
- Tcl_AppendResult(interp, "the library initialization"
- " routine failed", NULL);
+ Tcl_AppendToObj(errMsg, "the library initialization"
+ " routine failed", -1);
break;
default:
TclWinConvertError(lastError);
- Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL);
+ Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), -1);
}
+ Tcl_SetObjResult(interp, errMsg);
return TCL_ERROR;
}
@@ -190,7 +190,8 @@ FindSymbol(
Tcl_DStringFree(&ds);
}
if (proc == NULL && interp != NULL) {
- Tcl_AppendResult(interp, "cannot find symbol \"", symbol, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "cannot find symbol \"%s\"", symbol));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL);
}
return proc;
@@ -286,8 +287,9 @@ TclpTempFileNameForLibrary(
Tcl_MutexLock(&dllDirectoryNameMutex);
if (dllDirectoryName == NULL) {
if (InitDLLDirectoryName() == TCL_ERROR) {
- Tcl_AppendResult(interp, "couldn't create temporary directory: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't create temporary directory: %s",
+ Tcl_PosixError(interp)));
Tcl_MutexUnlock(&dllDirectoryNameMutex);
return NULL;
}
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c
index 65d4d06..36ae58a 100644
--- a/win/tclWinPipe.c
+++ b/win/tclWinPipe.c
@@ -676,6 +676,7 @@ TclpCreateTempFile(
if (contents != NULL) {
DWORD result, length;
const char *p;
+ int toCopy;
/*
* Convert the contents from UTF to native encoding
@@ -683,7 +684,8 @@ TclpCreateTempFile(
native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring);
- for (p = native; *p != '\0'; p++) {
+ toCopy = Tcl_DStringLength(&dstring);
+ for (p = native; toCopy > 0; p++, toCopy--) {
if (*p == '\n') {
length = p - native;
if (length > 0) {
@@ -1028,8 +1030,9 @@ TclpCreateProcess(
}
if (startInfo.hStdInput == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "couldn't duplicate input handle: ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't duplicate input handle: %s",
+ Tcl_PosixError(interp)));
goto end;
}
@@ -1063,8 +1066,9 @@ TclpCreateProcess(
}
if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "couldn't duplicate output handle: ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't duplicate output handle: %s",
+ Tcl_PosixError(interp)));
goto end;
}
@@ -1082,8 +1086,9 @@ TclpCreateProcess(
}
if (startInfo.hStdError == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "couldn't duplicate error handle: ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't duplicate error handle: %s",
+ Tcl_PosixError(interp)));
goto end;
}
@@ -1127,9 +1132,9 @@ TclpCreateProcess(
}
if (applType == APPL_DOS) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"DOS application process not supported on this platform",
- (char *) NULL);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "DOS_APP",
NULL);
goto end;
@@ -1156,12 +1161,12 @@ TclpCreateProcess(
BuildCommandLine(execPath, argc, argv, &cmdLine);
- if (CreateProcess(NULL,
- (TCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE,
- (DWORD) createFlags, NULL, NULL, &startInfo, &procInfo) == 0) {
+ if (CreateProcess(NULL, (TCHAR *) Tcl_DStringValue(&cmdLine),
+ NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo,
+ &procInfo) == 0) {
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "couldn't execute \"", argv[0],
- "\": ", Tcl_PosixError(interp), (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s",
+ argv[0], Tcl_PosixError(interp)));
goto end;
}
@@ -1407,8 +1412,8 @@ ApplicationType(
if (applType == APPL_NONE) {
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "couldn't execute \"", originalName,
- "\": ", Tcl_PosixError(interp), (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s",
+ originalName, Tcl_PosixError(interp)));
return APPL_NONE;
}
@@ -1671,8 +1676,8 @@ Tcl_CreatePipe(
if (!CreatePipe(&readHandle, &writeHandle, &sec, 0)) {
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "pipe creation failed: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "pipe creation failed: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
@@ -1709,8 +1714,8 @@ TclGetAndDetachPids(
{
PipeInfo *pipePtr;
const Tcl_ChannelType *chanTypePtr;
+ Tcl_Obj *pidsObj;
int i;
- char buf[TCL_INTEGER_SPACE];
/*
* Punt if the channel is not a command channel.
@@ -1721,12 +1726,15 @@ TclGetAndDetachPids(
return;
}
- pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan);
+ pipePtr = Tcl_GetChannelInstanceData(chan);
+ TclNewObj(pidsObj);
for (i = 0; i < pipePtr->numPids; i++) {
- wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i]));
- Tcl_AppendElement(interp, buf);
- Tcl_DetachPids(1, &(pipePtr->pidPtr[i]));
+ Tcl_ListObjAppendElement(NULL, pidsObj,
+ Tcl_NewWideIntObj((unsigned)
+ TclpGetPid(pipePtr->pidPtr[i])));
+ Tcl_DetachPids(1, &pipePtr->pidPtr[i]);
}
+ Tcl_SetObjResult(interp, pidsObj);
if (pipePtr->numPids > 0) {
ckfree(pipePtr->pidPtr);
pipePtr->numPids = 0;
@@ -1873,12 +1881,26 @@ PipeClose2Proc(
&& (pipePtr->writeFile != NULL)) {
if (pipePtr->writeThread) {
/*
- * Wait for the writer thread to finish the current buffer, then
- * terminate the thread and close the handles. If the channel is
- * nonblocking, there should be no pending write operations.
+ * Wait for the writer thread to finish the current buffer, then
+ * terminate the thread and close the handles. If the channel is
+ * nonblocking but blocked during exit, bail out since the worker
+ * thread is not interruptible and we want TIP#398-fast-exit.
*/
+ if (TclInExit()
+ && (pipePtr->flags & PIPE_ASYNC)) {
- WaitForSingleObject(pipePtr->writable, INFINITE);
+ /* give it a chance to leave honorably */
+ SetEvent(pipePtr->stopWriter);
+
+ if (WaitForSingleObject(pipePtr->writable, 0) == WAIT_TIMEOUT) {
+ return EAGAIN;
+ }
+
+ } else {
+
+ WaitForSingleObject(pipePtr->writable, INFINITE);
+
+ }
/*
* The thread may already have closed on it's own. Check its exit
@@ -2626,15 +2648,13 @@ Tcl_PidObjCmd(
PipeInfo *pipePtr;
int i;
Tcl_Obj *resultPtr;
- char buf[TCL_INTEGER_SPACE];
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
return TCL_ERROR;
}
if (objc == 1) {
- wsprintfA(buf, "%lu", (unsigned long) getpid());
- Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj((unsigned) getpid()));
} else {
chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL),
NULL);
@@ -2649,9 +2669,9 @@ Tcl_PidObjCmd(
pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan);
resultPtr = Tcl_NewObj();
for (i = 0; i < pipePtr->numPids; i++) {
- wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i]));
Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr,
- Tcl_NewStringObj(buf, -1));
+ Tcl_NewWideIntObj((unsigned)
+ TclpGetPid(pipePtr->pidPtr[i])));
}
Tcl_SetObjResult(interp, resultPtr);
}
@@ -2943,6 +2963,10 @@ PipeWriterThread(
* an error, so exit.
*/
+ if (waitResult == WAIT_OBJECT_0) {
+ SetEvent(infoPtr->writable);
+ }
+
break;
}
diff --git a/win/tclWinPort.h b/win/tclWinPort.h
index c262671..c6ac2b7 100644
--- a/win/tclWinPort.h
+++ b/win/tclWinPort.h
@@ -14,8 +14,8 @@
#ifndef _TCLWINPORT
#define _TCLWINPORT
-#ifndef _WIN64
-/* See [Bug 2935503]: file mtime sets wrong time */
+#if !defined(_WIN64) && defined(BUILD_tcl)
+/* See [Bug 3354324]: file mtime sets wrong time */
# define _USE_32BIT_TIME_T
#endif
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
index 10437e6..6ac5caf 100644
--- a/win/tclWinReg.c
+++ b/win/tclWinReg.c
@@ -13,9 +13,9 @@
*/
#undef STATIC_BUILD
-#ifndef USE_TCL_STUBS
-# define USE_TCL_STUBS
-#endif
+#undef USE_TCL_STUBS
+#define USE_TCL_STUBS
+
#include "tclInt.h"
#ifdef _MSC_VER
# pragma comment (lib, "advapi32.lib")
@@ -24,20 +24,20 @@
#ifndef UNICODE
# undef Tcl_WinTCharToUtf
-# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c)
+# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c)
# undef Tcl_WinUtfToTChar
-# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c)
-#endif
+# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c)
+#endif /* !UNICODE */
/*
* Ensure that we can say which registry is being accessed.
*/
#ifndef KEY_WOW64_64KEY
-#define KEY_WOW64_64KEY (0x0100)
+# define KEY_WOW64_64KEY (0x0100)
#endif
#ifndef KEY_WOW64_32KEY
-#define KEY_WOW64_32KEY (0x0200)
+# define KEY_WOW64_32KEY (0x0200)
#endif
/*
@@ -45,7 +45,7 @@
*/
#ifndef MAX_KEY_LENGTH
-#define MAX_KEY_LENGTH 256
+# define MAX_KEY_LENGTH 256
#endif
/*
@@ -58,14 +58,6 @@
#define TCL_STORAGE_CLASS DLLEXPORT
/*
- * The maximum length of a sub-key name.
- */
-
-#ifndef MAX_KEY_LENGTH
-#define MAX_KEY_LENGTH 256
-#endif
-
-/*
* The following macros convert between different endian ints.
*/
@@ -173,7 +165,7 @@ Registry_Init(
{
Tcl_Command cmd;
- if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
return TCL_ERROR;
}
@@ -535,9 +527,9 @@ DeleteValue(
result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
if (result != ERROR_SUCCESS) {
- Tcl_AppendResult(interp, "unable to delete value \"",
- Tcl_GetString(valueNameObj), "\" from key \"",
- Tcl_GetString(keyNameObj), "\": ", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unable to delete value \"%s\" from key \"%s\": ",
+ Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
result = TCL_ERROR;
} else {
@@ -575,7 +567,8 @@ GetKeyNames(
{
const char *pattern; /* Pattern being matched against subkeys */
HKEY key; /* Handle to the key being examined */
- TCHAR buffer[MAX_KEY_LENGTH]; /* Buffer to hold the subkey name */
+ TCHAR buffer[MAX_KEY_LENGTH];
+ /* Buffer to hold the subkey name */
DWORD bufSize; /* Size of the buffer */
DWORD index; /* Position of the current subkey */
char *name; /* Subkey name */
@@ -611,9 +604,9 @@ GetKeyNames(
if (result == ERROR_NO_MORE_ITEMS) {
result = TCL_OK;
} else {
- Tcl_SetObjResult(interp, Tcl_NewObj());
- Tcl_AppendResult(interp, "unable to enumerate subkeys of \"",
- Tcl_GetString(keyNameObj), "\": ", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unable to enumerate subkeys of \"%s\": ",
+ Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
result = TCL_ERROR;
}
@@ -694,9 +687,9 @@ GetType(
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
- Tcl_AppendResult(interp, "unable to get type of value \"",
- Tcl_GetString(valueNameObj), "\" from key \"",
- Tcl_GetString(keyNameObj), "\": ", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unable to get type of value \"%s\" from key \"%s\": ",
+ Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
return TCL_ERROR;
}
@@ -780,7 +773,7 @@ GetValue(
* HKEY_PERFORMANCE_DATA
*/
- length *= 2;
+ length = Tcl_DStringLength(&data) * (2 / sizeof(TCHAR));
Tcl_DStringSetLength(&data, (int) length * sizeof(TCHAR));
result = RegQueryValueEx(key, nativeValue,
NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length);
@@ -788,9 +781,9 @@ GetValue(
Tcl_DStringFree(&buf);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
- Tcl_AppendResult(interp, "unable to get value \"",
- Tcl_GetString(valueNameObj), "\" from key \"",
- Tcl_GetString(keyNameObj), "\": ", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unable to get value \"%s\" from key \"%s\": ",
+ Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
Tcl_DStringFree(&data);
return TCL_ERROR;
@@ -817,16 +810,16 @@ GetValue(
* we get bogus data.
*/
- while ((p < end)
- && (*((Tcl_UniChar *) p)) != 0) {
+ while ((p < end) && *((Tcl_UniChar *) p) != 0) {
Tcl_UniChar *up;
+
Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf);
Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(Tcl_DStringValue(&buf),
Tcl_DStringLength(&buf)));
up = (Tcl_UniChar *) p;
- while (*up++ != 0) {}
+ while (*up++ != 0) {/* empty body */}
p = (char *) up;
Tcl_DStringFree(&buf);
}
@@ -1111,8 +1104,8 @@ ParseKeyName(
rootName = name;
}
if (!rootName) {
- Tcl_AppendResult(interp, "bad key \"", name,
- "\": must start with a valid root", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad key \"%s\": must start with a valid root", name));
Tcl_SetErrorCode(interp, "WIN_REG", "NO_ROOT_KEY", NULL);
return TCL_ERROR;
}
@@ -1226,8 +1219,8 @@ RecursiveDeleteKey(
}
break;
} else if (result == ERROR_SUCCESS) {
- result = RecursiveDeleteKey(hKey, (const TCHAR *) Tcl_DStringValue(&subkey),
- mode);
+ result = RecursiveDeleteKey(hKey,
+ (const TCHAR *) Tcl_DStringValue(&subkey), mode);
}
}
Tcl_DStringFree(&subkey);
@@ -1294,8 +1287,8 @@ SetValue(
return TCL_ERROR;
}
- value = ConvertDWORD((DWORD)type, (DWORD)value);
- result = RegSetValueEx(key, (TCHAR *)valueName, 0,
+ value = ConvertDWORD((DWORD) type, (DWORD) value);
+ result = RegSetValueEx(key, (TCHAR *) valueName, 0,
(DWORD) type, (BYTE *) &value, sizeof(DWORD));
} else if (type == REG_MULTI_SZ) {
Tcl_DString data, buf;
@@ -1316,21 +1309,20 @@ SetValue(
Tcl_DStringInit(&data);
for (i = 0; i < objc; i++) {
- TclDStringAppendObj(&data, objv[i]);
+ const char *bytes = Tcl_GetStringFromObj(objv[i], &length);
+
+ Tcl_DStringAppend(&data, bytes, length);
/*
- * Add a null character to separate this value from the next. We
- * accomplish this by growing the string by one byte. Since the
- * DString always tacks on an extra null byte, the new byte will
- * already be set to null.
+ * Add a null character to separate this value from the next.
*/
- Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1);
+ Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */
}
Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1,
&buf);
- result = RegSetValueEx(key, (TCHAR *)valueName, 0,
+ result = RegSetValueEx(key, (TCHAR *) valueName, 0,
(DWORD) type, (BYTE *) Tcl_DStringValue(&buf),
(DWORD) Tcl_DStringLength(&buf));
Tcl_DStringFree(&data);
@@ -1339,7 +1331,7 @@ SetValue(
Tcl_DString buf;
const char *data = Tcl_GetStringFromObj(dataObj, &length);
- data = (char *)Tcl_WinUtfToTChar(data, length, &buf);
+ data = (char *) Tcl_WinUtfToTChar(data, length, &buf);
/*
* Include the null in the length, padding if needed for Unicode.
@@ -1348,7 +1340,7 @@ SetValue(
Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
length = Tcl_DStringLength(&buf) + 1;
- result = RegSetValueEx(key, (TCHAR *)valueName, 0,
+ result = RegSetValueEx(key, (TCHAR *) valueName, 0,
(DWORD) type, (BYTE *) data, (DWORD) length);
Tcl_DStringFree(&buf);
} else {
@@ -1359,7 +1351,7 @@ SetValue(
*/
data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &length);
- result = RegSetValueEx(key, (TCHAR *)valueName, 0,
+ result = RegSetValueEx(key, (TCHAR *) valueName, 0,
(DWORD) type, data, (DWORD) length);
}
@@ -1530,14 +1522,15 @@ ConvertDWORD(
DWORD type, /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */
DWORD value) /* The value to be converted. */
{
- DWORD order = 1;
+ const DWORD order = 1;
DWORD localType;
/*
* Check to see if the low bit is in the first byte.
*/
- localType = (*((char *) &order) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
+ localType = (*((const char *) &order) == 1)
+ ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
return (type != localType) ? (DWORD) SWAPLONG(value) : value;
}
diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c
index 58a9eb4..9e9d1af 100644
--- a/win/tclWinSerial.c
+++ b/win/tclWinSerial.c
@@ -1673,12 +1673,7 @@ SerialSetOptionProc(
if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
- if (interp != NULL) {
- TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "can't get comm state: ",
- Tcl_PosixError(interp), NULL);
- }
- return TCL_ERROR;
+ goto getStateFailed;
}
native = Tcl_WinUtfToTChar(value, -1, &ds);
result = BuildCommDCB(native, &dcb);
@@ -1686,8 +1681,9 @@ SerialSetOptionProc(
if (result == FALSE) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "bad value \"", value,
- "\" for -mode: should be baud,parity,data,stop", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad value \"%s\" for -mode: should be baud,parity,data,stop",
+ value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL);
}
return TCL_ERROR;
@@ -1703,12 +1699,7 @@ SerialSetOptionProc(
dcb.fAbortOnError = FALSE;
if (!SetCommState(infoPtr->handle, &dcb)) {
- if (interp != NULL) {
- TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "can't set comm state: ",
- Tcl_PosixError(interp), NULL);
- }
- return TCL_ERROR;
+ goto setStateFailed;
}
return TCL_OK;
}
@@ -1719,12 +1710,7 @@ SerialSetOptionProc(
if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
- if (interp != NULL) {
- TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "can't get comm state: ",
- Tcl_PosixError(interp), NULL);
- }
- return TCL_ERROR;
+ goto getStateFailed;
}
/*
@@ -1759,21 +1745,16 @@ SerialSetOptionProc(
dcb.fDtrControl = DTR_CONTROL_HANDSHAKE;
} else {
if (interp != NULL) {
- Tcl_AppendResult(interp, "bad value \"", value,
- "\" for -handshake: must be one of xonxoff, rtscts, "
- "dtrdsr or none", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad value \"%s\" for -handshake: must be one of"
+ " xonxoff, rtscts, dtrdsr or none", value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "HANDSHAKE", NULL);
}
return TCL_ERROR;
}
if (!SetCommState(infoPtr->handle, &dcb)) {
- if (interp != NULL) {
- TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "can't set comm state: ",
- Tcl_PosixError(interp), NULL);
- }
- return TCL_ERROR;
+ goto setStateFailed;
}
return TCL_OK;
}
@@ -1784,12 +1765,7 @@ SerialSetOptionProc(
if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
- if (interp != NULL) {
- TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "can't get comm state: ",
- Tcl_PosixError(interp), NULL);
- }
- return TCL_ERROR;
+ goto getStateFailed;
}
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
@@ -1798,9 +1774,9 @@ SerialSetOptionProc(
if (argc != 2) {
badXchar:
if (interp != NULL) {
- Tcl_AppendResult(interp, "bad value for -xchar: should be "
- "a list of two elements with each a single character",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad value for -xchar: should be a list of"
+ " two elements with each a single character", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL);
}
ckfree(argv);
@@ -1837,12 +1813,7 @@ SerialSetOptionProc(
ckfree(argv);
if (!SetCommState(infoPtr->handle, &dcb)) {
- if (interp != NULL) {
- TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "can't set comm state: ",
- Tcl_PosixError(interp), NULL);
- }
- return TCL_ERROR;
+ goto setStateFailed;
}
return TCL_OK;
}
@@ -1859,9 +1830,9 @@ SerialSetOptionProc(
}
if ((argc % 2) == 1) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "bad value \"", value,
- "\" for -ttycontrol: should be a list of "
- "signal,value pairs", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad value \"%s\" for -ttycontrol: should be "
+ "a list of signal,value pairs", value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTYCONTROL", NULL);
}
ckfree(argv);
@@ -1877,7 +1848,8 @@ SerialSetOptionProc(
if (!EscapeCommFunction(infoPtr->handle,
(DWORD) (flag ? SETDTR : CLRDTR))) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "can't set DTR signal", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can't set DTR signal", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
"FCONFIGURE", "TTY_SIGNAL", NULL);
}
@@ -1888,7 +1860,8 @@ SerialSetOptionProc(
if (!EscapeCommFunction(infoPtr->handle,
(DWORD) (flag ? SETRTS : CLRRTS))) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "can't set RTS signal", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can't set RTS signal", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
"FCONFIGURE", "TTY_SIGNAL", NULL);
}
@@ -1899,7 +1872,8 @@ SerialSetOptionProc(
if (!EscapeCommFunction(infoPtr->handle,
(DWORD) (flag ? SETBREAK : CLRBREAK))) {
if (interp != NULL) {
- Tcl_AppendResult(interp,"can't set BREAK signal",NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can't set BREAK signal", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
"FCONFIGURE", "TTY_SIGNAL", NULL);
}
@@ -1908,9 +1882,9 @@ SerialSetOptionProc(
}
} else {
if (interp != NULL) {
- Tcl_AppendResult(interp, "bad signal name \"", argv[i],
- "\" for -ttycontrol: must be DTR, RTS or BREAK",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad signal name \"%s\" for -ttycontrol: must be"
+ " DTR, RTS or BREAK", argv[i]));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTY_SIGNAL",
NULL);
}
@@ -1949,9 +1923,9 @@ SerialSetOptionProc(
if ((argc < 1) || (argc > 2) || (inSize <= 0) || (outSize <= 0)) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "bad value \"", value,
- "\" for -sysbuffer: should be a list of one or two "
- "integers > 0", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad value \"%s\" for -sysbuffer: should be "
+ "a list of one or two integers > 0", value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SYS_BUFFER", NULL);
}
return TCL_ERROR;
@@ -1960,8 +1934,9 @@ SerialSetOptionProc(
if (!SetupComm(infoPtr->handle, inSize, outSize)) {
if (interp != NULL) {
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "can't setup comm buffers: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't setup comm buffers: %s",
+ Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -1974,22 +1949,12 @@ SerialSetOptionProc(
*/
if (!GetCommState(infoPtr->handle, &dcb)) {
- if (interp != NULL) {
- TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "can't get comm state: ",
- Tcl_PosixError(interp), NULL);
- }
- return TCL_ERROR;
+ goto getStateFailed;
}
dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2);
dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4);
if (!SetCommState(infoPtr->handle, &dcb)) {
- if (interp != NULL) {
- TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "can't set comm state: ",
- Tcl_PosixError(interp), NULL);
- }
- return TCL_ERROR;
+ goto setStateFailed;
}
return TCL_OK;
}
@@ -2020,8 +1985,9 @@ SerialSetOptionProc(
if (!SetCommTimeouts(infoPtr->handle, &tout)) {
if (interp != NULL) {
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "can't set comm timeouts: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't set comm timeouts: %s",
+ Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -2031,6 +1997,22 @@ SerialSetOptionProc(
return Tcl_BadChannelOption(interp, optionName,
"mode handshake pollinterval sysbuffer timeout ttycontrol xchar");
+
+ getStateFailed:
+ if (interp != NULL) {
+ TclWinConvertError(GetLastError());
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't get comm state: %s", Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+
+ setStateFailed:
+ if (interp != NULL) {
+ TclWinConvertError(GetLastError());
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't set comm state: %s", Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
}
/*
@@ -2089,8 +2071,8 @@ SerialGetOptionProc(
if (!GetCommState(infoPtr->handle, &dcb)) {
if (interp != NULL) {
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "can't get comm state: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't get comm state: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -2159,8 +2141,8 @@ SerialGetOptionProc(
if (!GetCommState(infoPtr->handle, &dcb)) {
if (interp != NULL) {
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "can't get comm state: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't get comm state: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -2237,8 +2219,8 @@ SerialGetOptionProc(
if (!GetCommModemStatus(infoPtr->handle, &status)) {
if (interp != NULL) {
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "can't get tty status: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't get tty status: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -2248,10 +2230,9 @@ SerialGetOptionProc(
if (valid) {
return TCL_OK;
- } else {
- return Tcl_BadChannelOption(interp, optionName,
- "mode pollinterval lasterror queue sysbuffer ttystatus xchar");
}
+ return Tcl_BadChannelOption(interp, optionName,
+ "mode pollinterval lasterror queue sysbuffer ttystatus xchar");
}
/*
diff --git a/win/tclWinSock.c b/win/tclWinSock.c
index ca49d22..9f7caee 100644
--- a/win/tclWinSock.c
+++ b/win/tclWinSock.c
@@ -220,7 +220,7 @@ static void SocketExitHandler(ClientData clientData);
static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam,
LPARAM lParam);
static int SocketsEnabled(void);
-static void TcpAccept(TcpFdList *fds);
+static void TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr);
static int WaitForSocketEvent(SocketInfo *infoPtr, int events,
int *errorCodePtr);
static DWORD WINAPI SocketThread(LPVOID arg);
@@ -558,8 +558,8 @@ TclpHasSockets(
return TCL_OK;
}
if (interp != NULL) {
- Tcl_AppendResult(interp, "sockets are not available on this system",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "sockets are not available on this system", -1));
}
return TCL_ERROR;
}
@@ -692,6 +692,9 @@ SocketEventProc(
int mask = 0, events;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
TcpFdList *fds;
+ SOCKET newSocket;
+ address addr;
+ int len;
if (!(flags & TCL_FILE_EVENTS)) {
return 0;
@@ -708,13 +711,13 @@ SocketEventProc(
break;
}
}
- SetEvent(tsdPtr->socketListLock);
/*
* Discard events that have gone stale.
*/
if (!infoPtr) {
+ SetEvent(tsdPtr->socketListLock);
return 1;
}
@@ -726,11 +729,65 @@ SocketEventProc(
if (infoPtr->readyEvents & FD_ACCEPT) {
for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) {
- TcpAccept(fds);
+
+ /*
+ * Accept the incoming connection request.
+ */
+ len = sizeof(address);
+
+ newSocket = accept(fds->fd, &(addr.sa), &len);
+
+ /* On Tcl server sockets with multiple OS fds we loop over the fds trying
+ * an accept() on each, so we expect INVALID_SOCKET. There are also other
+ * network stack conditions that can result in FD_ACCEPT but a subsequent
+ * failure on accept() by the time we get around to it.
+ * Access to sockets (acceptEventCount, readyEvents) in socketList
+ * is still protected by the lock (prevents reintroduction of
+ * SF Tcl Bug 3056775.
+ */
+
+ if (newSocket == INVALID_SOCKET) {
+ /* int err = WSAGetLastError(); */
+ continue;
+ }
+
+ /*
+ * It is possible that more than one FD_ACCEPT has been sent, so an extra
+ * count must be kept. Decrement the count, and reset the readyEvent bit
+ * if the count is no longer > 0.
+ */
+ infoPtr->acceptEventCount--;
+
+ if (infoPtr->acceptEventCount <= 0) {
+ infoPtr->readyEvents &= ~(FD_ACCEPT);
+ }
+
+ SetEvent(tsdPtr->socketListLock);
+
+ /* Caution: TcpAccept() has the side-effect of evaluating the server
+ * accept script (via AcceptCallbackProc() in tclIOCmd.c), which can
+ * close the server socket and invalidate infoPtr and fds.
+ * If TcpAccept() accepts a socket we must return immediately and let
+ * SocketCheckProc queue additional FD_ACCEPT events.
+ */
+ TcpAccept(fds, newSocket, addr);
+ return 1;
}
+
+ /* Loop terminated with no sockets accepted; clear the ready mask so
+ * we can detect the next connection request. Note that connection
+ * requests are level triggered, so if there is a request already
+ * pending, a new event will be generated.
+ */
+ infoPtr->acceptEventCount = 0;
+ infoPtr->readyEvents &= ~(FD_ACCEPT);
+
+ SetEvent(tsdPtr->socketListLock);
return 1;
}
+ SetEvent(tsdPtr->socketListLock);
+
/*
* Mask off unwanted events and compute the read/write mask so we can
* notify the channel.
@@ -872,9 +929,15 @@ TcpCloseProc(
* background.
*/
- if (closesocket(infoPtr->sockets->fd) == SOCKET_ERROR) {
- TclWinConvertError((DWORD) WSAGetLastError());
- errorCode = Tcl_GetErrno();
+ while ( infoPtr->sockets != NULL ) {
+ TcpFdList *thisfd = infoPtr->sockets;
+ infoPtr->sockets = thisfd->next;
+
+ if (closesocket(thisfd->fd) == SOCKET_ERROR) {
+ TclWinConvertError((DWORD) WSAGetLastError());
+ errorCode = Tcl_GetErrno();
+ }
+ ckfree(thisfd);
}
}
@@ -928,12 +991,14 @@ TcpClose2Proc(
break;
default:
if (interp) {
- Tcl_AppendResult(interp,
- "Socket close2proc called bidirectionally", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "Socket close2proc called bidirectionally", -1));
}
return TCL_ERROR;
}
+ /* single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or
+ * TCL_WRITABLE so this should never be called for a server socket. */
if (shutdown(infoPtr->sockets->fd, sd) == SOCKET_ERROR) {
TclWinConvertError((DWORD) WSAGetLastError());
errorCode = Tcl_GetErrno();
@@ -945,6 +1010,51 @@ TcpClose2Proc(
/*
*----------------------------------------------------------------------
*
+ * AddSocketInfoFd --
+ *
+ * This function adds a SOCKET file descriptor to the 'sockets' linked
+ * list of a SocketInfo structure.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None, except for allocation of memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+AddSocketInfoFd(
+ SocketInfo *infoPtr,
+ SOCKET socket)
+{
+ TcpFdList *fds = infoPtr->sockets;
+
+ if ( fds == NULL ) {
+ /* Add the first FD */
+ infoPtr->sockets = ckalloc(sizeof(TcpFdList));
+ fds = infoPtr->sockets;
+ } else {
+ /* Find end of list and append FD */
+ while ( fds->next != NULL ) {
+ fds = fds->next;
+ }
+
+ fds->next = ckalloc(sizeof(TcpFdList));
+ fds = fds->next;
+ }
+
+ /* Populate new FD */
+ fds->fd = socket;
+ fds->infoPtr = infoPtr;
+ fds->next = NULL;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
* NewSocketInfo --
*
* This function allocates and initializes a new SocketInfo structure.
@@ -963,14 +1073,10 @@ NewSocketInfo(
SOCKET socket)
{
SocketInfo *infoPtr = ckalloc(sizeof(SocketInfo));
- TcpFdList *fds = ckalloc(sizeof(TcpFdList));
- fds->fd = socket;
- fds->next = NULL;
- fds->infoPtr = infoPtr;
/* ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); */
infoPtr->channel = 0;
- infoPtr->sockets = fds;
+ infoPtr->sockets = NULL;
infoPtr->flags = 0;
infoPtr->watchEvents = 0;
infoPtr->readyEvents = 0;
@@ -988,6 +1094,8 @@ NewSocketInfo(
infoPtr->nextPtr = NULL;
+ AddSocketInfoFd(infoPtr, socket);
+
return infoPtr;
}
@@ -1057,7 +1165,6 @@ CreateSocket(
}
if (server) {
- TcpFdList *fds = NULL, *newfds;
for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) {
sock = socket(addrPtr->ai_family, SOCK_STREAM, 0);
@@ -1140,7 +1247,6 @@ CreateSocket(
*/
infoPtr = NewSocketInfo(sock);
- fds = infoPtr->sockets;
/*
* Set up the select mask for connection request events.
@@ -1150,13 +1256,7 @@ CreateSocket(
infoPtr->watchEvents |= FD_ACCEPT;
} else {
- newfds = ckalloc(sizeof(TcpFdList));
- memset(newfds, (int) 0, sizeof(TcpFdList));
- newfds->fd = sock;
- newfds->infoPtr = infoPtr;
- newfds->next = NULL;
- fds->next = newfds;
- fds = newfds;
+ AddSocketInfoFd( infoPtr, sock );
}
}
} else {
@@ -1280,12 +1380,9 @@ CreateSocket(
}
if (interp != NULL) {
- Tcl_AppendResult(interp, "couldn't open socket: ", NULL);
- if (errorMsg == NULL) {
- Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL);
- } else {
- Tcl_AppendResult(interp, errorMsg, NULL);
- }
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't open socket: %s",
+ (errorMsg ? errorMsg : Tcl_PosixError(interp))));
}
if (sock != INVALID_SOCKET) {
@@ -1403,7 +1500,7 @@ Tcl_OpenTcpClient(
return NULL;
}
- sprintf(channelName, "sock%Id", (size_t) infoPtr->sockets->fd);
+ sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd);
infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
infoPtr, (TCL_READABLE | TCL_WRITABLE));
@@ -1466,7 +1563,7 @@ Tcl_MakeTcpClientChannel(
infoPtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE;
SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr);
- sprintf(channelName, "sock%Id", (size_t) infoPtr->sockets->fd);
+ sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd);
infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
infoPtr, (TCL_READABLE | TCL_WRITABLE));
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto crlf");
@@ -1519,7 +1616,7 @@ Tcl_OpenTcpServer(
infoPtr->acceptProc = acceptProc;
infoPtr->acceptProcData = acceptProcData;
- sprintf(channelName, "sock%Id", (size_t) infoPtr->sockets->fd);
+ sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd);
infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
infoPtr, 0);
@@ -1537,8 +1634,9 @@ Tcl_OpenTcpServer(
*
* TcpAccept --
*
- * Accept a TCP socket connection. This is called by SocketEventProc and
- * it in turns calls the registered accept function.
+ * Creates a channel for a newly accepted socket connection. This is
+ * called by SocketEventProc and it in turns calls the registered
+ * accept function.
*
* Results:
* None.
@@ -1551,60 +1649,18 @@ Tcl_OpenTcpServer(
static void
TcpAccept(
- TcpFdList *fds) /* Socket to accept. */
+ TcpFdList *fds, /* Server socket that accepted newSocket. */
+ SOCKET newSocket, /* Newly accepted socket. */
+ address addr) /* Address of new socket. */
{
- SOCKET newSocket;
SocketInfo *newInfoPtr;
SocketInfo *infoPtr = fds->infoPtr;
- SOCKADDR_IN addr;
- int len;
+ int len = sizeof(addr);
char channelName[16 + TCL_INTEGER_SPACE];
+ char host[NI_MAXHOST], port[NI_MAXSERV];
ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
/*
- * Accept the incoming connection request.
- */
-
- len = sizeof(SOCKADDR_IN);
-
- newSocket = accept(fds->fd, (SOCKADDR *) &addr, &len);
-
- /*
- * Protect access to sockets (acceptEventCount, readyEvents) in socketList
- * by the lock. Fix for SF Tcl Bug 3056775.
- */
-
- WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
-
- /*
- * Clear the ready mask so we can detect the next connection request. Note
- * that connection requests are level triggered, so if there is a request
- * already pending, a new event will be generated.
- */
-
- if (newSocket == INVALID_SOCKET) {
- infoPtr->acceptEventCount = 0;
- infoPtr->readyEvents &= ~(FD_ACCEPT);
-
- SetEvent(tsdPtr->socketListLock);
- return;
- }
-
- /*
- * It is possible that more than one FD_ACCEPT has been sent, so an extra
- * count must be kept. Decrement the count, and reset the readyEvent bit
- * if the count is no longer > 0.
- */
-
- infoPtr->acceptEventCount--;
-
- if (infoPtr->acceptEventCount <= 0) {
- infoPtr->readyEvents &= ~(FD_ACCEPT);
- }
-
- SetEvent(tsdPtr->socketListLock);
-
- /*
* Win-NT has a misfeature that sockets are inherited in child processes
* by default. Turn off the inherit bit.
*/
@@ -1625,7 +1681,7 @@ TcpAccept(
SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
(LPARAM) newInfoPtr);
- sprintf(channelName, "sock%Id", (size_t) newInfoPtr->sockets->fd);
+ sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) newInfoPtr->sockets->fd);
newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
newInfoPtr, (TCL_READABLE | TCL_WRITABLE));
if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation",
@@ -1644,8 +1700,10 @@ TcpAccept(
*/
if (infoPtr->acceptProc != NULL) {
+ getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port),
+ NI_NUMERICHOST|NI_NUMERICSERV);
infoPtr->acceptProc(infoPtr->acceptProcData, newInfoPtr->channel,
- inet_ntoa(addr.sin_addr), ntohs(addr.sin_port));
+ host, atoi(port));
}
}
@@ -1720,6 +1778,7 @@ TcpInputProc(
while (1) {
SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
(WPARAM) UNSELECT, (LPARAM) infoPtr);
+ /* single fd operation: this proc is only called for a connected socket. */
bytesRead = recv(infoPtr->sockets->fd, buf, toRead, 0);
infoPtr->readyEvents &= ~(FD_READ);
@@ -1840,6 +1899,7 @@ TcpOutputProc(
SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
(WPARAM) UNSELECT, (LPARAM) infoPtr);
+ /* single fd operation: this proc is only called for a connected socket. */
bytesWritten = send(infoPtr->sockets->fd, buf, toWrite, 0);
if (bytesWritten != SOCKET_ERROR) {
/*
@@ -1929,12 +1989,14 @@ TcpSetOptionProc(
if (!SocketsEnabled()) {
if (interp) {
- Tcl_AppendResult(interp, "winsock is not initialized", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "winsock is not initialized", -1));
}
return TCL_ERROR;
}
#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
+ #error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat infoPtr->sockets as single fd or list"
sock = infoPtr->sockets->fd;
if (!strcasecmp(optionName, "-keepalive")) {
@@ -1952,8 +2014,9 @@ TcpSetOptionProc(
if (rtn != 0) {
TclWinConvertError(WSAGetLastError());
if (interp) {
- Tcl_AppendResult(interp, "couldn't set socket option: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't set socket option: %s",
+ Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -1973,8 +2036,9 @@ TcpSetOptionProc(
if (rtn != 0) {
TclWinConvertError(WSAGetLastError());
if (interp) {
- Tcl_AppendResult(interp, "couldn't set socket option: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't set socket option: %s",
+ Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -2032,7 +2096,8 @@ TcpGetOptionProc(
if (!SocketsEnabled()) {
if (interp) {
- Tcl_AppendResult(interp, "winsock is not initialized", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "winsock is not initialized", -1));
}
return TCL_ERROR;
}
@@ -2099,8 +2164,9 @@ TcpGetOptionProc(
if (len) {
TclWinConvertError((DWORD) WSAGetLastError());
if (interp) {
- Tcl_AppendResult(interp, "can't get peername: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't get peername: %s",
+ Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -2164,8 +2230,8 @@ TcpGetOptionProc(
} else {
if (interp) {
TclWinConvertError((DWORD) WSAGetLastError());
- Tcl_AppendResult(interp, "can't get sockname: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't get sockname: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -2398,6 +2464,7 @@ SocketProc(
int event, error;
SOCKET socket;
SocketInfo *infoPtr;
+ TcpFdList *fds = NULL;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
#ifdef _WIN64
GetWindowLongPtr(hwnd, GWLP_USERDATA);
@@ -2442,58 +2509,60 @@ SocketProc(
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
- if (infoPtr->sockets->fd == socket) {
- /*
- * Update the socket state.
- *
- * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event
- * happens, then clear the FD_ACCEPT count. Otherwise,
- * increment the count if the current event is an FD_ACCEPT.
- */
-
- if (event & FD_CLOSE) {
- infoPtr->acceptEventCount = 0;
- infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT);
- } else if (event & FD_ACCEPT) {
- infoPtr->acceptEventCount++;
- }
-
- if (event & FD_CONNECT) {
+ for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) {
+ if (fds->fd == socket) {
/*
- * The socket is now connected, clear the async connect
- * flag.
+ * Update the socket state.
+ *
+ * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event
+ * happens, then clear the FD_ACCEPT count. Otherwise,
+ * increment the count if the current event is an FD_ACCEPT.
*/
- infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);
+ if (event & FD_CLOSE) {
+ infoPtr->acceptEventCount = 0;
+ infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT);
+ } else if (event & FD_ACCEPT) {
+ infoPtr->acceptEventCount++;
+ }
- /*
- * Remember any error that occurred so we can report
- * connection failures.
- */
+ if (event & FD_CONNECT) {
+ /*
+ * The socket is now connected, clear the async connect
+ * flag.
+ */
+
+ infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);
+
+ /*
+ * Remember any error that occurred so we can report
+ * connection failures.
+ */
- if (error != ERROR_SUCCESS) {
- TclWinConvertError((DWORD) error);
- infoPtr->lastError = Tcl_GetErrno();
+ if (error != ERROR_SUCCESS) {
+ TclWinConvertError((DWORD) error);
+ infoPtr->lastError = Tcl_GetErrno();
+ }
}
- }
- if (infoPtr->flags & SOCKET_ASYNC_CONNECT) {
- infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);
- if (error != ERROR_SUCCESS) {
- TclWinConvertError((DWORD) error);
- infoPtr->lastError = Tcl_GetErrno();
+ if (infoPtr->flags & SOCKET_ASYNC_CONNECT) {
+ infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);
+ if (error != ERROR_SUCCESS) {
+ TclWinConvertError((DWORD) error);
+ infoPtr->lastError = Tcl_GetErrno();
+ }
+ infoPtr->readyEvents |= FD_WRITE;
}
- infoPtr->readyEvents |= FD_WRITE;
- }
- infoPtr->readyEvents |= event;
+ infoPtr->readyEvents |= event;
- /*
- * Wake up the Main Thread.
- */
+ /*
+ * Wake up the Main Thread.
+ */
- SetEvent(tsdPtr->readyEvent);
- Tcl_ThreadAlert(tsdPtr->threadId);
- break;
+ SetEvent(tsdPtr->readyEvent);
+ Tcl_ThreadAlert(tsdPtr->threadId);
+ break;
+ }
}
}
SetEvent(tsdPtr->socketListLock);
@@ -2501,15 +2570,18 @@ SocketProc(
case SOCKET_SELECT:
infoPtr = (SocketInfo *) lParam;
- if (wParam == SELECT) {
- WSAAsyncSelect(infoPtr->sockets->fd, hwnd,
- SOCKET_MESSAGE, infoPtr->selectEvents);
- } else {
- /*
- * Clear the selection mask
- */
+ for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) {
+ infoPtr = (SocketInfo *) lParam;
+ if (wParam == SELECT) {
+ WSAAsyncSelect(fds->fd, hwnd,
+ SOCKET_MESSAGE, infoPtr->selectEvents);
+ } else {
+ /*
+ * Clear the selection mask
+ */
- WSAAsyncSelect(infoPtr->sockets->fd, hwnd, 0, 0);
+ WSAAsyncSelect(fds->fd, hwnd, 0, 0);
+ }
}
break;
@@ -2579,20 +2651,16 @@ InitializeHostName(
Tcl_DStringInit(&ds);
if (TclpHasSockets(NULL) == TCL_OK) {
/*
- * Buffer length of 255 copied slavishly from previous version of
- * this routine. Presumably there's a more "correct" macro value
- * for a properly sized buffer for a gethostname() call.
- * Maintainers are welcome to supply it.
+ * The buffer size of 256 is recommended by the MSDN page that
+ * documents gethostname() as being always adequate.
*/
Tcl_DString inDs;
Tcl_DStringInit(&inDs);
- Tcl_DStringSetLength(&inDs, 255);
+ Tcl_DStringSetLength(&inDs, 256);
if (gethostname(Tcl_DStringValue(&inDs),
Tcl_DStringLength(&inDs)) == 0) {
- TclDStringClear(&ds);
- } else {
Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), -1,
&ds);
}