summaryrefslogtreecommitdiffstats
path: root/doc/src/snippets/code/src_script_qscriptengineagent.cpp
diff options
context:
space:
mode:
Diffstat (limited to 'doc/src/snippets/code/src_script_qscriptengineagent.cpp')
0 files changed, 0 insertions, 0 deletions
_3414754'>bug_3414754 Tcl is a high-level, general-purpose, interpreted, dynamic programming language. It was designed with the goal of being very simple but powerful.
summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-x[-rw-r--r--]compat/zlib/win32/zlib1.dllbin107520 -> 107520 bytes
-rwxr-xr-x[-rw-r--r--]compat/zlib/win64/zlib1.dllbin112640 -> 112640 bytes
-rw-r--r--[-rwxr-xr-x]doc/GetCwd.30
-rw-r--r--[-rwxr-xr-x]doc/GetVersion.30
-rw-r--r--doc/encoding.n34
-rw-r--r--doc/fcopy.n27
-rw-r--r--[-rwxr-xr-x]doc/lset.n0
-rw-r--r--doc/string.n28
-rw-r--r--doc/tclvars.n2
-rw-r--r--generic/tcl.h43
-rw-r--r--generic/tclAssembly.c12
-rw-r--r--generic/tclBasic.c62
-rw-r--r--generic/tclBinary.c74
-rw-r--r--generic/tclClock.c38
-rw-r--r--generic/tclCmdAH.c2
-rw-r--r--generic/tclCmdMZ.c47
-rw-r--r--generic/tclCompCmds.c4
-rw-r--r--generic/tclCompCmdsGR.c60
-rw-r--r--generic/tclCompCmdsSZ.c364
-rw-r--r--generic/tclCompile.c65
-rw-r--r--generic/tclCompile.h50
-rw-r--r--generic/tclDecls.h24
-rw-r--r--generic/tclEncoding.c4
-rw-r--r--generic/tclEnv.c4
-rw-r--r--generic/tclExecute.c568
-rw-r--r--generic/tclFCmd.c2
-rw-r--r--generic/tclIO.c1112
-rw-r--r--generic/tclIO.h1
-rw-r--r--generic/tclIOCmd.c28
-rw-r--r--generic/tclIOGT.c122
-rw-r--r--generic/tclIORChan.c277
-rw-r--r--generic/tclIOUtil.c8
-rw-r--r--generic/tclInt.h16
-rw-r--r--generic/tclIntPlatDecls.h22
-rw-r--r--generic/tclLoad.c4
-rw-r--r--generic/tclMain.c2
-rw-r--r--generic/tclOO.c10
-rw-r--r--generic/tclOO.decls1
-rw-r--r--generic/tclOOBasic.c43
-rw-r--r--generic/tclOODecls.h78
-rw-r--r--generic/tclOOIntDecls.h45
-rw-r--r--generic/tclPathObj.c6
-rw-r--r--generic/tclPlatDecls.h6
-rw-r--r--generic/tclProc.c72
-rw-r--r--[-rwxr-xr-x]generic/tclStrToD.c0
-rw-r--r--generic/tclStringObj.c42
-rw-r--r--generic/tclStringTrim.h27
-rw-r--r--generic/tclStubInit.c38
-rw-r--r--generic/tclStubLibTbl.c58
-rw-r--r--generic/tclTest.c6
-rw-r--r--generic/tclThread.c8
-rw-r--r--generic/tclThreadAlloc.c27
-rw-r--r--generic/tclThreadJoin.c4
-rw-r--r--[-rwxr-xr-x]library/encoding/tis-620.enc0
-rw-r--r--[-rwxr-xr-x]library/msgs/af.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/af_za.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/ar.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/ar_in.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/ar_jo.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/ar_lb.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/ar_sy.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/be.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/bg.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/bn.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/bn_in.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/ca.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/cs.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/da.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/de.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/de_at.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/de_be.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/el.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/en_au.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/en_be.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/en_bw.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/en_ca.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/en_gb.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/en_hk.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/en_ie.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/en_in.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/en_nz.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/en_ph.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/en_sg.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/en_za.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/en_zw.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/eo.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es_ar.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es_bo.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es_cl.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es_co.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es_cr.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es_do.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es_ec.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es_gt.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es_hn.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es_mx.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es_ni.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es_pa.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es_pe.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es_pr.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es_py.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es_sv.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es_uy.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/es_ve.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/et.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/eu.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/eu_es.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/fa.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/fa_in.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/fa_ir.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/fi.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/fo.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/fo_fo.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/fr.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/fr_be.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/fr_ca.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/fr_ch.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/ga.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/ga_ie.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/gl.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/gl_es.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/gv.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/gv_gb.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/he.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/hi.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/hi_in.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/hr.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/hu.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/id.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/id_id.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/is.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/it.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/it_ch.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/ja.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/kl.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/kl_gl.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/ko.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/ko_kr.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/kok.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/kok_in.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/kw.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/kw_gb.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/lt.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/lv.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/mk.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/mr.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/mr_in.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/ms.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/ms_my.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/mt.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/nb.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/nl.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/nl_be.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/nn.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/pl.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/pt.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/pt_br.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/ro.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/ru.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/ru_ua.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/sh.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/sk.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/sl.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/sq.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/sr.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/sv.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/sw.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/ta.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/ta_in.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/te.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/te_in.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/th.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/tr.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/uk.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/vi.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/zh.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/zh_cn.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/zh_hk.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/zh_sg.msg0
-rw-r--r--[-rwxr-xr-x]library/msgs/zh_tw.msg0
-rw-r--r--[-rwxr-xr-x]library/tzdata/Africa/Asmara0
-rw-r--r--[-rwxr-xr-x]library/tzdata/America/Atikokan0
-rw-r--r--[-rwxr-xr-x]library/tzdata/America/Blanc-Sablon0
-rw-r--r--[-rwxr-xr-x]library/tzdata/America/Indiana/Petersburg0
-rw-r--r--[-rwxr-xr-x]library/tzdata/America/Indiana/Tell_City0
-rw-r--r--[-rwxr-xr-x]library/tzdata/America/Indiana/Vincennes0
-rw-r--r--[-rwxr-xr-x]library/tzdata/America/Indiana/Winamac0
-rw-r--r--[-rwxr-xr-x]library/tzdata/America/Moncton0
-rw-r--r--[-rwxr-xr-x]library/tzdata/America/North_Dakota/New_Salem0
-rw-r--r--[-rwxr-xr-x]library/tzdata/America/Resolute0
-rw-r--r--[-rwxr-xr-x]library/tzdata/Atlantic/Faroe0
-rw-r--r--[-rwxr-xr-x]library/tzdata/Australia/Eucla0
-rw-r--r--[-rwxr-xr-x]library/tzdata/Europe/Guernsey0
-rw-r--r--[-rwxr-xr-x]library/tzdata/Europe/Isle_of_Man0
-rw-r--r--[-rwxr-xr-x]library/tzdata/Europe/Jersey0
-rw-r--r--[-rwxr-xr-x]library/tzdata/Europe/Podgorica0
-rw-r--r--[-rwxr-xr-x]library/tzdata/Europe/Volgograd0
-rw-r--r--tests/clock.test9
-rw-r--r--tests/cmdAH.test3
-rw-r--r--tests/coroutine.test92
-rw-r--r--tests/fCmd.test6
-rw-r--r--tests/http.test12
-rw-r--r--tests/io.test71
-rw-r--r--tests/ioCmd.test98
-rw-r--r--tests/ioTrans.test43
-rw-r--r--tests/iogt.test35
-rw-r--r--[-rwxr-xr-x]tests/lsetComp.test0
-rw-r--r--tests/namespace.test11
-rw-r--r--[-rwxr-xr-x]tests/notify.test0
-rw-r--r--tests/obj.test4
-rw-r--r--tests/string.test9
-rw-r--r--tests/stringComp.test34
-rw-r--r--[-rwxr-xr-x]tests/tcltest.test0
-rw-r--r--tests/winFCmd.test100
-rw-r--r--tests/winFile.test18
-rw-r--r--tests/winPipe.test8
-rw-r--r--[-rwxr-xr-x]tools/encoding/ebcdic.txt0
-rw-r--r--[-rwxr-xr-x]tools/encoding/tis-620.txt0
-rw-r--r--tools/genStubs.tcl6
-rwxr-xr-xunix/configure16
-rw-r--r--unix/tcl.m416
-rw-r--r--unix/tcl.pc.in8
-rw-r--r--unix/tclConfig.sh.in2
-rw-r--r--unix/tclUnixFCmd.c184
-rw-r--r--unix/tclUnixFile.c6
-rw-r--r--unix/tclUnixInit.c30
-rw-r--r--unix/tclUnixPort.h3
-rw-r--r--unix/tclUnixThrd.c1
-rw-r--r--[-rwxr-xr-x]win/buildall.vc.bat0
-rwxr-xr-xwin/configure4
-rw-r--r--win/makefile.vc2
-rw-r--r--win/tcl.m44
-rw-r--r--win/tclConfig.sh.in2
-rw-r--r--win/tclWin32Dll.c4
-rw-r--r--win/tclWinChan.c107
-rw-r--r--win/tclWinConsole.c7
-rw-r--r--win/tclWinFCmd.c12
-rw-r--r--win/tclWinFile.c84
-rw-r--r--win/tclWinInit.c39
-rw-r--r--win/tclWinInt.h2
-rw-r--r--win/tclWinPipe.c6
-rw-r--r--win/tclWinPort.h9
-rw-r--r--win/tclWinSerial.c25
-rw-r--r--win/tclWinSock.c82
-rw-r--r--win/tclWinTest.c2
246 files changed, 2978 insertions, 1815 deletions
diff --git a/compat/zlib/win32/zlib1.dll b/compat/zlib/win32/zlib1.dll
index 9ea38d5..9ea38d5 100644..100755
--- a/compat/zlib/win32/zlib1.dll
+++ b/compat/zlib/win32/zlib1.dll
Binary files differ
diff --git a/compat/zlib/win64/zlib1.dll b/compat/zlib/win64/zlib1.dll
index bd1dbc6..bd1dbc6 100644..100755
--- a/compat/zlib/win64/zlib1.dll
+++ b/compat/zlib/win64/zlib1.dll
Binary files differ
diff --git a/doc/GetCwd.3 b/doc/GetCwd.3
index 58abcde..58abcde 100755..100644
--- a/doc/GetCwd.3
+++ b/doc/GetCwd.3
diff --git a/doc/GetVersion.3 b/doc/GetVersion.3
index 89f63d5..89f63d5 100755..100644
--- a/doc/GetVersion.3
+++ b/doc/GetVersion.3
diff --git a/doc/encoding.n b/doc/encoding.n
index be1dc3f..5782199 100644
--- a/doc/encoding.n
+++ b/doc/encoding.n
@@ -14,10 +14,21 @@ encoding \- Manipulate encodings
.BE
.SH INTRODUCTION
.PP
-Strings in Tcl are encoded using 16-bit Unicode characters. Different
-operating system interfaces or applications may generate strings in
-other encodings such as Shift-JIS. The \fBencoding\fR command helps
-to bridge the gap between Unicode and these other formats.
+Strings in Tcl are logically a sequence of 16-bit Unicode characters.
+These strings are represented in memory as a sequence of bytes that
+may be in one of several encodings: modified UTF\-8 (which uses 1 to 3
+bytes per character), 16-bit
+.QW Unicode
+(which uses 2 bytes per character, with an endianness that is
+dependent on the host architecture), and binary (which uses a single
+byte per character but only handles a restricted range of characters).
+Tcl does not guarantee to always use the same encoding for the same
+string.
+.PP
+Different operating system interfaces or applications may generate
+strings in other encodings such as Shift\-JIS. The \fBencoding\fR
+command helps to bridge the gap between Unicode and these other
+formats.
.SH DESCRIPTION
.PP
Performs one of several encoding related operations, depending on
@@ -37,8 +48,9 @@ system encoding is used.
Convert \fIstring\fR from Unicode to the specified \fIencoding\fR.
The result is a sequence of bytes that represents the converted
string. Each byte is stored in the lower 8-bits of a Unicode
-character. If \fIencoding\fR is not specified, the current
-system encoding is used.
+character (indeed, the resulting string is a binary string as far as
+Tcl is concerned, at least initially). If \fIencoding\fR is not
+specified, the current system encoding is used.
.TP
\fBencoding dirs\fR ?\fIdirectoryList\fR?
.
@@ -56,6 +68,11 @@ searchable directory, that element is ignored.
.
Returns a list containing the names of all of the encodings that are
currently available.
+The encodings
+.QW utf-8
+and
+.QW iso8859-1
+are guaranteed to be present in the list.
.TP
\fBencoding system\fR ?\fIencoding\fR?
.
@@ -73,7 +90,7 @@ However, because the \fBsource\fR command always reads files using the
current system encoding, Tcl will only source such files correctly
when the encoding used to write the file is the same. This tends not
to be true in an internationalized setting. For example, if such a
-file was sourced in North America (where the ISO8859-1 is normally
+file was sourced in North America (where the ISO8859\-1 is normally
used), each byte in the file would be treated as a separate character
that maps to the 00 page in Unicode. The resulting Tcl strings will
not contain the expected Japanese characters. Instead, they will
@@ -93,3 +110,6 @@ which is the Hiragana letter HA.
Tcl_GetEncoding(3)
.SH KEYWORDS
encoding, unicode
+.\" Local Variables:
+.\" mode: nroff
+.\" End:
diff --git a/doc/fcopy.n b/doc/fcopy.n
index ec3d5c6..071896c 100644
--- a/doc/fcopy.n
+++ b/doc/fcopy.n
@@ -46,8 +46,11 @@ non-blocking mode; the \fBfcopy\fR command takes care of that automatically.
However, it is necessary to enter the event loop by using
the \fBvwait\fR command or by using Tk.
.PP
-You are not allowed to do other I/O operations with
-\fIinchan\fR or \fIoutchan\fR during a background \fBfcopy\fR.
+You are not allowed to do other input operations with \fIinchan\fR, or
+output operations with \fIoutchan\fR, during a background
+\fBfcopy\fR. The converse is entirely legitimate, as exhibited by the
+bidirectional fcopy example below.
+.PP
If either \fIinchan\fR or \fIoutchan\fR get closed
while the copy is in progress, the current copy is stopped
and the command callback is \fInot\fR made.
@@ -57,7 +60,7 @@ then all data already queued for \fIoutchan\fR is written out.
Note that \fIinchan\fR can become readable during a background copy.
You should turn off any \fBfileevent\fR handlers during a background
copy so those handlers do not interfere with the copy.
-Any I/O attempted by a \fBfileevent\fR handler will get a
+Any wrong-sided I/O attempted (by a \fBfileevent\fR handler or otherwise) will get a
.QW "channel busy"
error.
.PP
@@ -149,6 +152,24 @@ set total 0
-command [list CopyMore $in $out $chunk]
vwait done
.CE
+.PP
+The fourth example starts an asynchronous, bidirectional fcopy between
+two sockets. Those could also be pipes from two [open "|hal 9000" r+]
+(though their conversation would remain secret to the script, since
+all four fileevent slots are busy).
+.PP
+.CS
+set flows 2
+proc Done {dir args} {
+ global flows done
+ puts "$dir is over."
+ incr flows -1
+ if {$flows<=0} {set done 1}
+}
+\fBfcopy\fR $sok1 $sok2 -command [list Done UP]
+\fBfcopy\fR $sok2 $sok1 -command [list Done DOWN]
+vwait done
+.CE
.SH "SEE ALSO"
eof(n), fblocked(n), fconfigure(n), file(n)
.SH KEYWORDS
diff --git a/doc/lset.n b/doc/lset.n
index 954bd30..954bd30 100755..100644
--- a/doc/lset.n
+++ b/doc/lset.n
diff --git a/doc/string.n b/doc/string.n
index 76005fc..163abdd 100644
--- a/doc/string.n
+++ b/doc/string.n
@@ -343,10 +343,13 @@ misleading.
\fBstring bytelength \fIstring\fR
.
Returns a decimal string giving the number of bytes used to represent
-\fIstring\fR in memory. Because UTF\-8 uses one to three bytes to
-represent Unicode characters, the byte length will not be the same as
-the character length in general. The cases where a script cares about
-the byte length are rare.
+\fIstring\fR in memory when encoded as Tcl's internal modified UTF\-8;
+Tcl may use other encodings for \fIstring\fR as well, and does not
+guarantee to only use a single encoding for a particular \fIstring\fR.
+Because UTF\-8 uses a variable number of bytes to represent Unicode
+characters, the byte length will not be the same as the character
+length in general. The cases where a script cares about the byte
+length are rare.
.RS
.PP
In almost all cases, you should use the
@@ -354,10 +357,27 @@ In almost all cases, you should use the
Tcl byte array value). Refer to the \fBTcl_NumUtfChars\fR manual
entry for more details on the UTF\-8 representation.
.PP
+Formally, the \fBstring bytelength\fR operation returns the content of
+the \fIlength\fR field of the \fBTcl_Obj\fR structure, after calling
+\fBTcl_GetString\fR to ensure that the \fIbytes\fR field is populated.
+This is highly unlikely to be useful to Tcl scripts, as Tcl's internal
+encoding is not strict UTF\-8, but rather a modified CESU\-8 with a
+denormalized NUL (identical to that used in a number of places by
+Java's serialization mechanism) to enable basic processing with
+non-Unicode-aware C functions. As this representation should only
+ever be used by Tcl's implementation, the number of bytes used to
+store the representation is of very low value (except to C extension
+code, which has direct access for the purpose of memory management,
+etc.)
+.PP
\fICompatibility note:\fR it is likely that this subcommand will be
withdrawn in a future version of Tcl. It is better to use the
\fBencoding convertto\fR command to convert a string to a known
encoding and then apply \fBstring length\fR to that.
+.PP
+.CS
+\fBstring length\fR [encoding convertto utf-8 $theString]
+.CE
.RE
.TP
\fBstring wordend \fIstring charIndex\fR
diff --git a/doc/tclvars.n b/doc/tclvars.n
index 2fec222..9d7a4ce 100644
--- a/doc/tclvars.n
+++ b/doc/tclvars.n
@@ -10,7 +10,7 @@
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
-argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_precision, tcl_rcFileName, tcl_traceCompile, tcl_traceEval, tcl_wordchars, tcl_version \- Variables used by Tcl
+argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_precision, tcl_rcFileName, tcl_traceCompile, tcl_traceExec, tcl_wordchars, tcl_version \- Variables used by Tcl
.BE
.SH DESCRIPTION
.PP
diff --git a/generic/tcl.h b/generic/tcl.h
index 4bf81cc..e557290 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -67,15 +67,12 @@ extern "C" {
* We use this method because there is no autoconf equivalent.
*/
-#ifndef __WIN32__
-# if defined(_WIN32) || defined(WIN32) || defined(__MINGW32__) || defined(__BORLANDC__) || (defined(__WATCOMC__) && defined(__WINDOWS_386__))
+#ifdef _WIN32
+# ifndef __WIN32__
# define __WIN32__
-# ifndef WIN32
-# define WIN32
-# endif
-# ifndef _WIN32
-# define _WIN32
-# endif
+# endif
+# ifndef WIN32
+# define WIN32
# endif
#endif
@@ -83,11 +80,11 @@ extern "C" {
* STRICT: See MSDN Article Q83456
*/
-#ifdef __WIN32__
+#ifdef _WIN32
# ifndef STRICT
# define STRICT
# endif
-#endif /* __WIN32__ */
+#endif /* _WIN32 */
/*
* Utility macros: STRINGIFY takes an argument and wraps it in "" (double
@@ -191,7 +188,7 @@ extern "C" {
* MSVCRT.
*/
-#if (defined(__WIN32__) && (defined(_MSC_VER) || (__BORLANDC__ >= 0x0550) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec))))
+#if (defined(_WIN32) && (defined(_MSC_VER) || (defined(__BORLANDC__) && (__BORLANDC__ >= 0x0550)) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec))))
# define HAVE_DECLSPEC 1
# ifdef STATIC_BUILD
# define DLLIMPORT
@@ -315,14 +312,14 @@ extern "C" {
* VOID. This block is skipped under Cygwin and Mingw.
*/
-#if defined(__WIN32__) && !defined(HAVE_WINNT_IGNORE_VOID)
+#if defined(_WIN32) && !defined(HAVE_WINNT_IGNORE_VOID)
#ifndef VOID
#define VOID void
typedef char CHAR;
typedef short SHORT;
typedef long LONG;
#endif
-#endif /* __WIN32__ && !HAVE_WINNT_IGNORE_VOID */
+#endif /* _WIN32 && !HAVE_WINNT_IGNORE_VOID */
/*
* Macro to use instead of "void" for arguments that must have type "void *"
@@ -390,7 +387,7 @@ typedef long LONG;
*/
#if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG)
-# if defined(__WIN32__)
+# if defined(_WIN32)
# define TCL_WIDE_INT_TYPE __int64
# ifdef __BORLANDC__
# define TCL_LL_MODIFIER "L"
@@ -400,7 +397,7 @@ typedef long LONG;
# elif defined(__GNUC__)
# define TCL_WIDE_INT_TYPE long long
# define TCL_LL_MODIFIER "ll"
-# else /* ! __WIN32__ && ! __GNUC__ */
+# else /* ! _WIN32 && ! __GNUC__ */
/*
* Don't know what platform it is and configure hasn't discovered what is
* going on for us. Try to guess...
@@ -415,7 +412,7 @@ typedef long LONG;
# define TCL_WIDE_INT_TYPE long long
# endif
# endif /* NO_LIMITS_H */
-# endif /* __WIN32__ */
+# endif /* _WIN32 */
#endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */
#ifdef TCL_WIDE_INT_IS_LONG
# undef TCL_WIDE_INT_TYPE
@@ -447,7 +444,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
# define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val)))
#endif /* TCL_WIDE_INT_IS_LONG */
-#if defined(__WIN32__)
+#if defined(_WIN32)
# ifdef __BORLANDC__
typedef struct stati64 Tcl_StatBuf;
# elif defined(_WIN64)
@@ -562,7 +559,7 @@ typedef struct Tcl_ZLibStream_ *Tcl_ZlibStream;
* will be called as the main fuction of the new thread created by that call.
*/
-#if defined __WIN32__
+#if defined _WIN32
typedef unsigned (__stdcall Tcl_ThreadCreateProc) (ClientData clientData);
#else
typedef void (Tcl_ThreadCreateProc) (ClientData clientData);
@@ -574,7 +571,7 @@ typedef void (Tcl_ThreadCreateProc) (ClientData clientData);
* in generic/tclThreadTest.c for it's usage.
*/
-#if defined __WIN32__
+#if defined _WIN32
# define Tcl_ThreadCreateType unsigned __stdcall
# define TCL_THREAD_CREATE_RETURN return 0
#else
@@ -2436,9 +2433,15 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
/*
* Include platform specific public function declarations that are accessible
- * via the stubs table.
+ * via the stubs table. Make all TclOO symbols MODULE_SCOPE (which only
+ * has effect on building it as a shared library). See ticket [3010352].
*/
+#if defined(BUILD_tcl)
+# undef TCLAPI
+# define TCLAPI MODULE_SCOPE
+#endif
+
#include "tclPlatDecls.h"
/*
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 89c286a..d1866c8 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -26,6 +26,7 @@
*- jumpTable testing
*- syntax (?)
*- returnCodeBranch
+ *- tclooNext, tclooNextClass
*/
#include "tclInt.h"
@@ -49,7 +50,7 @@ typedef enum BasicBlockCatchState {
BBCS_UNKNOWN = 0, /* Catch context has not yet been identified */
BBCS_NONE, /* Block is outside of any catch */
BBCS_INCATCH, /* Block is within a catch context */
- BBCS_CAUGHT, /* Block is within a catch context and
+ BBCS_CAUGHT /* Block is within a catch context and
* may be executed after an exception fires */
} BasicBlockCatchState;
@@ -120,7 +121,7 @@ enum BasicBlockFlags {
* marking it as the start of a 'catch'
* sequence. The 'jumpTarget' is the exception
* exit from the catch block. */
- BB_ENDCATCH = (1 << 5), /* Block ends with an 'endCatch' instruction,
+ BB_ENDCATCH = (1 << 5) /* Block ends with an 'endCatch' instruction,
* unwinding the catch from the exception
* stack. */
};
@@ -183,7 +184,7 @@ typedef enum TalInstType {
* produces N */
ASSEM_SINT1, /* One 1-byte signed-integer operand
* (INCR_STK_IMM) */
- ASSEM_SINT4_LVT4, /* Signed 4-byte integer operand followed by
+ ASSEM_SINT4_LVT4 /* Signed 4-byte integer operand followed by
* LVT entry. Fixed arity */
} TalInstType;
@@ -437,6 +438,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"nop", ASSEM_1BYTE, INST_NOP, 0, 0},
{"not", ASSEM_1BYTE, INST_LNOT, 1, 1},
{"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1},
+ {"numericType", ASSEM_1BYTE, INST_NUM_TYPE, 1, 1},
{"originCmd", ASSEM_1BYTE, INST_ORIGIN_COMMAND, 1, 1},
{"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1},
{"pop", ASSEM_1BYTE, INST_POP, 1, 0},
@@ -477,6 +479,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1},
{"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1},
{"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1},
+ {"tryCvtToBoolean", ASSEM_1BYTE, INST_TRY_CVT_TO_BOOLEAN,1, 2},
{"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1},
{"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1},
{"unset", ASSEM_BOOL_LVT4,INST_UNSET_SCALAR, 0, 0},
@@ -516,7 +519,8 @@ static const unsigned char NonThrowingByteCodes[] = {
INST_RESOLVE_COMMAND, /* 154 */
INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 166-168 */
INST_CONCAT_STK, /* 169 */
- INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE /* 170-172 */
+ INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE, /* 170-172 */
+ INST_NUM_TYPE /* 180 */
};
/*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 7c02706..2a334c4 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -259,7 +259,7 @@ static const CmdInfo builtInCmds[] = {
{"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, CMD_IS_SAFE},
{"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, CMD_IS_SAFE},
{"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, CMD_IS_SAFE},
- {"yieldto", NULL, NULL, TclNRYieldToObjCmd, CMD_IS_SAFE},
+ {"yieldto", NULL, TclCompileYieldToCmd, TclNRYieldToObjCmd, CMD_IS_SAFE},
/*
* Commands in the OS-interface. Note that many of these are unsafe.
@@ -2085,10 +2085,19 @@ Tcl_CreateCommand(
*/
cmdPtr = Tcl_GetHashValue(hPtr);
- oldRefPtr = cmdPtr->importRefPtr;
- cmdPtr->importRefPtr = NULL;
+ cmdPtr->refCount++;
+ if (cmdPtr->importRefPtr) {
+ cmdPtr->flags |= CMD_REDEF_IN_PROGRESS;
+ }
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
+
+ if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) {
+ oldRefPtr = cmdPtr->importRefPtr;
+ cmdPtr->importRefPtr = NULL;
+ }
+ TclCleanupCommandMacro(cmdPtr);
+
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew);
if (!isNew) {
/*
@@ -2272,10 +2281,19 @@ Tcl_CreateObjCommand(
* intact.
*/
- oldRefPtr = cmdPtr->importRefPtr;
- cmdPtr->importRefPtr = NULL;
+ cmdPtr->refCount++;
+ if (cmdPtr->importRefPtr) {
+ cmdPtr->flags |= CMD_REDEF_IN_PROGRESS;
+ }
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
+
+ if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) {
+ oldRefPtr = cmdPtr->importRefPtr;
+ cmdPtr->importRefPtr = NULL;
+ }
+ TclCleanupCommandMacro(cmdPtr);
+
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew);
if (!isNew) {
/*
@@ -3117,12 +3135,13 @@ Tcl_DeleteCommandFromToken(
* commands were created that refer back to this command. Delete these
* imported commands now.
*/
-
- for (refPtr = cmdPtr->importRefPtr; refPtr != NULL;
- refPtr = nextRefPtr) {
- nextRefPtr = refPtr->nextPtr;
- importCmd = (Tcl_Command) refPtr->importedCmdPtr;
- Tcl_DeleteCommandFromToken(interp, importCmd);
+ if (!(cmdPtr->flags & CMD_REDEF_IN_PROGRESS)) {
+ for (refPtr = cmdPtr->importRefPtr; refPtr != NULL;
+ refPtr = nextRefPtr) {
+ nextRefPtr = refPtr->nextPtr;
+ importCmd = (Tcl_Command) refPtr->importedCmdPtr;
+ Tcl_DeleteCommandFromToken(interp, importCmd);
+ }
}
/*
@@ -8416,8 +8435,7 @@ TclNRYieldToObjCmd(
{
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
Tcl_Obj *listPtr, *nsObjPtr;
- Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
- Tcl_Namespace *ns1Ptr;
+ Tcl_Namespace *nsPtr = TclGetCurrentNamespace(interp);
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
@@ -8431,11 +8449,13 @@ TclNRYieldToObjCmd(
return TCL_ERROR;
}
- /*
- * Add the tailcall in the caller env, then just yield.
- *
- * This is essentially code from TclNRTailcallObjCmd
- */
+ if (((Namespace *) nsPtr)->flags & NS_DYING) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "yieldto called in deleted namespace", -1));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
+ NULL);
+ return TCL_ERROR;
+ }
/*
* Add the tailcall in the caller env, then just yield.
@@ -8444,15 +8464,9 @@ TclNRYieldToObjCmd(
*/
listPtr = Tcl_NewListObj(objc, objv);
-
nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
- if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
- || (nsPtr != ns1Ptr)) {
- Tcl_Panic("yieldto failed to find the proper namespace");
- }
TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
-
/*
* Add the callback in the caller's env, then instruct TEBC to yield.
*/
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 4e977f2..981f174 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -610,9 +610,7 @@ UpdateStringOfByteArray(
*
* This function appends an array of bytes to a byte array object. Note
* that the object *must* be unshared, and the array of bytes *must not*
- * refer to the object being appended to. Also the caller must have
- * already checked that the final length of the bytearray after the
- * append operations is complete will not overflow the int range.
+ * refer to the object being appended to.
*
* Results:
* None.
@@ -631,6 +629,7 @@ TclAppendBytesToByteArray(
int len)
{
ByteArray *byteArrayPtr;
+ int needed;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
@@ -639,64 +638,57 @@ TclAppendBytesToByteArray(
Tcl_Panic("%s must be called with definite number of bytes to append",
"TclAppendBytesToByteArray");
}
+ if (len == 0) {
+ /* Append zero bytes is a no-op. */
+ return;
+ }
if (objPtr->typePtr != &tclByteArrayType) {
SetByteArrayFromAny(NULL, objPtr);
}
byteArrayPtr = GET_BYTEARRAY(objPtr);
+ if (len > INT_MAX - byteArrayPtr->used) {
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+ }
+
+ needed = byteArrayPtr->used + len;
/*
* If we need to, resize the allocated space in the byte array.
*/
- if (byteArrayPtr->used + len > byteArrayPtr->allocated) {
- unsigned int attempt, used = byteArrayPtr->used;
- ByteArray *tmpByteArrayPtr = NULL;
+ if (needed > byteArrayPtr->allocated) {
+ ByteArray *ptr = NULL;
+ int attempt;
- attempt = byteArrayPtr->allocated;
- if (attempt < 1) {
- /*
- * No allocated bytes, so must be none used too. We use this
- * method to calculate how many bytes to allocate because we can
- * end up with a zero-length buffer otherwise, when doubling can
- * cause trouble. [Bug 3067036]
- */
-
- attempt = len + 1;
- } else {
- do {
- attempt *= 2;
- } while (attempt < used+len);
+ if (needed <= INT_MAX/2) {
+ /* Try to allocate double the total space that is needed. */
+ attempt = 2 * needed;
+ ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
}
+ if (ptr == NULL) {
+ /* Try to allocate double the increment that is needed (plus). */
+ unsigned int limit = INT_MAX - needed;
+ unsigned int extra = len + TCL_MIN_GROWTH;
+ int growth = (int) ((extra > limit) ? limit : extra);
- if (BYTEARRAY_SIZE(attempt) > BYTEARRAY_SIZE(used)) {
- tmpByteArrayPtr = attemptckrealloc(byteArrayPtr,
- BYTEARRAY_SIZE(attempt));
+ attempt = needed + growth;
+ ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
}
-
- if (tmpByteArrayPtr == NULL) {
- attempt = used + len;
- if (BYTEARRAY_SIZE(attempt) < BYTEARRAY_SIZE(used)) {
- Tcl_Panic("attempt to allocate a bigger buffer than we can handle");
- }
- tmpByteArrayPtr = ckrealloc(byteArrayPtr,
- BYTEARRAY_SIZE(attempt));
+ if (ptr == NULL) {
+ /* Last chance: Try to allocate exactly what is needed. */
+ attempt = needed;
+ ptr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
}
-
- byteArrayPtr = tmpByteArrayPtr;
+ byteArrayPtr = ptr;
byteArrayPtr->allocated = attempt;
- byteArrayPtr->used = used;
SET_BYTEARRAY(objPtr, byteArrayPtr);
}
- /*
- * Do the append if there's any point.
- */
-
- if (len > 0) {
+ if (bytes) {
memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len);
- byteArrayPtr->used += len;
- TclInvalidateStringRep(objPtr);
}
+ byteArrayPtr->used += len;
+ TclInvalidateStringRep(objPtr);
}
/*
diff --git a/generic/tclClock.c b/generic/tclClock.c
index 6d2976d..15f29e5 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -19,7 +19,7 @@
* Windows has mktime. The configurators do not check.
*/
-#ifdef __WIN32__
+#ifdef _WIN32
#define HAVE_MKTIME 1
#endif
@@ -548,18 +548,21 @@ ClockGetjuliandayfromerayearmonthdayObjCmd(
}
dict = objv[1];
if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK
+ || fieldPtr == NULL
|| Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT,
&era) != TCL_OK
- || Tcl_DictObjGet(interp, dict, literals[LIT_YEAR],
- &fieldPtr) != TCL_OK
+ || Tcl_DictObjGet(interp, dict, literals[LIT_YEAR], &fieldPtr) != TCL_OK
+ || fieldPtr == NULL
|| TclGetIntFromObj(interp, fieldPtr, &fields.year) != TCL_OK
- || Tcl_DictObjGet(interp, dict, literals[LIT_MONTH],
- &fieldPtr) != TCL_OK
+ || Tcl_DictObjGet(interp, dict, literals[LIT_MONTH], &fieldPtr) != TCL_OK
+ || fieldPtr == NULL
|| TclGetIntFromObj(interp, fieldPtr, &fields.month) != TCL_OK
- || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFMONTH],
- &fieldPtr) != TCL_OK
+ || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFMONTH], &fieldPtr) != TCL_OK
+ || fieldPtr == NULL
|| TclGetIntFromObj(interp, fieldPtr, &fields.dayOfMonth)!=TCL_OK
|| TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
+ if (fieldPtr == NULL)
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("expected key(s) not found in dictionary", -1));
return TCL_ERROR;
}
fields.era = era;
@@ -638,18 +641,21 @@ ClockGetjuliandayfromerayearweekdayObjCmd(
}
dict = objv[1];
if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK
+ || fieldPtr == NULL
|| Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT,
&era) != TCL_OK
- || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601YEAR],
- &fieldPtr) != TCL_OK
- || TclGetIntFromObj(interp, fieldPtr, &fields.iso8601Year)!=TCL_OK
- || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601WEEK],
- &fieldPtr) != TCL_OK
- || TclGetIntFromObj(interp, fieldPtr, &fields.iso8601Week)!=TCL_OK
- || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFWEEK],
- &fieldPtr) != TCL_OK
- || TclGetIntFromObj(interp, fieldPtr, &fields.dayOfWeek) != TCL_OK
+ || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601YEAR], &fieldPtr) != TCL_OK
+ || fieldPtr == NULL
+ || TclGetIntFromObj(interp, fieldPtr, &(fields.iso8601Year)) != TCL_OK
+ || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601WEEK], &fieldPtr) != TCL_OK
+ || fieldPtr == NULL
+ || TclGetIntFromObj(interp, fieldPtr, &(fields.iso8601Week)) != TCL_OK
+ || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFWEEK], &fieldPtr) != TCL_OK
+ || fieldPtr == NULL
+ || TclGetIntFromObj(interp, fieldPtr, &(fields.dayOfWeek)) != TCL_OK
|| TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
+ if (fieldPtr == NULL)
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("expected key(s) not found in dictionary", -1));
return TCL_ERROR;
}
fields.era = era;
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index f90819a..d90a747 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -1590,7 +1590,7 @@ FileAttrIsOwnedCmd(
* test for equivalence to the current user.
*/
-#if defined(__WIN32__) || defined(__CYGWIN__)
+#if defined(_WIN32) || defined(__CYGWIN__)
value = 1;
#else
value = (geteuid() == buf.st_uid);
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index d477216..00c9f2f 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -32,6 +32,39 @@ static int TryPostHandler(ClientData data[], Tcl_Interp *interp,
int result);
static int UniCharIsAscii(int character);
static int UniCharIsHexDigit(int character);
+
+/*
+ * Default set of characters to trim in [string trim] and friends. This is a
+ * UTF-8 literal string containing all Unicode space characters [TIP #413]
+ */
+
+const char tclDefaultTrimSet[] =
+ "\x09\x0a\x0b\x0c\x0d " /* ASCII */
+ "\xc0\x80" /* nul (U+0000) */
+ "\xc2\x85" /* next line (U+0085) */
+ "\xc2\xa0" /* non-breaking space (U+00a0) */
+ "\xe1\x9a\x80" /* ogham space mark (U+1680) */
+ "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */
+ "\xe2\x80\x80" /* en quad (U+2000) */
+ "\xe2\x80\x81" /* em quad (U+2001) */
+ "\xe2\x80\x82" /* en space (U+2002) */
+ "\xe2\x80\x83" /* em space (U+2003) */
+ "\xe2\x80\x84" /* three-per-em space (U+2004) */
+ "\xe2\x80\x85" /* four-per-em space (U+2005) */
+ "\xe2\x80\x86" /* six-per-em space (U+2006) */
+ "\xe2\x80\x87" /* figure space (U+2007) */
+ "\xe2\x80\x88" /* punctuation space (U+2008) */
+ "\xe2\x80\x89" /* thin space (U+2009) */
+ "\xe2\x80\x8a" /* hair space (U+200a) */
+ "\xe2\x80\x8b" /* zero width space (U+200b) */
+ "\xe2\x80\xa8" /* line separator (U+2028) */
+ "\xe2\x80\xa9" /* paragraph separator (U+2029) */
+ "\xe2\x80\xaf" /* narrow no-break space (U+202f) */
+ "\xe2\x81\x9f" /* medium mathematical space (U+205f) */
+ "\xe2\x81\xa0" /* word joiner (U+2060) */
+ "\xe3\x80\x80" /* ideographic space (U+3000) */
+ "\xef\xbb\xbf" /* zero width no-break space (U+feff) */
+;
/*
*----------------------------------------------------------------------
@@ -3158,8 +3191,8 @@ StringTrimCmd(
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
- string2 = DEFAULT_TRIM_SET;
- length2 = strlen(DEFAULT_TRIM_SET);
+ string2 = tclDefaultTrimSet;
+ length2 = strlen(tclDefaultTrimSet);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
return TCL_ERROR;
@@ -3206,8 +3239,8 @@ StringTrimLCmd(
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
- string2 = DEFAULT_TRIM_SET;
- length2 = strlen(DEFAULT_TRIM_SET);
+ string2 = tclDefaultTrimSet;
+ length2 = strlen(tclDefaultTrimSet);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
return TCL_ERROR;
@@ -3252,8 +3285,8 @@ StringTrimRCmd(
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
- string2 = DEFAULT_TRIM_SET;
- length2 = strlen(DEFAULT_TRIM_SET);
+ string2 = tclDefaultTrimSet;
+ length2 = strlen(tclDefaultTrimSet);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
return TCL_ERROR;
@@ -3299,7 +3332,7 @@ TclInitStringCmd(
{"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0},
{"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0},
{"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0},
- {"is", StringIsCmd, NULL, NULL, NULL, 0},
+ {"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0},
{"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0},
{"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0},
{"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 05b6d07..d1d7a80 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -278,7 +278,7 @@ TclCompileArraySetCmd(
if (isDataValid && !isDataEven) {
PushStringLiteral(envPtr, "list must have an even number of elements");
- PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}");
+ PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}");
TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr);
TclEmitInt4( 0, envPtr);
goto done;
@@ -373,7 +373,7 @@ TclCompileArraySetCmd(
offsetFwd = CurrentOffset(envPtr);
TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
PushStringLiteral(envPtr, "list must have an even number of elements");
- PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}");
+ PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}");
TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr);
TclEmitInt4( 0, envPtr);
TclAdjustStackDepth(-1, envPtr);
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index df8895f..b3e273f 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -3039,6 +3039,66 @@ IndexTailVarIfKnown(
return localIndex;
}
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclCompileObjectNextCmd, TclCompileObjectSelfCmd --
+ *
+ * Compilations of the TclOO utility commands [next] and [self].
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclCompileObjectNextCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = parsePtr->tokenPtr;
+ int i;
+
+ if (parsePtr->numWords > 255) {
+ return TCL_ERROR;
+ }
+
+ for (i=0 ; i<parsePtr->numWords ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ TclEmitInstInt1( INST_TCLOO_NEXT, i, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileObjectNextToCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = parsePtr->tokenPtr;
+ int i;
+
+ if (parsePtr->numWords < 2 || parsePtr->numWords > 255) {
+ return TCL_ERROR;
+ }
+
+ for (i=0 ; i<parsePtr->numWords ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ TclEmitInstInt1( INST_TCLOO_NEXT_CLASS, i, envPtr);
+ return TCL_OK;
+}
+
int
TclCompileObjectSelfCmd(
Tcl_Interp *interp, /* Used for error reporting. */
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 0f2790f..e6ec0a6 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -425,6 +425,284 @@ TclCompileStringIndexCmd(
}
int
+TclCompileStringIsCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ static const char *const isClasses[] = {
+ "alnum", "alpha", "ascii", "control",
+ "boolean", "digit", "double", "entier",
+ "false", "graph", "integer", "list",
+ "lower", "print", "punct", "space",
+ "true", "upper", "wideinteger", "wordchar",
+ "xdigit", NULL
+ };
+ enum isClasses {
+ STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
+ STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER,
+ STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST,
+ STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE,
+ STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD,
+ STR_IS_XDIGIT
+ };
+ int t, range, allowEmpty = 0, end;
+ InstStringClassType strClassType;
+ Tcl_Obj *isClass;
+
+ if (parsePtr->numWords < 3 || parsePtr->numWords > 6) {
+ return TCL_ERROR;
+ }
+ isClass = Tcl_NewObj();
+ if (!TclWordKnownAtCompileTime(tokenPtr, isClass)) {
+ Tcl_DecrRefCount(isClass);
+ return TCL_ERROR;
+ } else if (Tcl_GetIndexFromObj(interp, isClass, isClasses, "class", 0,
+ &t) != TCL_OK) {
+ Tcl_DecrRefCount(isClass);
+ TclCompileSyntaxError(interp, envPtr);
+ return TCL_OK;
+ }
+ Tcl_DecrRefCount(isClass);
+
+#define GotLiteral(tokenPtr, word) \
+ ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD && \
+ (tokenPtr)[1].size > 1 && \
+ (tokenPtr)[1].start[0] == word[0] && \
+ strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0)
+
+ /*
+ * Cannot handle the -failindex option at all, and that's the only legal
+ * way to have more than 4 arguments.
+ */
+
+ if (parsePtr->numWords != 3 && parsePtr->numWords != 4) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(tokenPtr);
+ if (parsePtr->numWords == 3) {
+ allowEmpty = 1;
+ } else {
+ if (!GotLiteral(tokenPtr, "-strict")) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+#undef GotLiteral
+
+ /*
+ * Compile the code. There are several main classes of check here.
+ * 1. Character classes
+ * 2. Booleans
+ * 3. Integers
+ * 4. Floats
+ * 5. Lists
+ */
+
+ CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
+
+ switch ((enum isClasses) t) {
+ case STR_IS_ALNUM:
+ strClassType = STR_CLASS_ALNUM;
+ goto compileStrClass;
+ case STR_IS_ALPHA:
+ strClassType = STR_CLASS_ALPHA;
+ goto compileStrClass;
+ case STR_IS_ASCII:
+ strClassType = STR_CLASS_ASCII;
+ goto compileStrClass;
+ case STR_IS_CONTROL:
+ strClassType = STR_CLASS_CONTROL;
+ goto compileStrClass;
+ case STR_IS_DIGIT:
+ strClassType = STR_CLASS_DIGIT;
+ goto compileStrClass;
+ case STR_IS_GRAPH:
+ strClassType = STR_CLASS_GRAPH;
+ goto compileStrClass;
+ case STR_IS_LOWER:
+ strClassType = STR_CLASS_LOWER;
+ goto compileStrClass;
+ case STR_IS_PRINT:
+ strClassType = STR_CLASS_PRINT;
+ goto compileStrClass;
+ case STR_IS_PUNCT:
+ strClassType = STR_CLASS_PUNCT;
+ goto compileStrClass;
+ case STR_IS_SPACE:
+ strClassType = STR_CLASS_SPACE;
+ goto compileStrClass;
+ case STR_IS_UPPER:
+ strClassType = STR_CLASS_UPPER;
+ goto compileStrClass;
+ case STR_IS_WORD:
+ strClassType = STR_CLASS_WORD;
+ goto compileStrClass;
+ case STR_IS_XDIGIT:
+ strClassType = STR_CLASS_XDIGIT;
+ compileStrClass:
+ if (allowEmpty) {
+ OP1( STR_CLASS, strClassType);
+ } else {
+ int over, over2;
+
+ OP( DUP);
+ OP1( STR_CLASS, strClassType);
+ JUMP1( JUMP_TRUE, over);
+ OP( POP);
+ PUSH( "0");
+ JUMP1( JUMP, over2);
+ FIXJUMP1(over);
+ PUSH( "");
+ OP( STR_NEQ);
+ FIXJUMP1(over2);
+ }
+ return TCL_OK;
+
+ case STR_IS_BOOL:
+ case STR_IS_FALSE:
+ case STR_IS_TRUE:
+ OP( TRY_CVT_TO_BOOLEAN);
+ switch (t) {
+ int over, over2;
+
+ case STR_IS_BOOL:
+ if (allowEmpty) {
+ JUMP1( JUMP_TRUE, over);
+ PUSH( "");
+ OP( STR_EQ);
+ JUMP1( JUMP, over2);
+ FIXJUMP1(over);
+ OP( POP);
+ PUSH( "1");
+ FIXJUMP1(over2);
+ } else {
+ OP4( REVERSE, 2);
+ OP( POP);
+ }
+ return TCL_OK;
+ case STR_IS_TRUE:
+ JUMP1( JUMP_TRUE, over);
+ if (allowEmpty) {
+ PUSH( "");
+ OP( STR_EQ);
+ } else {
+ OP( POP);
+ PUSH( "0");
+ }
+ FIXJUMP1( over);
+ OP( LNOT);
+ OP( LNOT);
+ return TCL_OK;
+ case STR_IS_FALSE:
+ JUMP1( JUMP_TRUE, over);
+ if (allowEmpty) {
+ PUSH( "");
+ OP( STR_NEQ);
+ } else {
+ OP( POP);
+ PUSH( "1");
+ }
+ FIXJUMP1( over);
+ OP( LNOT);
+ return TCL_OK;
+ }
+
+ case STR_IS_DOUBLE: {
+ int satisfied, isEmpty;
+
+ if (allowEmpty) {
+ OP( DUP);
+ PUSH( "");
+ OP( STR_EQ);
+ JUMP1( JUMP_TRUE, isEmpty);
+ OP( NUM_TYPE);
+ JUMP1( JUMP_TRUE, satisfied);
+ PUSH( "0");
+ JUMP1( JUMP, end);
+ FIXJUMP1( isEmpty);
+ OP( POP);
+ FIXJUMP1( satisfied);
+ } else {
+ OP( NUM_TYPE);
+ JUMP1( JUMP_TRUE, satisfied);
+ PUSH( "0");
+ JUMP1( JUMP, end);
+ TclAdjustStackDepth(-1, envPtr);
+ FIXJUMP1( satisfied);
+ }
+ PUSH( "1");
+ FIXJUMP1( end);
+ return TCL_OK;
+ }
+
+ case STR_IS_INT:
+ case STR_IS_WIDE:
+ case STR_IS_ENTIER:
+ if (allowEmpty) {
+ int testNumType;
+
+ OP( DUP);
+ OP( NUM_TYPE);
+ OP( DUP);
+ JUMP1( JUMP_TRUE, testNumType);
+ OP( POP);
+ PUSH( "");
+ OP( STR_EQ);
+ JUMP1( JUMP, end);
+ TclAdjustStackDepth(1, envPtr);
+ FIXJUMP1( testNumType);
+ OP4( REVERSE, 2);
+ OP( POP);
+ } else {
+ OP( NUM_TYPE);
+ OP( DUP);
+ JUMP1( JUMP_FALSE, end);
+ }
+
+ switch (t) {
+ case STR_IS_INT:
+ PUSH( "1");
+ OP( EQ);
+ break;
+ case STR_IS_WIDE:
+ PUSH( "2");
+ OP( LE);
+ break;
+ case STR_IS_ENTIER:
+ PUSH( "3");
+ OP( LE);
+ break;
+ }
+ FIXJUMP1( end);
+ return TCL_OK;
+
+ case STR_IS_LIST:
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ OP4( BEGIN_CATCH4, range);
+ ExceptionRangeStarts(envPtr, range);
+ OP( DUP);
+ OP( LIST_LENGTH);
+ OP( POP);
+ ExceptionRangeEnds(envPtr, range);
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ OP( POP);
+ OP( PUSH_RETURN_CODE);
+ OP( END_CATCH);
+ OP( LNOT);
+ return TCL_OK;
+ }
+
+ return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
TclCompileStringMatchCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
@@ -810,7 +1088,7 @@ TclCompileStringTrimLCmd(
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
} else {
- PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET));
+ PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet));
}
OP( STR_TRIM_LEFT);
return TCL_OK;
@@ -838,7 +1116,7 @@ TclCompileStringTrimRCmd(
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
} else {
- PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET));
+ PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet));
}
OP( STR_TRIM_RIGHT);
return TCL_OK;
@@ -866,7 +1144,7 @@ TclCompileStringTrimCmd(
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
} else {
- PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET));
+ PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet));
}
OP( STR_TRIM);
return TCL_OK;
@@ -939,6 +1217,41 @@ TclCompileStringToTitleCmd(
}
/*
+ * Support definitions for the [string is] compilation.
+ */
+
+static int
+UniCharIsAscii(
+ int character)
+{
+ return (character >= 0) && (character < 0x80);
+}
+
+static int
+UniCharIsHexDigit(
+ int character)
+{
+ return (character >= 0) && (character < 0x80) && isxdigit(character);
+}
+
+StringClassDesc const tclStringClassTable[] = {
+ {"alnum", Tcl_UniCharIsAlnum},
+ {"alpha", Tcl_UniCharIsAlpha},
+ {"ascii", UniCharIsAscii},
+ {"control", Tcl_UniCharIsControl},
+ {"digit", Tcl_UniCharIsDigit},
+ {"graph", Tcl_UniCharIsGraph},
+ {"lower", Tcl_UniCharIsLower},
+ {"print", Tcl_UniCharIsPrint},
+ {"punct", Tcl_UniCharIsPunct},
+ {"space", Tcl_UniCharIsSpace},
+ {"upper", Tcl_UniCharIsUpper},
+ {"word", Tcl_UniCharIsWordChar},
+ {"xdigit", UniCharIsHexDigit},
+ {NULL, NULL}
+};
+
+/*
*----------------------------------------------------------------------
*
* TclCompileSubstCmd --
@@ -3447,6 +3760,51 @@ TclCompileYieldCmd(
/*
*----------------------------------------------------------------------
*
+ * TclCompileYieldToCmd --
+ *
+ * Procedure called to compile the "yieldto" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "yieldto" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileYieldToCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ int i;
+
+ if (parsePtr->numWords < 2) {
+ return TCL_ERROR;
+ }
+
+ OP( NS_CURRENT);
+ for (i = 1 ; i < parsePtr->numWords ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ OP4( LIST, i);
+ OP( YIELD_TO_INVOKE);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* CompileUnaryOpCmd --
*
* Utility routine to compile the unary operator commands.
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 0732fe5..347e3f0 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -493,6 +493,7 @@ InstructionDesc const tclInstructionTable[] = {
* qualified version, or produces the empty string if no such command
* exists. Never generates errors.
* Stack: ... cmdName => ... fullCmdName */
+
{"tclooSelf", 1, +1, 0, {OPERAND_NONE}},
/* Push the identity of the current TclOO object (i.e., the name of
* its current public access command) on the stack. */
@@ -616,6 +617,39 @@ InstructionDesc const tclInstructionTable[] = {
* of the command named on the top of the stack.
* Stack: ... cmdName => ... fullOriginalCmdName */
+ {"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}},
+ /* Call the next item on the TclOO call chain, passing opnd arguments
+ * (min 1, max 255, *includes* "next"). The result of the invoked
+ * method implementation will be pushed on the stack in place of the
+ * arguments (similar to invokeStk).
+ * Stack: ... "next" arg2 arg3 -- argN => ... result */
+ {"tclooNextClass", 2, INT_MIN, 1, {OPERAND_UINT1}},
+ /* Call the following item on the TclOO call chain defined by class
+ * className, passing opnd arguments (min 2, max 255, *includes*
+ * "nextto" and the class name). The result of the invoked method
+ * implementation will be pushed on the stack in place of the
+ * arguments (similar to invokeStk).
+ * Stack: ... "nextto" className arg3 arg4 -- argN => ... result */
+
+ {"yieldToInvoke", 1, 0, 0, {OPERAND_NONE}},
+ /* Makes the current coroutine yield the value at the top of the
+ * stack, invoking the given command/args with resolution in the given
+ * namespace (all packed into a list), and places the list of values
+ * that are the response back on top of the stack when it resumes.
+ * Stack: ... [list ns cmd arg1 ... argN] => ... resumeList */
+
+ {"numericType", 1, 0, 0, {OPERAND_NONE}},
+ /* Pushes the numeric type code of the word at the top of the stack.
+ * Stack: ... value => ... typeCode */
+ {"tryCvtToBoolean", 1, +1, 0, {OPERAND_NONE}},
+ /* Try converting stktop to boolean if possible. No errors.
+ * Stack: ... value => ... value isStrictBool */
+ {"strclass", 2, 0, 1, {OPERAND_SCLS1}},
+ /* See if all the characters of the given string are a member of the
+ * specified (by opnd) character class. Note that an empty string will
+ * satisfy the class check (standard definition of "all").
+ * Stack: ... stringValue => ... boolean */
+
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
@@ -5063,6 +5097,11 @@ FormatInstruction(
}
Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd);
break;
+ case OPERAND_SCLS1:
+ opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
+ Tcl_AppendPrintfToObj(bufferObj, "%s ",
+ tclStringClassTable[opnd].name);
+ break;
case OPERAND_NONE:
default:
break;
@@ -5279,7 +5318,7 @@ PrintSourceToObj(
int maxChars) /* Maximum number of chars to print. */
{
register const char *p;
- register int i = 0;
+ register int i = 0, len;
if (stringPtr == NULL) {
Tcl_AppendToObj(appendObj, "\"\"", -1);
@@ -5288,32 +5327,50 @@ PrintSourceToObj(
Tcl_AppendToObj(appendObj, "\"", -1);
p = stringPtr;
- for (; (*p != '\0') && (i < maxChars); p++, i++) {
- switch (*p) {
+ for (; (*p != '\0') && (i < maxChars); p+=len) {
+ Tcl_UniChar ch;
+
+ len = TclUtfToUniChar(p, &ch);
+ switch (ch) {
case '"':
Tcl_AppendToObj(appendObj, "\\\"", -1);
+ i += 2;
continue;
case '\f':
Tcl_AppendToObj(appendObj, "\\f", -1);
+ i += 2;
continue;
case '\n':
Tcl_AppendToObj(appendObj, "\\n", -1);
+ i += 2;
continue;
case '\r':
Tcl_AppendToObj(appendObj, "\\r", -1);
+ i += 2;
continue;
case '\t':
Tcl_AppendToObj(appendObj, "\\t", -1);
+ i += 2;
continue;
case '\v':
Tcl_AppendToObj(appendObj, "\\v", -1);
+ i += 2;
continue;
default:
- Tcl_AppendPrintfToObj(appendObj, "%c", *p);
+ if (ch < 0x20 || ch >= 0x7f) {
+ Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ch);
+ i += 6;
+ } else {
+ Tcl_AppendPrintfToObj(appendObj, "%c", ch);
+ i++;
+ }
continue;
}
}
Tcl_AppendToObj(appendObj, "\"", -1);
+ if (*p != '\0') {
+ Tcl_AppendToObj(appendObj, "...", -1);
+ }
}
#ifdef TCL_COMPILE_STATS
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index fb66e90..5665ca9 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -751,6 +751,8 @@ typedef struct ByteCode {
#define INST_INFO_LEVEL_NUM 152
#define INST_INFO_LEVEL_ARGS 153
#define INST_RESOLVE_COMMAND 154
+
+/* For compilation relating to TclOO */
#define INST_TCLOO_SELF 155
#define INST_TCLOO_CLASS 156
#define INST_TCLOO_NS 157
@@ -788,8 +790,17 @@ typedef struct ByteCode {
#define INST_ORIGIN_COMMAND 178
+#define INST_TCLOO_NEXT 179
+#define INST_TCLOO_NEXT_CLASS 180
+
+#define INST_YIELD_TO_INVOKE 181
+
+#define INST_NUM_TYPE 182
+#define INST_TRY_CVT_TO_BOOLEAN 183
+#define INST_STR_CLASS 184
+
/* The last opcode */
-#define LAST_INST_OPCODE 178
+#define LAST_INST_OPCODE 184
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
@@ -814,8 +825,9 @@ typedef enum InstOperandType {
* variable table. */
OPERAND_LVT4, /* Four byte unsigned index into the local
* variable table. */
- OPERAND_AUX4 /* Four byte unsigned index into the aux data
+ OPERAND_AUX4, /* Four byte unsigned index into the aux data
* table. */
+ OPERAND_SCLS1 /* Index into tclStringClassTable. */
} InstOperandType;
typedef struct InstructionDesc {
@@ -834,6 +846,40 @@ typedef struct InstructionDesc {
MODULE_SCOPE InstructionDesc const tclInstructionTable[];
/*
+ * Constants used by INST_STRING_CLASS to indicate character classes. These
+ * correspond closely by name with what [string is] can support, but there is
+ * no requirement to keep the values the same.
+ */
+
+typedef enum InstStringClassType {
+ STR_CLASS_ALNUM, /* Unicode alphabet or digit characters. */
+ STR_CLASS_ALPHA, /* Unicode alphabet characters. */
+ STR_CLASS_ASCII, /* Characters in range U+000000..U+00007F. */
+ STR_CLASS_CONTROL, /* Unicode control characters. */
+ STR_CLASS_DIGIT, /* Unicode digit characters. */
+ STR_CLASS_GRAPH, /* Unicode printing characters, excluding
+ * space. */
+ STR_CLASS_LOWER, /* Unicode lower-case alphabet characters. */
+ STR_CLASS_PRINT, /* Unicode printing characters, including
+ * spaces. */
+ STR_CLASS_PUNCT, /* Unicode punctuation characters. */
+ STR_CLASS_SPACE, /* Unicode space characters. */
+ STR_CLASS_UPPER, /* Unicode upper-case alphabet characters. */
+ STR_CLASS_WORD, /* Unicode word (alphabetic, digit, connector
+ * punctuation) characters. */
+ STR_CLASS_XDIGIT /* Characters that can be used as digits in
+ * hexadecimal numbers ([0-9A-Fa-f]). */
+} InstStringClassType;
+
+typedef struct StringClassDesc {
+ const char *name; /* Name of the class. */
+ int (*comparator)(int); /* Function to test if a single unicode
+ * character is a member of the class. */
+} StringClassDesc;
+
+MODULE_SCOPE StringClassDesc const tclStringClassTable[];
+
+/*
* Compilation of some Tcl constructs such as if commands and the logical or
* (||) and logical and (&&) operators in expressions requires the generation
* of forward jumps. Since the PC target of these jumps isn't known when the
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 830c998..91c0add 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -63,7 +63,7 @@ EXTERN void Tcl_DbCkfree(char *ptr, const char *file, int line);
/* 8 */
EXTERN char * Tcl_DbCkrealloc(char *ptr, unsigned int size,
const char *file, int line);
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
+#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
/* 9 */
EXTERN void Tcl_CreateFileHandler(int fd, int mask,
Tcl_FileProc *proc, ClientData clientData);
@@ -73,7 +73,7 @@ EXTERN void Tcl_CreateFileHandler(int fd, int mask,
EXTERN void Tcl_CreateFileHandler(int fd, int mask,
Tcl_FileProc *proc, ClientData clientData);
#endif /* MACOSX */
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
+#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
/* 10 */
EXTERN void Tcl_DeleteFileHandler(int fd);
#endif /* UNIX */
@@ -511,7 +511,7 @@ EXTERN Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp);
EXTERN const char * Tcl_GetNameOfExecutable(void);
/* 166 */
EXTERN Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp);
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
+#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
/* 167 */
EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp,
const char *chanID, int forWriting,
@@ -1835,19 +1835,19 @@ typedef struct TclStubs {
char * (*tcl_DbCkalloc) (unsigned int size, const char *file, int line); /* 6 */
void (*tcl_DbCkfree) (char *ptr, const char *file, int line); /* 7 */
char * (*tcl_DbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 8 */
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
+#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */
#endif /* UNIX */
-#if defined(__WIN32__) /* WIN */
+#if defined(_WIN32) /* WIN */
void (*reserved9)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */
#endif /* MACOSX */
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
+#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tcl_DeleteFileHandler) (int fd); /* 10 */
#endif /* UNIX */
-#if defined(__WIN32__) /* WIN */
+#if defined(_WIN32) /* WIN */
void (*reserved10)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
@@ -2009,10 +2009,10 @@ typedef struct TclStubs {
Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */
const char * (*tcl_GetNameOfExecutable) (void); /* 165 */
Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
+#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */
#endif /* UNIX */
-#if defined(__WIN32__) /* WIN */
+#if defined(_WIN32) /* WIN */
void (*reserved167)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
@@ -2513,7 +2513,7 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_DbCkfree) /* 7 */
#define Tcl_DbCkrealloc \
(tclStubsPtr->tcl_DbCkrealloc) /* 8 */
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
+#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
#define Tcl_CreateFileHandler \
(tclStubsPtr->tcl_CreateFileHandler) /* 9 */
#endif /* UNIX */
@@ -2521,7 +2521,7 @@ extern const TclStubs *tclStubsPtr;
#define Tcl_CreateFileHandler \
(tclStubsPtr->tcl_CreateFileHandler) /* 9 */
#endif /* MACOSX */
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
+#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
#define Tcl_DeleteFileHandler \
(tclStubsPtr->tcl_DeleteFileHandler) /* 10 */
#endif /* UNIX */
@@ -2841,7 +2841,7 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */
#define Tcl_GetObjResult \
(tclStubsPtr->tcl_GetObjResult) /* 166 */
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
+#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
#define Tcl_GetOpenFile \
(tclStubsPtr->tcl_GetOpenFile) /* 167 */
#endif /* UNIX */
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 2cc55d6..d246cb2 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -182,6 +182,7 @@ TCL_DECLARE_MUTEX(encodingMutex)
static Tcl_Encoding defaultEncoding;
static Tcl_Encoding systemEncoding;
+Tcl_Encoding tclIdentityEncoding;
/*
* The following variable is used in the sparse matrix code for a
@@ -567,7 +568,7 @@ TclInitEncodingSubsystem(void)
type.freeProc = NULL;
type.nullSize = 1;
type.clientData = NULL;
- Tcl_CreateEncoding(&type);
+ tclIdentityEncoding = Tcl_CreateEncoding(&type);
type.encodingName = "utf-8";
type.toUtfProc = UtfExtToUtfIntProc;
@@ -651,6 +652,7 @@ TclFinalizeEncodingSubsystem(void)
Tcl_MutexLock(&encodingMutex);
encodingsInitialized = 0;
FreeEncoding(systemEncoding);
+ FreeEncoding(tclIdentityEncoding);
hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
while (hPtr != NULL) {
diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index 8f51c1b..cd1a954 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.c
@@ -444,7 +444,7 @@ TclUnsetEnv(
* that no = should be included, and Windows requires it.
*/
-#if defined(__WIN32__) || defined(__CYGWIN__)
+#if defined(_WIN32) || defined(__CYGWIN__)
string = ckalloc(length + 2);
memcpy(string, name, (size_t) length);
string[length] = '=';
@@ -453,7 +453,7 @@ TclUnsetEnv(
string = ckalloc(length + 1);
memcpy(string, name, (size_t) length);
string[length] = '\0';
-#endif /* WIN32 */
+#endif /* _WIN32 */
Tcl_UtfToExternalDString(NULL, string, -1, &envString);
string = ckrealloc(string, Tcl_DStringLength(&envString) + 1);
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 78e09c3..4ecca5b 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -174,28 +174,24 @@ static BuiltinFunc const tclBuiltinFuncTable[] = {
typedef struct TEBCdata {
ByteCode *codePtr; /* Constant until the BC returns */
/* -----------------------------------------*/
- const unsigned char *pc; /* These fields are used on return TO this */
- ptrdiff_t *catchTop; /* this level: they record the state when a */
- int cleanup; /* new codePtr was received for NR */
- Tcl_Obj *auxObjList; /* execution. */
- CmdFrame cmdFrame;
+ ptrdiff_t *catchTop; /* These fields are used on return TO this */
+ Tcl_Obj *auxObjList; /* this level: they record the state when a */
+ CmdFrame cmdFrame; /* new codePtr was received for NR */
+ /* execution. */
void *stack[1]; /* Start of the actual combined catch and obj
* stacks; the struct will be expanded as
* necessary */
} TEBCdata;
#define TEBC_YIELD() \
- do { \
- esPtr->tosPtr = tosPtr; \
- TD->pc = pc; \
- TD->cleanup = cleanup; \
- TclNRAddCallback(interp, TEBCresume, TD, INT2PTR(1), NULL, NULL); \
+ do { \
+ esPtr->tosPtr = tosPtr; \
+ TclNRAddCallback(interp, TEBCresume, \
+ TD, pc, INT2PTR(cleanup), NULL); \
} while (0)
#define TEBC_DATA_DIG() \
do { \
- pc = TD->pc; \
- cleanup = TD->cleanup; \
tosPtr = esPtr->tosPtr; \
} while (0)
@@ -804,7 +800,8 @@ static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords);
static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords);
static Tcl_NRPostProc CopyCallback;
static Tcl_NRPostProc ExprObjCallback;
-
+static Tcl_NRPostProc FinalizeOONext;
+static Tcl_NRPostProc FinalizeOONextFilter;
static Tcl_NRPostProc TEBCresume;
/*
@@ -2000,6 +1997,41 @@ TclIncrObj(
/*
*----------------------------------------------------------------------
*
+ * ArgumentBCEnter --
+ *
+ * This is a helper for TclNRExecuteByteCode/TEBCresume that encapsulates
+ * a code sequence that is fairly common in the code but *not* commonly
+ * called.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * May register information about the bytecode in the command frame.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ArgumentBCEnter(
+ Tcl_Interp *interp,
+ ByteCode *codePtr,
+ TEBCdata *tdPtr,
+ const unsigned char *pc,
+ int objc,
+ Tcl_Obj **objv)
+{
+ int cmd;
+
+ if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
+ TclArgumentBCEnter(interp, objv, objc, codePtr, &tdPtr->cmdFrame, cmd,
+ pc - codePtr->codeStart);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclNRExecuteByteCode --
*
* This procedure executes the instructions of a ByteCode structure. It
@@ -2032,10 +2064,6 @@ TclNRExecuteByteCode(
* sizeof(void *);
int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *);
- if (iPtr->execEnvPtr->rewind) {
- return TCL_ERROR;
- }
-
codePtr->refCount++;
/*
@@ -2054,9 +2082,7 @@ TclNRExecuteByteCode(
esPtr->tosPtr = initTosPtr;
TD->codePtr = codePtr;
- TD->pc = codePtr->codeStart;
TD->catchTop = initCatchTop;
- TD->cleanup = 0;
TD->auxObjList = NULL;
/*
@@ -2086,8 +2112,8 @@ TclNRExecuteByteCode(
* Push the callback for bytecode execution
*/
- TclNRAddCallback(interp, TEBCresume, TD, /*resume*/ INT2PTR(0),
- NULL, NULL);
+ TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL,
+ /* cleanup */ INT2PTR(0), NULL);
return TCL_OK;
}
@@ -2150,7 +2176,8 @@ TEBCresume(
Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation
* stack. */
- const unsigned char *pc; /* The current program counter. */
+ const unsigned char *pc = data[1];
+ /* The current program counter. */
unsigned char inst; /* The currently running instruction */
/*
@@ -2158,7 +2185,7 @@ TEBCresume(
* executing an instruction.
*/
- int cleanup = 0;
+ int cleanup = PTR2INT(data[2]);
Tcl_Obj *objResultPtr;
int checkInterp; /* Indicates when a check of interp readyness
* is necessary. Set by CACHE_STACK_INFO() */
@@ -2186,16 +2213,17 @@ TEBCresume(
TEBC_DATA_DIG();
#ifdef TCL_COMPILE_DEBUG
- if (!data[1] && (tclTraceExec >= 2)) {
+ if (!pc && (tclTraceExec >= 2)) {
PrintByteCodeInfo(codePtr);
fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH);
fflush(stdout);
}
#endif
- if (!data[1]) {
+ if (!pc) {
/* bytecode is starting from scratch */
checkInterp = 0;
+ pc = codePtr->codeStart;
goto cleanup0;
} else {
/* resume from invocation */
@@ -2213,7 +2241,7 @@ TEBCresume(
}
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
- TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
+ TclArgumentBCRelease(interp, bcFramePtr);
}
if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
iPtr->flags |= ERR_ALREADY_LOGGED;
@@ -2466,9 +2494,12 @@ TEBCresume(
TRACE_APPEND(("\n"));
goto processExceptionReturn;
- case INST_YIELD: {
- CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+ {
+ CoroutineData *corPtr;
+ int yieldParameter;
+ case INST_YIELD:
+ corPtr = iPtr->execEnvPtr->corPtr;
TRACE(("%.30s => ", O2S(OBJ_AT_TOS)));
if (!corPtr) {
TRACE_APPEND(("ERROR: yield outside coroutine\n"));
@@ -2482,11 +2513,74 @@ TEBCresume(
}
#ifdef TCL_COMPILE_DEBUG
- TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr);
- if (traceInstructions) {
- fprintf(stdout, "\n");
+ if (tclTraceExec >= 2) {
+ if (traceInstructions) {
+ TRACE_APPEND(("YIELD...\n"));
+ } else {
+ fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n",
+ iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
+ Tcl_GetString(OBJ_AT_TOS));
+ }
+ fflush(stdout);
}
#endif
+ yieldParameter = 0;
+ Tcl_SetObjResult(interp, OBJ_AT_TOS);
+ goto doYield;
+
+ case INST_YIELD_TO_INVOKE:
+ corPtr = iPtr->execEnvPtr->corPtr;
+ valuePtr = OBJ_AT_TOS;
+ if (!corPtr) {
+ TRACE(("[%.30s] => ERROR: yield outside coroutine\n",
+ O2S(valuePtr)));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "yieldto can only be called in a coroutine", -1));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
+ NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+ if (((Namespace *)TclGetCurrentNamespace(interp))->flags & NS_DYING) {
+ TRACE(("[%.30s] => ERROR: yield in deleted\n",
+ O2S(valuePtr)));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "yieldto called in deleted namespace", -1));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
+ NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+
+#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceExec >= 2) {
+ if (traceInstructions) {
+ TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr)));
+ } else {
+ /* FIXME: What is the right thing to trace? */
+ fprintf(stdout, "%d: (%u) yielding to [%.30s]\n",
+ iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
+ Tcl_GetString(valuePtr));
+ }
+ fflush(stdout);
+ }
+#endif
+
+ /*
+ * Install a tailcall record in the caller and continue with the
+ * yield. The yield is switched into multi-return mode (via the
+ * 'yieldParameter').
+ */
+
+ Tcl_IncrRefCount(valuePtr);
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+ TclSetTailcall(interp, valuePtr);
+ iPtr->execEnvPtr = corPtr->eePtr;
+ yieldParameter = (PTR2INT(NULL)+1); /*==CORO_ACTIVATE_YIELDM*/
+
+ doYield:
/* TIP #280: Record the last piece of info needed by
* 'TclGetSrcInfoForPc', and push the frame.
*/
@@ -2495,21 +2589,14 @@ TEBCresume(
iPtr->cmdFramePtr = bcFramePtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
- int cmd;
- if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
- TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
- codePtr, bcFramePtr, cmd, pc - codePtr->codeStart);
- }
+ ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
}
pc++;
cleanup = 1;
TEBC_YIELD();
-
- Tcl_SetObjResult(interp, OBJ_AT_TOS);
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
- INT2PTR(0), NULL, NULL);
-
+ INT2PTR(yieldParameter), NULL, NULL);
return TCL_OK;
}
@@ -2529,6 +2616,7 @@ TEBCresume(
}
#ifdef TCL_COMPILE_DEBUG
+ /* FIXME: What is the right thing to trace? */
{
register int i;
@@ -2969,11 +3057,7 @@ TEBCresume(
iPtr->cmdFramePtr = bcFramePtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
- int cmd;
- if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
- TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
- codePtr, bcFramePtr, cmd, pc - codePtr->codeStart);
- }
+ ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
}
DECACHE_STACK_INFO();
@@ -3118,11 +3202,7 @@ TEBCresume(
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
- int cmd;
- if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
- TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
- codePtr, bcFramePtr, cmd, pc - codePtr->codeStart);
- }
+ ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
}
iPtr->ensembleRewrite.sourceObjs = objv;
iPtr->ensembleRewrite.numRemovedObjs = opnd;
@@ -4513,10 +4593,20 @@ TEBCresume(
TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS)));
NEXT_INST_F(1, 1, 1);
}
- case INST_TCLOO_SELF: {
- CallFrame *framePtr = iPtr->varFramePtr;
+
+ /*
+ * -----------------------------------------------------------------
+ * Start of TclOO support instructions.
+ */
+
+ {
+ Object *oPtr;
+ CallFrame *framePtr;
CallContext *contextPtr;
+ int skip, newDepth;
+ case INST_TCLOO_SELF:
+ framePtr = iPtr->varFramePtr;
if (framePtr == NULL ||
!(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
TRACE(("=> ERROR: no TclOO call context\n"));
@@ -4537,9 +4627,212 @@ TEBCresume(
objResultPtr = TclOOObjectName(interp, contextPtr->oPtr);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
- }
- {
- Object *oPtr;
+
+ case INST_TCLOO_NEXT_CLASS:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ framePtr = iPtr->varFramePtr;
+ valuePtr = OBJ_AT_DEPTH(opnd - 2);
+ objv = &OBJ_AT_DEPTH(opnd - 1);
+ skip = 2;
+ TRACE(("%d => ", opnd));
+ if (framePtr == NULL ||
+ !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ TRACE_APPEND(("ERROR: no TclOO call context\n"));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "nextto may only be called from inside a method",
+ -1));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+ contextPtr = framePtr->clientData;
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr);
+ if (oPtr == NULL) {
+ TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr)));
+ goto gotError;
+ } else {
+ Class *classPtr = oPtr->classPtr;
+ struct MInvoke *miPtr;
+ int i;
+ const char *methodType;
+
+ if (classPtr == NULL) {
+ TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr)));
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not a class", TclGetString(valuePtr)));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+
+ for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
+ miPtr = contextPtr->callPtr->chain + i;
+ if (!miPtr->isFilter &&
+ miPtr->mPtr->declaringClassPtr == classPtr) {
+ newDepth = i;
+#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceExec >= 2) {
+ if (traceInstructions) {
+ strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
+ } else {
+ fprintf(stdout, "%d: (%u) invoking ",
+ iPtr->numLevels,
+ (unsigned)(pc - codePtr->codeStart));
+ }
+ for (i = 0; i < opnd; i++) {
+ TclPrintObject(stdout, objv[i], 15);
+ fprintf(stdout, " ");
+ }
+ fprintf(stdout, "\n");
+ fflush(stdout);
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+ goto doInvokeNext;
+ }
+ }
+
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ methodType = "constructor";
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ methodType = "destructor";
+ } else {
+ methodType = "method";
+ }
+
+ TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n",
+ O2S(valuePtr)));
+ for (i=contextPtr->index ; i>=0 ; i--) {
+ miPtr = contextPtr->callPtr->chain + i;
+ if (miPtr->isFilter
+ || miPtr->mPtr->declaringClassPtr != classPtr) {
+ continue;
+ }
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s implementation by \"%s\" not reachable from here",
+ methodType, TclGetString(valuePtr)));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE",
+ NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s has no non-filter implementation by \"%s\"",
+ methodType, TclGetString(valuePtr)));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+
+ case INST_TCLOO_NEXT:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ objv = &OBJ_AT_DEPTH(opnd - 1);
+ framePtr = iPtr->varFramePtr;
+ skip = 1;
+ TRACE(("%d => ", opnd));
+ if (framePtr == NULL ||
+ !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ TRACE_APPEND(("ERROR: no TclOO call context\n"));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "next may only be called from inside a method",
+ -1));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+ contextPtr = framePtr->clientData;
+
+ newDepth = contextPtr->index + 1;
+ if (newDepth >= contextPtr->callPtr->numChain) {
+ /*
+ * We're at the end of the chain; generate an error message unless
+ * the interpreter is being torn down, in which case we might be
+ * getting here because of methods/destructors doing a [next] (or
+ * equivalent) unexpectedly.
+ */
+
+ const char *methodType;
+
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ methodType = "constructor";
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ methodType = "destructor";
+ } else {
+ methodType = "method";
+ }
+
+ TRACE_APPEND(("ERROR: no TclOO next impl\n"));
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "no next %s implementation", methodType));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+#ifdef TCL_COMPILE_DEBUG
+ } else if (tclTraceExec >= 2) {
+ int i;
+
+ if (traceInstructions) {
+ strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
+ } else {
+ fprintf(stdout, "%d: (%u) invoking ",
+ iPtr->numLevels, (unsigned)(pc - codePtr->codeStart));
+ }
+ for (i = 0; i < opnd; i++) {
+ TclPrintObject(stdout, objv[i], 15);
+ fprintf(stdout, " ");
+ }
+ fprintf(stdout, "\n");
+ fflush(stdout);
+#endif /*TCL_COMPILE_DEBUG*/
+ }
+
+ doInvokeNext:
+ bcFramePtr->data.tebc.pc = (char *) pc;
+ iPtr->cmdFramePtr = bcFramePtr;
+
+ if (iPtr->flags & INTERP_DEBUG_FRAME) {
+ ArgumentBCEnter(interp, codePtr, TD, pc, opnd, objv);
+ }
+
+ pcAdjustment = 2;
+ cleanup = opnd;
+ DECACHE_STACK_INFO();
+ iPtr->varFramePtr = framePtr->callerVarPtr;
+ pc += pcAdjustment;
+ TEBC_YIELD();
+
+ oPtr = contextPtr->oPtr;
+ if (oPtr->flags & FILTER_HANDLING) {
+ TclNRAddCallback(interp, FinalizeOONextFilter,
+ framePtr, contextPtr, INT2PTR(contextPtr->index),
+ INT2PTR(contextPtr->skip));
+ } else {
+ TclNRAddCallback(interp, FinalizeOONext,
+ framePtr, contextPtr, INT2PTR(contextPtr->index),
+ INT2PTR(contextPtr->skip));
+ }
+ contextPtr->skip = skip;
+ contextPtr->index = newDepth;
+ if (contextPtr->callPtr->chain[newDepth].isFilter
+ || contextPtr->callPtr->flags & FILTER_HANDLING) {
+ oPtr->flags |= FILTER_HANDLING;
+ } else {
+ oPtr->flags &= ~FILTER_HANDLING;
+ }
+
+ {
+ register Method *const mPtr =
+ contextPtr->callPtr->chain[newDepth].mPtr;
+
+ return mPtr->typePtr->callProc(mPtr->clientData, interp,
+ (Tcl_ObjectContext) contextPtr, opnd, objv);
+ }
case INST_TCLOO_IS_OBJECT:
oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
@@ -4573,6 +4866,7 @@ TEBCresume(
}
/*
+ * End of TclOO support instructions.
* -----------------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
@@ -5098,6 +5392,7 @@ TEBCresume(
} else {
length = Tcl_UtfToUpper(TclGetString(valuePtr));
Tcl_SetObjLength(valuePtr, length);
+ TclFreeIntRep(valuePtr);
TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
@@ -5114,6 +5409,7 @@ TEBCresume(
} else {
length = Tcl_UtfToLower(TclGetString(valuePtr));
Tcl_SetObjLength(valuePtr, length);
+ TclFreeIntRep(valuePtr);
TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
@@ -5130,6 +5426,7 @@ TEBCresume(
} else {
length = Tcl_UtfToTitle(TclGetString(valuePtr));
Tcl_SetObjLength(valuePtr, length);
+ TclFreeIntRep(valuePtr);
TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
@@ -5405,11 +5702,21 @@ TEBCresume(
length - toIdx);
}
} else {
- objResultPtr = value3Ptr;
+ /*
+ * Be careful with splicing the stack in this case; we have a
+ * refCount:1 object in value3Ptr and we want to append to it and
+ * make it be the refCount:1 object at the top of the stack
+ * afterwards. [Bug 82e7f67325]
+ */
+
if (toIdx < length) {
- Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
+ Tcl_AppendUnicodeToObj(value3Ptr, ustring1 + toIdx + 1,
length - toIdx);
}
+ TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr)));
+ TclDecrRefCount(valuePtr);
+ OBJ_AT_TOS = value3Ptr; /* Tricky! */
+ NEXT_INST_F(1, 0, 0);
}
TclDecrRefCount(value3Ptr);
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
@@ -5516,6 +5823,25 @@ TEBCresume(
TclNewIntObj(objResultPtr, match);
NEXT_INST_F(1, 2, 1);
+
+ case INST_STR_CLASS:
+ opnd = TclGetInt1AtPtr(pc+1);
+ valuePtr = OBJ_AT_TOS;
+ TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name,
+ O2S(valuePtr)));
+ ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
+ match = 1;
+ if (length > 0) {
+ end = ustring1 + length;
+ for (p=ustring1 ; p<end ; p++) {
+ if (!tclStringClassTable[opnd].comparator(*p)) {
+ match = 0;
+ break;
+ }
+ }
+ }
+ TRACE_APPEND(("%d\n", match));
+ JUMP_PEEPHOLE_F(match, 2, 1);
}
case INST_STR_MATCH:
@@ -5592,14 +5918,34 @@ TEBCresume(
trim2 = 0;
}
createTrimmedString:
+ /*
+ * Careful here; trim set often contains non-ASCII characters so we
+ * take care when printing. [Bug 971cb4f1db]
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ if (traceInstructions) {
+ TRACE(("\"%.30s\" ", O2S(valuePtr)));
+ TclPrintObject(stdout, value2Ptr, 30);
+ printf(" => ");
+ }
+#endif
if (trim1 == 0 && trim2 == 0) {
- TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ",
- O2S(valuePtr), O2S(value2Ptr)), valuePtr);
+#ifdef TCL_COMPILE_DEBUG
+ if (traceInstructions) {
+ TclPrintObject(stdout, valuePtr, 30);
+ printf("\n");
+ }
+#endif
NEXT_INST_F(1, 1, 0);
} else {
objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1-trim2);
- TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ",
- O2S(valuePtr), O2S(value2Ptr)), objResultPtr);
+#ifdef TCL_COMPILE_DEBUG
+ if (traceInstructions) {
+ TclPrintObject(stdout, objResultPtr, 30);
+ printf("\n");
+ }
+#endif
NEXT_INST_F(1, 2, 1);
}
}
@@ -5650,6 +5996,39 @@ TEBCresume(
int type1, type2;
long l1, l2, lResult;
+ case INST_NUM_TYPE:
+ if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
+ type1 = 0;
+ } else if (type1 == TCL_NUMBER_LONG) {
+ /* value is between LONG_MIN and LONG_MAX */
+ /* [string is integer] is -UINT_MAX to UINT_MAX range */
+ int i;
+
+ if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) {
+ type1 = TCL_NUMBER_WIDE;
+ }
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (type1 == TCL_NUMBER_WIDE) {
+ /* value is between WIDE_MIN and WIDE_MAX */
+ /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */
+ int i;
+ if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) {
+ type1 = TCL_NUMBER_LONG;
+ }
+#endif
+ } else if (type1 == TCL_NUMBER_BIG) {
+ /* value is an integer outside the WIDE_MIN to WIDE_MAX range */
+ /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */
+ Tcl_WideInt w;
+
+ if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) {
+ type1 = TCL_NUMBER_WIDE;
+ }
+ }
+ TclNewIntObj(objResultPtr, type1);
+ TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
+ NEXT_INST_F(1, 1, 1);
+
case INST_EQ:
case INST_NEQ:
case INST_LT:
@@ -6327,6 +6706,17 @@ TEBCresume(
* -----------------------------------------------------------------
*/
+ case INST_TRY_CVT_TO_BOOLEAN:
+ valuePtr = OBJ_AT_TOS;
+ if (valuePtr->typePtr == &tclBooleanType) {
+ objResultPtr = TCONST(1);
+ } else {
+ int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK);
+ objResultPtr = TCONST(result);
+ }
+ TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr);
+ NEXT_INST_F(1, 0, 1);
+
case INST_BREAK:
/*
DECACHE_STACK_INFO();
@@ -7706,6 +8096,58 @@ TEBCresume(
#undef auxObjList
#undef catchTop
#undef TCONST
+
+static int
+FinalizeOONext(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ CallContext *contextPtr = data[1];
+
+ /*
+ * Reset the variable lookup frame.
+ */
+
+ iPtr->varFramePtr = data[0];
+
+ /*
+ * Restore the call chain context index as we've finished the inner invoke
+ * and want to operate in the outer context again.
+ */
+
+ contextPtr->index = PTR2INT(data[2]);
+ contextPtr->skip = PTR2INT(data[3]);
+ contextPtr->oPtr->flags &= ~FILTER_HANDLING;
+ return result;
+}
+
+static int
+FinalizeOONextFilter(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ CallContext *contextPtr = data[1];
+
+ /*
+ * Reset the variable lookup frame.
+ */
+
+ iPtr->varFramePtr = data[0];
+
+ /*
+ * Restore the call chain context index as we've finished the inner invoke
+ * and want to operate in the outer context again.
+ */
+
+ contextPtr->index = PTR2INT(data[2]);
+ contextPtr->skip = PTR2INT(data[3]);
+ contextPtr->oPtr->flags |= FILTER_HANDLING;
+ return result;
+}
/*
*----------------------------------------------------------------------
@@ -9233,10 +9675,12 @@ IllegalExprOperandType(
ClientData ptr;
int type;
const unsigned char opcode = *pc;
- const char *description, *operator = operatorStrings[opcode - INST_LOR];
+ const char *description, *operator = "unknown";
if (opcode == INST_EXPON) {
operator = "**";
+ } else if (opcode <= INST_STR_NEQ) {
+ operator = operatorStrings[opcode - INST_LOR];
}
if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index 13377d3..6452fff 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -517,7 +517,7 @@ CopyRenameOneFile(
* 16 bits and we get collisions. See bug #2015723.
*/
-#if !defined(WIN32) && !defined(__CYGWIN__)
+#if !defined(_WIN32) && !defined(__CYGWIN__)
if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) {
if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) &&
(sourceStatBuf.st_dev == targetStatBuf.st_dev)) {
diff --git a/generic/tclIO.c b/generic/tclIO.c
index f1d85bf..58c7b3c 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -162,11 +162,12 @@ typedef struct CloseCallback {
*/
static ChannelBuffer * AllocChannelBuffer(int length);
+static void PreserveChannelBuffer(ChannelBuffer *bufPtr);
+static void ReleaseChannelBuffer(ChannelBuffer *bufPtr);
+static int IsShared(ChannelBuffer *bufPtr);
static void ChannelTimerProc(ClientData clientData);
static int CheckChannelErrors(ChannelState *statePtr,
int direction);
-static int CheckFlush(Channel *chanPtr, ChannelBuffer *bufPtr,
- int newlineFlag);
static int CheckForDeadChannel(Tcl_Interp *interp,
ChannelState *statePtr);
static void CheckForStdChannelsBeingClosed(Tcl_Channel chan);
@@ -194,15 +195,14 @@ static void DiscardInputQueued(ChannelState *statePtr,
int discardSavedBuffers);
static void DiscardOutputQueued(ChannelState *chanPtr);
static int DoRead(Channel *chanPtr, char *srcPtr, int slen, int allowShortReads);
-static int DoWrite(Channel *chanPtr, const char *src, int srcLen);
static int DoReadChars(Channel *chan, Tcl_Obj *objPtr, int toRead,
int appendFlag);
-static int DoWriteChars(Channel *chan, const char *src, int len);
static int FilterInputBytes(Channel *chanPtr,
GetsState *statePtr);
static int FlushChannel(Tcl_Interp *interp, Channel *chanPtr,
int calledFromAsyncFlush);
static int TclGetsObjBinary(Tcl_Channel chan, Tcl_Obj *objPtr);
+static Tcl_Encoding GetBinaryEncoding();
static void FreeBinaryEncoding(ClientData clientData);
static Tcl_HashTable * GetChannelTable(Tcl_Interp *interp);
static int GetInput(Channel *chanPtr);
@@ -222,18 +222,19 @@ static int SetBlockMode(Tcl_Interp *interp, Channel *chanPtr,
static void StopCopy(CopyState *csPtr);
static int TranslateInputEOL(ChannelState *statePtr, char *dst,
const char *src, int *dstLenPtr, int *srcLenPtr);
-static int TranslateOutputEOL(ChannelState *statePtr, char *dst,
- const char *src, int *dstLenPtr, int *srcLenPtr);
static void UpdateInterest(Channel *chanPtr);
-static int WriteBytes(Channel *chanPtr, const char *src,
- int srcLen);
-static int WriteChars(Channel *chanPtr, const char *src,
- int srcLen);
+static int Write(Channel *chanPtr, const char *src,
+ int srcLen, Tcl_Encoding encoding);
static Tcl_Obj * FixLevelCode(Tcl_Obj *msg);
static void SpliceChannel(Tcl_Channel chan);
static void CutChannel(Tcl_Channel chan);
static int WillRead(Channel *chanPtr);
+#define WriteChars(chanPtr, src, srcLen) \
+ Write(chanPtr, src, srcLen, chanPtr->state->encoding)
+#define WriteBytes(chanPtr, src, srcLen) \
+ Write(chanPtr, src, srcLen, tclIdentityEncoding)
+
/*
* Simplifying helper macros. All may use their argument(s) multiple times.
* The ANSI C "prototypes" for the macros are listed below, together with a
@@ -323,14 +324,13 @@ static int WillRead(Channel *chanPtr);
static void DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static int SetChannelFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
-static void UpdateStringOfChannel(Tcl_Obj *objPtr);
static void FreeChannelIntRep(Tcl_Obj *objPtr);
-static const Tcl_ObjType tclChannelType = {
+static const Tcl_ObjType chanObjType = {
"channel", /* name for this type */
FreeChannelIntRep, /* freeIntRepProc */
DupChannelIntRep, /* dupIntRepProc */
- NULL, /* updateStringProc UpdateStringOfChannel */
+ NULL, /* updateStringProc */
NULL /* setFromAnyProc SetChannelFromAny */
};
@@ -339,7 +339,7 @@ static const Tcl_ObjType tclChannelType = {
#define SET_CHANNELSTATE(objPtr, storePtr) \
((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (storePtr))
#define GET_CHANNELINTERP(objPtr) \
- ((Interp *) (objPtr)->internalRep.twoPtrValue.ptr2)
+ ((Tcl_Interp *) (objPtr)->internalRep.twoPtrValue.ptr2)
#define SET_CHANNELINTERP(objPtr, storePtr) \
((objPtr)->internalRep.twoPtrValue.ptr2 = (void *) (storePtr))
@@ -390,6 +390,7 @@ ChanRead(
int *errnoPtr)
{
if (WillRead(chanPtr) < 0) {
+ *errnoPtr = Tcl_GetErrno();
return -1;
}
@@ -1581,11 +1582,7 @@ Tcl_CreateChannel(
statePtr->timer = NULL;
statePtr->csPtrR = NULL;
statePtr->csPtrW = NULL;
-
statePtr->outputStage = NULL;
- if ((statePtr->encoding != NULL) && GotFlag(statePtr, TCL_WRITABLE)) {
- statePtr->outputStage = ckalloc(statePtr->bufSize + 2);
- }
/*
* As we are creating the channel, it is obviously the top for now.
@@ -1750,6 +1747,10 @@ Tcl_StackChannel(
statePtr->csPtrR = NULL;
statePtr->csPtrW = NULL;
+ /*
+ * TODO: Examine what can go wrong if Tcl_Flush() call disturbs
+ * the stacking state of this channel during its operations.
+ */
if (Tcl_Flush((Tcl_Channel) prevChanPtr) != TCL_OK) {
statePtr->csPtrR = csPtrR;
statePtr->csPtrW = csPtrW;
@@ -1879,6 +1880,13 @@ Tcl_UnstackChannel(
* into the old structure.
*/
+ /*
+ * TODO: Figure out how to handle the situation where the chan
+ * operations called below by this unstacking operation cause
+ * another unstacking recursively. In that case the downChanPtr
+ * value we're holding on to will not be the right thing.
+ */
+
Channel *downChanPtr = chanPtr->downChanPtr;
/*
@@ -1983,7 +1991,7 @@ Tcl_UnstackChannel(
*/
Tcl_EventuallyFree(chanPtr, TCL_DYNAMIC);
- UpdateInterest(downChanPtr);
+ UpdateInterest(statePtr->topChanPtr);
if (result != 0) {
Tcl_SetErrno(result);
@@ -2295,8 +2303,33 @@ AllocChannelBuffer(
bufPtr->nextRemoved = BUFFER_PADDING;
bufPtr->bufLength = length + BUFFER_PADDING;
bufPtr->nextPtr = NULL;
+ bufPtr->refCount = 1;
return bufPtr;
}
+
+static void
+PreserveChannelBuffer(
+ ChannelBuffer *bufPtr)
+{
+ bufPtr->refCount++;
+}
+
+static void
+ReleaseChannelBuffer(
+ ChannelBuffer *bufPtr)
+{
+ if (--bufPtr->refCount) {
+ return;
+ }
+ ckfree(bufPtr);
+}
+
+static int
+IsShared(
+ ChannelBuffer *bufPtr)
+{
+ return bufPtr->refCount > 1;
+}
/*
*----------------------------------------------------------------------
@@ -2327,9 +2360,12 @@ RecycleBuffer(
/*
* Do we have to free the buffer to the OS?
*/
+ if (IsShared(bufPtr)) {
+ mustDiscard = 1;
+ }
if (mustDiscard) {
- ckfree(bufPtr);
+ ReleaseChannelBuffer(bufPtr);
return;
}
@@ -2340,7 +2376,7 @@ RecycleBuffer(
*/
if ((bufPtr->bufLength - BUFFER_PADDING) < statePtr->bufSize) {
- ckfree(bufPtr);
+ ReleaseChannelBuffer(bufPtr);
return;
}
@@ -2375,7 +2411,7 @@ RecycleBuffer(
* If we reached this code we return the buffer to the OS.
*/
- ckfree(bufPtr);
+ ReleaseChannelBuffer(bufPtr);
return;
keepBuffer:
@@ -2551,6 +2587,7 @@ FlushChannel(
* Produce the output on the channel.
*/
+ PreserveChannelBuffer(bufPtr);
toWrite = BytesLeft(bufPtr);
if (toWrite == 0) {
written = 0;
@@ -2674,6 +2711,7 @@ FlushChannel(
}
RecycleBuffer(statePtr, bufPtr, 0);
}
+ ReleaseChannelBuffer(bufPtr);
} /* Closes "while (1)". */
/*
@@ -2775,7 +2813,7 @@ CloseChannel(
*/
if (statePtr->curOutPtr != NULL) {
- ckfree(statePtr->curOutPtr);
+ ReleaseChannelBuffer(statePtr->curOutPtr);
statePtr->curOutPtr = NULL;
}
@@ -2838,10 +2876,6 @@ CloseChannel(
}
Tcl_FreeEncoding(statePtr->encoding);
- if (statePtr->outputStage != NULL) {
- ckfree(statePtr->outputStage);
- statePtr->outputStage = NULL;
- }
}
/*
@@ -3191,7 +3225,8 @@ Tcl_Close(
stickyError = 0;
- if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL)
+ if ((statePtr->encoding != NULL)
+ && !(statePtr->outputEncodingFlags & TCL_ENCODING_START)
&& (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
statePtr->outputEncodingFlags |= TCL_ENCODING_END;
if (WriteChars(chanPtr, "", 0) < 0) {
@@ -3281,7 +3316,17 @@ Tcl_Close(
Tcl_SetObjResult(interp,
Tcl_NewStringObj(Tcl_PosixError(interp), -1));
}
- flushcode = -1;
+ return TCL_ERROR;
+ }
+ /*
+ * Bug 97069ea11a: set error message if a flush code is set and no error
+ * message set up to now.
+ */
+ if (flushcode != 0 && interp != NULL
+ && 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp)) ) {
+ Tcl_SetErrno(flushcode);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(Tcl_PosixError(interp), -1));
}
if ((flushcode != 0) || (result != 0)) {
return TCL_ERROR;
@@ -3778,7 +3823,7 @@ Tcl_Write(
if (srcLen < 0) {
srcLen = strlen(src);
}
- return DoWrite(chanPtr, src, srcLen);
+ return WriteBytes(chanPtr, src, srcLen);
}
/*
@@ -3869,82 +3914,40 @@ Tcl_WriteChars(
int len) /* Length of string in bytes, or < 0 for
* strlen(). */
{
- ChannelState *statePtr; /* State info for channel */
-
- statePtr = ((Channel *) chan)->state;
+ Channel *chanPtr = (Channel *) chan;
+ ChannelState *statePtr = chanPtr->state; /* State info for channel */
+ int result;
+ Tcl_Obj *objPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
return -1;
}
- return DoWriteChars((Channel *) chan, src, len);
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * DoWriteChars --
- *
- * Takes a sequence of UTF-8 characters and converts them for output
- * using the channel's current encoding, may queue the buffer for output
- * if it gets full, and also remembers whether the current buffer is
- * ready e.g. if it contains a newline and we are in line buffering mode.
- * Compensates stacking, i.e. will redirect the data from the specified
- * channel to the topmost channel in a stack.
- *
- * Results:
- * The number of bytes written or -1 in case of error. If -1,
- * Tcl_GetErrno will return the error code.
- *
- * Side effects:
- * May buffer up output and may cause output to be produced on the
- * channel.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-DoWriteChars(
- Channel *chanPtr, /* The channel to buffer output for. */
- const char *src, /* UTF-8 characters to queue in output
- * buffer. */
- int len) /* Length of string in bytes, or < 0 for
- * strlen(). */
-{
- /*
- * Always use the topmost channel of the stack
- */
-
- ChannelState *statePtr; /* State info for channel */
-
- statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
if (len < 0) {
len = strlen(src);
}
- if (statePtr->encoding == NULL) {
- /*
- * Inefficient way to convert UTF-8 to byte-array, but the code
- * parallels the way it is done for objects.
- * Special case for 1-byte (used by eg [puts] for the \n) could
- * be extended to more efficient translation of the src string.
- */
-
- int result;
+ if (statePtr->encoding) {
+ return WriteChars(chanPtr, src, len);
+ }
- if ((len == 1) && (UCHAR(*src) < 0xC0)) {
- result = WriteBytes(chanPtr, src, len);
- } else {
- Tcl_Obj *objPtr = Tcl_NewStringObj(src, len);
+ /*
+ * Inefficient way to convert UTF-8 to byte-array, but the code
+ * parallels the way it is done for objects. Special case for 1-byte
+ * (used by eg [puts] for the \n) could be extended to more efficient
+ * translation of the src string.
+ */
- src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len);
- result = WriteBytes(chanPtr, src, len);
- TclDecrRefCount(objPtr);
- }
- return result;
+ if ((len == 1) && (UCHAR(*src) < 0xC0)) {
+ return WriteBytes(chanPtr, src, len);
}
- return WriteChars(chanPtr, src, len);
+
+ objPtr = Tcl_NewStringObj(src, len);
+ src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len);
+ result = WriteBytes(chanPtr, src, len);
+ TclDecrRefCount(objPtr);
+ return result;
}
/*
@@ -4020,6 +4023,11 @@ static int
WillRead(
Channel *chanPtr)
{
+ if (chanPtr->typePtr == NULL) {
+ /* Prevent read attempts on a closed channel */
+ Tcl_SetErrno(EINVAL);
+ return -1;
+ }
if ((chanPtr->typePtr->seekProc != NULL)
&& (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) {
if ((chanPtr->state->curOutPtr != NULL)
@@ -4036,110 +4044,9 @@ WillRead(
/*
*----------------------------------------------------------------------
*
- * WriteBytes --
+ * Write --
*
- * Write a sequence of bytes into an output buffer, may queue the buffer
- * for output if it gets full, and also remembers whether the current
- * buffer is ready e.g. if it contains a newline and we are in line
- * buffering mode.
- *
- * Results:
- * The number of bytes written or -1 in case of error. If -1,
- * Tcl_GetErrno will return the error code.
- *
- * Side effects:
- * May buffer up output and may cause output to be produced on the
- * channel.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-WriteBytes(
- Channel *chanPtr, /* The channel to buffer output for. */
- const char *src, /* Bytes to write. */
- int srcLen) /* Number of bytes to write. */
-{
- ChannelState *statePtr = chanPtr->state;
- /* State info for channel */
- ChannelBuffer *bufPtr;
- char *dst;
- int dstMax, sawLF, savedLF, total, dstLen, toWrite, translate;
-
- if (srcLen) {
- WillWrite(chanPtr);
- }
-
- total = 0;
- sawLF = 0;
- savedLF = 0;
- translate = GotFlag(statePtr, CHANNEL_LINEBUFFERED)
- || (statePtr->outputTranslation != TCL_TRANSLATE_LF);
-
- /*
- * Loop over all bytes in src, storing them in output buffer with proper
- * EOL translation.
- */
-
- while (srcLen + savedLF > 0) {
- bufPtr = statePtr->curOutPtr;
- if (bufPtr == NULL) {
- bufPtr = AllocChannelBuffer(statePtr->bufSize);
- statePtr->curOutPtr = bufPtr;
- }
- dst = InsertPoint(bufPtr);
- dstMax = SpaceLeft(bufPtr);
- dstLen = dstMax;
-
- toWrite = dstLen;
- if (toWrite > srcLen) {
- toWrite = srcLen;
- }
-
- if (translate) {
- if (savedLF) {
- /*
- * A '\n' was left over from last call to TranslateOutputEOL()
- * and we need to store it in this buffer. If the channel is
- * line-based, we will need to flush it.
- */
-
- *dst++ = '\n';
- dstLen--;
- sawLF++;
- }
- if (TranslateOutputEOL(statePtr, dst, src, &dstLen, &toWrite)) {
- sawLF++;
- }
- dstLen += savedLF;
- savedLF = 0;
- if (dstLen > dstMax) {
- savedLF = 1;
- dstLen = dstMax;
- }
- } else {
- memcpy(dst, src, toWrite);
- dstLen = toWrite;
- }
-
- bufPtr->nextAdded += dstLen;
- if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) {
- return -1;
- }
- total += dstLen;
- src += toWrite;
- srcLen -= toWrite;
- sawLF = 0;
- }
- return total;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * WriteChars --
- *
- * Convert UTF-8 bytes to the channel's external encoding and write the
+ * Convert srcLen bytes starting at src according to encoding and write
* produced bytes into an output buffer, may queue the buffer for output
* if it gets full, and also remembers whether the current buffer is
* ready e.g. if it contains a newline and we are in line buffering mode.
@@ -4156,381 +4063,166 @@ WriteBytes(
*/
static int
-WriteChars(
+Write(
Channel *chanPtr, /* The channel to buffer output for. */
const char *src, /* UTF-8 string to write. */
- int srcLen) /* Length of UTF-8 string in bytes. */
+ int srcLen, /* Length of UTF-8 string in bytes. */
+ Tcl_Encoding encoding)
{
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
- ChannelBuffer *bufPtr;
- char *dst, *stage;
- int saved, savedLF, sawLF, total, dstLen, stageMax, dstWrote;
- int stageLen, toWrite, stageRead, endEncoding, result;
- int consumedSomething, translate;
- Tcl_Encoding encoding;
- char safe[BUFFER_PADDING];
+ char *nextNewLine = NULL;
+ int endEncoding, saved = 0, total = 0, flushed = 0, needNlFlush = 0;
if (srcLen) {
WillWrite(chanPtr);
}
- total = 0;
- sawLF = 0;
- savedLF = 0;
- saved = 0;
- encoding = statePtr->encoding;
-
/*
* Write the terminated escape sequence even if srcLen is 0.
*/
endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);
- translate = GotFlag(statePtr, CHANNEL_LINEBUFFERED)
- || (statePtr->outputTranslation != TCL_TRANSLATE_LF);
-
- /*
- * Loop over all UTF-8 characters in src, storing them in staging buffer
- * with proper EOL translation.
- */
+ if (GotFlag(statePtr, CHANNEL_LINEBUFFERED)
+ || (statePtr->outputTranslation != TCL_TRANSLATE_LF)) {
+ nextNewLine = memchr(src, '\n', srcLen);
+ }
- consumedSomething = 1;
- while (consumedSomething && (srcLen + savedLF + endEncoding > 0)) {
- consumedSomething = 0;
- stage = statePtr->outputStage;
- stageMax = statePtr->bufSize;
- stageLen = stageMax;
+ while (srcLen + saved + endEncoding > 0) {
+ ChannelBuffer *bufPtr;
+ char *dst, safe[BUFFER_PADDING];
+ int result, srcRead, dstLen, dstWrote, srcLimit = srcLen;
- toWrite = stageLen;
- if (toWrite > srcLen) {
- toWrite = srcLen;
+ if (nextNewLine) {
+ srcLimit = nextNewLine - src;
}
-
- if (translate) {
- if (savedLF) {
- /*
- * A '\n' was left over from last call to TranslateOutputEOL()
- * and we need to store it in the staging buffer. If the
- * channel is line-based, we will need to flush the output
- * buffer (after translating the staging buffer).
- */
-
- *stage++ = '\n';
- stageLen--;
- sawLF++;
- }
- if (TranslateOutputEOL(statePtr, stage, src, &stageLen,
- &toWrite)) {
- sawLF++;
- }
-
- stage -= savedLF;
- stageLen += savedLF;
- savedLF = 0;
-
- if (stageLen > stageMax) {
- savedLF = 1;
- stageLen = stageMax;
- }
- } else {
- memcpy(stage, src, toWrite);
- stageLen = toWrite;
+
+ /* Get space to write into */
+ bufPtr = statePtr->curOutPtr;
+ if (bufPtr == NULL) {
+ bufPtr = AllocChannelBuffer(statePtr->bufSize);
+ statePtr->curOutPtr = bufPtr;
}
- src += toWrite;
- srcLen -= toWrite;
-
- /*
- * Loop over all UTF-8 characters in staging buffer, converting them
- * to external encoding, storing them in output buffer.
- */
-
- while (stageLen + saved + endEncoding > 0) {
- bufPtr = statePtr->curOutPtr;
- if (bufPtr == NULL) {
- bufPtr = AllocChannelBuffer(statePtr->bufSize);
- statePtr->curOutPtr = bufPtr;
- }
- dst = InsertPoint(bufPtr);
- dstLen = SpaceLeft(bufPtr);
-
- if (saved != 0) {
- /*
- * Here's some translated bytes left over from the last buffer
- * that we need to stick at the beginning of this buffer.
- */
-
- memcpy(dst, safe, (size_t) saved);
- bufPtr->nextAdded += saved;
- dst += saved;
- dstLen -= saved;
- saved = 0;
- }
-
- result = Tcl_UtfToExternal(NULL, encoding, stage, stageLen,
- statePtr->outputEncodingFlags,
- &statePtr->outputEncodingState, dst,
- dstLen + BUFFER_PADDING, &stageRead, &dstWrote, NULL);
-
+ if (saved) {
/*
- * Fix for SF #506297, reported by Martin Forssen
- * <ruric@users.sourceforge.net>.
- *
- * The encoding chosen in the script exposing the bug writes out
- * three intro characters when TCL_ENCODING_START is set, but does
- * not consume any input as TCL_ENCODING_END is cleared. As some
- * output was generated the enclosing loop calls UtfToExternal
- * again, again with START set. Three more characters in the out
- * and still no use of input ... To break this infinite loop we
- * remove TCL_ENCODING_START from the set of flags after the first
- * call (no condition is required, the later calls remove an unset
- * flag, which is a no-op). This causes the subsequent calls to
- * UtfToExternal to consume and convert the actual input.
+ * Here's some translated bytes left over from the last buffer
+ * that we need to stick at the beginning of this buffer.
*/
- statePtr->outputEncodingFlags &= ~TCL_ENCODING_START;
+ memcpy(InsertPoint(bufPtr), safe, (size_t) saved);
+ bufPtr->nextAdded += saved;
+ saved = 0;
+ }
+ PreserveChannelBuffer(bufPtr);
+ dst = InsertPoint(bufPtr);
+ dstLen = SpaceLeft(bufPtr);
+
+ result = Tcl_UtfToExternal(NULL, encoding, src, srcLimit,
+ statePtr->outputEncodingFlags,
+ &statePtr->outputEncodingState, dst,
+ dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL);
+
+ /* See chan-io-1.[89]. Tcl Bug 506297. */
+ statePtr->outputEncodingFlags &= ~TCL_ENCODING_START;
+
+ if ((result != TCL_OK) && (srcRead + dstWrote == 0)) {
+ /* We're reading from invalid/incomplete UTF-8 */
+ ReleaseChannelBuffer(bufPtr);
+ if (total == 0) {
+ Tcl_SetErrno(EINVAL);
+ return -1;
+ }
+ break;
+ }
- /*
- * The following code must be executed only when result is not 0.
- */
+ bufPtr->nextAdded += dstWrote;
+ src += srcRead;
+ srcLen -= srcRead;
+ total += dstWrote;
+ dst += dstWrote;
+ dstLen -= dstWrote;
- if ((result != 0) && (stageRead + dstWrote == 0)) {
- /*
- * We have an incomplete UTF-8 character at the end of the
- * staging buffer. It will get moved to the beginning of the
- * staging buffer followed by more bytes from src.
- */
+ if (src == nextNewLine && dstLen > 0) {
+ static char crln[3] = "\r\n";
+ char *nl = NULL;
+ int nlLen = 0;
- src -= stageLen;
- srcLen += stageLen;
- stageLen = 0;
- savedLF = 0;
+ switch (statePtr->outputTranslation) {
+ case TCL_TRANSLATE_LF:
+ nl = crln + 1;
+ nlLen = 1;
+ break;
+ case TCL_TRANSLATE_CR:
+ nl = crln;
+ nlLen = 1;
+ break;
+ case TCL_TRANSLATE_CRLF:
+ nl = crln;
+ nlLen = 2;
+ break;
+ default:
+ Tcl_Panic("unknown output translation requested");
break;
}
- bufPtr->nextAdded += dstWrote;
- if (IsBufferOverflowing(bufPtr)) {
- /*
- * When translating from UTF-8 to external encoding, we
- * allowed the translation to produce a character that crossed
- * the end of the output buffer, so that we would get a
- * completely full buffer before flushing it. The extra bytes
- * will be moved to the beginning of the next buffer.
- */
+
+ result |= Tcl_UtfToExternal(NULL, encoding, nl, nlLen,
+ statePtr->outputEncodingFlags,
+ &statePtr->outputEncodingState, dst,
+ dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL);
- saved = -SpaceLeft(bufPtr);
- memcpy(safe, dst + dstLen, (size_t) saved);
- bufPtr->nextAdded = bufPtr->bufLength;
- }
- if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) {
- return -1;
+ if (srcRead != nlLen) {
+ Tcl_Panic("Can This Happen?");
}
+ bufPtr->nextAdded += dstWrote;
+ src++;
+ srcLen--;
total += dstWrote;
- stage += stageRead;
- stageLen -= stageRead;
- sawLF = 0;
-
- consumedSomething = 1;
+ dst += dstWrote;
+ dstLen -= dstWrote;
+ nextNewLine = memchr(src, '\n', srcLen);
+ needNlFlush = 1;
+ }
+ if (IsBufferOverflowing(bufPtr)) {
/*
- * If all translated characters are written to the buffer,
- * endEncoding is set to 0 because the escape sequence may be
- * output.
+ * When translating from UTF-8 to external encoding, we
+ * allowed the translation to produce a character that crossed
+ * the end of the output buffer, so that we would get a
+ * completely full buffer before flushing it. The extra bytes
+ * will be moved to the beginning of the next buffer.
*/
- if ((stageLen + saved == 0) && (result == 0)) {
- endEncoding = 0;
- }
- }
- }
-
- /*
- * If nothing was written and it happened because there was no progress in
- * the UTF conversion, we throw an error.
- */
-
- if (!consumedSomething && (total == 0)) {
- Tcl_SetErrno(EINVAL);
- return -1;
- }
- return total;
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * TranslateOutputEOL --
- *
- * Helper function for WriteBytes() and WriteChars(). Converts the '\n'
- * characters in the source buffer into the appropriate EOL form
- * specified by the output translation mode.
- *
- * EOL translation stops either when the source buffer is empty or the
- * output buffer is full.
- *
- * When converting to CRLF mode and there is only 1 byte left in the
- * output buffer, this routine stores the '\r' in the last byte and then
- * stores the '\n' in the byte just past the end of the buffer. The
- * caller is responsible for passing in a buffer that is large enough to
- * hold the extra byte.
- *
- * Results:
- * The return value is 1 if a '\n' was translated from the source buffer,
- * or 0 otherwise -- this can be used by the caller to decide to flush a
- * line-based channel even though the channel buffer is not full.
- *
- * *dstLenPtr is filled with how many bytes of the output buffer were
- * used. As mentioned above, this can be one more that the output
- * buffer's specified length if a CRLF was stored.
- *
- * *srcLenPtr is filled with how many bytes of the source buffer were
- * consumed.
- *
- * Side effects:
- * It may be obvious, but bears mentioning that when converting in CRLF
- * mode (which requires two bytes of storage in the output buffer), the
- * number of bytes consumed from the source buffer will be less than the
- * number of bytes stored in the output buffer.
- *
- *---------------------------------------------------------------------------
- */
-
-static int
-TranslateOutputEOL(
- ChannelState *statePtr, /* Channel being read, for translation and
- * buffering modes. */
- char *dst, /* Output buffer filled with UTF-8 chars by
- * applying appropriate EOL translation to
- * source characters. */
- const char *src, /* Source UTF-8 characters. */
- int *dstLenPtr, /* On entry, the maximum length of output
- * buffer in bytes. On exit, the number of
- * bytes actually used in output buffer. */
- int *srcLenPtr) /* On entry, the length of source buffer. On
- * exit, the number of bytes read from the
- * source buffer. */
-{
- char *dstEnd;
- int srcLen, newlineFound;
-
- newlineFound = 0;
- srcLen = *srcLenPtr;
-
- switch (statePtr->outputTranslation) {
- case TCL_TRANSLATE_LF:
- for (dstEnd = dst + srcLen; dst < dstEnd; ) {
- if (*src == '\n') {
- newlineFound = 1;
- }
- *dst++ = *src++;
- }
- *dstLenPtr = srcLen;
- break;
- case TCL_TRANSLATE_CR:
- for (dstEnd = dst + srcLen; dst < dstEnd;) {
- if (*src == '\n') {
- *dst++ = '\r';
- newlineFound = 1;
- src++;
- } else {
- *dst++ = *src++;
- }
+ saved = -SpaceLeft(bufPtr);
+ memcpy(safe, dst + dstLen, (size_t) saved);
+ bufPtr->nextAdded = bufPtr->bufLength;
}
- *dstLenPtr = srcLen;
- break;
- case TCL_TRANSLATE_CRLF: {
- /*
- * Since this causes the number of bytes to grow, we start off trying
- * to put 'srcLen' bytes into the output buffer, but allow it to store
- * more bytes, as long as there's still source bytes and room in the
- * output buffer.
- */
-
- char *dstStart, *dstMax;
- const char *srcStart;
-
- dstStart = dst;
- dstMax = dst + *dstLenPtr;
-
- srcStart = src;
- if (srcLen < *dstLenPtr) {
- dstEnd = dst + srcLen;
- } else {
- dstEnd = dst + *dstLenPtr;
+ if ((srcLen + saved == 0) && (result == TCL_OK)) {
+ endEncoding = 0;
}
- while (dst < dstEnd) {
- if (*src == '\n') {
- if (dstEnd < dstMax) {
- dstEnd++;
- }
- *dst++ = '\r';
- newlineFound = 1;
- }
- *dst++ = *src++;
- }
- *srcLenPtr = src - srcStart;
- *dstLenPtr = dst - dstStart;
- break;
- }
- default:
- break;
- }
- return newlineFound;
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * CheckFlush --
- *
- * Helper function for WriteBytes() and WriteChars(). If the channel
- * buffer is ready to be flushed, flush it.
- *
- * Results:
- * The return value is -1 if there was a problem flushing the channel
- * buffer, or 0 otherwise.
- *
- * Side effects:
- * The buffer will be recycled if it is flushed.
- *
- *---------------------------------------------------------------------------
- */
-
-static int
-CheckFlush(
- Channel *chanPtr, /* Channel being read, for buffering mode. */
- ChannelBuffer *bufPtr, /* Channel buffer to possibly flush. */
- int newlineFlag) /* Non-zero if a the channel buffer contains a
- * newline. */
-{
- ChannelState *statePtr = chanPtr->state;
- /* State info for channel */
-
- /*
- * The current buffer is ready for output:
- * 1. if it is full.
- * 2. if it contains a newline and this channel is line-buffered.
- * 3. if it contains any output and this channel is unbuffered.
- */
- if (!GotFlag(statePtr, BUFFER_READY)) {
if (IsBufferFull(bufPtr)) {
- SetFlag(statePtr, BUFFER_READY);
- } else if (GotFlag(statePtr, CHANNEL_LINEBUFFERED)) {
- if (newlineFlag != 0) {
- SetFlag(statePtr, BUFFER_READY);
+ if (FlushChannel(NULL, chanPtr, 0) != 0) {
+ return -1;
+ }
+ flushed += statePtr->bufSize;
+ if (saved == 0 || src[-1] != '\n') {
+ needNlFlush = 0;
}
- } else if (GotFlag(statePtr, CHANNEL_UNBUFFERED)) {
- SetFlag(statePtr, BUFFER_READY);
}
+ ReleaseChannelBuffer(bufPtr);
}
- if (GotFlag(statePtr, BUFFER_READY)) {
+ if ((flushed < total) && (GotFlag(statePtr, CHANNEL_UNBUFFERED) ||
+ (needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED)))) {
+ SetFlag(statePtr, BUFFER_READY);
if (FlushChannel(NULL, chanPtr, 0) != 0) {
return -1;
}
}
- return 0;
+
+ return total;
}
/*
@@ -4633,6 +4325,7 @@ Tcl_GetsObj(
*/
chanPtr = statePtr->topChanPtr;
+ Tcl_Preserve(chanPtr);
bufPtr = statePtr->inQueueHead;
encoding = statePtr->encoding;
@@ -4656,16 +4349,7 @@ Tcl_GetsObj(
*/
if (encoding == NULL) {
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
- if (tsdPtr->binaryEncoding == NULL) {
- tsdPtr->binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1");
- Tcl_CreateThreadExitHandler(FreeBinaryEncoding, NULL);
- }
- encoding = tsdPtr->binaryEncoding;
- if (encoding == NULL) {
- Tcl_Panic("attempted gets on binary channel where no iso8859-1 encoding available");
- }
+ encoding = GetBinaryEncoding();
}
/*
@@ -4875,7 +4559,11 @@ Tcl_GetsObj(
* self-modifying reflected transforms.
*/
- chanPtr = statePtr->topChanPtr;
+ if (chanPtr != statePtr->topChanPtr) {
+ Tcl_Release(chanPtr);
+ chanPtr = statePtr->topChanPtr;
+ Tcl_Preserve(chanPtr);
+ }
bufPtr = gs.bufPtr;
if (bufPtr == NULL) {
@@ -4909,16 +4597,18 @@ Tcl_GetsObj(
* Regenerate the top channel, in case it was changed due to
* self-modifying reflected transforms.
*/
-
- chanPtr = statePtr->topChanPtr;
-
+ if (chanPtr != statePtr->topChanPtr) {
+ Tcl_Release(chanPtr);
+ chanPtr = statePtr->topChanPtr;
+ Tcl_Preserve(chanPtr);
+ }
bufPtr = statePtr->inQueueHead;
- if (bufPtr == NULL) {
- Tcl_Panic("Tcl_GetsObj: restore reached with bufPtr==NULL");
+ if (bufPtr != NULL) {
+ bufPtr->nextRemoved = oldRemoved;
+ bufPtr = bufPtr->nextPtr;
}
- bufPtr->nextRemoved = oldRemoved;
- for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) {
+ for ( ; bufPtr != NULL; bufPtr = bufPtr->nextPtr) {
bufPtr->nextRemoved = BUFFER_PADDING;
}
CommonGetsCleanup(chanPtr);
@@ -4951,10 +4641,13 @@ Tcl_GetsObj(
* Regenerate the top channel, in case it was changed due to
* self-modifying reflected transforms.
*/
-
- chanPtr = statePtr->topChanPtr;
-
+ if (chanPtr != statePtr->topChanPtr) {
+ Tcl_Release(chanPtr);
+ chanPtr = statePtr->topChanPtr;
+ Tcl_Preserve(chanPtr);
+ }
UpdateInterest(chanPtr);
+ Tcl_Release(chanPtr);
return copiedTotal;
}
@@ -5000,6 +4693,7 @@ TclGetsObjBinary(
*/
chanPtr = statePtr->topChanPtr;
+ Tcl_Preserve(chanPtr);
bufPtr = statePtr->inQueueHead;
@@ -5057,6 +4751,9 @@ TclGetsObjBinary(
goto restore;
}
bufPtr = statePtr->inQueueTail;
+ if (bufPtr == NULL) {
+ goto restore;
+ }
}
dst = (unsigned char *) RemovePoint(bufPtr);
@@ -5169,12 +4866,12 @@ TclGetsObjBinary(
restore:
bufPtr = statePtr->inQueueHead;
- if (bufPtr == NULL) {
- Tcl_Panic("TclGetsObjBinary: restore reached with bufPtr==NULL");
+ if (bufPtr) {
+ bufPtr->nextRemoved = oldRemoved;
+ bufPtr = bufPtr->nextPtr;
}
- bufPtr->nextRemoved = oldRemoved;
- for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) {
+ for ( ; bufPtr != NULL; bufPtr = bufPtr->nextPtr) {
bufPtr->nextRemoved = BUFFER_PADDING;
}
CommonGetsCleanup(chanPtr);
@@ -5203,6 +4900,7 @@ TclGetsObjBinary(
done:
UpdateInterest(chanPtr);
+ Tcl_Release(chanPtr);
return copiedTotal;
}
@@ -5231,6 +4929,21 @@ FreeBinaryEncoding(
tsdPtr->binaryEncoding = NULL;
}
}
+
+static Tcl_Encoding
+GetBinaryEncoding()
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if (tsdPtr->binaryEncoding == NULL) {
+ tsdPtr->binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1");
+ Tcl_CreateThreadExitHandler(FreeBinaryEncoding, NULL);
+ }
+ if (tsdPtr->binaryEncoding == NULL) {
+ Tcl_Panic("binary encoding is not available");
+ }
+ return tsdPtr->binaryEncoding;
+}
/*
*---------------------------------------------------------------------------
@@ -5313,6 +5026,11 @@ FilterInputBytes(
}
bufPtr = statePtr->inQueueTail;
gsPtr->bufPtr = bufPtr;
+ if (bufPtr == NULL) {
+ gsPtr->charsWrote = 0;
+ gsPtr->rawRead = 0;
+ return -1;
+ }
}
/*
@@ -5660,6 +5378,7 @@ Tcl_ReadRaw(
* requests more bytes.
*/
+ Tcl_Preserve(chanPtr);
for (copied = 0; copied < bytesToRead; copied += copiedNow) {
copiedNow = CopyBuffer(chanPtr, bufPtr + copied,
bytesToRead - copied);
@@ -5742,7 +5461,7 @@ Tcl_ReadRaw(
* over EAGAIN/WOULDBLOCK handling.
*/
- return copied;
+ goto done;
}
SetFlag(statePtr, CHANNEL_BLOCKED);
@@ -5750,14 +5469,17 @@ Tcl_ReadRaw(
}
Tcl_SetErrno(result);
- return -1;
+ copied = -1;
+ goto done;
}
- return copied + nread;
+ copied += nread;
+ goto done;
}
}
done:
+ Tcl_Release(chanPtr);
return copied;
}
@@ -5865,6 +5587,7 @@ DoReadChars(
chanPtr = statePtr->topChanPtr;
encoding = statePtr->encoding;
factor = UTF_EXPANSION_FACTOR;
+ Tcl_Preserve(chanPtr);
if (appendFlag == 0) {
if (encoding == NULL) {
@@ -5926,6 +5649,11 @@ DoReadChars(
ResetFlag(statePtr, CHANNEL_BLOCKED);
}
result = GetInput(chanPtr);
+ if (chanPtr != statePtr->topChanPtr) {
+ Tcl_Release(chanPtr);
+ chanPtr = statePtr->topChanPtr;
+ Tcl_Preserve(chanPtr);
+ }
if (result != 0) {
if (result == EAGAIN) {
break;
@@ -5956,10 +5684,13 @@ DoReadChars(
* Regenerate the top channel, in case it was changed due to
* self-modifying reflected transforms.
*/
-
- chanPtr = statePtr->topChanPtr;
-
+ if (chanPtr != statePtr->topChanPtr) {
+ Tcl_Release(chanPtr);
+ chanPtr = statePtr->topChanPtr;
+ Tcl_Preserve(chanPtr);
+ }
UpdateInterest(chanPtr);
+ Tcl_Release(chanPtr);
return copied;
}
@@ -6715,7 +6446,7 @@ DiscardInputQueued(
*/
if (discardSavedBuffers && statePtr->saveInBufPtr != NULL) {
- ckfree(statePtr->saveInBufPtr);
+ ReleaseChannelBuffer(statePtr->saveInBufPtr);
statePtr->saveInBufPtr = NULL;
}
}
@@ -6808,7 +6539,7 @@ GetInput(
if ((bufPtr != NULL)
&& (bufPtr->bufLength - BUFFER_PADDING < statePtr->bufSize)) {
- ckfree(bufPtr);
+ ReleaseChannelBuffer(bufPtr);
bufPtr = NULL;
}
@@ -6870,10 +6601,12 @@ GetInput(
} else
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
{
+ PreserveChannelBuffer(bufPtr);
nread = ChanRead(chanPtr, InsertPoint(bufPtr), toRead, &result);
}
if (nread > 0) {
+ result = 0;
bufPtr->nextAdded += nread;
/*
@@ -6897,6 +6630,7 @@ GetInput(
}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
} else if (nread == 0) {
+ result = 0;
SetFlag(statePtr, CHANNEL_EOF);
statePtr->inputEncodingFlags |= TCL_ENCODING_END;
} else if (nread < 0) {
@@ -6905,9 +6639,9 @@ GetInput(
result = EAGAIN;
}
Tcl_SetErrno(result);
- return result;
}
- return 0;
+ ReleaseChannelBuffer(bufPtr);
+ return result;
}
/*
@@ -7594,14 +7328,6 @@ Tcl_SetChannelBufferSize(
statePtr = ((Channel *) chan)->state;
statePtr->bufSize = sz;
-
- if (statePtr->outputStage != NULL) {
- ckfree(statePtr->outputStage);
- statePtr->outputStage = NULL;
- }
- if ((statePtr->encoding != NULL) && GotFlag(statePtr, TCL_WRITABLE)) {
- statePtr->outputStage = ckalloc(statePtr->bufSize + 2);
- }
}
/*
@@ -8053,7 +7779,8 @@ Tcl_SetChannelOption(
* iso2022, the terminated escape sequence must write to the buffer.
*/
- if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL)
+ if ((statePtr->encoding != NULL)
+ && !(statePtr->outputEncodingFlags & TCL_ENCODING_START)
&& (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
statePtr->outputEncodingFlags |= TCL_ENCODING_END;
WriteChars(chanPtr, "", 0);
@@ -8242,17 +7969,6 @@ Tcl_SetChannelOption(
statePtr->inQueueTail = NULL;
}
- /*
- * If encoding or bufsize changes, need to update output staging buffer.
- */
-
- if (statePtr->outputStage != NULL) {
- ckfree(statePtr->outputStage);
- statePtr->outputStage = NULL;
- }
- if ((statePtr->encoding != NULL) && GotFlag(statePtr, TCL_WRITABLE)) {
- statePtr->outputStage = ckalloc(statePtr->bufSize + 2);
- }
return TCL_OK;
}
@@ -8487,6 +8203,11 @@ UpdateInterest(
/* State info for channel */
int mask = statePtr->interestMask;
+ if (chanPtr->typePtr == NULL) {
+ /* Do not update interest on a closed channel */
+ return;
+ }
+
/*
* If there are flushed buffers waiting to be written, then we need to
* watch for the channel to become writable.
@@ -9399,9 +9120,9 @@ CopyData(
}
if (outBinary || sameEncoding) {
- sizeb = DoWrite(outStatePtr->topChanPtr, buffer, sizeb);
+ sizeb = WriteBytes(outStatePtr->topChanPtr, buffer, sizeb);
} else {
- sizeb = DoWriteChars(outStatePtr->topChanPtr, buffer, sizeb);
+ sizeb = WriteChars(outStatePtr->topChanPtr, buffer, sizeb);
}
/*
@@ -9590,6 +9311,7 @@ DoRead(
* operation.
*/
+ Tcl_Preserve(chanPtr);
if (!GotFlag(statePtr, CHANNEL_STICKY_EOF)) {
ResetFlag(statePtr, CHANNEL_EOF);
}
@@ -9630,6 +9352,7 @@ DoRead(
done:
UpdateInterest(chanPtr);
+ Tcl_Release(chanPtr);
return copied;
}
@@ -9953,162 +9676,6 @@ CopyBuffer(
/*
*----------------------------------------------------------------------
*
- * DoWrite --
- *
- * Puts a sequence of characters into an output buffer, may queue the
- * buffer for output if it gets full, and also remembers whether the
- * current buffer is ready e.g. if it contains a newline and we are in
- * line buffering mode.
- *
- * Results:
- * The number of bytes written or -1 in case of error. If -1,
- * Tcl_GetErrno will return the error code.
- *
- * Side effects:
- * May buffer up output and may cause output to be produced on the
- * channel.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-DoWrite(
- Channel *chanPtr, /* The channel to buffer output for. */
- const char *src, /* Data to write. */
- int srcLen) /* Number of bytes to write. */
-{
- ChannelState *statePtr = chanPtr->state;
- /* State info for channel */
- ChannelBuffer *outBufPtr; /* Current output buffer. */
- int foundNewline; /* Did we find a newline in output? */
- char *dPtr;
- const char *sPtr; /* Search variables for newline. */
- int crsent; /* In CRLF eol translation mode, remember the
- * fact that a CR was output to the channel
- * without its following NL. */
- int i; /* Loop index for newline search. */
- int destCopied; /* How many bytes were used in this
- * destination buffer to hold the output? */
- int totalDestCopied; /* How many bytes total were copied to the
- * channel buffer? */
- int srcCopied; /* How many bytes were copied from the source
- * string? */
- char *destPtr; /* Where in line to copy to? */
-
- /*
- * If we are in network (or windows) translation mode, record the fact
- * that we have not yet sent a CR to the channel.
- */
-
- crsent = 0;
-
- /*
- * Loop filling buffers and flushing them until all output has been
- * consumed.
- */
-
- srcCopied = 0;
- totalDestCopied = 0;
-
- while (srcLen > 0) {
- /*
- * Make sure there is a current output buffer to accept output.
- */
-
- if (statePtr->curOutPtr == NULL) {
- statePtr->curOutPtr = AllocChannelBuffer(statePtr->bufSize);
- }
-
- outBufPtr = statePtr->curOutPtr;
-
- destCopied = SpaceLeft(outBufPtr);
- if (destCopied > srcLen) {
- destCopied = srcLen;
- }
-
- destPtr = InsertPoint(outBufPtr);
- switch (statePtr->outputTranslation) {
- case TCL_TRANSLATE_LF:
- srcCopied = destCopied;
- memcpy(destPtr, src, (size_t) destCopied);
- break;
- case TCL_TRANSLATE_CR:
- srcCopied = destCopied;
- memcpy(destPtr, src, (size_t) destCopied);
- for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) {
- if (*dPtr == '\n') {
- *dPtr = '\r';
- }
- }
- break;
- case TCL_TRANSLATE_CRLF:
- for (srcCopied = 0, dPtr = destPtr, sPtr = src;
- dPtr < destPtr + destCopied;
- dPtr++, sPtr++, srcCopied++) {
- if (*sPtr == '\n') {
- if (crsent) {
- *dPtr = '\n';
- crsent = 0;
- } else {
- *dPtr = '\r';
- crsent = 1;
- sPtr--, srcCopied--;
- }
- } else {
- *dPtr = *sPtr;
- }
- }
- break;
- case TCL_TRANSLATE_AUTO:
- Tcl_Panic("Tcl_Write: AUTO output translation mode not supported");
- default:
- Tcl_Panic("Tcl_Write: unknown output translation mode");
- }
-
- /*
- * The current buffer is ready for output if it is full, or if it
- * contains a newline and this channel is line-buffered, or if it
- * contains any output and this channel is unbuffered.
- */
-
- outBufPtr->nextAdded += destCopied;
- if (!GotFlag(statePtr, BUFFER_READY)) {
- if (IsBufferFull(outBufPtr)) {
- SetFlag(statePtr, BUFFER_READY);
- } else if (GotFlag(statePtr, CHANNEL_LINEBUFFERED)) {
- for (sPtr = src, i = 0, foundNewline = 0;
- (i < srcCopied) && (!foundNewline);
- i++, sPtr++) {
- if (*sPtr == '\n') {
- foundNewline = 1;
- break;
- }
- }
- if (foundNewline) {
- SetFlag(statePtr, BUFFER_READY);
- }
- } else if (GotFlag(statePtr, CHANNEL_UNBUFFERED)) {
- SetFlag(statePtr, BUFFER_READY);
- }
- }
-
- totalDestCopied += srcCopied;
- src += srcCopied;
- srcLen -= srcCopied;
-
- if (GotFlag(statePtr, BUFFER_READY)) {
- if (FlushChannel(NULL, chanPtr, 0) != 0) {
- return -1;
- }
- }
- } /* Closes "while" */
-
- return totalDestCopied;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* CopyEventProc --
*
* This routine is invoked as a channel event handler for the background
@@ -10223,12 +9790,15 @@ StackSetBlockMode(
{
int result = 0;
Tcl_DriverBlockModeProc *blockModeProc;
+ ChannelState *statePtr = chanPtr->state;
/*
* Start at the top of the channel stack
+ * TODO: Examine what can go wrong when blockModeProc calls
+ * disturb the stacking state of the channel.
*/
- chanPtr = chanPtr->state->topChanPtr;
+ chanPtr = statePtr->topChanPtr;
while (chanPtr != NULL) {
blockModeProc = Tcl_ChannelBlockModeProc(chanPtr->typePtr);
if (blockModeProc != NULL) {
@@ -11331,12 +10901,11 @@ DupChannelIntRep(
* currently have an internal rep.*/
{
ChannelState *statePtr = GET_CHANNELSTATE(srcPtr);
- Interp *interpPtr = GET_CHANNELINTERP(srcPtr);
SET_CHANNELSTATE(copyPtr, statePtr);
- SET_CHANNELINTERP(copyPtr, interpPtr);
+ SET_CHANNELINTERP(copyPtr, GET_CHANNELINTERP(srcPtr));
Tcl_Preserve(statePtr);
- copyPtr->typePtr = &tclChannelType;
+ copyPtr->typePtr = srcPtr->typePtr;
}
/*
@@ -11362,43 +10931,29 @@ SetChannelFromAny(
register Tcl_Obj *objPtr) /* The object to convert. */
{
ChannelState *statePtr;
- Interp *interpPtr;
if (interp == NULL) {
return TCL_ERROR;
}
- if (objPtr->typePtr == &tclChannelType) {
+ if (objPtr->typePtr == &chanObjType) {
/*
* The channel is valid until any call to DetachChannel occurs.
* Ensure consistency checks are done.
*/
statePtr = GET_CHANNELSTATE(objPtr);
- interpPtr = GET_CHANNELINTERP(objPtr);
if (GotFlag(statePtr, CHANNEL_TAINTED|CHANNEL_CLOSED)) {
ResetFlag(statePtr, CHANNEL_TAINTED);
Tcl_Release(statePtr);
- UpdateStringOfChannel(objPtr);
objPtr->typePtr = NULL;
- } else if (interpPtr != (Interp*) interp) {
+ } else if (interp != GET_CHANNELINTERP(objPtr)) {
Tcl_Release(statePtr);
- UpdateStringOfChannel(objPtr);
objPtr->typePtr = NULL;
}
}
- if (objPtr->typePtr != &tclChannelType) {
- Tcl_Channel chan;
-
- /*
- * We need a valid string with which to check for a valid channel, but
- * make sure not to free internal rep until validated. [Bug 1847044]
- */
-
- if ((objPtr->typePtr != NULL) && (objPtr->bytes == NULL)) {
- objPtr->typePtr->updateStringProc(objPtr);
- }
+ if (objPtr->typePtr != &chanObjType) {
+ Tcl_Channel chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL);
- chan = Tcl_GetChannel(interp, objPtr->bytes, NULL);
if (chan == NULL) {
return TCL_ERROR;
}
@@ -11408,7 +10963,7 @@ SetChannelFromAny(
Tcl_Preserve(statePtr);
SET_CHANNELSTATE(objPtr, statePtr);
SET_CHANNELINTERP(objPtr, interp);
- objPtr->typePtr = &tclChannelType;
+ objPtr->typePtr = &chanObjType;
}
return TCL_OK;
}
@@ -11416,45 +10971,6 @@ SetChannelFromAny(
/*
*----------------------------------------------------------------------
*
- * UpdateStringOfChannel --
- *
- * Update the string representation for an object whose internal
- * representation is "Channel".
- *
- * Results:
- * None.
- *
- * Side effects:
- * The object's string may be set by converting its Unicode represention
- * to UTF format.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-UpdateStringOfChannel(
- Tcl_Obj *objPtr) /* Object with string rep to update. */
-{
- if (objPtr->bytes == NULL) {
- ChannelState *statePtr = GET_CHANNELSTATE(objPtr);
- const char *name = statePtr->channelName;
-
- if (name) {
- size_t len = strlen(name);
-
- objPtr->bytes = ckalloc(len + 1);
- objPtr->length = len;
- memcpy(objPtr->bytes, name, len);
- } else {
- objPtr->bytes = tclEmptyStringRep;
- objPtr->length = 0;
- }
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
* FreeChannelIntRep --
*
* Release statePtr storage.
diff --git a/generic/tclIO.h b/generic/tclIO.h
index e84f300..1e02749 100644
--- a/generic/tclIO.h
+++ b/generic/tclIO.h
@@ -36,6 +36,7 @@
*/
typedef struct ChannelBuffer {
+ int refCount; /* Current uses count */
int nextAdded; /* The next position into which a character
* will be put in the buffer. */
int nextRemoved; /* Position of next byte to be removed from
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 1673bce..14910d7 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -181,6 +181,7 @@ Tcl_PutsObjCmd(
return TCL_ERROR;
}
+ Tcl_Preserve(chan);
result = Tcl_WriteObj(chan, string);
if (result < 0) {
goto error;
@@ -191,6 +192,7 @@ Tcl_PutsObjCmd(
goto error;
}
}
+ Tcl_Release(chan);
return TCL_OK;
/*
@@ -205,6 +207,7 @@ Tcl_PutsObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s",
TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
+ Tcl_Release(chan);
return TCL_ERROR;
}
@@ -252,6 +255,7 @@ Tcl_FlushObjCmd(
return TCL_ERROR;
}
+ Tcl_Preserve(chan);
if (Tcl_Flush(chan) != TCL_OK) {
/*
* TIP #219.
@@ -265,8 +269,10 @@ Tcl_FlushObjCmd(
"error flushing \"%s\": %s",
TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
+ Tcl_Release(chan);
return TCL_ERROR;
}
+ Tcl_Release(chan);
return TCL_OK;
}
@@ -299,6 +305,7 @@ Tcl_GetsObjCmd(
int lineLen; /* Length of line just read. */
int mode; /* Mode in which channel is opened. */
Tcl_Obj *linePtr, *chanObjPtr;
+ int code = TCL_OK;
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
@@ -315,6 +322,7 @@ Tcl_GetsObjCmd(
return TCL_ERROR;
}
+ Tcl_Preserve(chan);
linePtr = Tcl_NewObj();
lineLen = Tcl_GetsObj(chan, linePtr);
if (lineLen < 0) {
@@ -333,7 +341,8 @@ Tcl_GetsObjCmd(
"error reading \"%s\": %s",
TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
- return TCL_ERROR;
+ code = TCL_ERROR;
+ goto done;
}
lineLen = -1;
}
@@ -346,7 +355,9 @@ Tcl_GetsObjCmd(
} else {
Tcl_SetObjResult(interp, linePtr);
}
- return TCL_OK;
+ done:
+ Tcl_Release(chan);
+ return code;
}
/*
@@ -453,6 +464,7 @@ Tcl_ReadObjCmd(
resultPtr = Tcl_NewObj();
Tcl_IncrRefCount(resultPtr);
+ Tcl_Preserve(chan);
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
if (charactersRead < 0) {
/*
@@ -467,6 +479,7 @@ Tcl_ReadObjCmd(
"error reading \"%s\": %s",
TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
+ Tcl_Release(chan);
Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
}
@@ -485,6 +498,7 @@ Tcl_ReadObjCmd(
}
}
Tcl_SetObjResult(interp, resultPtr);
+ Tcl_Release(chan);
Tcl_DecrRefCount(resultPtr);
return TCL_OK;
}
@@ -544,6 +558,7 @@ Tcl_SeekObjCmd(
mode = modeArray[optionIndex];
}
+ Tcl_Preserve(chan);
result = Tcl_Seek(chan, offset, mode);
if (result == Tcl_LongAsWide(-1)) {
/*
@@ -558,8 +573,10 @@ Tcl_SeekObjCmd(
"error during seek on \"%s\": %s",
TclGetString(objv[1]), Tcl_PosixError(interp)));
}
+ Tcl_Release(chan);
return TCL_ERROR;
}
+ Tcl_Release(chan);
return TCL_OK;
}
@@ -590,6 +607,7 @@ Tcl_TellObjCmd(
{
Tcl_Channel chan; /* The channel to tell on. */
Tcl_WideInt newLoc;
+ int code;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
@@ -605,6 +623,7 @@ Tcl_TellObjCmd(
return TCL_ERROR;
}
+ Tcl_Preserve(chan);
newLoc = Tcl_Tell(chan);
/*
@@ -613,7 +632,10 @@ Tcl_TellObjCmd(
* them into the regular interpreter result.
*/
- if (TclChanCaughtErrorBypass(interp, chan)) {
+
+ code = TclChanCaughtErrorBypass(interp, chan);
+ Tcl_Release(chan);
+ if (code) {
return TCL_ERROR;
}
diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c
index 825f408..29996ea 100644
--- a/generic/tclIOGT.c
+++ b/generic/tclIOGT.c
@@ -210,7 +210,27 @@ struct TransformChannelData {
* a transformation of incoming data. Also
* serves as buffer of all data not yet
* consumed by the reader. */
+ int refCount;
};
+
+static void
+PreserveData(
+ TransformChannelData *dataPtr)
+{
+ dataPtr->refCount++;
+}
+
+static void
+ReleaseData(
+ TransformChannelData *dataPtr)
+{
+ if (--dataPtr->refCount) {
+ return;
+ }
+ ResultClear(&dataPtr->result);
+ Tcl_DecrRefCount(dataPtr->command);
+ ckfree(dataPtr);
+}
/*
*----------------------------------------------------------------------
@@ -240,6 +260,7 @@ TclChannelTransform(
Channel *chanPtr; /* The actual channel. */
ChannelState *statePtr; /* State info for channel. */
int mode; /* Read/write mode of the channel. */
+ int objc;
TransformChannelData *dataPtr;
Tcl_DString ds;
@@ -247,6 +268,12 @@ TclChannelTransform(
return TCL_ERROR;
}
+ if (TCL_OK != Tcl_ListObjLength(interp, cmdObjPtr, &objc)) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("-command value is not a list", -1));
+ return TCL_ERROR;
+ }
+
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
@@ -261,6 +288,7 @@ TclChannelTransform(
dataPtr = ckalloc(sizeof(TransformChannelData));
+ dataPtr->refCount = 1;
Tcl_DStringInit(&ds);
Tcl_GetChannelOption(interp, chan, "-blocking", &ds);
dataPtr->readIsFlushed = 0;
@@ -286,9 +314,7 @@ TclChannelTransform(
if (dataPtr->self == NULL) {
Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp),
"\nfailed to stack channel \"%s\"", Tcl_GetChannelName(chan));
- Tcl_DecrRefCount(dataPtr->command);
- ResultClear(&dataPtr->result);
- ckfree(dataPtr);
+ ReleaseData(dataPtr);
return TCL_ERROR;
}
@@ -296,9 +322,11 @@ TclChannelTransform(
* At last initialize the transformation at the script level.
*/
+ PreserveData(dataPtr);
if ((dataPtr->mode & TCL_WRITABLE) && ExecuteCallback(dataPtr, NULL,
A_CREATE_WRITE, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE) != TCL_OK){
Tcl_UnstackChannel(interp, chan);
+ ReleaseData(dataPtr);
return TCL_ERROR;
}
@@ -307,9 +335,11 @@ TclChannelTransform(
ExecuteCallback(dataPtr, NULL, A_DELETE_WRITE, NULL, 0, TRANSMIT_DONT,
P_NO_PRESERVE);
Tcl_UnstackChannel(interp, chan);
+ ReleaseData(dataPtr);
return TCL_ERROR;
}
+ ReleaseData(dataPtr);
return TCL_OK;
}
@@ -350,7 +380,10 @@ ExecuteCallback(
unsigned char *resBuf;
Tcl_InterpState state = NULL;
int res = TCL_OK;
- Tcl_Obj *command = Tcl_DuplicateObj(dataPtr->command);
+ Tcl_Obj *command = TclListObjCopy(NULL, dataPtr->command);
+ Tcl_Interp *eval = dataPtr->interp;
+
+ Tcl_Preserve(eval);
/*
* Step 1, create the complete command to execute. Do this by appending
@@ -361,26 +394,18 @@ ExecuteCallback(
*/
if (preserve == P_PRESERVE) {
- state = Tcl_SaveInterpState(dataPtr->interp, res);
+ state = Tcl_SaveInterpState(eval, res);
}
Tcl_IncrRefCount(command);
- res = Tcl_ListObjAppendElement(dataPtr->interp, command,
- Tcl_NewStringObj((char *) op, -1));
- if (res != TCL_OK) {
- goto cleanup;
- }
+ Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, -1));
/*
* Use a byte-array to prevent the misinterpretation of binary data coming
* through as UTF while at the tcl level.
*/
- res = Tcl_ListObjAppendElement(dataPtr->interp, command,
- Tcl_NewByteArrayObj(buf, bufLen));
- if (res != TCL_OK) {
- goto cleanup;
- }
+ Tcl_ListObjAppendElement(NULL, command, Tcl_NewByteArrayObj(buf, bufLen));
/*
* Step 2, execute the command at the global level of the interpreter used
@@ -390,13 +415,14 @@ ExecuteCallback(
* current interpreter. Don't copy if in preservation mode.
*/
- res = Tcl_EvalObjEx(dataPtr->interp, command, TCL_EVAL_GLOBAL);
+ res = Tcl_EvalObjEx(eval, command, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(command);
command = NULL;
- if ((res != TCL_OK) && (interp != NULL) && (dataPtr->interp != interp)
+ if ((res != TCL_OK) && (interp != NULL) && (eval != interp)
&& (preserve == P_NO_PRESERVE)) {
- Tcl_SetObjResult(interp, Tcl_GetObjResult(dataPtr->interp));
+ Tcl_SetObjResult(interp, Tcl_GetObjResult(eval));
+ Tcl_Release(eval);
return res;
}
@@ -411,20 +437,20 @@ ExecuteCallback(
break;
case TRANSMIT_DOWN:
- resObj = Tcl_GetObjResult(dataPtr->interp);
+ resObj = Tcl_GetObjResult(eval);
resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf,
resLen);
break;
case TRANSMIT_SELF:
- resObj = Tcl_GetObjResult(dataPtr->interp);
+ resObj = Tcl_GetObjResult(eval);
resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen);
break;
case TRANSMIT_IBUF:
- resObj = Tcl_GetObjResult(dataPtr->interp);
+ resObj = Tcl_GetObjResult(eval);
resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
ResultAdd(&dataPtr->result, resBuf, resLen);
break;
@@ -434,24 +460,16 @@ ExecuteCallback(
* Interpret result as integer number.
*/
- resObj = Tcl_GetObjResult(dataPtr->interp);
- TclGetIntFromObj(dataPtr->interp, resObj, &dataPtr->maxRead);
+ resObj = Tcl_GetObjResult(eval);
+ TclGetIntFromObj(eval, resObj, &dataPtr->maxRead);
break;
}
- Tcl_ResetResult(dataPtr->interp);
- if (preserve == P_PRESERVE) {
- (void) Tcl_RestoreInterpState(dataPtr->interp, state);
- }
- return res;
-
- cleanup:
+ Tcl_ResetResult(eval);
if (preserve == P_PRESERVE) {
- (void) Tcl_RestoreInterpState(dataPtr->interp, state);
- }
- if (command != NULL) {
- Tcl_DecrRefCount(command);
+ (void) Tcl_RestoreInterpState(eval, state);
}
+ Tcl_Release(eval);
return res;
}
@@ -535,6 +553,7 @@ TransformCloseProc(
* system rely on (f.e. signaling the close to interested parties).
*/
+ PreserveData(dataPtr);
if (dataPtr->mode & TCL_WRITABLE) {
ExecuteCallback(dataPtr, interp, A_FLUSH_WRITE, NULL, 0,
TRANSMIT_DOWN, P_PRESERVE);
@@ -554,14 +573,13 @@ TransformCloseProc(
ExecuteCallback(dataPtr, interp, A_DELETE_READ, NULL, 0,
TRANSMIT_DONT, P_PRESERVE);
}
+ ReleaseData(dataPtr);
/*
* General cleanup.
*/
- ResultClear(&dataPtr->result);
- Tcl_DecrRefCount(dataPtr->command);
- ckfree(dataPtr);
+ ReleaseData(dataPtr);
return TCL_OK;
}
@@ -606,6 +624,7 @@ TransformInputProc(
gotBytes = 0;
downChan = Tcl_GetStackedChannel(dataPtr->self);
+ PreserveData(dataPtr);
while (toRead > 0) {
/*
* Loop until the request is satisfied (or no data is available from
@@ -623,7 +642,7 @@ TransformInputProc(
* break out of the loop and return to the caller.
*/
- return gotBytes;
+ break;
}
/*
@@ -647,7 +666,7 @@ TransformInputProc(
}
} /* else: 'maxRead < 0' == Accept the current value of toRead. */
if (toRead <= 0) {
- return gotBytes;
+ break;
}
/*
@@ -664,11 +683,12 @@ TransformInputProc(
int error = Tcl_GetErrno();
if ((error == EAGAIN) && (gotBytes > 0)) {
- return gotBytes;
+ break;
}
*errorCodePtr = error;
- return -1;
+ gotBytes = -1;
+ break;
} else if (read == 0) {
/*
* Check wether we hit on EOF in the underlying channel or not. If
@@ -683,9 +703,9 @@ TransformInputProc(
if (!Tcl_Eof(downChan)) {
if ((gotBytes == 0) && (dataPtr->flags & CHANNEL_ASYNC)) {
*errorCodePtr = EWOULDBLOCK;
- return -1;
+ gotBytes = -1;
}
- return gotBytes;
+ break;
}
if (dataPtr->readIsFlushed) {
@@ -693,7 +713,7 @@ TransformInputProc(
* Already flushed, nothing to do anymore.
*/
- return gotBytes;
+ break;
}
dataPtr->readIsFlushed = 1;
@@ -705,7 +725,7 @@ TransformInputProc(
* We had nothing to flush.
*/
- return gotBytes;
+ break;
}
continue; /* at: while (toRead > 0) */
@@ -719,9 +739,11 @@ TransformInputProc(
if (ExecuteCallback(dataPtr, NULL, A_READ, UCHARP(buf), read,
TRANSMIT_IBUF, P_PRESERVE) != TCL_OK) {
*errorCodePtr = EINVAL;
- return -1;
+ gotBytes = -1;
+ break;
}
} /* while toRead > 0 */
+ ReleaseData(dataPtr);
return gotBytes;
}
@@ -763,11 +785,13 @@ TransformOutputProc(
return 0;
}
+ PreserveData(dataPtr);
if (ExecuteCallback(dataPtr, NULL, A_WRITE, UCHARP(buf), toWrite,
TRANSMIT_DOWN, P_NO_PRESERVE) != TCL_OK) {
*errorCodePtr = EINVAL;
- return -1;
+ toWrite = -1;
}
+ ReleaseData(dataPtr);
return toWrite;
}
@@ -820,6 +844,7 @@ TransformSeekProc(
* request down, unchanged.
*/
+ PreserveData(dataPtr);
if (dataPtr->mode & TCL_WRITABLE) {
ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN,
P_NO_PRESERVE);
@@ -831,6 +856,7 @@ TransformSeekProc(
ResultClear(&dataPtr->result);
dataPtr->readIsFlushed = 0;
}
+ ReleaseData(dataPtr);
return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode,
errorCodePtr);
@@ -891,6 +917,7 @@ TransformWideSeekProc(
* request down, unchanged.
*/
+ PreserveData(dataPtr);
if (dataPtr->mode & TCL_WRITABLE) {
ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN,
P_NO_PRESERVE);
@@ -902,6 +929,7 @@ TransformWideSeekProc(
ResultClear(&dataPtr->result);
dataPtr->readIsFlushed = 0;
}
+ ReleaseData(dataPtr);
/*
* If we have a wide seek capability, we should stick with that.
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index cb0282a..94428bb 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -99,31 +99,9 @@ typedef struct {
Tcl_ThreadId thread; /* Thread the 'interp' belongs to. == Handler thread */
Tcl_ThreadId owner; /* Thread owning the structure. == Channel thread */
#endif
-
- /* See [==] as well.
- * Storage for the command prefix and the additional words required for
- * the invocation of methods in the command handler.
- *
- * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2]
- * cmd ... pfx | method chan | detail1 detail2
- * ~~~~ CT ~~~ ~~ CT ~~
- *
- * CT = Belongs to the 'Command handler Thread'.
- */
-
- int argc; /* Number of preallocated words - 2 */
- Tcl_Obj **argv; /* Preallocated array for calling the handler.
- * args[0] is placeholder for cmd word.
- * Followed by the arguments in the prefix,
- * plus 4 placeholders for method, channel,
- * and at most two varying (method specific)
- * words. */
- int methods; /* Bitmask of supported methods */
-
- /*
- * NOTE (9): Should we have predefined shared literals for the method
- * names?
- */
+ Tcl_Obj *cmd; /* Callback command prefix */
+ Tcl_Obj *methods; /* Methods to append to command prefix */
+ Tcl_Obj *name; /* Name of the channel as created */
int mode; /* Mask of R/W mode */
int interest; /* Mask of events the channel is interested
@@ -450,9 +428,8 @@ static ReflectedChannel * NewReflectedChannel(Tcl_Interp *interp,
Tcl_Obj *cmdpfxObj, int mode, Tcl_Obj *handleObj);
static Tcl_Obj * NextHandle(void);
static void FreeReflectedChannel(ReflectedChannel *rcPtr);
-static void FreeReflectedChannelArgs(ReflectedChannel *rcPtr);
static int InvokeTclMethod(ReflectedChannel *rcPtr,
- const char *method, Tcl_Obj *argOneObj,
+ MethodName method, Tcl_Obj *argOneObj,
Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr);
static ReflectedChannelMap * GetReflectedChannelMap(Tcl_Interp *interp);
@@ -467,9 +444,7 @@ static int ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj *resObj);
* list-quoting to keep the words of the message together. See also [x].
*/
-static const char *msg_read_unsup = "{read not supported by Tcl driver}";
static const char *msg_read_toomuch = "{read delivered more than requested}";
-static const char *msg_write_unsup = "{write not supported by Tcl driver}";
static const char *msg_write_toomuch = "{write wrote more than requested}";
static const char *msg_write_nothing = "{write wrote nothing}";
static const char *msg_seek_beforestart = "{Tried to seek before origin}";
@@ -583,10 +558,6 @@ TclChanCreateObjCmd(
rcId = NextHandle();
rcPtr = NewReflectedChannel(interp, cmdObj, mode, rcId);
- chan = Tcl_CreateChannel(&tclRChannelType, TclGetString(rcId), rcPtr,
- mode);
- rcPtr->chan = chan;
- chanPtr = (Channel *) chan;
/*
* Invoke 'initialize' and validate that the handler is present and ok.
@@ -600,7 +571,7 @@ TclChanCreateObjCmd(
modeObj = DecodeEventMask(mode);
/* assert modeObj.refCount == 1 */
- result = InvokeTclMethod(rcPtr, "initialize", modeObj, NULL, &resObj);
+ result = InvokeTclMethod(rcPtr, METH_INIT, modeObj, NULL, &resObj);
Tcl_DecrRefCount(modeObj);
if (result != TCL_OK) {
@@ -683,7 +654,11 @@ TclChanCreateObjCmd(
* Everything is fine now.
*/
- rcPtr->methods = methods;
+ chan = Tcl_CreateChannel(&tclRChannelType, TclGetString(rcId), rcPtr,
+ mode);
+ rcPtr->chan = chan;
+ Tcl_Preserve(chan);
+ chanPtr = (Channel *) chan;
if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) {
/*
@@ -744,12 +719,10 @@ TclChanCreateObjCmd(
return TCL_OK;
error:
- /*
- * Signal to ReflectClose to not call 'finalize'.
- */
-
- rcPtr->methods = 0;
- Tcl_Close(interp, chan);
+ Tcl_DecrRefCount(rcPtr->name);
+ Tcl_DecrRefCount(rcPtr->methods);
+ Tcl_DecrRefCount(rcPtr->cmd);
+ ckfree((char*) rcPtr);
return TCL_ERROR;
#undef MODE
@@ -1172,6 +1145,7 @@ ReflectClose(
if (result != TCL_OK) {
FreeReceivedError(&p);
}
+ return EOK;
}
#endif
@@ -1180,18 +1154,6 @@ ReflectClose(
}
/*
- * -- No -- ASSERT rcPtr->methods & FLAG(METH_FINAL)
- *
- * A cleaned method mask here implies that the channel creation was
- * aborted, and "finalize" must not be called.
- */
-
- if (rcPtr->methods == 0) {
- Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
- return EOK;
- }
-
- /*
* Are we in the correct thread?
*/
@@ -1208,14 +1170,12 @@ ReflectClose(
Tcl_DeleteEvents(ReflectEventDelete, rcPtr);
- Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
-
if (result != TCL_OK) {
PassReceivedErrorInterp(interp, &p);
}
} else {
#endif
- result = InvokeTclMethod(rcPtr, "finalize", NULL, NULL, &resObj);
+ result = InvokeTclMethod(rcPtr, METH_FINAL, NULL, NULL, &resObj);
if ((result != TCL_OK) && (interp != NULL)) {
Tcl_SetChannelErrorInterp(interp, resObj);
}
@@ -1290,18 +1250,6 @@ ReflectInput(
Tcl_Obj *resObj; /* Result data for 'read' */
/*
- * The following check can be done before thread redirection, because we
- * are reading from an item which is readonly, i.e. will never change
- * during the lifetime of the channel.
- */
-
- if (!(rcPtr->methods & FLAG(METH_READ))) {
- SetChannelErrorStr(rcPtr->chan, msg_read_unsup);
- *errorCodePtr = EINVAL;
- return -1;
- }
-
- /*
* Are we in the correct thread?
*/
@@ -1339,7 +1287,7 @@ ReflectInput(
toReadObj = Tcl_NewIntObj(toRead);
Tcl_IncrRefCount(toReadObj);
- if (InvokeTclMethod(rcPtr, "read", toReadObj, NULL, &resObj)!=TCL_OK) {
+ if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK) {
int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
@@ -1405,18 +1353,6 @@ ReflectOutput(
int written;
/*
- * The following check can be done before thread redirection, because we
- * are reading from an item which is readonly, i.e. will never change
- * during the lifetime of the channel.
- */
-
- if (!(rcPtr->methods & FLAG(METH_WRITE))) {
- SetChannelErrorStr(rcPtr->chan, msg_write_unsup);
- *errorCodePtr = EINVAL;
- return -1;
- }
-
- /*
* Are we in the correct thread?
*/
@@ -1454,7 +1390,7 @@ ReflectOutput(
bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toWrite);
Tcl_IncrRefCount(bufObj);
- if (InvokeTclMethod(rcPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
+ if (InvokeTclMethod(rcPtr, METH_WRITE, bufObj, NULL, &resObj) != TCL_OK) {
int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
@@ -1568,7 +1504,7 @@ ReflectSeekWide(
Tcl_IncrRefCount(offObj);
Tcl_IncrRefCount(baseObj);
- if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj) != TCL_OK) {
+ if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK) {
Tcl_SetChannelError(rcPtr->chan, resObj);
goto invalid;
}
@@ -1639,8 +1575,6 @@ ReflectWatch(
ReflectedChannel *rcPtr = clientData;
Tcl_Obj *maskObj;
- /* ASSERT rcPtr->methods & FLAG(METH_WATCH) */
-
/*
* We restrict the interest to what the channel can support. IOW there
* will never be write events for a channel which is not writable.
@@ -1683,7 +1617,7 @@ ReflectWatch(
maskObj = DecodeEventMask(mask);
/* assert maskObj.refCount == 1 */
- (void) InvokeTclMethod(rcPtr, "watch", maskObj, NULL, NULL);
+ (void) InvokeTclMethod(rcPtr, METH_WATCH, maskObj, NULL, NULL);
Tcl_DecrRefCount(maskObj);
Tcl_Release(rcPtr);
@@ -1742,7 +1676,7 @@ ReflectBlock(
Tcl_Preserve(rcPtr);
- if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL, &resObj)!=TCL_OK) {
+ if (InvokeTclMethod(rcPtr,METH_BLOCKING,blockObj,NULL,&resObj)!=TCL_OK) {
Tcl_SetChannelError(rcPtr->chan, resObj);
errorNum = EINVAL;
} else {
@@ -1854,7 +1788,7 @@ ReflectSetOption(
Tcl_IncrRefCount(optionObj);
Tcl_IncrRefCount(valueObj);
- result = InvokeTclMethod(rcPtr, "configure",optionObj,valueObj, &resObj);
+ result = InvokeTclMethod(rcPtr, METH_CONFIGURE,optionObj,valueObj, &resObj);
if (result != TCL_OK) {
UnmarshallErrorResult(interp, resObj);
}
@@ -1899,7 +1833,7 @@ ReflectGetOption(
Tcl_Obj *resObj; /* Result data for 'configure' */
int listc, result = TCL_OK;
Tcl_Obj **listv;
- const char *method;
+ MethodName method;
/*
* Are we in the correct thread?
@@ -1938,14 +1872,14 @@ ReflectGetOption(
* Retrieve all options.
*/
- method = "cgetall";
+ method = METH_CGETALL;
optionObj = NULL;
} else {
/*
* Retrieve the value of one option.
*/
- method = "cget";
+ method = METH_CGET;
optionObj = Tcl_NewStringObj(optionName, -1);
Tcl_IncrRefCount(optionObj);
}
@@ -2159,16 +2093,13 @@ NewReflectedChannel(
Tcl_Obj *handleObj)
{
ReflectedChannel *rcPtr;
- int i, listc;
- Tcl_Obj **listv;
+ MethodName mn = METH_BLOCKING;
rcPtr = ckalloc(sizeof(ReflectedChannel));
/* rcPtr->chan: Assigned by caller. Dummy data here. */
- /* rcPtr->methods: Assigned by caller. Dummy data here. */
rcPtr->chan = NULL;
- rcPtr->methods = 0;
rcPtr->interp = interp;
rcPtr->dead = 0;
#ifdef TCL_THREADS
@@ -2177,54 +2108,17 @@ NewReflectedChannel(
rcPtr->mode = mode;
rcPtr->interest = 0; /* Initially no interest registered */
- /*
- * Method placeholder.
- */
-
/* ASSERT: cmdpfxObj is a Tcl List */
-
- Tcl_ListObjGetElements(interp, cmdpfxObj, &listc, &listv);
-
- /*
- * See [==] as well.
- * Storage for the command prefix and the additional words required for
- * the invocation of methods in the command handler.
- *
- * listv [0] [listc-1] | [listc] [listc+1] |
- * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2]
- * cmd ... pfx | method chan | detail1 detail2
- */
-
- rcPtr->argc = listc + 2;
- rcPtr->argv = ckalloc(sizeof(Tcl_Obj *) * (listc+4));
-
- /*
- * Duplicate object references.
- */
-
- for (i=0; i<listc ; i++) {
- Tcl_Obj *word = rcPtr->argv[i] = listv[i];
-
- Tcl_IncrRefCount(word);
- }
-
- i++; /* Skip placeholder for method */
-
- /*
- * [Bug 1667990]: See [x] in FreeReflectedChannel for release
- */
-
- rcPtr->argv[i] = handleObj;
- Tcl_IncrRefCount(handleObj);
-
- /*
- * The next two objects are kept empty, varying arguments.
- */
-
- /*
- * Initialization complete.
- */
-
+ rcPtr->cmd = TclListObjCopy(NULL, cmdpfxObj);
+ Tcl_IncrRefCount(rcPtr->cmd);
+ rcPtr->methods = Tcl_NewListObj(METH_WRITE + 1, NULL);
+ while (mn <= METH_WRITE) {
+ Tcl_ListObjAppendElement(NULL, rcPtr->methods,
+ Tcl_NewStringObj(methodNames[mn++], -1));
+ }
+ Tcl_IncrRefCount(rcPtr->methods);
+ rcPtr->name = handleObj;
+ Tcl_IncrRefCount(rcPtr->name);
return rcPtr;
}
@@ -2271,28 +2165,6 @@ NextHandle(void)
}
static void
-FreeReflectedChannelArgs(
- ReflectedChannel *rcPtr)
-{
- int i, n = rcPtr->argc - 2;
-
- if (n < 0) {
- return;
- }
- for (i=0; i<n; i++) {
- Tcl_DecrRefCount(rcPtr->argv[i]);
- }
-
- /*
- * [Bug 1667990]: See [x] in NewReflectedChannel for lock. n+1 = argc-1.
- */
-
- Tcl_DecrRefCount(rcPtr->argv[n+1]);
-
- rcPtr->argc = 1;
-}
-
-static void
FreeReflectedChannel(
ReflectedChannel *rcPtr)
{
@@ -2306,10 +2178,10 @@ FreeReflectedChannel(
ckfree(chanPtr->typePtr);
chanPtr->typePtr = NULL;
}
-
- FreeReflectedChannelArgs(rcPtr);
-
- ckfree(rcPtr->argv);
+ Tcl_Release(chanPtr);
+ Tcl_DecrRefCount(rcPtr->name);
+ Tcl_DecrRefCount(rcPtr->methods);
+ Tcl_DecrRefCount(rcPtr->cmd);
ckfree(rcPtr);
}
@@ -2340,16 +2212,16 @@ FreeReflectedChannel(
static int
InvokeTclMethod(
ReflectedChannel *rcPtr,
- const char *method,
+ MethodName method,
Tcl_Obj *argOneObj, /* NULL'able */
Tcl_Obj *argTwoObj, /* NULL'able */
Tcl_Obj **resultObjPtr) /* NULL'able */
{
- int cmdc; /* #words in constructed command */
Tcl_Obj *methObj = NULL; /* Method name in object form */
Tcl_InterpState sr; /* State of handler interp */
int result; /* Result code of method invokation */
Tcl_Obj *resObj = NULL; /* Result of method invokation. */
+ Tcl_Obj *cmd;
if (rcPtr->dead) {
/*
@@ -2372,19 +2244,15 @@ InvokeTclMethod(
}
/*
- * NOTE (5): Decide impl. issue: Cache objects with method names? Needs
- * TSD data as reflections can be created in many different threads.
- * NO: Caching of command resolutions means storage per channel.
- */
-
- /*
- * Insert method into the pre-allocated area, after the command prefix,
+ * Insert method into the callback command, after the command prefix,
* before the channel id.
*/
- methObj = Tcl_NewStringObj(method, -1);
- Tcl_IncrRefCount(methObj);
- rcPtr->argv[rcPtr->argc - 2] = methObj;
+ cmd = TclListObjCopy(NULL, rcPtr->cmd);
+
+ Tcl_ListObjIndex(NULL, rcPtr->methods, method, &methObj);
+ Tcl_ListObjAppendElement(NULL, cmd, methObj);
+ Tcl_ListObjAppendElement(NULL, cmd, rcPtr->name);
/*
* Append the additional argument containing method specific details
@@ -2394,13 +2262,10 @@ InvokeTclMethod(
* The objects will survive the Tcl_EvalObjv without change.
*/
- cmdc = rcPtr->argc;
if (argOneObj) {
- rcPtr->argv[cmdc] = argOneObj;
- cmdc++;
+ Tcl_ListObjAppendElement(NULL, cmd, argOneObj);
if (argTwoObj) {
- rcPtr->argv[cmdc] = argTwoObj;
- cmdc++;
+ Tcl_ListObjAppendElement(NULL, cmd, argTwoObj);
}
}
@@ -2409,9 +2274,10 @@ InvokeTclMethod(
* existing state intact.
*/
+ Tcl_IncrRefCount(cmd);
sr = Tcl_SaveInterpState(rcPtr->interp, 0 /* Dummy */);
Tcl_Preserve(rcPtr->interp);
- result = Tcl_EvalObjv(rcPtr->interp, cmdc, rcPtr->argv, TCL_EVAL_GLOBAL);
+ result = Tcl_EvalObjEx(rcPtr->interp, cmd, TCL_EVAL_GLOBAL);
/*
* We do not try to extract the result information if the caller has no
@@ -2437,7 +2303,6 @@ InvokeTclMethod(
*/
if (result != TCL_ERROR) {
- Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rcPtr->argv);
int cmdLen;
const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen);
@@ -2451,25 +2316,17 @@ InvokeTclMethod(
result = TCL_ERROR;
}
Tcl_AppendObjToErrorInfo(rcPtr->interp, Tcl_ObjPrintf(
- "\n (chan handler subcommand \"%s\")", method));
+ "\n (chan handler subcommand \"%s\")",
+ methodNames[method]));
resObj = MarshallError(rcPtr->interp);
}
Tcl_IncrRefCount(resObj);
}
+ Tcl_DecrRefCount(cmd);
Tcl_RestoreInterpState(rcPtr->interp, sr);
Tcl_Release(rcPtr->interp);
/*
- * Cleanup of the dynamic parts of the command.
- *
- * The detail objects survived the Tcl_EvalObjv without change because of
- * the contract. Therefore there is no need to decrement the refcounts. Only
- * the internal method object has to be disposed of.
- */
-
- Tcl_DecrRefCount(methObj);
-
- /*
* The resObj has a ref count of 1 at this location. This means that the
* caller of InvokeTclMethod has to dispose of it (but only if it was
* returned to it).
@@ -2700,7 +2557,6 @@ DeleteReflectedChannelMap(
}
rcPtr->dead = 1;
- FreeReflectedChannelArgs(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
#endif
@@ -2840,7 +2696,6 @@ DeleteThreadReflectedChannelMap(
ReflectedChannel *rcPtr = Tcl_GetChannelInstanceData(chan);
rcPtr->dead = 1;
- FreeReflectedChannelArgs(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
ckfree(rcmPtr);
@@ -3023,12 +2878,12 @@ ForwardProc(
* No parameters/results.
*/
- if (InvokeTclMethod(rcPtr, "finalize", NULL, NULL, &resObj)!=TCL_OK) {
+ if (InvokeTclMethod(rcPtr, METH_FINAL, NULL, NULL, &resObj)!=TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
}
/*
- * Freeing is done here, in the origin thread, because the argv[]
+ * Freeing is done here, in the origin thread, callback command
* objects belong to this thread. Deallocating them in a different
* thread is not allowed
*
@@ -3047,7 +2902,7 @@ ForwardProc(
Tcl_GetChannelName(rcPtr->chan));
Tcl_DeleteHashEntry(hPtr);
- FreeReflectedChannelArgs(rcPtr);
+ Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
break;
case ForwardedInput: {
@@ -3055,7 +2910,7 @@ ForwardProc(
Tcl_IncrRefCount(toReadObj);
Tcl_Preserve(rcPtr);
- if (InvokeTclMethod(rcPtr, "read", toReadObj, NULL, &resObj)!=TCL_OK){
+ if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK){
int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
@@ -3095,7 +2950,7 @@ ForwardProc(
Tcl_IncrRefCount(bufObj);
Tcl_Preserve(rcPtr);
- if (InvokeTclMethod(rcPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
+ if (InvokeTclMethod(rcPtr, METH_WRITE, bufObj, NULL, &resObj) != TCL_OK) {
int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
@@ -3138,7 +2993,7 @@ ForwardProc(
Tcl_IncrRefCount(baseObj);
Tcl_Preserve(rcPtr);
- if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj)!=TCL_OK){
+ if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK){
ForwardSetObjError(paramPtr, resObj);
paramPtr->seek.offset = -1;
} else {
@@ -3174,7 +3029,7 @@ ForwardProc(
/* assert maskObj.refCount == 1 */
Tcl_Preserve(rcPtr);
- (void) InvokeTclMethod(rcPtr, "watch", maskObj, NULL, NULL);
+ (void) InvokeTclMethod(rcPtr, METH_WATCH, maskObj, NULL, NULL);
Tcl_DecrRefCount(maskObj);
Tcl_Release(rcPtr);
break;
@@ -3185,7 +3040,7 @@ ForwardProc(
Tcl_IncrRefCount(blockObj);
Tcl_Preserve(rcPtr);
- if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL,
+ if (InvokeTclMethod(rcPtr, METH_BLOCKING, blockObj, NULL,
&resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
}
@@ -3201,7 +3056,7 @@ ForwardProc(
Tcl_IncrRefCount(optionObj);
Tcl_IncrRefCount(valueObj);
Tcl_Preserve(rcPtr);
- if (InvokeTclMethod(rcPtr, "configure", optionObj, valueObj,
+ if (InvokeTclMethod(rcPtr, METH_CONFIGURE, optionObj, valueObj,
&resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
}
@@ -3220,7 +3075,7 @@ ForwardProc(
Tcl_IncrRefCount(optionObj);
Tcl_Preserve(rcPtr);
- if (InvokeTclMethod(rcPtr, "cget", optionObj, NULL, &resObj)!=TCL_OK){
+ if (InvokeTclMethod(rcPtr, METH_CGET, optionObj, NULL, &resObj)!=TCL_OK){
ForwardSetObjError(paramPtr, resObj);
} else {
TclDStringAppendObj(paramPtr->getOpt.value, resObj);
@@ -3236,7 +3091,7 @@ ForwardProc(
*/
Tcl_Preserve(rcPtr);
- if (InvokeTclMethod(rcPtr, "cgetall", NULL, NULL, &resObj) != TCL_OK){
+ if (InvokeTclMethod(rcPtr, METH_CGETALL, NULL, NULL, &resObj) != TCL_OK){
ForwardSetObjError(paramPtr, resObj);
} else {
/*
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 6259216..f624cb7 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -19,7 +19,7 @@
*/
#include "tclInt.h"
-#ifdef __WIN32__
+#ifdef _WIN32
# include "tclWinInt.h"
#endif
#include "tclFileSystem.h"
@@ -792,7 +792,7 @@ TclFinalizeFilesystem(void)
* filesystem is likely to fail.
*/
-#ifdef __WIN32__
+#ifdef _WIN32
TclWinEncodingsCleanup();
#endif
}
@@ -819,7 +819,7 @@ TclResetFilesystem(void)
filesystemList = &nativeFilesystemRecord;
theFilesystemEpoch++;
-#ifdef __WIN32__
+#ifdef _WIN32
/*
* Cleans up the win32 API filesystem proc lookup table. This must happen
* very late in finalization so that deleting of copied dlls can occur.
@@ -3255,7 +3255,7 @@ Tcl_LoadFile(
return TCL_ERROR;
}
-#ifndef __WIN32__
+#ifndef _WIN32
/*
* Do we need to set appropriate permissions on the file? This may be
* required on some systems. On Unix we could loop over the file
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 94ee836..7b1f5bf 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -1686,6 +1686,7 @@ typedef struct Command {
#define CMD_TRACE_ACTIVE 0x2
#define CMD_HAS_EXEC_TRACES 0x4
#define CMD_COMPILES_EXPANDED 0x8
+#define CMD_REDEF_IN_PROGRESS 0x10
/*
*----------------------------------------------------------------
@@ -2639,6 +2640,8 @@ MODULE_SCOPE char *tclMemDumpFileName;
MODULE_SCOPE TclPlatformType tclPlatform;
MODULE_SCOPE Tcl_NotifierProcs tclNotifierHooks;
+MODULE_SCOPE Tcl_Encoding tclIdentityEncoding;
+
/*
* TIP #233 (Virtualized Time)
* Data for the time hooks, if any.
@@ -2893,6 +2896,7 @@ MODULE_SCOPE void TclFinalizeObjects(void);
MODULE_SCOPE void TclFinalizePreserve(void);
MODULE_SCOPE void TclFinalizeSynchronization(void);
MODULE_SCOPE void TclFinalizeThreadAlloc(void);
+MODULE_SCOPE void TclFinalizeThreadAllocThread(void);
MODULE_SCOPE void TclFinalizeThreadData(void);
MODULE_SCOPE void TclFinalizeThreadObjects(void);
MODULE_SCOPE double TclFloor(const mp_int *a);
@@ -3589,6 +3593,12 @@ MODULE_SCOPE int TclCompileNamespaceWhichCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileObjectNextCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileObjectNextToCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileObjectSelfCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3616,6 +3626,9 @@ MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileStringLastCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3682,6 +3695,9 @@ MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileYieldToCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileBasic0ArgCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index 72719fe..ac06787 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -13,7 +13,7 @@
#ifndef _TCLINTPLATDECLS
#define _TCLINTPLATDECLS
-#ifdef __WIN32__
+#ifdef _WIN32
# define Tcl_DirEntry void
# define DIR void
#endif
@@ -45,7 +45,7 @@ extern "C" {
* Exported function declarations:
*/
-#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
+#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
/* 0 */
EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
Tcl_Channel chan);
@@ -104,7 +104,7 @@ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
Tcl_Obj *resultingNameObj);
#endif /* UNIX */
-#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
+#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
/* 0 */
EXTERN void TclWinConvertError(DWORD errCode);
/* 1 */
@@ -258,7 +258,7 @@ typedef struct TclIntPlatStubs {
int magic;
void *hooks;
-#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
+#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
@@ -291,7 +291,7 @@ typedef struct TclIntPlatStubs {
int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* UNIX */
-#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
+#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
void (*tclWinConvertError) (DWORD errCode); /* 0 */
void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */
struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */
@@ -371,7 +371,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
* Inline function declarations:
*/
-#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
+#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
#define TclGetAndDetachPids \
(tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
#define TclpCloseFile \
@@ -420,7 +420,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
#define TclUnixOpenTemporaryFile \
(tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */
#endif /* UNIX */
-#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
+#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
#define TclWinConvertError \
(tclIntPlatStubsPtr->tclWinConvertError) /* 0 */
#define TclWinConvertWSAError \
@@ -550,9 +550,15 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
#undef TclpInetNtoa
#define TclpInetNtoa inet_ntoa
-#if defined(__WIN32__) || defined(__CYGWIN__)
+#if defined(_WIN32)
# undef TclWinNToHS
+# undef TclWinGetServByName
+# undef TclWinGetSockOpt
+# undef TclWinSetSockOpt
# define TclWinNToHS ntohs
+# define TclWinGetServByName getservbyname
+# define TclWinGetSockOpt getsockopt
+# define TclWinSetSockOpt setsockopt
#else
# undef TclpGetPid
# define TclpGetPid(pid) ((unsigned long) (pid))
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index 5cacab1..7c70e03 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -830,7 +830,7 @@ Tcl_UnloadObjCmd(
* Unload the shared library from the application memory...
*/
-#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__)
+#if defined(TCL_UNLOAD_DLLS) || defined(_WIN32)
/*
* Some Unix dlls are poorly behaved - registering things like atexit
* calls that can't be unregistered. If you unload such dlls, you get
@@ -1151,7 +1151,7 @@ TclFinalizeLoad(void)
pkgPtr = firstPackagePtr;
firstPackagePtr = pkgPtr->nextPtr;
-#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__)
+#if defined(TCL_UNLOAD_DLLS) || defined(_WIN32)
/*
* Some Unix dlls are poorly behaved - registering things like atexit
* calls that can't be unregistered. If you unload such dlls, you get
diff --git a/generic/tclMain.c b/generic/tclMain.c
index faea75a..360f5e9 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -47,7 +47,7 @@
* we have to translate that to strcmp here.
*/
-#ifndef __WIN32__
+#ifndef _WIN32
# define TCHAR char
# define TEXT(arg) arg
# define _tcscmp strcmp
diff --git a/generic/tclOO.c b/generic/tclOO.c