Check-in [8f0855701a]
Not logged in

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

Overview
Comment:merge trunk
Timelines: family | ancestors | descendants | both | dkf-improved-disassembler
Files: files | file ages | folders
SHA1: 8f0855701a5b81ea2bbcf32695d4727b34d26608
User & Date: kbk 2014-06-29 02:20:31.732
Context
2014-08-02
19:20
merge trunk check-in: 63ed148e71 user: kbk tags: dkf-improved-disassembler
2014-06-29
02:20
merge trunk check-in: 8f0855701a user: kbk tags: dkf-improved-disassembler
2014-06-26
16:01
Fix mismatch of Tcl_Preserve() / Tcl_Release(). check-in: 4626888b50 user: dgp tags: trunk
2014-02-08
07:54
merge trunk check-in: 470ba4edf6 user: dkf tags: dkf-improved-disassembler
Changes
Unified Diff Ignore Whitespace Patch
Changes to doc/StringObj.3.
289
290
291
292
293
294
295

296
297
298
299
300
301
302
\fBTcl_AppendFormatToObj\fR is an appending alternative form
of \fBTcl_Format\fR with functionality equivalent to:
.PP
.CS
Tcl_Obj *newPtr = \fBTcl_Format\fR(interp, format, objc, objv);
if (newPtr == NULL) return TCL_ERROR;
\fBTcl_AppendObjToObj\fR(objPtr, newPtr);

return TCL_OK;
.CE
.PP
but with greater convenience and efficiency when the appending
functionality is needed.
.PP
\fBTcl_ObjPrintf\fR serves as a replacement for the common sequence







>







289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
\fBTcl_AppendFormatToObj\fR is an appending alternative form
of \fBTcl_Format\fR with functionality equivalent to:
.PP
.CS
Tcl_Obj *newPtr = \fBTcl_Format\fR(interp, format, objc, objv);
if (newPtr == NULL) return TCL_ERROR;
\fBTcl_AppendObjToObj\fR(objPtr, newPtr);
\fBTcl_DecrRefCount\fR(newPtr);
return TCL_OK;
.CE
.PP
but with greater convenience and efficiency when the appending
functionality is needed.
.PP
\fBTcl_ObjPrintf\fR serves as a replacement for the common sequence
333
334
335
336
337
338
339

340

341
342
343
344
345
346
347
mismatches between the format and any subsequent arguments.
Compile-time protection may be provided by some compilers.
.PP
\fBTcl_AppendPrintfToObj\fR is an appending alternative form
of \fBTcl_ObjPrintf\fR with functionality equivalent to
.PP
.CS

\fBTcl_AppendObjToObj\fR(objPtr, \fBTcl_ObjPrintf\fR(format, ...));

.CE
.PP
but with greater convenience and efficiency when the appending
functionality is needed.
.PP
The \fBTcl_SetObjLength\fR procedure changes the length of the
string value of its \fIobjPtr\fR argument.  If the \fInewLength\fR







>
|
>







334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
mismatches between the format and any subsequent arguments.
Compile-time protection may be provided by some compilers.
.PP
\fBTcl_AppendPrintfToObj\fR is an appending alternative form
of \fBTcl_ObjPrintf\fR with functionality equivalent to
.PP
.CS
Tcl_Obj *newPtr = \fBTcl_ObjPrintf\fR(format, ...);
\fBTcl_AppendObjToObj\fR(objPtr, newPtr);
\fBTcl_DecrRefCount\fR(newPtr);
.CE
.PP
but with greater convenience and efficiency when the appending
functionality is needed.
.PP
The \fBTcl_SetObjLength\fR procedure changes the length of the
string value of its \fIobjPtr\fR argument.  If the \fInewLength\fR
Changes to doc/clock.n.
633
634
635
636
637
638
639
640

641
642
643
644
645
646
647
648
This format group is reserved for internal use within the Tcl library.
.TP
\fB%r\fR
On output, produces a locale-dependent time of day representation on a
12-hour clock. On input, accepts whatever \fB%r\fR produces.
.TP
\fB%R\fR
On output, produces a locale-dependent time of day representation on a

24-hour clock. On input, accepts whatever \fB%R\fR produces.
.TP
\fB%s\fR
On output, simply formats the \fItimeVal\fR argument as a decimal
integer and inserts it into the output string.  On input, accepts
a decimal integer and uses is as the time value without any further
processing. Since \fB%s\fR uniquely determines a point in time, it
overrides all other input formats.







|
>
|







633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
This format group is reserved for internal use within the Tcl library.
.TP
\fB%r\fR
On output, produces a locale-dependent time of day representation on a
12-hour clock. On input, accepts whatever \fB%r\fR produces.
.TP
\fB%R\fR
On output, the time in 24-hour notation (%H:%M). For a version
including the seconds, see \fB%T\fR below. On input, accepts whatever
\fB%R\fR produces.
.TP
\fB%s\fR
On output, simply formats the \fItimeVal\fR argument as a decimal
integer and inserts it into the output string.  On input, accepts
a decimal integer and uses is as the time value without any further
processing. Since \fB%s\fR uniquely determines a point in time, it
overrides all other input formats.
Changes to doc/dict.n.
21
22
23
24
25
26
27
28

29
30
31
32
33
34
35
36
37
38
39
\fIoption\fRs (which may be abbreviated) are:
.TP
\fBdict append \fIdictionaryVariable key \fR?\fIstring ...\fR?
.
This appends the given string (or strings) to the value that the given
key maps to in the dictionary value contained in the given variable,
writing the resulting dictionary value back to that variable.
Non-existent keys are treated as if they map to an empty string.

.TP
\fBdict create \fR?\fIkey value ...\fR?
.
Create a new dictionary that contains each of the key/value mappings
listed as arguments (keys and values alternating, with each key being
followed by its associated value.)
.TP
\fBdict exists \fIdictionaryValue key \fR?\fIkey ...\fR?
.
This returns a boolean value indicating whether the given key (or path
of keys through a set of nested dictionaries) exists in the given







|
>



|







21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
\fIoption\fRs (which may be abbreviated) are:
.TP
\fBdict append \fIdictionaryVariable key \fR?\fIstring ...\fR?
.
This appends the given string (or strings) to the value that the given
key maps to in the dictionary value contained in the given variable,
writing the resulting dictionary value back to that variable.
Non-existent keys are treated as if they map to an empty string. The
updated dictionary value is returned.
.TP
\fBdict create \fR?\fIkey value ...\fR?
.
Return a new dictionary that contains each of the key/value mappings
listed as arguments (keys and values alternating, with each key being
followed by its associated value.)
.TP
\fBdict exists \fIdictionaryValue key \fR?\fIkey ...\fR?
.
This returns a boolean value indicating whether the given key (or path
of keys through a set of nested dictionaries) exists in the given
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
.TP
\fBdict filter \fIdictionaryValue \fBkey\fR ?\fIglobPattern ...\fR?
.VS 8.6
The key rule only matches those key/value pairs whose keys match any
of the given patterns (in the style of \fBstring match\fR.)
.VE 8.6
.TP
\fBdict filter \fIdictionaryValue \fBscript {\fIkeyVar valueVar\fB} \fIscript\fR
.
The script rule tests for matching by assigning the key to the
\fIkeyVar\fR and the value to the \fIvalueVar\fR, and then evaluating
the given script which should return a boolean value (with the
key/value pair only being included in the result of the \fBdict
filter\fR when a true value is returned.)  Note that the first
argument after the rule selection word is a two-element list.  If the
\fIscript\fR returns with a condition of \fBTCL_BREAK\fR, no further
key/value pairs are considered for inclusion in the resulting
dictionary, and a condition of \fBTCL_CONTINUE\fR is equivalent to a false
result. The key/value pairs are tested in the order in which the keys
were inserted into the dictionary.
.TP
\fBdict filter \fIdictionaryValue \fBvalue \fR?\fIglobPattern ...\fR?
.VS 8.6
The value rule only matches those key/value pairs whose values match any
of the given patterns (in the style of \fBstring match\fR.)
.VE 8.6
.RE
.TP
\fBdict for {\fIkeyVar valueVar\fB} \fIdictionaryValue body\fR
.
This command takes three arguments, the first a two-element list of
variable names (for the key and value respectively of each mapping in
the dictionary), the second the dictionary value to iterate across,
and the third a script to be evaluated for each mapping with the key
and value variables set appropriately (in the manner of \fBforeach\fR.)
The result of the command is an empty string. If any evaluation of the







|


|

















|







50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
.TP
\fBdict filter \fIdictionaryValue \fBkey\fR ?\fIglobPattern ...\fR?
.VS 8.6
The key rule only matches those key/value pairs whose keys match any
of the given patterns (in the style of \fBstring match\fR.)
.VE 8.6
.TP
\fBdict filter \fIdictionaryValue \fBscript {\fIkeyVariable valueVariable\fB} \fIscript\fR
.
The script rule tests for matching by assigning the key to the
\fIkeyVariable\fR and the value to the \fIvalueVariable\fR, and then evaluating
the given script which should return a boolean value (with the
key/value pair only being included in the result of the \fBdict
filter\fR when a true value is returned.)  Note that the first
argument after the rule selection word is a two-element list.  If the
\fIscript\fR returns with a condition of \fBTCL_BREAK\fR, no further
key/value pairs are considered for inclusion in the resulting
dictionary, and a condition of \fBTCL_CONTINUE\fR is equivalent to a false
result. The key/value pairs are tested in the order in which the keys
were inserted into the dictionary.
.TP
\fBdict filter \fIdictionaryValue \fBvalue \fR?\fIglobPattern ...\fR?
.VS 8.6
The value rule only matches those key/value pairs whose values match any
of the given patterns (in the style of \fBstring match\fR.)
.VE 8.6
.RE
.TP
\fBdict for {\fIkeyVariable valueVariable\fB} \fIdictionaryValue body\fR
.
This command takes three arguments, the first a two-element list of
variable names (for the key and value respectively of each mapping in
the dictionary), the second the dictionary value to iterate across,
and the third a script to be evaluated for each mapping with the key
and value variables set appropriately (in the manner of \fBforeach\fR.)
The result of the command is an empty string. If any evaluation of the
117
118
119
120
121
122
123
124

125
126
127
128
129
130
131
\fBdict incr \fIdictionaryVariable key \fR?\fIincrement\fR?
.
This adds the given increment value (an integer that defaults to 1 if
not specified) to the value that the given key maps to in the
dictionary value contained in the given variable, writing the
resulting dictionary value back to that variable. Non-existent keys
are treated as if they map to 0. It is an error to increment a value
for an existing key if that value is not an integer.

.TP
\fBdict info \fIdictionaryValue\fR
.
This returns information (intended for display to people) about the
given dictionary though the format of this data is dependent on the
implementation of the dictionary. For dictionaries that are
implemented by hash tables, it is expected that this will return the







|
>







118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
\fBdict incr \fIdictionaryVariable key \fR?\fIincrement\fR?
.
This adds the given increment value (an integer that defaults to 1 if
not specified) to the value that the given key maps to in the
dictionary value contained in the given variable, writing the
resulting dictionary value back to that variable. Non-existent keys
are treated as if they map to 0. It is an error to increment a value
for an existing key if that value is not an integer. The updated
dictionary value is returned.
.TP
\fBdict info \fIdictionaryValue\fR
.
This returns information (intended for display to people) about the
given dictionary though the format of this data is dependent on the
implementation of the dictionary. For dictionaries that are
implemented by hash tables, it is expected that this will return the
141
142
143
144
145
146
147
148

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
\fBdict lappend \fIdictionaryVariable key \fR?\fIvalue ...\fR?
.
This appends the given items to the list value that the given key maps
to in the dictionary value contained in the given variable, writing
the resulting dictionary value back to that variable. Non-existent
keys are treated as if they map to an empty list, and it is legal for
there to be no items to append to the list. It is an error for the
value that the key maps to to not be representable as a list.

.TP
\fBdict map \fR{\fIkeyVar valueVar\fR} \fIdictionaryValue body\fR
.
This command applies a transformation to each element of a dictionary,
returning a new dictionary. It takes three arguments: the first is a
two-element list of variable names (for the key and value respectively of each
mapping in the dictionary), the second the dictionary value to iterate across,
and the third a script to be evaluated for each mapping with the key and value
variables set appropriately (in the manner of \fBlmap\fR). In an iteration
where the evaluated script completes normally (\fBTCL_OK\fR, as opposed to an
\fBerror\fR, etc.) the result of the script is put into an accumulator
dictionary using the key that is the current contents of the \fIkeyVar\fR
variable at that point. The result of the \fBdict map\fR command is the
accumulator dictionary after all keys have been iterated over.
.RS
.PP
If the evaluation of the body for any particular step generates a \fBbreak\fR,
no further pairs from the dictionary will be iterated over and the \fBdict
map\fR command will terminate successfully immediately. If the evaluation of







|
>

|









|







143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
\fBdict lappend \fIdictionaryVariable key \fR?\fIvalue ...\fR?
.
This appends the given items to the list value that the given key maps
to in the dictionary value contained in the given variable, writing
the resulting dictionary value back to that variable. Non-existent
keys are treated as if they map to an empty list, and it is legal for
there to be no items to append to the list. It is an error for the
value that the key maps to to not be representable as a list. The
updated dictionary value is returned.
.TP
\fBdict map \fR{\fIkeyVariable valueVariable\fR} \fIdictionaryValue body\fR
.
This command applies a transformation to each element of a dictionary,
returning a new dictionary. It takes three arguments: the first is a
two-element list of variable names (for the key and value respectively of each
mapping in the dictionary), the second the dictionary value to iterate across,
and the third a script to be evaluated for each mapping with the key and value
variables set appropriately (in the manner of \fBlmap\fR). In an iteration
where the evaluated script completes normally (\fBTCL_OK\fR, as opposed to an
\fBerror\fR, etc.) the result of the script is put into an accumulator
dictionary using the key that is the current contents of the \fIkeyVariable\fR
variable at that point. The result of the \fBdict map\fR command is the
accumulator dictionary after all keys have been iterated over.
.RS
.PP
If the evaluation of the body for any particular step generates a \fBbreak\fR,
no further pairs from the dictionary will be iterated over and the \fBdict
map\fR command will terminate successfully immediately. If the evaluation of
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219

220
221
222
223
224
225
226
.TP
\fBdict set \fIdictionaryVariable key \fR?\fIkey ...\fR? \fIvalue\fR
.
This operation takes the name of a variable containing a dictionary
value and places an updated dictionary value in that variable
containing a mapping from the given key to the given value. When
multiple keys are present, this operation creates or updates a chain
of nested dictionaries.
.TP
\fBdict size \fIdictionaryValue\fR
.
Return the number of key/value mappings in the given dictionary value.
.TP
\fBdict unset \fIdictionaryVariable key \fR?\fIkey ...\fR?
.
This operation (the companion to \fBdict set\fR) takes the name of a
variable containing a dictionary value and places an updated
dictionary value in that variable that does not contain a mapping for
the given key. Where multiple keys are present, this describes a path
through nested dictionaries to the mapping to remove. At least one key
must be specified, but the last key on the key-path need not exist.
All other components on the path must exist.

.TP
\fBdict update \fIdictionaryVariable key varName \fR?\fIkey varName ...\fR? \fIbody\fR
.
Execute the Tcl script in \fIbody\fR with the value for each \fIkey\fR
(as found by reading the dictionary value in \fIdictionaryVariable\fR)
mapped to the variable \fIvarName\fR. There may be multiple
\fIkey\fR/\fIvarName\fR pairs. If a \fIkey\fR does not have a mapping,







|













|
>







201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
.TP
\fBdict set \fIdictionaryVariable key \fR?\fIkey ...\fR? \fIvalue\fR
.
This operation takes the name of a variable containing a dictionary
value and places an updated dictionary value in that variable
containing a mapping from the given key to the given value. When
multiple keys are present, this operation creates or updates a chain
of nested dictionaries. The updated dictionary value is returned.
.TP
\fBdict size \fIdictionaryValue\fR
.
Return the number of key/value mappings in the given dictionary value.
.TP
\fBdict unset \fIdictionaryVariable key \fR?\fIkey ...\fR?
.
This operation (the companion to \fBdict set\fR) takes the name of a
variable containing a dictionary value and places an updated
dictionary value in that variable that does not contain a mapping for
the given key. Where multiple keys are present, this describes a path
through nested dictionaries to the mapping to remove. At least one key
must be specified, but the last key on the key-path need not exist.
All other components on the path must exist. The updated dictionary
value is returned.
.TP
\fBdict update \fIdictionaryVariable key varName \fR?\fIkey varName ...\fR? \fIbody\fR
.
Execute the Tcl script in \fIbody\fR with the value for each \fIkey\fR
(as found by reading the dictionary value in \fIdictionaryVariable\fR)
mapped to the variable \fIvarName\fR. There may be multiple
\fIkey\fR/\fIvarName\fR pairs. If a \fIkey\fR does not have a mapping,
Changes to doc/encoding.n.
10
11
12
13
14
15
16
17










18
19
20

21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39

40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58





59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95



.SH NAME
encoding \- Manipulate encodings
.SH SYNOPSIS
\fBencoding \fIoption\fR ?\fIarg arg ...\fR?
.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.

.SH DESCRIPTION
.PP
Performs one of several encoding related operations, depending on
\fIoption\fR.  The legal \fIoption\fRs are:
.TP
\fBencoding convertfrom\fR ?\fIencoding\fR? \fIdata\fR
.
Convert \fIdata\fR to Unicode from the specified \fIencoding\fR.  The
characters in \fIdata\fR are treated as binary data where the lower
8-bits of each character is taken as a single byte.  The resulting
sequence of bytes is treated as a string in the specified
\fIencoding\fR.  If \fIencoding\fR is not specified, the current
system encoding is used.
.TP
\fBencoding convertto\fR ?\fIencoding\fR? \fIstring\fR
.
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.
.TP
\fBencoding dirs\fR ?\fIdirectoryList\fR?
.
Tcl can load encoding data files from the file system that describe
additional encodings for it to work with. This command sets the search
path for \fB*.enc\fR encoding data files to the list of directories
\fIdirectoryList\fR. If \fIdirectoryList\fR is omitted then the
command returns the current list of directories that make up the
search path. It is an error for \fIdirectoryList\fR to not be a valid
list. If, when a search for an encoding data file is happening, an
element in \fIdirectoryList\fR does not refer to a readable,
searchable directory, that element is ignored.
.TP
\fBencoding names\fR
.
Returns a list containing the names of all of the encodings that are
currently available. 





.TP
\fBencoding system\fR ?\fIencoding\fR?
.
Set the system encoding to \fIencoding\fR. If \fIencoding\fR is
omitted then the command returns the current system encoding.  The
system encoding is used whenever Tcl passes strings to system calls.
.SH EXAMPLE
.PP
It is common practice to write script files using a text editor that
produces output in the euc-jp encoding, which represents the ASCII
characters as singe bytes and Japanese characters as two bytes.  This
makes it easy to embed literal strings that correspond to non-ASCII
characters by simply typing the strings in place in the script.
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
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
contain a sequence of Latin-1 characters that correspond to the bytes
of the original string.  The \fBencoding\fR command can be used to
convert this string to the expected Japanese Unicode characters.  For
example,
.PP
.CS
set s [\fBencoding convertfrom\fR euc-jp "\exA4\exCF"]
.CE
.PP
would return the Unicode string
.QW "\eu306F" ,
which is the Hiragana letter HA.
.SH "SEE ALSO"
Tcl_GetEncoding(3)
.SH KEYWORDS
encoding, unicode










|
>
>
>
>
>
>
>
>
>
>
|
|
|
>



















>
|
|

















>
>
>
>
>

















|



















>
>
>
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
.SH NAME
encoding \- Manipulate encodings
.SH SYNOPSIS
\fBencoding \fIoption\fR ?\fIarg arg ...\fR?
.BE
.SH INTRODUCTION
.PP
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
\fIoption\fR.  The legal \fIoption\fRs are:
.TP
\fBencoding convertfrom\fR ?\fIencoding\fR? \fIdata\fR
.
Convert \fIdata\fR to Unicode from the specified \fIencoding\fR.  The
characters in \fIdata\fR are treated as binary data where the lower
8-bits of each character is taken as a single byte.  The resulting
sequence of bytes is treated as a string in the specified
\fIencoding\fR.  If \fIencoding\fR is not specified, the current
system encoding is used.
.TP
\fBencoding convertto\fR ?\fIencoding\fR? \fIstring\fR
.
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 (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?
.
Tcl can load encoding data files from the file system that describe
additional encodings for it to work with. This command sets the search
path for \fB*.enc\fR encoding data files to the list of directories
\fIdirectoryList\fR. If \fIdirectoryList\fR is omitted then the
command returns the current list of directories that make up the
search path. It is an error for \fIdirectoryList\fR to not be a valid
list. If, when a search for an encoding data file is happening, an
element in \fIdirectoryList\fR does not refer to a readable,
searchable directory, that element is ignored.
.TP
\fBencoding names\fR
.
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?
.
Set the system encoding to \fIencoding\fR. If \fIencoding\fR is
omitted then the command returns the current system encoding.  The
system encoding is used whenever Tcl passes strings to system calls.
.SH EXAMPLE
.PP
It is common practice to write script files using a text editor that
produces output in the euc-jp encoding, which represents the ASCII
characters as singe bytes and Japanese characters as two bytes.  This
makes it easy to embed literal strings that correspond to non-ASCII
characters by simply typing the strings in place in the script.
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
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
contain a sequence of Latin-1 characters that correspond to the bytes
of the original string.  The \fBencoding\fR command can be used to
convert this string to the expected Japanese Unicode characters.  For
example,
.PP
.CS
set s [\fBencoding convertfrom\fR euc-jp "\exA4\exCF"]
.CE
.PP
would return the Unicode string
.QW "\eu306F" ,
which is the Hiragana letter HA.
.SH "SEE ALSO"
Tcl_GetEncoding(3)
.SH KEYWORDS
encoding, unicode
.\" Local Variables:
.\" mode: nroff
.\" End:
Changes to doc/fcopy.n.
42
43
44
45
46
47
48
49
50



51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
error string associated with the error.
With a background copy,
it is not necessary to put \fIinchan\fR or \fIoutchan\fR into
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.



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.
If \fIinchan\fR is closed,
then all data already queued for \fIoutchan\fR is written out.
.PP
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
.QW "channel busy"
error.
.PP
\fBFcopy\fR translates end-of-line sequences in \fIinchan\fR and \fIoutchan\fR
according to the \fB\-translation\fR option
for these channels.
See the manual entry for \fBfconfigure\fR for details on the







|
|
>
>
>









|







42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
error string associated with the error.
With a background copy,
it is not necessary to put \fIinchan\fR or \fIoutchan\fR into
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 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.
If \fIinchan\fR is closed,
then all data already queued for \fIoutchan\fR is written out.
.PP
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 wrong-sided I/O attempted (by a \fBfileevent\fR handler or otherwise) will get a
.QW "channel busy"
error.
.PP
\fBFcopy\fR translates end-of-line sequences in \fIinchan\fR and \fIoutchan\fR
according to the \fB\-translation\fR option
for these channels.
See the manual entry for \fBfconfigure\fR for details on the
145
146
147
148
149
150
151


















152
153
154
155
set out [socket $server $port]
set chunk 1024
set total 0
\fBfcopy\fR $in $out -size $chunk \e
        -command [list CopyMore $in $out $chunk]
vwait done
.CE


















.SH "SEE ALSO"
eof(n), fblocked(n), fconfigure(n), file(n)
.SH KEYWORDS
blocking, channel, end of line, end of file, nonblocking, read, translation







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
set out [socket $server $port]
set chunk 1024
set total 0
\fBfcopy\fR $in $out -size $chunk \e
        -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
blocking, channel, end of line, end of file, nonblocking, read, translation
Changes to doc/string.n.
339
340
341
342
343
344
345
346



347
348
349
350
351
352
353
354
355













356
357
358
359
360




361
362
363
364
365
366
367
These subcommands are currently supported, but are likely to go away in a
future release as their functionality is either virtually never used or highly
misleading.
.TP
\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.
.RS
.PP
In almost all cases, you should use the
\fBstring length\fR operation (including determining the length of a
Tcl byte array value).  Refer to the \fBTcl_NumUtfChars\fR manual
entry for more details on the UTF\-8 representation.













.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.




.RE
.TP
\fBstring wordend \fIstring charIndex\fR
.
Returns the index of the character just after the last one in the word
containing character \fIcharIndex\fR of \fIstring\fR.  \fIcharIndex\fR
may be specified using the forms in \fBSTRING INDICES\fR.  A word is







|
>
>
>
|
|
|






>
>
>
>
>
>
>
>
>
>
>
>
>





>
>
>
>







339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
These subcommands are currently supported, but are likely to go away in a
future release as their functionality is either virtually never used or highly
misleading.
.TP
\fBstring bytelength \fIstring\fR
.
Returns a decimal string giving the number of bytes used to represent
\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
\fBstring length\fR operation (including determining the length of a
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
.
Returns the index of the character just after the last one in the word
containing character \fIcharIndex\fR of \fIstring\fR.  \fIcharIndex\fR
may be specified using the forms in \fBSTRING INDICES\fR.  A word is
Changes to doc/tclvars.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
.TH tclvars n 8.0 Tcl "Tcl Built-In Commands"
.so man.macros
.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
.BE
.SH DESCRIPTION
.PP
The following global variables are created and managed automatically
by the Tcl library.  Except where noted below, these variables should
normally be treated as read-only by application-specific code and by users.
.TP












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
.TH tclvars n 8.0 Tcl "Tcl Built-In Commands"
.so man.macros
.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_traceExec, tcl_wordchars, tcl_version \- Variables used by Tcl
.BE
.SH DESCRIPTION
.PP
The following global variables are created and managed automatically
by the Tcl library.  Except where noted below, these variables should
normally be treated as read-only by application-specific code and by users.
.TP
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
If this variable exists, then the interpreter
was compiled with threads enabled.
.TP
\fBuser\fR
.
This identifies the
current user based on the login information available on the platform.
This comes from the USER or LOGNAME environment variable on Unix,
and the value from GetUserName on Windows.
.TP
\fBwordSize\fR
.
This gives the size of the native-machine word in bytes (strictly, it
is same as the result of evaluating \fIsizeof(long)\fR in C.)
.RE
.TP







|
|







343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
If this variable exists, then the interpreter
was compiled with threads enabled.
.TP
\fBuser\fR
.
This identifies the
current user based on the login information available on the platform.
This value comes from the getuid() and getpwuid() system calls on Unix,
and the value from the GetUserName() system call on Windows.
.TP
\fBwordSize\fR
.
This gives the size of the native-machine word in bytes (strictly, it
is same as the result of evaluating \fIsizeof(long)\fR in C.)
.RE
.TP
Changes to generic/tcl.h.
63
64
65
66
67
68
69

70
71
72

73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97

/*
 *----------------------------------------------------------------------------
 * The following definitions set up the proper options for Windows compilers.
 * 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__))
#	define __WIN32__

#	ifndef WIN32
#	    define WIN32
#	endif
#	ifndef _WIN32
#	    define _WIN32
#	endif
#   endif
#endif

/*
 * STRICT: See MSDN Article Q83456
 */

#ifdef __WIN32__
#   ifndef STRICT
#	define STRICT
#   endif
#endif /* __WIN32__ */

/*
 * Utility macros: STRINGIFY takes an argument and wraps it in "" (double
 * quotation marks), JOIN joins two arguments.
 */

#ifndef STRINGIFY







>
|
<

>
|
|
<
<
<
<







|



|







63
64
65
66
67
68
69
70
71

72
73
74
75




76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94

/*
 *----------------------------------------------------------------------------
 * The following definitions set up the proper options for Windows compilers.
 * We use this method because there is no autoconf equivalent.
 */

#ifdef _WIN32
#   ifndef __WIN32__

#	define __WIN32__
#   endif
#   ifndef WIN32
#	define WIN32




#   endif
#endif

/*
 * STRICT: See MSDN Article Q83456
 */

#ifdef _WIN32
#   ifndef STRICT
#	define STRICT
#   endif
#endif /* _WIN32 */

/*
 * Utility macros: STRINGIFY takes an argument and wraps it in "" (double
 * quotation marks), JOIN joins two arguments.
 */

#ifndef STRINGIFY
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
 *
 * Note: when building static but linking dynamically to MSVCRT we must still
 *       correctly decorate the C library imported function.  Use CRTIMPORT
 *       for this purpose.  _DLL is defined by the compiler when linking to
 *       MSVCRT.
 */

#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
#       define DLLEXPORT
#       ifdef _DLL
#           define CRTIMPORT __declspec(dllimport)
#       else







|







184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
 *
 * Note: when building static but linking dynamically to MSVCRT we must still
 *       correctly decorate the C library imported function.  Use CRTIMPORT
 *       for this purpose.  _DLL is defined by the compiler when linking to
 *       MSVCRT.
 */

#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
#       define DLLEXPORT
#       ifdef _DLL
#           define CRTIMPORT __declspec(dllimport)
#       else
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
/*
 *----------------------------------------------------------------------------
 * The following code is copied from winnt.h. If we don't replicate it here,
 * then <windows.h> can't be included after tcl.h, since tcl.h also defines
 * VOID. This block is skipped under Cygwin and Mingw.
 */

#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 */

/*
 * Macro to use instead of "void" for arguments that must have type "void *"
 * in ANSI C; maps them to type "char *" in non-ANSI systems.
 */

#ifndef __VXWORKS__







|






|







308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
/*
 *----------------------------------------------------------------------------
 * The following code is copied from winnt.h. If we don't replicate it here,
 * then <windows.h> can't be included after tcl.h, since tcl.h also defines
 * VOID. This block is skipped under Cygwin and Mingw.
 */

#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 */

/*
 * Macro to use instead of "void" for arguments that must have type "void *"
 * in ANSI C; maps them to type "char *" in non-ANSI systems.
 */

#ifndef __VXWORKS__
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
 *
 * Note on converting between Tcl_WideInt and strings. This implementation (in
 * tclObj.c) depends on the function
 * sprintf(...,"%" TCL_LL_MODIFIER "d",...).
 */

#if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG)
#   if defined(__WIN32__)
#      define TCL_WIDE_INT_TYPE __int64
#      ifdef __BORLANDC__
#         define TCL_LL_MODIFIER	"L"
#      else /* __BORLANDC__ */
#         define TCL_LL_MODIFIER	"I64"
#      endif /* __BORLANDC__ */
#   elif defined(__GNUC__)
#      define TCL_WIDE_INT_TYPE long long
#      define TCL_LL_MODIFIER	"ll"
#   else /* ! __WIN32__ && ! __GNUC__ */
/*
 * Don't know what platform it is and configure hasn't discovered what is
 * going on for us. Try to guess...
 */
#      ifdef NO_LIMITS_H
#	  error please define either TCL_WIDE_INT_TYPE or TCL_WIDE_INT_IS_LONG
#      else /* !NO_LIMITS_H */
#	  include <limits.h>
#	  if (INT_MAX < LONG_MAX)
#	     define TCL_WIDE_INT_IS_LONG	1
#	  else
#	     define TCL_WIDE_INT_TYPE long long
#         endif
#      endif /* NO_LIMITS_H */
#   endif /* __WIN32__ */
#endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */
#ifdef TCL_WIDE_INT_IS_LONG
#   undef TCL_WIDE_INT_TYPE
#   define TCL_WIDE_INT_TYPE	long
#endif /* TCL_WIDE_INT_IS_LONG */

typedef TCL_WIDE_INT_TYPE		Tcl_WideInt;







|









|














|







383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
 *
 * Note on converting between Tcl_WideInt and strings. This implementation (in
 * tclObj.c) depends on the function
 * sprintf(...,"%" TCL_LL_MODIFIER "d",...).
 */

#if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG)
#   if defined(_WIN32)
#      define TCL_WIDE_INT_TYPE __int64
#      ifdef __BORLANDC__
#         define TCL_LL_MODIFIER	"L"
#      else /* __BORLANDC__ */
#         define TCL_LL_MODIFIER	"I64"
#      endif /* __BORLANDC__ */
#   elif defined(__GNUC__)
#      define TCL_WIDE_INT_TYPE long long
#      define TCL_LL_MODIFIER	"ll"
#   else /* ! _WIN32 && ! __GNUC__ */
/*
 * Don't know what platform it is and configure hasn't discovered what is
 * going on for us. Try to guess...
 */
#      ifdef NO_LIMITS_H
#	  error please define either TCL_WIDE_INT_TYPE or TCL_WIDE_INT_IS_LONG
#      else /* !NO_LIMITS_H */
#	  include <limits.h>
#	  if (INT_MAX < LONG_MAX)
#	     define TCL_WIDE_INT_IS_LONG	1
#	  else
#	     define TCL_WIDE_INT_TYPE long long
#         endif
#      endif /* NO_LIMITS_H */
#   endif /* _WIN32 */
#endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */
#ifdef TCL_WIDE_INT_IS_LONG
#   undef TCL_WIDE_INT_TYPE
#   define TCL_WIDE_INT_TYPE	long
#endif /* TCL_WIDE_INT_IS_LONG */

typedef TCL_WIDE_INT_TYPE		Tcl_WideInt;
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
#   endif /* !TCL_LL_MODIFIER */
#   define Tcl_WideAsLong(val)		((long)((Tcl_WideInt)(val)))
#   define Tcl_LongAsWide(val)		((Tcl_WideInt)((long)(val)))
#   define Tcl_WideAsDouble(val)	((double)((Tcl_WideInt)(val)))
#   define Tcl_DoubleAsWide(val)	((Tcl_WideInt)((double)(val)))
#endif /* TCL_WIDE_INT_IS_LONG */

#if defined(__WIN32__)
#   ifdef __BORLANDC__
	typedef struct stati64 Tcl_StatBuf;
#   elif defined(_WIN64)
	typedef struct __stat64 Tcl_StatBuf;
#   elif (defined(_MSC_VER) && (_MSC_VER < 1400)) || defined(_USE_32BIT_TIME_T)
	typedef struct _stati64	Tcl_StatBuf;
#   else







|







440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
#   endif /* !TCL_LL_MODIFIER */
#   define Tcl_WideAsLong(val)		((long)((Tcl_WideInt)(val)))
#   define Tcl_LongAsWide(val)		((Tcl_WideInt)((long)(val)))
#   define Tcl_WideAsDouble(val)	((double)((Tcl_WideInt)(val)))
#   define Tcl_DoubleAsWide(val)	((Tcl_WideInt)((double)(val)))
#endif /* TCL_WIDE_INT_IS_LONG */

#if defined(_WIN32)
#   ifdef __BORLANDC__
	typedef struct stati64 Tcl_StatBuf;
#   elif defined(_WIN64)
	typedef struct __stat64 Tcl_StatBuf;
#   elif (defined(_MSC_VER) && (_MSC_VER < 1400)) || defined(_USE_32BIT_TIME_T)
	typedef struct _stati64	Tcl_StatBuf;
#   else
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
/*
 *----------------------------------------------------------------------------
 * Definition of the interface to functions implementing threads. A function
 * following this definition is given to each call of 'Tcl_CreateThread' and
 * will be called as the main fuction of the new thread created by that call.
 */

#if defined __WIN32__
typedef unsigned (__stdcall Tcl_ThreadCreateProc) (ClientData clientData);
#else
typedef void (Tcl_ThreadCreateProc) (ClientData clientData);
#endif

/*
 * Threading function return types used for abstracting away platform
 * differences when writing a Tcl_ThreadCreateProc. See the NewThread function
 * in generic/tclThreadTest.c for it's usage.
 */

#if defined __WIN32__
#   define Tcl_ThreadCreateType		unsigned __stdcall
#   define TCL_THREAD_CREATE_RETURN	return 0
#else
#   define Tcl_ThreadCreateType		void
#   define TCL_THREAD_CREATE_RETURN
#endif








|











|







555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
/*
 *----------------------------------------------------------------------------
 * Definition of the interface to functions implementing threads. A function
 * following this definition is given to each call of 'Tcl_CreateThread' and
 * will be called as the main fuction of the new thread created by that call.
 */

#if defined _WIN32
typedef unsigned (__stdcall Tcl_ThreadCreateProc) (ClientData clientData);
#else
typedef void (Tcl_ThreadCreateProc) (ClientData clientData);
#endif

/*
 * Threading function return types used for abstracting away platform
 * differences when writing a Tcl_ThreadCreateProc. See the NewThread function
 * in generic/tclThreadTest.c for it's usage.
 */

#if defined _WIN32
#   define Tcl_ThreadCreateType		unsigned __stdcall
#   define TCL_THREAD_CREATE_RETURN	return 0
#else
#   define Tcl_ThreadCreateType		void
#   define TCL_THREAD_CREATE_RETURN
#endif

2432
2433
2434
2435
2436
2437
2438
2439

2440





2441
2442
2443
2444
2445
2446
2447
 * table.
 */

#include "tclDecls.h"

/*
 * Include platform specific public function declarations that are accessible
 * via the stubs table.

 */






#include "tclPlatDecls.h"

/*
 *----------------------------------------------------------------------------
 * The following declarations either map ckalloc and ckfree to malloc and
 * free, or they map them to functions with all sorts of debugging hooks







|
>

>
>
>
>
>







2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
 * table.
 */

#include "tclDecls.h"

/*
 * Include platform specific public function declarations that are accessible
 * 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"

/*
 *----------------------------------------------------------------------------
 * The following declarations either map ckalloc and ckfree to malloc and
 * free, or they map them to functions with all sorts of debugging hooks
Changes to generic/tclClock.c.
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

#include "tclInt.h"

/*
 * Windows has mktime. The configurators do not check.
 */

#ifdef __WIN32__
#define HAVE_MKTIME 1
#endif

/*
 * Constants
 */








|







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

#include "tclInt.h"

/*
 * Windows has mktime. The configurators do not check.
 */

#ifdef _WIN32
#define HAVE_MKTIME 1
#endif

/*
 * Constants
 */

544
545
546
547
548
549
550

551
552
553
554
555
556
557
558
559
560
561
562


563
564
565
566
567
568
569

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "dict changeover");
	return TCL_ERROR;
    }
    dict = objv[1];
    if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK

	    || Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT,
		&era) != TCL_OK
	    || Tcl_DictObjGet(interp, dict, literals[LIT_YEAR],
		&fieldPtr) != TCL_OK
	    || TclGetIntFromObj(interp, fieldPtr, &fields.year) != TCL_OK
	    || Tcl_DictObjGet(interp, dict, literals[LIT_MONTH],
		&fieldPtr) != TCL_OK
	    || TclGetIntFromObj(interp, fieldPtr, &fields.month) != TCL_OK
	    || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFMONTH],
		&fieldPtr) != TCL_OK
	    || TclGetIntFromObj(interp, fieldPtr, &fields.dayOfMonth)!=TCL_OK
	    || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {


	return TCL_ERROR;
    }
    fields.era = era;

    /*
     * Get Julian day.
     */







>


|
|

|
|

|
|


>
>







544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "dict changeover");
	return TCL_ERROR;
    }
    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
		 || fieldPtr == NULL
	    || TclGetIntFromObj(interp, fieldPtr, &fields.year) != 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
		 || 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;

    /*
     * Get Julian day.
     */
634
635
636
637
638
639
640

641
642
643
644
645
646
647
648
649
650
651
652


653
654
655
656
657
658
659

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "dict changeover");
	return TCL_ERROR;
    }
    dict = objv[1];
    if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK

	    || 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
	    || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {


	return TCL_ERROR;
    }
    fields.era = era;

    /*
     * Get Julian day.
     */







>


|
|
|
|
|
|
|
|
|

>
>







637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "dict changeover");
	return TCL_ERROR;
    }
    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
		 || 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;

    /*
     * Get Julian day.
     */
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
    Tcl_Time now;
    Tcl_WideInt clicks = 0;

    switch (objc) {
    case 1:
	break;
    case 2:
	if (Tcl_GetIndexFromObj(interp, objv[1], clicksSwitches, "switch", 0,
		&index) != TCL_OK) {
	    return TCL_ERROR;
	}
	break;
    default:
	Tcl_WrongNumArgs(interp, 1, objv, "?-switch?");
	return TCL_ERROR;







|







1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
    Tcl_Time now;
    Tcl_WideInt clicks = 0;

    switch (objc) {
    case 1:
	break;
    case 2:
	if (Tcl_GetIndexFromObj(interp, objv[1], clicksSwitches, "option", 0,
		&index) != TCL_OK) {
	    return TCL_ERROR;
	}
	break;
    default:
	Tcl_WrongNumArgs(interp, 1, objv, "?-switch?");
	return TCL_ERROR;
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
     * Extract values for the keywords.
     */

    formatObj = litPtr[LIT__DEFAULT_FORMAT];
    localeObj = litPtr[LIT_C];
    timezoneObj = litPtr[LIT__NIL];
    for (i = 2; i < objc; i+=2) {
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", 0,
		&optionIndex) != TCL_OK) {
	    Tcl_SetErrorCode(interp, "CLOCK", "badSwitch",
		    Tcl_GetString(objv[i]), NULL);
	    return TCL_ERROR;
	}
	switch (optionIndex) {
	case CLOCK_FORMAT_FORMAT:
	    formatObj = objv[i+1];
	    break;







|

|







1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
     * Extract values for the keywords.
     */

    formatObj = litPtr[LIT__DEFAULT_FORMAT];
    localeObj = litPtr[LIT_C];
    timezoneObj = litPtr[LIT__NIL];
    for (i = 2; i < objc; i+=2) {
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
		&optionIndex) != TCL_OK) {
	    Tcl_SetErrorCode(interp, "CLOCK", "badOption",
		    Tcl_GetString(objv[i]), NULL);
	    return TCL_ERROR;
	}
	switch (optionIndex) {
	case CLOCK_FORMAT_FORMAT:
	    formatObj = objv[i+1];
	    break;
Changes to generic/tclCmdAH.c.
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
	 * For Windows, there are no user ids associated with a file, so we
	 * always return 1.
	 *
	 * TODO: use GetSecurityInfo to get the real owner of the file and
	 * test for equivalence to the current user.
	 */

#if defined(__WIN32__) || defined(__CYGWIN__)
	value = 1;
#else
	value = (geteuid() == buf.st_uid);
#endif
    }
    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
    return TCL_OK;







|







1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
	 * For Windows, there are no user ids associated with a file, so we
	 * always return 1.
	 *
	 * TODO: use GetSecurityInfo to get the real owner of the file and
	 * test for equivalence to the current user.
	 */

#if defined(_WIN32) || defined(__CYGWIN__)
	value = 1;
#else
	value = (geteuid() == buf.st_uid);
#endif
    }
    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
    return TCL_OK;
Changes to generic/tclCmdIL.c.
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
 * are used to arrange the objects being sorted into a collection of linked
 * lists.
 */

typedef struct SortElement {
    union {			/* The value that we sorting by. */
	const char *strValuePtr;
	long intValue;
	double doubleValue;
	Tcl_Obj *objValuePtr;
    } collationKey;
    union {			/* Object being sorted, or its index. */
	Tcl_Obj *objPtr;
	int index;
    } payload;







|







25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
 * are used to arrange the objects being sorted into a collection of linked
 * lists.
 */

typedef struct SortElement {
    union {			/* The value that we sorting by. */
	const char *strValuePtr;
	Tcl_WideInt wideValue;
	double doubleValue;
	Tcl_Obj *objValuePtr;
    } collationKey;
    union {			/* Object being sorted, or its index. */
	Tcl_Obj *objPtr;
	int index;
    } payload;
2889
2890
2891
2892
2893
2894
2895
2896

2897
2898
2899
2900
2901
2902
2903
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument values. */
{
    const char *bytes, *patternBytes;
    int i, match, index, result, listc, length, elemLen, bisect;
    int dataType, isIncreasing, lower, upper, patInt, objInt, offset;

    int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
    double patDouble, objDouble;
    SortInfo sortInfo;
    Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
    SortStrCmpFn_t strCmpFn = strcmp;
    Tcl_RegExp regexp = NULL;
    static const char *const options[] = {







|
>







2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument values. */
{
    const char *bytes, *patternBytes;
    int i, match, index, result, listc, length, elemLen, bisect;
    int dataType, isIncreasing, lower, upper, offset;
    Tcl_WideInt patWide, objWide;
    int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
    double patDouble, objDouble;
    SortInfo sortInfo;
    Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
    SortStrCmpFn_t strCmpFn = strcmp;
    Tcl_RegExp regexp = NULL;
    static const char *const options[] = {
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
    if (mode == EXACT || mode == SORTED) {
	switch ((enum datatypes) dataType) {
	case ASCII:
	case DICTIONARY:
	    patternBytes = TclGetStringFromObj(patObj, &length);
	    break;
	case INTEGER:
	    result = TclGetIntFromObj(interp, patObj, &patInt);
	    if (result != TCL_OK) {
		goto done;
	    }

	    /*
	     * List representation might have been shimmered; restore it. [Bug
	     * 1844789]







|







3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
    if (mode == EXACT || mode == SORTED) {
	switch ((enum datatypes) dataType) {
	case ASCII:
	case DICTIONARY:
	    patternBytes = TclGetStringFromObj(patObj, &length);
	    break;
	case INTEGER:
	    result = TclGetWideIntFromObj(interp, patObj, &patWide);
	    if (result != TCL_OK) {
		goto done;
	    }

	    /*
	     * List representation might have been shimmered; restore it. [Bug
	     * 1844789]
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
		match = strCmpFn(patternBytes, bytes);
		break;
	    case DICTIONARY:
		bytes = TclGetString(itemPtr);
		match = DictionaryCompare(patternBytes, bytes);
		break;
	    case INTEGER:
		result = TclGetIntFromObj(interp, itemPtr, &objInt);
		if (result != TCL_OK) {
		    goto done;
		}
		if (patInt == objInt) {
		    match = 0;
		} else if (patInt < objInt) {
		    match = -1;
		} else {
		    match = 1;
		}
		break;
	    case REAL:
		result = Tcl_GetDoubleFromObj(interp, itemPtr, &objDouble);







|



|

|







3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
		match = strCmpFn(patternBytes, bytes);
		break;
	    case DICTIONARY:
		bytes = TclGetString(itemPtr);
		match = DictionaryCompare(patternBytes, bytes);
		break;
	    case INTEGER:
		result = TclGetWideIntFromObj(interp, itemPtr, &objWide);
		if (result != TCL_OK) {
		    goto done;
		}
		if (patWide == objWide) {
		    match = 0;
		} else if (patWide < objWide) {
		    match = -1;
		} else {
		    match = 1;
		}
		break;
	    case REAL:
		result = Tcl_GetDoubleFromObj(interp, itemPtr, &objDouble);
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417

		case DICTIONARY:
		    bytes = TclGetString(itemPtr);
		    match = (DictionaryCompare(bytes, patternBytes) == 0);
		    break;

		case INTEGER:
		    result = TclGetIntFromObj(interp, itemPtr, &objInt);
		    if (result != TCL_OK) {
			if (listPtr != NULL) {
			    Tcl_DecrRefCount(listPtr);
			}
			goto done;
		    }
		    match = (objInt == patInt);
		    break;

		case REAL:
		    result = Tcl_GetDoubleFromObj(interp,itemPtr, &objDouble);
		    if (result != TCL_OK) {
			if (listPtr) {
			    Tcl_DecrRefCount(listPtr);







|






|







3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418

		case DICTIONARY:
		    bytes = TclGetString(itemPtr);
		    match = (DictionaryCompare(bytes, patternBytes) == 0);
		    break;

		case INTEGER:
		    result = TclGetWideIntFromObj(interp, itemPtr, &objWide);
		    if (result != TCL_OK) {
			if (listPtr != NULL) {
			    Tcl_DecrRefCount(listPtr);
			}
			goto done;
		    }
		    match = (objWide == patWide);
		    break;

		case REAL:
		    result = Tcl_GetDoubleFromObj(interp,itemPtr, &objDouble);
		    if (result != TCL_OK) {
			if (listPtr) {
			    Tcl_DecrRefCount(listPtr);
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
	/*
	 * Determine the "value" of this object for sorting purposes
	 */

	if (sortMode == SORTMODE_ASCII) {
	    elementArray[i].collationKey.strValuePtr = TclGetString(indexPtr);
	} else if (sortMode == SORTMODE_INTEGER) {
	    long a;

	    if (TclGetLongFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) {
		sortInfo.resultCode = TCL_ERROR;
		goto done1;
	    }
	    elementArray[i].collationKey.intValue = a;
	} else if (sortMode == SORTMODE_REAL) {
	    double a;

	    if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr,
		    &a) != TCL_OK) {
		sortInfo.resultCode = TCL_ERROR;
		goto done1;







|

|



|







3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
	/*
	 * Determine the "value" of this object for sorting purposes
	 */

	if (sortMode == SORTMODE_ASCII) {
	    elementArray[i].collationKey.strValuePtr = TclGetString(indexPtr);
	} else if (sortMode == SORTMODE_INTEGER) {
	    Tcl_WideInt a;

	    if (TclGetWideIntFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) {
		sortInfo.resultCode = TCL_ERROR;
		goto done1;
	    }
	    elementArray[i].collationKey.wideValue = a;
	} else if (sortMode == SORTMODE_REAL) {
	    double a;

	    if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr,
		    &a) != TCL_OK) {
		sortInfo.resultCode = TCL_ERROR;
		goto done1;
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
    } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) {
	order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr,
		elemPtr2->collationKey.strValuePtr);
    } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
	order = DictionaryCompare(elemPtr1->collationKey.strValuePtr,
		elemPtr2->collationKey.strValuePtr);
    } else if (infoPtr->sortMode == SORTMODE_INTEGER) {
	long a, b;

	a = elemPtr1->collationKey.intValue;
	b = elemPtr2->collationKey.intValue;
	order = ((a >= b) - (a <= b));
    } else if (infoPtr->sortMode == SORTMODE_REAL) {
	double a, b;

	a = elemPtr1->collationKey.doubleValue;
	b = elemPtr2->collationKey.doubleValue;
	order = ((a >= b) - (a <= b));







|

|
|







4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
    } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) {
	order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr,
		elemPtr2->collationKey.strValuePtr);
    } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
	order = DictionaryCompare(elemPtr1->collationKey.strValuePtr,
		elemPtr2->collationKey.strValuePtr);
    } else if (infoPtr->sortMode == SORTMODE_INTEGER) {
	Tcl_WideInt a, b;

	a = elemPtr1->collationKey.wideValue;
	b = elemPtr2->collationKey.wideValue;
	order = ((a >= b) - (a <= b));
    } else if (infoPtr->sortMode == SORTMODE_REAL) {
	double a, b;

	a = elemPtr1->collationKey.doubleValue;
	b = elemPtr2->collationKey.doubleValue;
	order = ((a >= b) - (a <= b));
Changes to generic/tclCmdMZ.c.
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
	const char *name;
	int index;

	name = TclGetString(objv[i]);
	if (name[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
		&index) != TCL_OK) {
	    goto optionError;
	}
	switch ((enum options) index) {
	case REGEXP_ALL:
	    all = 1;
	    break;







|







157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
	const char *name;
	int index;

	name = TclGetString(objv[i]);
	if (name[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", TCL_EXACT,
		&index) != TCL_OK) {
	    goto optionError;
	}
	switch ((enum options) index) {
	case REGEXP_ALL:
	    all = 1;
	    break;
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233


234
235
236
237
238
239
240
	    goto endOfForLoop;
	}
    }

  endOfForLoop:
    if ((objc - i) < (2 - about)) {
	Tcl_WrongNumArgs(interp, 1, objv,
	    "?-switch ...? exp string ?matchVar? ?subMatchVar ...?");
	goto optionError;
    }
    objc -= i;
    objv += i;

    /*
     * Check if the user requested -inline, but specified match variables; a
     * no-no.
     */

    if (doinline && ((objc - 2) != 0)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"regexp match variables not allowed when using -inline", -1));


	goto optionError;
    }

    /*
     * Handle the odd about case separately.
     */








|













>
>







213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
	    goto endOfForLoop;
	}
    }

  endOfForLoop:
    if ((objc - i) < (2 - about)) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-option ...? exp string ?matchVar? ?subMatchVar ...?");
	goto optionError;
    }
    objc -= i;
    objv += i;

    /*
     * Check if the user requested -inline, but specified match variables; a
     * no-no.
     */

    if (doinline && ((objc - 2) != 0)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"regexp match variables not allowed when using -inline", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGEXP",
		"MIX_VAR_INLINE", NULL);
	goto optionError;
    }

    /*
     * Handle the odd about case separately.
     */

515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
	const char *name;
	int index;

	name = TclGetString(objv[idx]);
	if (name[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch",
		TCL_EXACT, &index) != TCL_OK) {
	    goto optionError;
	}
	switch ((enum options) index) {
	case REGSUB_ALL:
	    all = 1;
	    break;







|







517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
	const char *name;
	int index;

	name = TclGetString(objv[idx]);
	if (name[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[idx], options, "option",
		TCL_EXACT, &index) != TCL_OK) {
	    goto optionError;
	}
	switch ((enum options) index) {
	case REGSUB_ALL:
	    all = 1;
	    break;
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
	    goto endOfForLoop;
	}
    }

  endOfForLoop:
    if (objc-idx < 3 || objc-idx > 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-switch ...? exp string subSpec ?varName?");
    optionError:
	if (startIndex) {
	    Tcl_DecrRefCount(startIndex);
	}
	return TCL_ERROR;
    }








|







564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
	    goto endOfForLoop;
	}
    }

  endOfForLoop:
    if (objc-idx < 3 || objc-idx > 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-option ...? exp string subSpec ?varName?");
    optionError:
	if (startIndex) {
	    Tcl_DecrRefCount(startIndex);
	}
	return TCL_ERROR;
    }

3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
	SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS
    };
    int i, flags = TCL_SUBST_ALL;

    for (i = 0; i < numOpts; i++) {
	int optionIndex;

	if (Tcl_GetIndexFromObj(interp, opts[i], substOptions, "switch", 0,
		&optionIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (optionIndex) {
	case SUBST_NOBACKSLASHES:
	    flags &= ~TCL_SUBST_BACKSLASHES;
	    break;







|







3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
	SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS
    };
    int i, flags = TCL_SUBST_ALL;

    for (i = 0; i < numOpts; i++) {
	int optionIndex;

	if (Tcl_GetIndexFromObj(interp, opts[i], substOptions, "option", 0,
		&optionIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (optionIndex) {
	case SUBST_NOBACKSLASHES:
	    flags &= ~TCL_SUBST_BACKSLASHES;
	    break;
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
	    break;
	}
    }

  finishedOptions:
    if (objc - i < 2) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-switch ...? string ?pattern body ...? ?default body?");
	return TCL_ERROR;
    }
    if (indexVarObj != NULL && mode != OPT_REGEXP) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"%s option requires -regexp option", "-indexvar"));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
		"MODERESTRICTION", NULL);







|







3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
	    break;
	}
    }

  finishedOptions:
    if (objc - i < 2) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-option ...? string ?pattern body ...? ?default body?");
	return TCL_ERROR;
    }
    if (indexVarObj != NULL && mode != OPT_REGEXP) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"%s option requires -regexp option", "-indexvar"));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
		"MODERESTRICTION", NULL);
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648

	/*
	 * Ensure that the list is non-empty.
	 */

	if (objc < 1) {
	    Tcl_WrongNumArgs(interp, 1, savedObjv,
		    "?-switch ...? string {?pattern body ...? ?default body?}");
	    return TCL_ERROR;
	}
	objv = listv;
	splitObjs = 1;
    }

    /*







|







3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650

	/*
	 * Ensure that the list is non-empty.
	 */

	if (objc < 1) {
	    Tcl_WrongNumArgs(interp, 1, savedObjv,
		    "?-option ...? string {?pattern body ...? ?default body?}");
	    return TCL_ERROR;
	}
	objv = listv;
	splitObjs = 1;
    }

    /*
Changes to generic/tclDecls.h.
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
EXTERN char *		Tcl_DbCkalloc(unsigned int size, const char *file,
				int line);
/* 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 */
/* 9 */
EXTERN void		Tcl_CreateFileHandler(int fd, int mask,
				Tcl_FileProc *proc, ClientData clientData);
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 9 */
EXTERN void		Tcl_CreateFileHandler(int fd, int mask,
				Tcl_FileProc *proc, ClientData clientData);
#endif /* MACOSX */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
/* 10 */
EXTERN void		Tcl_DeleteFileHandler(int fd);
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 10 */
EXTERN void		Tcl_DeleteFileHandler(int fd);
#endif /* MACOSX */







|









|







59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
EXTERN char *		Tcl_DbCkalloc(unsigned int size, const char *file,
				int line);
/* 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 */
/* 9 */
EXTERN void		Tcl_CreateFileHandler(int fd, int mask,
				Tcl_FileProc *proc, ClientData clientData);
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 9 */
EXTERN void		Tcl_CreateFileHandler(int fd, int mask,
				Tcl_FileProc *proc, ClientData clientData);
#endif /* MACOSX */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
/* 10 */
EXTERN void		Tcl_DeleteFileHandler(int fd);
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 10 */
EXTERN void		Tcl_DeleteFileHandler(int fd);
#endif /* MACOSX */
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
				Tcl_Interp *slaveInterp);
/* 164 */
EXTERN Tcl_Interp *	Tcl_GetMaster(Tcl_Interp *interp);
/* 165 */
EXTERN const char *	Tcl_GetNameOfExecutable(void);
/* 166 */
EXTERN Tcl_Obj *	Tcl_GetObjResult(Tcl_Interp *interp);
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
/* 167 */
EXTERN int		Tcl_GetOpenFile(Tcl_Interp *interp,
				const char *chanID, int forWriting,
				int checkUsage, ClientData *filePtr);
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 167 */







|







507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
				Tcl_Interp *slaveInterp);
/* 164 */
EXTERN Tcl_Interp *	Tcl_GetMaster(Tcl_Interp *interp);
/* 165 */
EXTERN const char *	Tcl_GetNameOfExecutable(void);
/* 166 */
EXTERN Tcl_Obj *	Tcl_GetObjResult(Tcl_Interp *interp);
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
/* 167 */
EXTERN int		Tcl_GetOpenFile(Tcl_Interp *interp,
				const char *chanID, int forWriting,
				int checkUsage, ClientData *filePtr);
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 167 */
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
    void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */
    char * (*tcl_Alloc) (unsigned int size); /* 3 */
    void (*tcl_Free) (char *ptr); /* 4 */
    char * (*tcl_Realloc) (char *ptr, unsigned int size); /* 5 */
    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 */
    void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */
#endif /* UNIX */
#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 */
    void (*tcl_DeleteFileHandler) (int fd); /* 10 */
#endif /* UNIX */
#if defined(__WIN32__) /* WIN */
    void (*reserved10)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
    void (*tcl_DeleteFileHandler) (int fd); /* 10 */
#endif /* MACOSX */
    void (*tcl_SetTimer) (const Tcl_Time *timePtr); /* 11 */
    void (*tcl_Sleep) (int ms); /* 12 */







|


|





|


|







1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
    void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */
    char * (*tcl_Alloc) (unsigned int size); /* 3 */
    void (*tcl_Free) (char *ptr); /* 4 */
    char * (*tcl_Realloc) (char *ptr, unsigned int size); /* 5 */
    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 */
    void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */
#endif /* UNIX */
#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 */
    void (*tcl_DeleteFileHandler) (int fd); /* 10 */
#endif /* UNIX */
#if defined(_WIN32) /* WIN */
    void (*reserved10)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
    void (*tcl_DeleteFileHandler) (int fd); /* 10 */
#endif /* MACOSX */
    void (*tcl_SetTimer) (const Tcl_Time *timePtr); /* 11 */
    void (*tcl_Sleep) (int ms); /* 12 */
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
    CONST84_RETURN char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */
    int (*tcl_GetErrno) (void); /* 161 */
    CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */
    int (*tcl_GetInterpPath) (Tcl_Interp *askInterp, Tcl_Interp *slaveInterp); /* 163 */
    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 */
    int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */
#endif /* UNIX */
#if defined(__WIN32__) /* WIN */
    void (*reserved167)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
    int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */
#endif /* MACOSX */
    Tcl_PathType (*tcl_GetPathType) (const char *path); /* 168 */
    int (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */







|


|







2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
    CONST84_RETURN char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */
    int (*tcl_GetErrno) (void); /* 161 */
    CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */
    int (*tcl_GetInterpPath) (Tcl_Interp *askInterp, Tcl_Interp *slaveInterp); /* 163 */
    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 */
    int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */
#endif /* UNIX */
#if defined(_WIN32) /* WIN */
    void (*reserved167)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
    int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */
#endif /* MACOSX */
    Tcl_PathType (*tcl_GetPathType) (const char *path); /* 168 */
    int (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
	(tclStubsPtr->tcl_Realloc) /* 5 */
#define Tcl_DbCkalloc \
	(tclStubsPtr->tcl_DbCkalloc) /* 6 */
#define Tcl_DbCkfree \
	(tclStubsPtr->tcl_DbCkfree) /* 7 */
#define Tcl_DbCkrealloc \
	(tclStubsPtr->tcl_DbCkrealloc) /* 8 */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
#define Tcl_CreateFileHandler \
	(tclStubsPtr->tcl_CreateFileHandler) /* 9 */
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
#define Tcl_CreateFileHandler \
	(tclStubsPtr->tcl_CreateFileHandler) /* 9 */
#endif /* MACOSX */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
#define Tcl_DeleteFileHandler \
	(tclStubsPtr->tcl_DeleteFileHandler) /* 10 */
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
#define Tcl_DeleteFileHandler \
	(tclStubsPtr->tcl_DeleteFileHandler) /* 10 */
#endif /* MACOSX */







|







|







2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
	(tclStubsPtr->tcl_Realloc) /* 5 */
#define Tcl_DbCkalloc \
	(tclStubsPtr->tcl_DbCkalloc) /* 6 */
#define Tcl_DbCkfree \
	(tclStubsPtr->tcl_DbCkfree) /* 7 */
#define Tcl_DbCkrealloc \
	(tclStubsPtr->tcl_DbCkrealloc) /* 8 */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
#define Tcl_CreateFileHandler \
	(tclStubsPtr->tcl_CreateFileHandler) /* 9 */
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
#define Tcl_CreateFileHandler \
	(tclStubsPtr->tcl_CreateFileHandler) /* 9 */
#endif /* MACOSX */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
#define Tcl_DeleteFileHandler \
	(tclStubsPtr->tcl_DeleteFileHandler) /* 10 */
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
#define Tcl_DeleteFileHandler \
	(tclStubsPtr->tcl_DeleteFileHandler) /* 10 */
#endif /* MACOSX */
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
	(tclStubsPtr->tcl_GetInterpPath) /* 163 */
#define Tcl_GetMaster \
	(tclStubsPtr->tcl_GetMaster) /* 164 */
#define Tcl_GetNameOfExecutable \
	(tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */
#define Tcl_GetObjResult \
	(tclStubsPtr->tcl_GetObjResult) /* 166 */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
#define Tcl_GetOpenFile \
	(tclStubsPtr->tcl_GetOpenFile) /* 167 */
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
#define Tcl_GetOpenFile \
	(tclStubsPtr->tcl_GetOpenFile) /* 167 */
#endif /* MACOSX */







|







2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
	(tclStubsPtr->tcl_GetInterpPath) /* 163 */
#define Tcl_GetMaster \
	(tclStubsPtr->tcl_GetMaster) /* 164 */
#define Tcl_GetNameOfExecutable \
	(tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */
#define Tcl_GetObjResult \
	(tclStubsPtr->tcl_GetObjResult) /* 166 */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
#define Tcl_GetOpenFile \
	(tclStubsPtr->tcl_GetOpenFile) /* 167 */
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
#define Tcl_GetOpenFile \
	(tclStubsPtr->tcl_GetOpenFile) /* 167 */
#endif /* MACOSX */
Changes to generic/tclDictObj.c.
150
151
152
153
154
155
156







157
158
159
160
161
162
163
    int epoch;			/* Epoch counter */
    int refcount;		/* Reference counter (see above) */
    Tcl_Obj *chain;		/* Linked list used for invalidating the
				 * string representations of updated nested
				 * dictionaries. */
} Dict;








/*
 * The structure below defines the dictionary object type by means of
 * functions that can be invoked by generic object code.
 */

const Tcl_ObjType tclDictType = {
    "dict",







>
>
>
>
>
>
>







150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
    int epoch;			/* Epoch counter */
    int refcount;		/* Reference counter (see above) */
    Tcl_Obj *chain;		/* Linked list used for invalidating the
				 * string representations of updated nested
				 * dictionaries. */
} Dict;

/*
 * Accessor macro for converting between a Tcl_Obj* and a Dict. Note that this
 * must be assignable as well as readable.
 */

#define DICT(dictObj)   (*((Dict **)&(dictObj)->internalRep.twoPtrValue.ptr1))

/*
 * The structure below defines the dictionary object type by means of
 * functions that can be invoked by generic object code.
 */

const Tcl_ObjType tclDictType = {
    "dict",
308
309
310
311
312
313
314

315
316
317
318
319
320
321
    ChainEntry *cPtr = (ChainEntry *)
	    Tcl_FindHashEntry(&dict->table, keyPtr);

    if (cPtr == NULL) {
	return 0;
    } else {
	Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry);

	TclDecrRefCount(valuePtr);
    }

    /*
     * Unstitch from the chain.
     */








>







315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
    ChainEntry *cPtr = (ChainEntry *)
	    Tcl_FindHashEntry(&dict->table, keyPtr);

    if (cPtr == NULL) {
	return 0;
    } else {
	Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry);

	TclDecrRefCount(valuePtr);
    }

    /*
     * Unstitch from the chain.
     */

357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
 */

static void
DupDictInternalRep(
    Tcl_Obj *srcPtr,
    Tcl_Obj *copyPtr)
{
    Dict *oldDict = srcPtr->internalRep.twoPtrValue.ptr1;
    Dict *newDict = ckalloc(sizeof(Dict));
    ChainEntry *cPtr;

    /*
     * Copy values across from the old hash table.
     */








|







365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
 */

static void
DupDictInternalRep(
    Tcl_Obj *srcPtr,
    Tcl_Obj *copyPtr)
{
    Dict *oldDict = DICT(srcPtr);
    Dict *newDict = ckalloc(sizeof(Dict));
    ChainEntry *cPtr;

    /*
     * Copy values across from the old hash table.
     */

392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
    newDict->chain = NULL;
    newDict->refcount = 1;

    /*
     * Store in the object.
     */

    copyPtr->internalRep.twoPtrValue.ptr1 = newDict;
    copyPtr->typePtr = &tclDictType;
}

/*
 *----------------------------------------------------------------------
 *
 * FreeDictInternalRep --







|







400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
    newDict->chain = NULL;
    newDict->refcount = 1;

    /*
     * Store in the object.
     */

    DICT(copyPtr) = newDict;
    copyPtr->typePtr = &tclDictType;
}

/*
 *----------------------------------------------------------------------
 *
 * FreeDictInternalRep --
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
 *----------------------------------------------------------------------
 */

static void
FreeDictInternalRep(
    Tcl_Obj *dictPtr)
{
    Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1;

    dict->refcount--;
    if (dict->refcount <= 0) {
	DeleteDict(dict);
    }
    dictPtr->typePtr = NULL;
}







|







426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
 *----------------------------------------------------------------------
 */

static void
FreeDictInternalRep(
    Tcl_Obj *dictPtr)
{
    Dict *dict = DICT(dictPtr);

    dict->refcount--;
    if (dict->refcount <= 0) {
	DeleteDict(dict);
    }
    dictPtr->typePtr = NULL;
}
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497

static void
UpdateStringOfDict(
    Tcl_Obj *dictPtr)
{
#define LOCAL_SIZE 20
    int localFlags[LOCAL_SIZE], *flagPtr = NULL;
    Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1;
    ChainEntry *cPtr;
    Tcl_Obj *keyPtr, *valuePtr;
    int i, length, bytesNeeded = 0;
    const char *elem;
    char *dst;
    const int maxFlags = UINT_MAX / sizeof(int);








|







491
492
493
494
495
496
497
498
499
500
501
502
503
504
505

static void
UpdateStringOfDict(
    Tcl_Obj *dictPtr)
{
#define LOCAL_SIZE 20
    int localFlags[LOCAL_SIZE], *flagPtr = NULL;
    Dict *dict = DICT(dictPtr);
    ChainEntry *cPtr;
    Tcl_Obj *keyPtr, *valuePtr;
    int i, length, bytesNeeded = 0;
    const char *elem;
    char *dst;
    const int maxFlags = UINT_MAX / sizeof(int);

596
597
598
599
600
601
602
603
604
605
606
607
608
609
610

static int
SetDictFromAny(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr)
{
    Tcl_HashEntry *hPtr;
    int isNew, result;
    Dict *dict = ckalloc(sizeof(Dict));

    InitChainTable(dict);

    /*
     * Since lists and dictionaries have very closely-related string
     * representations (i.e. the same parsing code) we can safely special-case







|







604
605
606
607
608
609
610
611
612
613
614
615
616
617
618

static int
SetDictFromAny(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr)
{
    Tcl_HashEntry *hPtr;
    int isNew;
    Dict *dict = ckalloc(sizeof(Dict));

    InitChainTable(dict);

    /*
     * Since lists and dictionaries have very closely-related string
     * representations (i.e. the same parsing code) we can safely special-case
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
	const char *limit = (nextElem + length);

	while (nextElem < limit) {
	    Tcl_Obj *keyPtr, *valuePtr;
	    const char *elemStart;
	    int elemSize, literal;

	    result = TclFindElement(interp, nextElem, (limit - nextElem),
		    &elemStart, &nextElem, &elemSize, &literal);
	    if (result != TCL_OK) {
		goto errorExit;
	    }
	    if (elemStart == limit) {
		break;
	    }
	    if (nextElem == limit) {
		goto missingValue;
	    }

	    if (literal) {
		TclNewStringObj(keyPtr, elemStart, elemSize);
	    } else {
		/* Avoid double copy */
		TclNewObj(keyPtr);
		keyPtr->bytes = ckalloc((unsigned) elemSize + 1);
		keyPtr->length = TclCopyAndCollapse(elemSize, elemStart,
			keyPtr->bytes);
	    }

	    result = TclFindElement(interp, nextElem, (limit - nextElem),
		    &elemStart, &nextElem, &elemSize, &literal);
	    if (result != TCL_OK) {
		TclDecrRefCount(keyPtr);
		goto errorExit;
	    }

	    if (literal) {
		TclNewStringObj(valuePtr, elemStart, elemSize);
	    } else {
		/* Avoid double copy */
		TclNewObj(valuePtr);







|
|
<
|


















|
|
<

|







655
656
657
658
659
660
661
662
663

664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684

685
686
687
688
689
690
691
692
693
	const char *limit = (nextElem + length);

	while (nextElem < limit) {
	    Tcl_Obj *keyPtr, *valuePtr;
	    const char *elemStart;
	    int elemSize, literal;

	    if (TclFindDictElement(interp, nextElem, (limit - nextElem),
		    &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) {

		goto errorInFindDictElement;
	    }
	    if (elemStart == limit) {
		break;
	    }
	    if (nextElem == limit) {
		goto missingValue;
	    }

	    if (literal) {
		TclNewStringObj(keyPtr, elemStart, elemSize);
	    } else {
		/* Avoid double copy */
		TclNewObj(keyPtr);
		keyPtr->bytes = ckalloc((unsigned) elemSize + 1);
		keyPtr->length = TclCopyAndCollapse(elemSize, elemStart,
			keyPtr->bytes);
	    }

	    if (TclFindDictElement(interp, nextElem, (limit - nextElem),
		    &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) {

		TclDecrRefCount(keyPtr);
		goto errorInFindDictElement;
	    }

	    if (literal) {
		TclNewStringObj(valuePtr, elemStart, elemSize);
	    } else {
		/* Avoid double copy */
		TclNewObj(valuePtr);
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
     * Tcl_GetStringFromObj, to use that old internalRep.
     */

    TclFreeIntRep(objPtr);
    dict->epoch = 0;
    dict->chain = NULL;
    dict->refcount = 1;
    objPtr->internalRep.twoPtrValue.ptr1 = dict;
    objPtr->typePtr = &tclDictType;
    return TCL_OK;

  missingValue:
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"missing value to go with key", -1));
	Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
    }
    result = TCL_ERROR;

  errorExit:
    if (interp != NULL) {
	Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
    }
    DeleteChainTable(dict);
    ckfree(dict);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclTraceDictPath --
 *







|









<
|
<
<
<
<


|







715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731

732




733
734
735
736
737
738
739
740
741
742
     * Tcl_GetStringFromObj, to use that old internalRep.
     */

    TclFreeIntRep(objPtr);
    dict->epoch = 0;
    dict->chain = NULL;
    dict->refcount = 1;
    DICT(objPtr) = dict;
    objPtr->typePtr = &tclDictType;
    return TCL_OK;

  missingValue:
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"missing value to go with key", -1));
	Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
    }

  errorInFindDictElement:




    DeleteChainTable(dict);
    ckfree(dict);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclTraceDictPath --
 *
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
    int keyc,
    Tcl_Obj *const keyv[],
    int flags)
{
    Dict *dict, *newDict;
    int i;

    if (dictPtr->typePtr != &tclDictType) {
	if (SetDictFromAny(interp, dictPtr) != TCL_OK) {
	    return NULL;
	}
    }
    dict = dictPtr->internalRep.twoPtrValue.ptr1;
    if (flags & DICT_PATH_UPDATE) {
	dict->chain = NULL;
    }

    for (i=0 ; i<keyc ; i++) {
	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&dict->table, keyv[i]);
	Tcl_Obj *tmpObj;







|
|
|
|
<
|







774
775
776
777
778
779
780
781
782
783
784

785
786
787
788
789
790
791
792
    int keyc,
    Tcl_Obj *const keyv[],
    int flags)
{
    Dict *dict, *newDict;
    int i;

    if (dictPtr->typePtr != &tclDictType
	    && SetDictFromAny(interp, dictPtr) != TCL_OK) {
	return NULL;
    }

    dict = DICT(dictPtr);
    if (flags & DICT_PATH_UPDATE) {
	dict->chain = NULL;
    }

    for (i=0 ; i<keyc ; i++) {
	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&dict->table, keyv[i]);
	Tcl_Obj *tmpObj;
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843

	    hPtr = CreateChainEntry(dict, keyv[i], &isNew);
	    tmpObj = Tcl_NewDictObj();
	    Tcl_IncrRefCount(tmpObj);
	    Tcl_SetHashValue(hPtr, tmpObj);
	} else {
	    tmpObj = Tcl_GetHashValue(hPtr);
	    if (tmpObj->typePtr != &tclDictType) {
		if (SetDictFromAny(interp, tmpObj) != TCL_OK) {
		    return NULL;
		}
	    }
	}

	newDict = tmpObj->internalRep.twoPtrValue.ptr1;
	if (flags & DICT_PATH_UPDATE) {
	    if (Tcl_IsShared(tmpObj)) {
		TclDecrRefCount(tmpObj);
		tmpObj = Tcl_DuplicateObj(tmpObj);
		Tcl_IncrRefCount(tmpObj);
		Tcl_SetHashValue(hPtr, tmpObj);
		dict->epoch++;
		newDict = tmpObj->internalRep.twoPtrValue.ptr1;
	    }

	    newDict->chain = dictPtr;
	}
	dict = newDict;
	dictPtr = tmpObj;
    }







|
|
|
<



|







|







814
815
816
817
818
819
820
821
822
823

824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842

	    hPtr = CreateChainEntry(dict, keyv[i], &isNew);
	    tmpObj = Tcl_NewDictObj();
	    Tcl_IncrRefCount(tmpObj);
	    Tcl_SetHashValue(hPtr, tmpObj);
	} else {
	    tmpObj = Tcl_GetHashValue(hPtr);
	    if (tmpObj->typePtr != &tclDictType
		    && SetDictFromAny(interp, tmpObj) != TCL_OK) {
		return NULL;

	    }
	}

	newDict = DICT(tmpObj);
	if (flags & DICT_PATH_UPDATE) {
	    if (Tcl_IsShared(tmpObj)) {
		TclDecrRefCount(tmpObj);
		tmpObj = Tcl_DuplicateObj(tmpObj);
		Tcl_IncrRefCount(tmpObj);
		Tcl_SetHashValue(hPtr, tmpObj);
		dict->epoch++;
		newDict = DICT(tmpObj);
	    }

	    newDict->chain = dictPtr;
	}
	dict = newDict;
	dictPtr = tmpObj;
    }
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
 *----------------------------------------------------------------------
 */

static void
InvalidateDictChain(
    Tcl_Obj *dictObj)
{
    Dict *dict = dictObj->internalRep.twoPtrValue.ptr1;

    do {
	TclInvalidateStringRep(dictObj);
	dict->epoch++;
	dictObj = dict->chain;
	if (dictObj == NULL) {
	    break;
	}
	dict->chain = NULL;
	dict = dictObj->internalRep.twoPtrValue.ptr1;
    } while (dict != NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DictObjPut --







|









|







863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
 *----------------------------------------------------------------------
 */

static void
InvalidateDictChain(
    Tcl_Obj *dictObj)
{
    Dict *dict = DICT(dictObj);

    do {
	TclInvalidateStringRep(dictObj);
	dict->epoch++;
	dictObj = dict->chain;
	if (dictObj == NULL) {
	    break;
	}
	dict->chain = NULL;
	dict = DICT(dictObj);
    } while (dict != NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DictObjPut --
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
    Tcl_HashEntry *hPtr;
    int isNew;

    if (Tcl_IsShared(dictPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_DictObjPut");
    }

    if (dictPtr->typePtr != &tclDictType) {
	int result = SetDictFromAny(interp, dictPtr);

	if (result != TCL_OK) {
	    return result;
	}
    }

    if (dictPtr->bytes != NULL) {
	TclInvalidateStringRep(dictPtr);
    }
    dict = dictPtr->internalRep.twoPtrValue.ptr1;
    hPtr = CreateChainEntry(dict, keyPtr, &isNew);
    Tcl_IncrRefCount(valuePtr);
    if (!isNew) {
	Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr);

	TclDecrRefCount(oldValuePtr);
    }







|
|
<
<
|
<





|







911
912
913
914
915
916
917
918
919


920

921
922
923
924
925
926
927
928
929
930
931
932
933
    Tcl_HashEntry *hPtr;
    int isNew;

    if (Tcl_IsShared(dictPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_DictObjPut");
    }

    if (dictPtr->typePtr != &tclDictType
	    && SetDictFromAny(interp, dictPtr) != TCL_OK) {


	return TCL_ERROR;

    }

    if (dictPtr->bytes != NULL) {
	TclInvalidateStringRep(dictPtr);
    }
    dict = DICT(dictPtr);
    hPtr = CreateChainEntry(dict, keyPtr, &isNew);
    Tcl_IncrRefCount(valuePtr);
    if (!isNew) {
	Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr);

	TclDecrRefCount(oldValuePtr);
    }
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
    Tcl_Obj *dictPtr,
    Tcl_Obj *keyPtr,
    Tcl_Obj **valuePtrPtr)
{
    Dict *dict;
    Tcl_HashEntry *hPtr;

    if (dictPtr->typePtr != &tclDictType) {
	int result = SetDictFromAny(interp, dictPtr);
	if (result != TCL_OK) {
	    *valuePtrPtr = NULL;
	    return result;
	}
    }

    dict = dictPtr->internalRep.twoPtrValue.ptr1;
    hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
    if (hPtr == NULL) {
	*valuePtrPtr = NULL;
    } else {
	*valuePtrPtr = Tcl_GetHashValue(hPtr);
    }
    return TCL_OK;







|
|
<
|
|
|
|
|
<







962
963
964
965
966
967
968
969
970

971
972
973
974
975

976
977
978
979
980
981
982
    Tcl_Obj *dictPtr,
    Tcl_Obj *keyPtr,
    Tcl_Obj **valuePtrPtr)
{
    Dict *dict;
    Tcl_HashEntry *hPtr;

    if (dictPtr->typePtr != &tclDictType
	    && SetDictFromAny(interp, dictPtr) != TCL_OK) {

	*valuePtrPtr = NULL;
	return TCL_ERROR;
    }

    dict = DICT(dictPtr);

    hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
    if (hPtr == NULL) {
	*valuePtrPtr = NULL;
    } else {
	*valuePtrPtr = Tcl_GetHashValue(hPtr);
    }
    return TCL_OK;
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028

1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
{
    Dict *dict;

    if (Tcl_IsShared(dictPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove");
    }

    if (dictPtr->typePtr != &tclDictType) {
	int result = SetDictFromAny(interp, dictPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }


    if (dictPtr->bytes != NULL) {
	TclInvalidateStringRep(dictPtr);
    }
    dict = dictPtr->internalRep.twoPtrValue.ptr1;
    if (DeleteChainEntry(dict, keyPtr)) {
	dict->epoch++;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------







|
|
<
|
|
|
|
>
|
|
|
<
<







1009
1010
1011
1012
1013
1014
1015
1016
1017

1018
1019
1020
1021
1022
1023
1024
1025


1026
1027
1028
1029
1030
1031
1032
{
    Dict *dict;

    if (Tcl_IsShared(dictPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove");
    }

    if (dictPtr->typePtr != &tclDictType
	    && SetDictFromAny(interp, dictPtr) != TCL_OK) {

	return TCL_ERROR;
    }

    dict = DICT(dictPtr);
    if (DeleteChainEntry(dict, keyPtr)) {
	if (dictPtr->bytes != NULL) {
	    TclInvalidateStringRep(dictPtr);
	}


	dict->epoch++;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
Tcl_DictObjSize(
    Tcl_Interp *interp,
    Tcl_Obj *dictPtr,
    int *sizePtr)
{
    Dict *dict;

    if (dictPtr->typePtr != &tclDictType) {
	int result = SetDictFromAny(interp, dictPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }

    dict = dictPtr->internalRep.twoPtrValue.ptr1;
    *sizePtr = dict->table.numEntries;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|
|
<
|
|
|
|
<







1050
1051
1052
1053
1054
1055
1056
1057
1058

1059
1060
1061
1062

1063
1064
1065
1066
1067
1068
1069
Tcl_DictObjSize(
    Tcl_Interp *interp,
    Tcl_Obj *dictPtr,
    int *sizePtr)
{
    Dict *dict;

    if (dictPtr->typePtr != &tclDictType
	    && SetDictFromAny(interp, dictPtr) != TCL_OK) {

	return TCL_ERROR;
    }

    dict = DICT(dictPtr);

    *sizePtr = dict->table.numEntries;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
				 * written into when there are no further
				 * values in the dictionary, or a 0
				 * otherwise. */
{
    Dict *dict;
    ChainEntry *cPtr;

    if (dictPtr->typePtr != &tclDictType) {
	int result = SetDictFromAny(interp, dictPtr);

	if (result != TCL_OK) {
	    return result;
	}
    }

    dict = dictPtr->internalRep.twoPtrValue.ptr1;
    cPtr = dict->entryChainHead;
    if (cPtr == NULL) {
	searchPtr->epoch = -1;
	*donePtr = 1;
    } else {
	*donePtr = 0;
	searchPtr->dictionaryPtr = (Tcl_Dict) dict;







|
|
<
<
|
|
|
|
<







1102
1103
1104
1105
1106
1107
1108
1109
1110


1111
1112
1113
1114

1115
1116
1117
1118
1119
1120
1121
				 * written into when there are no further
				 * values in the dictionary, or a 0
				 * otherwise. */
{
    Dict *dict;
    ChainEntry *cPtr;

    if (dictPtr->typePtr != &tclDictType
	    && SetDictFromAny(interp, dictPtr) != TCL_OK) {


	return TCL_ERROR;
    }

    dict = DICT(dictPtr);

    cPtr = dict->entryChainHead;
    if (cPtr == NULL) {
	searchPtr->epoch = -1;
	*donePtr = 1;
    } else {
	*donePtr = 0;
	searchPtr->dictionaryPtr = (Tcl_Dict) dict;
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306

1307
1308
1309
1310
1311
1312
1313
    }

    dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE);
    if (dictPtr == NULL) {
	return TCL_ERROR;
    }

    dict = dictPtr->internalRep.twoPtrValue.ptr1;
    hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
    Tcl_IncrRefCount(valuePtr);
    if (!isNew) {
	Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr);

	TclDecrRefCount(oldValuePtr);
    }
    Tcl_SetHashValue(hPtr, valuePtr);
    InvalidateDictChain(dictPtr);

    return TCL_OK;
}







|




>







1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
    }

    dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE);
    if (dictPtr == NULL) {
	return TCL_ERROR;
    }

    dict = DICT(dictPtr);
    hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
    Tcl_IncrRefCount(valuePtr);
    if (!isNew) {
	Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr);

	TclDecrRefCount(oldValuePtr);
    }
    Tcl_SetHashValue(hPtr, valuePtr);
    InvalidateDictChain(dictPtr);

    return TCL_OK;
}
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
    }

    dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_UPDATE);
    if (dictPtr == NULL) {
	return TCL_ERROR;
    }

    dict = dictPtr->internalRep.twoPtrValue.ptr1;
    DeleteChainEntry(dict, keyv[keyc-1]);
    InvalidateDictChain(dictPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------







|







1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
    }

    dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_UPDATE);
    if (dictPtr == NULL) {
	return TCL_ERROR;
    }

    dict = DICT(dictPtr);
    DeleteChainEntry(dict, keyv[keyc-1]);
    InvalidateDictChain(dictPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
    TclNewObj(dictPtr);
    TclInvalidateStringRep(dictPtr);
    dict = ckalloc(sizeof(Dict));
    InitChainTable(dict);
    dict->epoch = 0;
    dict->chain = NULL;
    dict->refcount = 1;
    dictPtr->internalRep.twoPtrValue.ptr1 = dict;
    dictPtr->typePtr = &tclDictType;
    return dictPtr;
#endif
}

/*
 *----------------------------------------------------------------------







|







1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
    TclNewObj(dictPtr);
    TclInvalidateStringRep(dictPtr);
    dict = ckalloc(sizeof(Dict));
    InitChainTable(dict);
    dict->epoch = 0;
    dict->chain = NULL;
    dict->refcount = 1;
    DICT(dictPtr) = dict;
    dictPtr->typePtr = &tclDictType;
    return dictPtr;
#endif
}

/*
 *----------------------------------------------------------------------
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
    TclDbNewObj(dictPtr, file, line);
    TclInvalidateStringRep(dictPtr);
    dict = ckalloc(sizeof(Dict));
    InitChainTable(dict);
    dict->epoch = 0;
    dict->chain = NULL;
    dict->refcount = 1;
    dictPtr->internalRep.twoPtrValue.ptr1 = dict;
    dictPtr->typePtr = &tclDictType;
    return dictPtr;
#else /* !TCL_MEM_DEBUG */
    return Tcl_NewDictObj();
#endif
}








|







1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
    TclDbNewObj(dictPtr, file, line);
    TclInvalidateStringRep(dictPtr);
    dict = ckalloc(sizeof(Dict));
    InitChainTable(dict);
    dict->epoch = 0;
    dict->chain = NULL;
    dict->refcount = 1;
    DICT(dictPtr) = dict;
    dictPtr->typePtr = &tclDictType;
    return dictPtr;
#else /* !TCL_MEM_DEBUG */
    return Tcl_NewDictObj();
#endif
}

1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
    }

    dictObj = Tcl_NewDictObj();
    for (i=1 ; i<objc ; i+=2) {
	/*
	 * The next command is assumed to never fail...
	 */
	Tcl_DictObjPut(interp, dictObj, objv[i], objv[i+1]);
    }
    Tcl_SetObjResult(interp, dictObj);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------







|







1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
    }

    dictObj = Tcl_NewDictObj();
    for (i=1 ; i<objc ; i+=2) {
	/*
	 * The next command is assumed to never fail...
	 */
	Tcl_DictObjPut(NULL, dictObj, objv[i], objv[i+1]);
    }
    Tcl_SetObjResult(interp, dictObj);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640




1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652

1653
1654
1655
1656
1657
1658
1659
DictReplaceCmd(
    ClientData dummy,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *dictPtr;
    int i, result;
    int allocatedDict = 0;

    if ((objc < 2) || (objc & 1)) {
	Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key value ...?");
	return TCL_ERROR;
    }

    dictPtr = objv[1];




    if (Tcl_IsShared(dictPtr)) {
	dictPtr = Tcl_DuplicateObj(dictPtr);
	allocatedDict = 1;
    }
    for (i=2 ; i<objc ; i+=2) {
	result = Tcl_DictObjPut(interp, dictPtr, objv[i], objv[i+1]);
	if (result != TCL_OK) {
	    if (allocatedDict) {
		TclDecrRefCount(dictPtr);
	    }
	    return TCL_ERROR;
	}

    }
    Tcl_SetObjResult(interp, dictPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------







|
<







>
>
>
>


<

<
<
<
|
|
|
|
<
>







1613
1614
1615
1616
1617
1618
1619
1620

1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633

1634



1635
1636
1637
1638

1639
1640
1641
1642
1643
1644
1645
1646
DictReplaceCmd(
    ClientData dummy,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *dictPtr;
    int i;


    if ((objc < 2) || (objc & 1)) {
	Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key value ...?");
	return TCL_ERROR;
    }

    dictPtr = objv[1];
    if (dictPtr->typePtr != &tclDictType
	    && SetDictFromAny(interp, dictPtr) != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_IsShared(dictPtr)) {
	dictPtr = Tcl_DuplicateObj(dictPtr);

    }



    if (dictPtr->bytes != NULL) {
	TclInvalidateStringRep(dictPtr);
    }
    for (i=2 ; i<objc ; i+=2) {

	Tcl_DictObjPut(NULL, dictPtr, objv[i], objv[i+1]);
    }
    Tcl_SetObjResult(interp, dictPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692




1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704

1705
1706
1707
1708
1709
1710
1711
DictRemoveCmd(
    ClientData dummy,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *dictPtr;
    int i, result;
    int allocatedDict = 0;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...?");
	return TCL_ERROR;
    }

    dictPtr = objv[1];




    if (Tcl_IsShared(dictPtr)) {
	dictPtr = Tcl_DuplicateObj(dictPtr);
	allocatedDict = 1;
    }
    for (i=2 ; i<objc ; i++) {
	result = Tcl_DictObjRemove(interp, dictPtr, objv[i]);
	if (result != TCL_OK) {
	    if (allocatedDict) {
		TclDecrRefCount(dictPtr);
	    }
	    return TCL_ERROR;
	}

    }
    Tcl_SetObjResult(interp, dictPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------







|
<







>
>
>
>


<

<
|
<
<
|
|
|
<
>







1664
1665
1666
1667
1668
1669
1670
1671

1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684

1685

1686


1687
1688
1689

1690
1691
1692
1693
1694
1695
1696
1697
DictRemoveCmd(
    ClientData dummy,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *dictPtr;
    int i;


    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...?");
	return TCL_ERROR;
    }

    dictPtr = objv[1];
    if (dictPtr->typePtr != &tclDictType
	    && SetDictFromAny(interp, dictPtr) != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_IsShared(dictPtr)) {
	dictPtr = Tcl_DuplicateObj(dictPtr);

    }

    if (dictPtr->bytes != NULL) {


	TclInvalidateStringRep(dictPtr);
    }
    for (i=2 ; i<objc ; i++) {

	Tcl_DictObjRemove(NULL, dictPtr, objv[i]);
    }
    Tcl_SetObjResult(interp, dictPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
    }

    /*
     * Make sure first argument is a dictionary.
     */

    targetObj = objv[1];
    if (targetObj->typePtr != &tclDictType) {
	if (SetDictFromAny(interp, targetObj) != TCL_OK) {
	    return TCL_ERROR;
	}
    }

    if (objc == 2) {
	/*
	 * Single argument, return it.
	 */








|
|
|
<







1732
1733
1734
1735
1736
1737
1738
1739
1740
1741

1742
1743
1744
1745
1746
1747
1748
    }

    /*
     * Make sure first argument is a dictionary.
     */

    targetObj = objv[1];
    if (targetObj->typePtr != &tclDictType
	    && SetDictFromAny(interp, targetObj) != TCL_OK) {
	return TCL_ERROR;

    }

    if (objc == 2) {
	/*
	 * Single argument, return it.
	 */

1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850

    /*
     * A direct check that we have a dictionary. We don't start the iteration
     * yet because that might allocate memory or set locks that we do not
     * need. [Bug 1705778, leak K04]
     */

    if (objv[1]->typePtr != &tclDictType) {
	int result = SetDictFromAny(interp, objv[1]);

	if (result != TCL_OK) {
	    return result;
	}
    }

    if (objc == 3) {
	pattern = TclGetString(objv[2]);
    }
    listPtr = Tcl_NewListObj(0, NULL);
    if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {







|
|
<
<
|
<







1816
1817
1818
1819
1820
1821
1822
1823
1824


1825

1826
1827
1828
1829
1830
1831
1832

    /*
     * A direct check that we have a dictionary. We don't start the iteration
     * yet because that might allocate memory or set locks that we do not
     * need. [Bug 1705778, leak K04]
     */

    if (objv[1]->typePtr != &tclDictType
	    && SetDictFromAny(interp, objv[1]) != TCL_OK) {


	return TCL_ERROR;

    }

    if (objc == 3) {
	pattern = TclGetString(objv[2]);
    }
    listPtr = Tcl_NewListObj(0, NULL);
    if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
	return TCL_ERROR;
    }

    dictPtr = objv[1];
    if (dictPtr->typePtr != &tclDictType) {
	int result = SetDictFromAny(interp, dictPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }
    dict = dictPtr->internalRep.twoPtrValue.ptr1;

    statsStr = Tcl_HashStats(&dict->table);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1));
    ckfree(statsStr);
    return TCL_OK;
}








|
|
<
|
|
<
|







2034
2035
2036
2037
2038
2039
2040
2041
2042

2043
2044

2045
2046
2047
2048
2049
2050
2051
2052

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
	return TCL_ERROR;
    }

    dictPtr = objv[1];
    if (dictPtr->typePtr != &tclDictType
	    && SetDictFromAny(interp, dictPtr) != TCL_OK) {

	return TCL_ERROR;
    }

    dict = DICT(dictPtr);

    statsStr = Tcl_HashStats(&dict->table);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1));
    ckfree(statsStr);
    return TCL_OK;
}

2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
    int objc,
    Tcl_Obj *const *objv)
{
    int code = TCL_OK;
    Tcl_Obj *dictPtr, *valuePtr = NULL;

    if (objc < 3 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName key ?increment?");
	return TCL_ERROR;
    }

    dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
    if (dictPtr == NULL) {
	/*
	 * Variable didn't yet exist. Create new dictionary value.







|







2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
    int objc,
    Tcl_Obj *const *objv)
{
    int code = TCL_OK;
    Tcl_Obj *dictPtr, *valuePtr = NULL;

    if (objc < 3 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?increment?");
	return TCL_ERROR;
    }

    dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
    if (dictPtr == NULL) {
	/*
	 * Variable didn't yet exist. Create new dictionary value.
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
	    } else {
		/*
		 * Remember to dispose with the bignum as we're not actually
		 * using it directly. [Bug 2874678]
		 */

		mp_clear(&increment);
		Tcl_DictObjPut(interp, dictPtr, objv[2], objv[3]);
	    }
	} else {
	    Tcl_DictObjPut(interp, dictPtr, objv[2], Tcl_NewIntObj(1));
	}
    } else {
	/*
	 * Key in dictionary. Increment its value with minimum dup.
	 */

	if (Tcl_IsShared(valuePtr)) {
	    valuePtr = Tcl_DuplicateObj(valuePtr);
	    Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr);
	}
	if (objc == 4) {
	    code = TclIncrObj(interp, valuePtr, objv[3]);
	} else {
	    Tcl_Obj *incrPtr = Tcl_NewIntObj(1);

	    Tcl_IncrRefCount(incrPtr);
	    code = TclIncrObj(interp, valuePtr, incrPtr);
	    Tcl_DecrRefCount(incrPtr);
	}
    }
    if (code == TCL_OK) {
	TclInvalidateStringRep(dictPtr);
	valuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL,
		dictPtr, TCL_LEAVE_ERR_MSG);
	if (valuePtr == NULL) {
	    code = TCL_ERROR;
	} else {
	    Tcl_SetObjResult(interp, valuePtr);
	}
    } else if (dictPtr->refCount == 0) {
	Tcl_DecrRefCount(dictPtr);
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *







|


|








|








|












|







2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
	    } else {
		/*
		 * Remember to dispose with the bignum as we're not actually
		 * using it directly. [Bug 2874678]
		 */

		mp_clear(&increment);
		Tcl_DictObjPut(NULL, dictPtr, objv[2], objv[3]);
	    }
	} else {
	    Tcl_DictObjPut(NULL, dictPtr, objv[2], Tcl_NewIntObj(1));
	}
    } else {
	/*
	 * Key in dictionary. Increment its value with minimum dup.
	 */

	if (Tcl_IsShared(valuePtr)) {
	    valuePtr = Tcl_DuplicateObj(valuePtr);
	    Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
	}
	if (objc == 4) {
	    code = TclIncrObj(interp, valuePtr, objv[3]);
	} else {
	    Tcl_Obj *incrPtr = Tcl_NewIntObj(1);

	    Tcl_IncrRefCount(incrPtr);
	    code = TclIncrObj(interp, valuePtr, incrPtr);
	    TclDecrRefCount(incrPtr);
	}
    }
    if (code == TCL_OK) {
	TclInvalidateStringRep(dictPtr);
	valuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL,
		dictPtr, TCL_LEAVE_ERR_MSG);
	if (valuePtr == NULL) {
	    code = TCL_ERROR;
	} else {
	    Tcl_SetObjResult(interp, valuePtr);
	}
    } else if (dictPtr->refCount == 0) {
	TclDecrRefCount(dictPtr);
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
    int i, allocatedDict = 0, allocatedValue = 0;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName key ?value ...?");
	return TCL_ERROR;
    }

    dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
    if (dictPtr == NULL) {
	allocatedDict = 1;
	dictPtr = Tcl_NewDictObj();







|







2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
    int i, allocatedDict = 0, allocatedValue = 0;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?");
	return TCL_ERROR;
    }

    dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
    if (dictPtr == NULL) {
	allocatedDict = 1;
	dictPtr = Tcl_NewDictObj();
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
		}
		return TCL_ERROR;
	    }
	}
    }

    if (allocatedValue) {
	Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr);
    } else if (dictPtr->bytes != NULL) {
	TclInvalidateStringRep(dictPtr);
    }

    resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
	    TCL_LEAVE_ERR_MSG);
    if (resultPtr == NULL) {







|







2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
		}
		return TCL_ERROR;
	    }
	}
    }

    if (allocatedValue) {
	Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
    } else if (dictPtr->bytes != NULL) {
	TclInvalidateStringRep(dictPtr);
    }

    resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
	    TCL_LEAVE_ERR_MSG);
    if (resultPtr == NULL) {
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
    int i, allocatedDict = 0;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName key ?value ...?");
	return TCL_ERROR;
    }

    dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
    if (dictPtr == NULL) {
	allocatedDict = 1;
	dictPtr = Tcl_NewDictObj();







|







2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
    int i, allocatedDict = 0;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?");
	return TCL_ERROR;
    }

    dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
    if (dictPtr == NULL) {
	allocatedDict = 1;
	dictPtr = Tcl_NewDictObj();
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
	    TclDecrRefCount(dictPtr);
	}
	return TCL_ERROR;
    }

    if (valuePtr == NULL) {
	TclNewObj(valuePtr);
    } else {
	if (Tcl_IsShared(valuePtr)) {
	    valuePtr = Tcl_DuplicateObj(valuePtr);
	}
    }

    for (i=3 ; i<objc ; i++) {
	Tcl_AppendObjToObj(valuePtr, objv[i]);
    }

    Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr);

    resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
	    TCL_LEAVE_ERR_MSG);
    if (resultPtr == NULL) {
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, resultPtr);







<
|
|
<






|







2305
2306
2307
2308
2309
2310
2311

2312
2313

2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
	    TclDecrRefCount(dictPtr);
	}
	return TCL_ERROR;
    }

    if (valuePtr == NULL) {
	TclNewObj(valuePtr);

    } else if (Tcl_IsShared(valuePtr)) {
	valuePtr = Tcl_DuplicateObj(valuePtr);

    }

    for (i=3 ; i<objc ; i++) {
	Tcl_AppendObjToObj(valuePtr, objv[i]);
    }

    Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);

    resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
	    TCL_LEAVE_ERR_MSG);
    if (resultPtr == NULL) {
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, resultPtr);
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399

2400
2401
2402
2403
2404
2405
2406
    Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
    Tcl_Obj **varv, *keyObj, *valueObj;
    Tcl_DictSearch *searchPtr;
    int varc, done;

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"{keyVar valueVar} dictionary script");
	return TCL_ERROR;
    }

    /*
     * Parse arguments.
     */

    if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
	return TCL_ERROR;
    }
    if (varc != 2) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"must have exactly two variable names", -1));

	return TCL_ERROR;
    }
    searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch));
    if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj,
	    &done) != TCL_OK) {
	TclStackFree(interp, searchPtr);
	return TCL_ERROR;







|













>







2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
    Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
    Tcl_Obj **varv, *keyObj, *valueObj;
    Tcl_DictSearch *searchPtr;
    int varc, done;

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"{keyVarName valueVarName} dictionary script");
	return TCL_ERROR;
    }

    /*
     * Parse arguments.
     */

    if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
	return TCL_ERROR;
    }
    if (varc != 2) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"must have exactly two variable names", -1));
	Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", NULL);
	return TCL_ERROR;
    }
    searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch));
    if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj,
	    &done) != TCL_OK) {
	TclStackFree(interp, searchPtr);
	return TCL_ERROR;
2426
2427
2428
2429
2430
2431
2432
2433

2434
2435
2436
2437
2438

2439
2440
2441
2442
2443
2444
2445

    /*
     * Stop the value from getting hit in any way by any traces on the key
     * variable.
     */

    Tcl_IncrRefCount(valueObj);
    if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) {

	TclDecrRefCount(valueObj);
	goto error;
    }
    TclDecrRefCount(valueObj);
    if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) {

	goto error;
    }

    /*
     * Run the script.
     */








|
>




|
>







2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426

    /*
     * Stop the value from getting hit in any way by any traces on the key
     * variable.
     */

    Tcl_IncrRefCount(valueObj);
    if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
	    TCL_LEAVE_ERR_MSG) == NULL) {
	TclDecrRefCount(valueObj);
	goto error;
    }
    TclDecrRefCount(valueObj);
    if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj,
	    TCL_LEAVE_ERR_MSG) == NULL) {
	goto error;
    }

    /*
     * Run the script.
     */

2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590

2591
2592
2593
2594
2595
2596
2597
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj **varv, *keyObj, *valueObj;
    DictMapStorage *storagePtr;
    int varc, done;

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"{keyVar valueVar} dictionary script");
	return TCL_ERROR;
    }

    /*
     * Parse arguments.
     */

    if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
	return TCL_ERROR;
    }
    if (varc != 2) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"must have exactly two variable names", -1));

	return TCL_ERROR;
    }
    storagePtr = TclStackAlloc(interp, sizeof(DictMapStorage));
    if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj,
	    &valueObj, &done) != TCL_OK) {
	TclStackFree(interp, storagePtr);
	return TCL_ERROR;







|













>







2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj **varv, *keyObj, *valueObj;
    DictMapStorage *storagePtr;
    int varc, done;

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"{keyVarName valueVarName} dictionary script");
	return TCL_ERROR;
    }

    /*
     * Parse arguments.
     */

    if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
	return TCL_ERROR;
    }
    if (varc != 2) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"must have exactly two variable names", -1));
	Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", NULL);
	return TCL_ERROR;
    }
    storagePtr = TclStackAlloc(interp, sizeof(DictMapStorage));
    if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj,
	    &valueObj, &done) != TCL_OK) {
	TclStackFree(interp, storagePtr);
	return TCL_ERROR;
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *dictPtr, *resultPtr;
    int result, allocatedDict = 0;

    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName key ?key ...? value");
	return TCL_ERROR;
    }

    dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
    if (dictPtr == NULL) {
	allocatedDict = 1;
	dictPtr = Tcl_NewDictObj();







|







2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *dictPtr, *resultPtr;
    int result, allocatedDict = 0;

    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?key ...? value");
	return TCL_ERROR;
    }

    dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
    if (dictPtr == NULL) {
	allocatedDict = 1;
	dictPtr = Tcl_NewDictObj();
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *dictPtr, *resultPtr;
    int result, allocatedDict = 0;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName key ?key ...?");
	return TCL_ERROR;
    }

    dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
    if (dictPtr == NULL) {
	allocatedDict = 1;
	dictPtr = Tcl_NewDictObj();







|







2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *dictPtr, *resultPtr;
    int result, allocatedDict = 0;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?key ...?");
	return TCL_ERROR;
    }

    dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
    if (dictPtr == NULL) {
	allocatedDict = 1;
	dictPtr = Tcl_NewDictObj();
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
		 * since we are not exhausing the search. [Bug 1705778, leak
		 * K05]
		 */

		Tcl_DictObjDone(&search);
		Tcl_DictObjGet(interp, objv[1], objv[3], &valueObj);
		if (valueObj != NULL) {
		    Tcl_DictObjPut(interp, resultObj, objv[3], valueObj);
		}
	    } else {
		while (!done) {
		    if (Tcl_StringMatch(TclGetString(keyObj), pattern)) {
			Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
		    }
		    Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
		}
	    }
	} else {
	    /*
	     * Can't optimize this match for trivial globbing: would disturb
	     * order.
	     */

	    resultObj = Tcl_NewDictObj();
	    while (!done) {
		int i;

		for (i=3 ; i<objc ; i++) {
		    pattern = TclGetString(objv[i]);
		    if (Tcl_StringMatch(TclGetString(keyObj), pattern)) {
			Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
			break;		/* stop inner loop */
		    }
		}
		Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
	    }
	}
	Tcl_SetObjResult(interp, resultObj);







|




|

















|







2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
		 * since we are not exhausing the search. [Bug 1705778, leak
		 * K05]
		 */

		Tcl_DictObjDone(&search);
		Tcl_DictObjGet(interp, objv[1], objv[3], &valueObj);
		if (valueObj != NULL) {
		    Tcl_DictObjPut(NULL, resultObj, objv[3], valueObj);
		}
	    } else {
		while (!done) {
		    if (Tcl_StringMatch(TclGetString(keyObj), pattern)) {
			Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj);
		    }
		    Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
		}
	    }
	} else {
	    /*
	     * Can't optimize this match for trivial globbing: would disturb
	     * order.
	     */

	    resultObj = Tcl_NewDictObj();
	    while (!done) {
		int i;

		for (i=3 ; i<objc ; i++) {
		    pattern = TclGetString(objv[i]);
		    if (Tcl_StringMatch(TclGetString(keyObj), pattern)) {
			Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj);
			break;		/* stop inner loop */
		    }
		}
		Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
	    }
	}
	Tcl_SetObjResult(interp, resultObj);
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028

3029
3030
3031
3032
3033
3034
3035
	resultObj = Tcl_NewDictObj();
	while (!done) {
	    int i;

	    for (i=3 ; i<objc ; i++) {
		pattern = TclGetString(objv[i]);
		if (Tcl_StringMatch(TclGetString(valueObj), pattern)) {
		    Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
		    break;		/* stop inner loop */
		}
	    }
	    Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
	}
	Tcl_SetObjResult(interp, resultObj);
	return TCL_OK;

    case FILTER_SCRIPT:
	if (objc != 5) {
	    Tcl_WrongNumArgs(interp, 1, objv,
		    "dictionary script {keyVar valueVar} filterScript");
	    return TCL_ERROR;
	}

	/*
	 * Create a dictionary whose key,value pairs all satisfy a script
	 * (i.e. get a true boolean result from its evaluation). Massive
	 * copying from the "dict for" implementation has occurred!
	 */

	if (TclListObjGetElements(interp, objv[3], &varc, &varv) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (varc != 2) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "must have exactly two variable names", -1));

	    return TCL_ERROR;
	}
	keyVarObj = varv[0];
	valueVarObj = varv[1];
	scriptObj = objv[4];

	/*







|











|















>







2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
	resultObj = Tcl_NewDictObj();
	while (!done) {
	    int i;

	    for (i=3 ; i<objc ; i++) {
		pattern = TclGetString(objv[i]);
		if (Tcl_StringMatch(TclGetString(valueObj), pattern)) {
		    Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj);
		    break;		/* stop inner loop */
		}
	    }
	    Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
	}
	Tcl_SetObjResult(interp, resultObj);
	return TCL_OK;

    case FILTER_SCRIPT:
	if (objc != 5) {
	    Tcl_WrongNumArgs(interp, 1, objv,
		    "dictionary script {keyVarName valueVarName} filterScript");
	    return TCL_ERROR;
	}

	/*
	 * Create a dictionary whose key,value pairs all satisfy a script
	 * (i.e. get a true boolean result from its evaluation). Massive
	 * copying from the "dict for" implementation has occurred!
	 */

	if (TclListObjGetElements(interp, objv[3], &varc, &varv) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (varc != 2) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "must have exactly two variable names", -1));
	    Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "filter", NULL);
	    return TCL_ERROR;
	}
	keyVarObj = varv[0];
	valueVarObj = varv[1];
	scriptObj = objv[4];

	/*
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
	     * key variable.
	     */

	    Tcl_IncrRefCount(keyObj);
	    Tcl_IncrRefCount(valueObj);
	    if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
		    TCL_LEAVE_ERR_MSG) == NULL) {
		Tcl_ResetResult(interp);
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"couldn't set key variable: \"%s\"",
			TclGetString(keyVarObj)));
		result = TCL_ERROR;
		goto abnormalResult;
	    }
	    if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj,
		    TCL_LEAVE_ERR_MSG) == NULL) {
		Tcl_ResetResult(interp);
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"couldn't set value variable: \"%s\"",
			TclGetString(valueVarObj)));
		result = TCL_ERROR;
		goto abnormalResult;
	    }

	    /*
	     * TIP #280. Make invoking context available to loop body.
	     */







|
<
|
<





|
<
|
<







3043
3044
3045
3046
3047
3048
3049
3050

3051

3052
3053
3054
3055
3056
3057

3058

3059
3060
3061
3062
3063
3064
3065
	     * key variable.
	     */

	    Tcl_IncrRefCount(keyObj);
	    Tcl_IncrRefCount(valueObj);
	    if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
		    TCL_LEAVE_ERR_MSG) == NULL) {
		Tcl_AddErrorInfo(interp, 

			"\n    (\"dict filter\" filter script key variable)");

		result = TCL_ERROR;
		goto abnormalResult;
	    }
	    if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj,
		    TCL_LEAVE_ERR_MSG) == NULL) {
		Tcl_AddErrorInfo(interp, 

			"\n    (\"dict filter\" filter script value variable)");

		result = TCL_ERROR;
		goto abnormalResult;
	    }

	    /*
	     * TIP #280. Make invoking context available to loop body.
	     */
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
			&satisfied) != TCL_OK) {
		    TclDecrRefCount(boolObj);
		    result = TCL_ERROR;
		    goto abnormalResult;
		}
		TclDecrRefCount(boolObj);
		if (satisfied) {
		    Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
		}
		break;
	    case TCL_BREAK:
		/*
		 * Force loop termination by calling Tcl_DictObjDone; this
		 * makes the next Tcl_DictObjNext say there is nothing more to
		 * do.







|







3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
			&satisfied) != TCL_OK) {
		    TclDecrRefCount(boolObj);
		    result = TCL_ERROR;
		    goto abnormalResult;
		}
		TclDecrRefCount(boolObj);
		if (satisfied) {
		    Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj);
		}
		break;
	    case TCL_BREAK:
		/*
		 * Force loop termination by calling Tcl_DictObjDone; this
		 * makes the next Tcl_DictObjNext say there is nothing more to
		 * do.
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *dictPtr, *objPtr;
    int i, dummy;

    if (objc < 5 || !(objc & 1)) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"varName key varName ?key varName ...? script");
	return TCL_ERROR;
    }

    dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
    if (dictPtr == NULL) {
	return TCL_ERROR;
    }







|







3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *dictPtr, *objPtr;
    int i, dummy;

    if (objc < 5 || !(objc & 1)) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"dictVarName key varName ?key varName ...? script");
	return TCL_ERROR;
    }

    dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
    if (dictPtr == NULL) {
	return TCL_ERROR;
    }
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
     * an instruction to remove the key.
     */

    Tcl_ListObjGetElements(NULL, argsObj, &objc, &objv);
    for (i=0 ; i<objc ; i+=2) {
	objPtr = Tcl_ObjGetVar2(interp, objv[i+1], NULL, 0);
	if (objPtr == NULL) {
	    Tcl_DictObjRemove(interp, dictPtr, objv[i]);
	} else if (objPtr == dictPtr) {
	    /*
	     * Someone is messing us around, trying to build a recursive
	     * structure. [Bug 1786481]
	     */

	    Tcl_DictObjPut(interp, dictPtr, objv[i],
		    Tcl_DuplicateObj(objPtr));
	} else {
	    /* Shouldn't fail */
	    Tcl_DictObjPut(interp, dictPtr, objv[i], objPtr);
	}
    }
    TclDecrRefCount(argsObj);

    /*
     * Write the dictionary back to its variable.
     */







|






<
|


|







3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275

3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
     * an instruction to remove the key.
     */

    Tcl_ListObjGetElements(NULL, argsObj, &objc, &objv);
    for (i=0 ; i<objc ; i+=2) {
	objPtr = Tcl_ObjGetVar2(interp, objv[i+1], NULL, 0);
	if (objPtr == NULL) {
	    Tcl_DictObjRemove(NULL, dictPtr, objv[i]);
	} else if (objPtr == dictPtr) {
	    /*
	     * Someone is messing us around, trying to build a recursive
	     * structure. [Bug 1786481]
	     */


	    Tcl_DictObjPut(NULL, dictPtr, objv[i], Tcl_DuplicateObj(objPtr));
	} else {
	    /* Shouldn't fail */
	    Tcl_DictObjPut(NULL, dictPtr, objv[i], objPtr);
	}
    }
    TclDecrRefCount(argsObj);

    /*
     * Write the dictionary back to its variable.
     */
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *dictPtr, *keysPtr, *pathPtr;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "dictVar ?key ...? script");
	return TCL_ERROR;
    }

    /*
     * Get the dictionary to open out.
     */








|







3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *dictPtr, *keysPtr, *pathPtr;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "dictVarName ?key ...? script");
	return TCL_ERROR;
    }

    /*
     * Get the dictionary to open out.
     */

Changes to generic/tclEnsemble.c.
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771






2772
2773
2774
2775
2776
2777
2778
    Command *oldCmdPtr = cmdPtr, *newCmdPtr;
    int len, result, flags = 0, i, depth = 1, invokeAnyway = 0;
    int ourResult = TCL_ERROR;
    unsigned numBytes;
    const char *word;

    Tcl_IncrRefCount(replaced);

    /*
     * This is where we return to if we are parsing multiple nested compiled
     * ensembles. [info object] is such a beast.
     */

  checkNextWord:
    if (parsePtr->numWords < depth + 1) {
	goto failed;
    }
    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	/*
	 * Too hard.
	 */

	goto failed;
    }







    word = tokenPtr[1].start;
    numBytes = tokenPtr[1].size;

    /*
     * There's a sporting chance we'll be able to compile this. But now we
     * must check properly. To do that, check that we're compiling an ensemble
     * that has a compilable command as its appropriate subcommand.







<
<
<
<
<
<
<











>
>
>
>
>
>







2747
2748
2749
2750
2751
2752
2753







2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
    Command *oldCmdPtr = cmdPtr, *newCmdPtr;
    int len, result, flags = 0, i, depth = 1, invokeAnyway = 0;
    int ourResult = TCL_ERROR;
    unsigned numBytes;
    const char *word;

    Tcl_IncrRefCount(replaced);







    if (parsePtr->numWords < depth + 1) {
	goto failed;
    }
    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	/*
	 * Too hard.
	 */

	goto failed;
    }

    /*
     * This is where we return to if we are parsing multiple nested compiled
     * ensembles. [info object] is such a beast.
     */

  checkNextWord:
    word = tokenPtr[1].start;
    numBytes = tokenPtr[1].size;

    /*
     * There's a sporting chance we'll be able to compile this. But now we
     * must check properly. To do that, check that we're compiling an ensemble
     * that has a compilable command as its appropriate subcommand.
2975
2976
2977
2978
2979
2980
2981











2982
2983
2984
2985
2986
2987
2988
    /*
     * See whether we have a nested ensemble. If we do, we can go round the
     * mulberry bush again, consuming the next word.
     */

    if (cmdPtr->compileProc == TclCompileEnsemble) {
	tokenPtr = TokenAfter(tokenPtr);











	ensemble = (Tcl_Command) cmdPtr;
	goto checkNextWord;
    }

    /*
     * Now we've done the mapping process, can now actually try to compile.
     * If there is a subcommand compiler and that successfully produces code,







>
>
>
>
>
>
>
>
>
>
>







2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
    /*
     * See whether we have a nested ensemble. If we do, we can go round the
     * mulberry bush again, consuming the next word.
     */

    if (cmdPtr->compileProc == TclCompileEnsemble) {
	tokenPtr = TokenAfter(tokenPtr);
	if (parsePtr->numWords < depth + 1
		|| tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    /*
	     * Too hard because the user has done something unpleasant like
	     * omitting the sub-ensemble's command name or used a non-constant
	     * name for a sub-ensemble's command name; we respond by bailing
	     * out completely (this is a rare case). [Bug 6d2f249a01]
	     */

	    goto cleanup;
	}
	ensemble = (Tcl_Command) cmdPtr;
	goto checkNextWord;
    }

    /*
     * Now we've done the mapping process, can now actually try to compile.
     * If there is a subcommand compiler and that successfully produces code,
Changes to generic/tclEnv.c.
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463

#ifdef USE_PUTENV_FOR_UNSET
    /*
     * For those platforms that support putenv to unset, Linux indicates
     * that no = should be included, and Windows requires it.
     */

#if defined(__WIN32__) || defined(__CYGWIN__)
    string = ckalloc(length + 2);
    memcpy(string, name, (size_t) length);
    string[length] = '=';
    string[length+1] = '\0';
#else
    string = ckalloc(length + 1);
    memcpy(string, name, (size_t) length);
    string[length] = '\0';
#endif /* WIN32 */

    Tcl_UtfToExternalDString(NULL, string, -1, &envString);
    string = ckrealloc(string, Tcl_DStringLength(&envString) + 1);
    memcpy(string, Tcl_DStringValue(&envString),
	    (unsigned) Tcl_DStringLength(&envString)+1);
    Tcl_DStringFree(&envString);








|








|







440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463

#ifdef USE_PUTENV_FOR_UNSET
    /*
     * For those platforms that support putenv to unset, Linux indicates
     * that no = should be included, and Windows requires it.
     */

#if defined(_WIN32) || defined(__CYGWIN__)
    string = ckalloc(length + 2);
    memcpy(string, name, (size_t) length);
    string[length] = '=';
    string[length+1] = '\0';
#else
    string = ckalloc(length + 1);
    memcpy(string, name, (size_t) length);
    string[length] = '\0';
#endif /* _WIN32 */

    Tcl_UtfToExternalDString(NULL, string, -1, &envString);
    string = ckrealloc(string, Tcl_DStringLength(&envString) + 1);
    memcpy(string, Tcl_DStringValue(&envString),
	    (unsigned) Tcl_DStringLength(&envString)+1);
    Tcl_DStringFree(&envString);

Changes to generic/tclExecute.c.
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588

#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \
    ((((objPtr)->typePtr == &tclIntType)				\
	|| ((objPtr)->typePtr == &tclBooleanType))			\
	? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK)	\
	: Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr)))

/*
 * Macro used in this file to save a function call for common uses of
 * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is:
 *
 * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
 *			Tcl_WideInt *wideIntPtr);
 */

#ifdef TCL_WIDE_INT_IS_LONG
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
    (((objPtr)->typePtr == &tclIntType)					\
	? (*(wideIntPtr) = (Tcl_WideInt)				\
		((objPtr)->internalRep.longValue), TCL_OK) :		\
	Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
#else /* !TCL_WIDE_INT_IS_LONG */
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr)		\
    (((objPtr)->typePtr == &tclWideIntType)				\
	? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) :	\
    ((objPtr)->typePtr == &tclIntType)					\
	? (*(wideIntPtr) = (Tcl_WideInt)				\
		((objPtr)->internalRep.longValue), TCL_OK) :		\
	Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
#endif /* TCL_WIDE_INT_IS_LONG */

/*
 * Macro used to make the check for type overflow more mnemonic. This works by
 * comparing sign bits; the rest of the word is irrelevant. The ANSI C
 * "prototype" (where inttype_t is any integer type) is:
 *
 * MODULE_SCOPE int Overflowing(inttype_t a, inttype_t b, inttype_t sum);
 *







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







551
552
553
554
555
556
557
























558
559
560
561
562
563
564

#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \
    ((((objPtr)->typePtr == &tclIntType)				\
	|| ((objPtr)->typePtr == &tclBooleanType))			\
	? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK)	\
	: Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr)))

























/*
 * Macro used to make the check for type overflow more mnemonic. This works by
 * comparing sign bits; the rest of the word is irrelevant. The ANSI C
 * "prototype" (where inttype_t is any integer type) is:
 *
 * MODULE_SCOPE int Overflowing(inttype_t a, inttype_t b, inttype_t sum);
 *
5388
5389
5390
5391
5392
5393
5394

5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410

5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426

5427
5428
5429
5430
5431
5432
5433
	    length = Tcl_UtfToUpper(TclGetString(objResultPtr));
	    Tcl_SetObjLength(objResultPtr, length);
	    TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
	    NEXT_INST_F(1, 1, 1);
	} else {
	    length = Tcl_UtfToUpper(TclGetString(valuePtr));
	    Tcl_SetObjLength(valuePtr, length);

	    TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
	    NEXT_INST_F(1, 0, 0);
	}
    case INST_STR_LOWER:
	valuePtr = OBJ_AT_TOS;
	TRACE(("\"%.20s\" => ", O2S(valuePtr)));
	if (Tcl_IsShared(valuePtr)) {
	    s1 = TclGetStringFromObj(valuePtr, &length);
	    TclNewStringObj(objResultPtr, s1, length);
	    length = Tcl_UtfToLower(TclGetString(objResultPtr));
	    Tcl_SetObjLength(objResultPtr, length);
	    TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
	    NEXT_INST_F(1, 1, 1);
	} else {
	    length = Tcl_UtfToLower(TclGetString(valuePtr));
	    Tcl_SetObjLength(valuePtr, length);

	    TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
	    NEXT_INST_F(1, 0, 0);
	}
    case INST_STR_TITLE:
	valuePtr = OBJ_AT_TOS;
	TRACE(("\"%.20s\" => ", O2S(valuePtr)));
	if (Tcl_IsShared(valuePtr)) {
	    s1 = TclGetStringFromObj(valuePtr, &length);
	    TclNewStringObj(objResultPtr, s1, length);
	    length = Tcl_UtfToTitle(TclGetString(objResultPtr));
	    Tcl_SetObjLength(objResultPtr, length);
	    TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
	    NEXT_INST_F(1, 1, 1);
	} else {
	    length = Tcl_UtfToTitle(TclGetString(valuePtr));
	    Tcl_SetObjLength(valuePtr, length);

	    TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
	    NEXT_INST_F(1, 0, 0);
	}

    case INST_STR_INDEX:
	value2Ptr = OBJ_AT_TOS;
	valuePtr = OBJ_UNDER_TOS;







>
















>
















>







5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
	    length = Tcl_UtfToUpper(TclGetString(objResultPtr));
	    Tcl_SetObjLength(objResultPtr, length);
	    TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
	    NEXT_INST_F(1, 1, 1);
	} else {
	    length = Tcl_UtfToUpper(TclGetString(valuePtr));
	    Tcl_SetObjLength(valuePtr, length);
	    TclFreeIntRep(valuePtr);
	    TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
	    NEXT_INST_F(1, 0, 0);
	}
    case INST_STR_LOWER:
	valuePtr = OBJ_AT_TOS;
	TRACE(("\"%.20s\" => ", O2S(valuePtr)));
	if (Tcl_IsShared(valuePtr)) {
	    s1 = TclGetStringFromObj(valuePtr, &length);
	    TclNewStringObj(objResultPtr, s1, length);
	    length = Tcl_UtfToLower(TclGetString(objResultPtr));
	    Tcl_SetObjLength(objResultPtr, length);
	    TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
	    NEXT_INST_F(1, 1, 1);
	} else {
	    length = Tcl_UtfToLower(TclGetString(valuePtr));
	    Tcl_SetObjLength(valuePtr, length);
	    TclFreeIntRep(valuePtr);
	    TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
	    NEXT_INST_F(1, 0, 0);
	}
    case INST_STR_TITLE:
	valuePtr = OBJ_AT_TOS;
	TRACE(("\"%.20s\" => ", O2S(valuePtr)));
	if (Tcl_IsShared(valuePtr)) {
	    s1 = TclGetStringFromObj(valuePtr, &length);
	    TclNewStringObj(objResultPtr, s1, length);
	    length = Tcl_UtfToTitle(TclGetString(objResultPtr));
	    Tcl_SetObjLength(objResultPtr, length);
	    TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
	    NEXT_INST_F(1, 1, 1);
	} else {
	    length = Tcl_UtfToTitle(TclGetString(valuePtr));
	    Tcl_SetObjLength(valuePtr, length);
	    TclFreeIntRep(valuePtr);
	    TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
	    NEXT_INST_F(1, 0, 0);
	}

    case INST_STR_INDEX:
	value2Ptr = OBJ_AT_TOS;
	valuePtr = OBJ_UNDER_TOS;
5695
5696
5697
5698
5699
5700
5701






5702
5703
5704
5705
5706




5707
5708
5709
5710
5711
5712
5713
	} else if (Tcl_IsShared(value3Ptr)) {
	    objResultPtr = Tcl_DuplicateObj(value3Ptr);
	    if (toIdx < length) {
		Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
			length - toIdx);
	    }
	} else {






	    objResultPtr = value3Ptr;
	    if (toIdx < length) {
		Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
			length - toIdx);
	    }




	}
	TclDecrRefCount(value3Ptr);
	TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
	NEXT_INST_F(1, 1, 1);

    case INST_STR_MAP:
	valuePtr = OBJ_AT_TOS;		/* "Main" string. */







>
>
>
>
>
>
|

|


>
>
>
>







5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
	} else if (Tcl_IsShared(value3Ptr)) {
	    objResultPtr = Tcl_DuplicateObj(value3Ptr);
	    if (toIdx < length) {
		Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
			length - toIdx);
	    }
	} else {
	    /*
	     * 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(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)));
	NEXT_INST_F(1, 1, 1);

    case INST_STR_MAP:
	valuePtr = OBJ_AT_TOS;		/* "Main" string. */
5982
5983
5984
5985
5986
5987
5988

























5989
5990
5991
5992
5993
5994
5995
	ClientData ptr1, ptr2;
	int type1, type2;
	long l1, l2, lResult;

    case INST_NUM_TYPE:
	if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
	    type1 = 0;

























	}
	TclNewIntObj(objResultPtr, type1);
	TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
	NEXT_INST_F(1, 1, 1);

    case INST_EQ:
    case INST_NEQ:







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







5971
5972
5973
5974
5975
5976
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
5992
5993
5994
5995
5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
	ClientData ptr1, ptr2;
	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:
Changes to generic/tclFCmd.c.
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
	/*
	 * Prevent copying or renaming a file onto itself. On Windows since
	 * 8.5 we do get an inode number, however the unsigned short field is
	 * insufficient to accept the Win32 API file id so it is truncated to
	 * 16 bits and we get collisions. See bug #2015723.
	 */

#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)) {
		result = TCL_OK;
		goto done;
	    }
	}







|







513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
	/*
	 * Prevent copying or renaming a file onto itself. On Windows since
	 * 8.5 we do get an inode number, however the unsigned short field is
	 * insufficient to accept the Win32 API file id so it is truncated to
	 * 16 bits and we get collisions. See bug #2015723.
	 */

#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)) {
		result = TCL_OK;
		goto done;
	    }
	}
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
	    /*
	     * We have a '-linktype' argument.
	     */

	    static const char *const linkTypes[] = {
		"-symbolic", "-hard", NULL
	    };
	    if (Tcl_GetIndexFromObj(interp, objv[1], linkTypes, "switch", 0,
		    &linkAction) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (linkAction == 0) {
		linkAction = TCL_CREATE_SYMBOLIC_LINK;
	    } else {
		linkAction = TCL_CREATE_HARD_LINK;







|







1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
	    /*
	     * We have a '-linktype' argument.
	     */

	    static const char *const linkTypes[] = {
		"-symbolic", "-hard", NULL
	    };
	    if (Tcl_GetIndexFromObj(interp, objv[1], linkTypes, "option", 0,
		    &linkAction) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (linkAction == 0) {
		linkAction = TCL_CREATE_SYMBOLIC_LINK;
	    } else {
		linkAction = TCL_CREATE_HARD_LINK;
Changes to generic/tclIO.c.
1
2
3
4
5
6
7
8

9
10
11
12
13
14
15
/*
 * tclIO.c --
 *
 *	This file provides the generic portions (those that are the same on
 *	all platforms and for all channel types) of Tcl's IO facilities.
 *
 * Copyright (c) 1998-2000 Ajuba Solutions
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.

 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include "tclIO.h"








>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
/*
 * tclIO.c --
 *
 *	This file provides the generic portions (those that are the same on
 *	all platforms and for all channel types) of Tcl's IO facilities.
 *
 * Copyright (c) 1998-2000 Ajuba Solutions
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Contributions from Don Porter, NIST, 2014. (not subject to US copyright)
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include "tclIO.h"
158
159
160
161
162
163
164



165

166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194

195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
} CloseCallback;

/*
 * Static functions in this file:
 */

static ChannelBuffer *	AllocChannelBuffer(int length);



static void		ChannelTimerProc(ClientData clientData);

static int		CheckChannelErrors(ChannelState *statePtr,
			    int direction);
static int		CheckForDeadChannel(Tcl_Interp *interp,
			    ChannelState *statePtr);
static void		CheckForStdChannelsBeingClosed(Tcl_Channel chan);
static void		CleanupChannelHandlers(Tcl_Interp *interp,
			    Channel *chanPtr);
static int		CloseChannel(Tcl_Interp *interp, Channel *chanPtr,
			    int errorCode);
static int		CloseChannelPart(Tcl_Interp *interp, Channel *chanPtr,
			    int errorCode, int flags);
static int		CloseWrite(Tcl_Interp *interp, Channel *chanPtr);
static void		CommonGetsCleanup(Channel *chanPtr);
static int		CopyAndTranslateBuffer(ChannelState *statePtr,
			    char *result, int space);
static int		CopyBuffer(Channel *chanPtr, char *result, int space);
static int		CopyData(CopyState *csPtr, int mask);
static void		CopyEventProc(ClientData clientData, int mask);
static void		CreateScriptRecord(Tcl_Interp *interp,
			    Channel *chanPtr, int mask, Tcl_Obj *scriptPtr);
static void		DeleteChannelTable(ClientData clientData,
			    Tcl_Interp *interp);
static void		DeleteScriptRecord(Tcl_Interp *interp,
			    Channel *chanPtr, int mask);
static int		DetachChannel(Tcl_Interp *interp, Tcl_Channel chan);
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		DoReadChars(Channel *chan, Tcl_Obj *objPtr, int toRead,
			    int appendFlag);
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);
static int		HaveVersion(const Tcl_ChannelType *typePtr,
			    Tcl_ChannelTypeVersion minimumVersion);
static void		PeekAhead(Channel *chanPtr, char **dstEndPtr,
			    GetsState *gsPtr);
static int		ReadBytes(ChannelState *statePtr, Tcl_Obj *objPtr,
			    int charsLeft, int *offsetPtr);
static int		ReadChars(ChannelState *statePtr, Tcl_Obj *objPtr,
			    int charsLeft, int *offsetPtr, int *factorPtr);
static void		RecycleBuffer(ChannelState *statePtr,
			    ChannelBuffer *bufPtr, int mustDiscard);
static int		StackSetBlockMode(Channel *chanPtr, int mode);
static int		SetBlockMode(Tcl_Interp *interp, Channel *chanPtr,
			    int mode);
static void		StopCopy(CopyState *csPtr);
static int		TranslateInputEOL(ChannelState *statePtr, char *dst,
			    const char *src, int *dstLenPtr, int *srcLenPtr);
static void		UpdateInterest(Channel *chanPtr);
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);







>
>
>

>













<
<
<












|
>
















|

|






|







159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183



184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
} CloseCallback;

/*
 * Static functions in this file:
 */

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		ChanRead(Channel *chanPtr, char *dst, int dstSize);
static int		CheckChannelErrors(ChannelState *statePtr,
			    int direction);
static int		CheckForDeadChannel(Tcl_Interp *interp,
			    ChannelState *statePtr);
static void		CheckForStdChannelsBeingClosed(Tcl_Channel chan);
static void		CleanupChannelHandlers(Tcl_Interp *interp,
			    Channel *chanPtr);
static int		CloseChannel(Tcl_Interp *interp, Channel *chanPtr,
			    int errorCode);
static int		CloseChannelPart(Tcl_Interp *interp, Channel *chanPtr,
			    int errorCode, int flags);
static int		CloseWrite(Tcl_Interp *interp, Channel *chanPtr);
static void		CommonGetsCleanup(Channel *chanPtr);



static int		CopyData(CopyState *csPtr, int mask);
static void		CopyEventProc(ClientData clientData, int mask);
static void		CreateScriptRecord(Tcl_Interp *interp,
			    Channel *chanPtr, int mask, Tcl_Obj *scriptPtr);
static void		DeleteChannelTable(ClientData clientData,
			    Tcl_Interp *interp);
static void		DeleteScriptRecord(Tcl_Interp *interp,
			    Channel *chanPtr, int mask);
static int		DetachChannel(Tcl_Interp *interp, Tcl_Channel chan);
static void		DiscardInputQueued(ChannelState *statePtr,
			    int discardSavedBuffers);
static void		DiscardOutputQueued(ChannelState *chanPtr);
static int		DoRead(Channel *chanPtr, char *dst, int bytesToRead,
			    int allowShortReads);
static int		DoReadChars(Channel *chan, Tcl_Obj *objPtr, int toRead,
			    int appendFlag);
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);
static int		HaveVersion(const Tcl_ChannelType *typePtr,
			    Tcl_ChannelTypeVersion minimumVersion);
static void		PeekAhead(Channel *chanPtr, char **dstEndPtr,
			    GetsState *gsPtr);
static int		ReadBytes(ChannelState *statePtr, Tcl_Obj *objPtr,
			    int charsLeft);
static int		ReadChars(ChannelState *statePtr, Tcl_Obj *objPtr,
			    int charsLeft, int *factorPtr);
static void		RecycleBuffer(ChannelState *statePtr,
			    ChannelBuffer *bufPtr, int mustDiscard);
static int		StackSetBlockMode(Channel *chanPtr, int mode);
static int		SetBlockMode(Tcl_Interp *interp, Channel *chanPtr,
			    int mode);
static void		StopCopy(CopyState *csPtr);
static void		TranslateInputEOL(ChannelState *statePtr, char *dst,
			    const char *src, int *dstLenPtr, int *srcLenPtr);
static void		UpdateInterest(Channel *chanPtr);
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);
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294

#define SpaceLeft(bufPtr)	((bufPtr)->bufLength - (bufPtr)->nextAdded)

#define IsBufferReady(bufPtr)	((bufPtr)->nextAdded > (bufPtr)->nextRemoved)

#define IsBufferEmpty(bufPtr)	((bufPtr)->nextAdded == (bufPtr)->nextRemoved)

#define IsBufferFull(bufPtr)	((bufPtr)->nextAdded >= (bufPtr)->bufLength)

#define IsBufferOverflowing(bufPtr) ((bufPtr)->nextAdded>(bufPtr)->bufLength)

#define InsertPoint(bufPtr)	((bufPtr)->buf + (bufPtr)->nextAdded)

#define RemovePoint(bufPtr)	((bufPtr)->buf + (bufPtr)->nextRemoved)








|







283
284
285
286
287
288
289
290
291
292
293
294
295
296
297

#define SpaceLeft(bufPtr)	((bufPtr)->bufLength - (bufPtr)->nextAdded)

#define IsBufferReady(bufPtr)	((bufPtr)->nextAdded > (bufPtr)->nextRemoved)

#define IsBufferEmpty(bufPtr)	((bufPtr)->nextAdded == (bufPtr)->nextRemoved)

#define IsBufferFull(bufPtr)	((bufPtr) && (bufPtr)->nextAdded >= (bufPtr)->bufLength)

#define IsBufferOverflowing(bufPtr) ((bufPtr)->nextAdded>(bufPtr)->bufLength)

#define InsertPoint(bufPtr)	((bufPtr)->buf + (bufPtr)->nextAdded)

#define RemovePoint(bufPtr)	((bufPtr)->buf + (bufPtr)->nextRemoved)

375
376
377
378
379
380
381























382
383
384
385
386


387





388





389
390
391
392
393

394
























395
396
397
398
399
400
401
    Channel *chanPtr,
    Tcl_Interp *interp,
    int flags)
{
    return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, flags);
}
























static inline int
ChanRead(
    Channel *chanPtr,
    char *dst,
    int dstSize,


    int *errnoPtr)





{





    if (WillRead(chanPtr) < 0) {
        return -1;
    }

    return chanPtr->typePtr->inputProc(chanPtr->instanceData, dst, dstSize,

	    errnoPtr);
























}

static inline Tcl_WideInt
ChanSeek(
    Channel *chanPtr,
    Tcl_WideInt offset,
    int mode,







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|



|
>
>
|
>
>
>
>
>
|
>
>
>
>
>




|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
    Channel *chanPtr,
    Tcl_Interp *interp,
    int flags)
{
    return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, flags);
}

/*
 *---------------------------------------------------------------------------
 *
 * ChanRead --
 *
 *	Read up to dstSize bytes using the inputProc of chanPtr, store
 *	them at dst, and return the number of bytes stored.
 *
 * Results:
 *	The return value of the driver inputProc,
 *	  - number of bytes stored at dst, ot
 *	  - -1 on error, with a Posix error code available to the
 *	    caller by calling Tcl_GetErrno().
 *
 * Side effects:
 *	The CHANNEL_BLOCKED and CHANNEL_EOF flags of the channel state are
 *	set as appropriate.
 *	On EOF, the inputEncodingFlags are set to perform ending operations
 *	on decoding.
 *	TODO - Is this really the right place for that?
 *
 *---------------------------------------------------------------------------
 */
static int
ChanRead(
    Channel *chanPtr,
    char *dst,
    int dstSize)
{
    int bytesRead, result;

    /*
     * If the caller asked for zero bytes, we'd force the inputProc
     * to return zero bytes, and then misinterpret that as EOF.
     */
    assert(dstSize > 0);

    /*
     * Each read op must set the blocked and eof states anew, not let
     * the effect of prior reads leak through.
     */
    ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF);
    if (WillRead(chanPtr) < 0) {
        return -1;
    }

    bytesRead = chanPtr->typePtr->inputProc(chanPtr->instanceData,
	    dst, dstSize, &result);

    /* Stop any flag leakage through stacked channel levels */
    ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF);
    if (bytesRead > 0) {
	/*
	 * If we get a short read, signal up that we may be BLOCKED.
	 * We should avoid calling the driver because on some
	 * platforms we will block in the low level reading code even
	 * though the channel is set into nonblocking mode.
	 */

	if (bytesRead < dstSize) {
	    SetFlag(chanPtr->state, CHANNEL_BLOCKED);
	}
    } else if (bytesRead == 0) {
	SetFlag(chanPtr->state, CHANNEL_EOF);
	chanPtr->state->inputEncodingFlags |= TCL_ENCODING_END;
    } else if (bytesRead < 0) {
	if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
	    SetFlag(chanPtr->state, CHANNEL_BLOCKED);
	    result = EAGAIN;
	}
	Tcl_SetErrno(result);
    }
    return bytesRead;
}

static inline Tcl_WideInt
ChanSeek(
    Channel *chanPtr,
    Tcl_WideInt offset,
    int mode,
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
    CheckForStdChannelsBeingClosed(chan);

    /*
     * If the refCount reached zero, close the actual channel.
     */

    if (statePtr->refCount <= 0) {
	/*
	 * Ensure that if there is another buffer, it gets flushed whether or
	 * not we are doing a background flush.
	 */

	if ((statePtr->curOutPtr != NULL) &&
		IsBufferReady(statePtr->curOutPtr)) {
	    SetFlag(statePtr, BUFFER_READY);
	}
	Tcl_Preserve(statePtr);
	if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
	    /*
	     * We don't want to re-enter Tcl_Close().
	     */

	    if (!GotFlag(statePtr, CHANNEL_CLOSED)) {







<
<
<
<
<
<
<
<
<







1233
1234
1235
1236
1237
1238
1239









1240
1241
1242
1243
1244
1245
1246
    CheckForStdChannelsBeingClosed(chan);

    /*
     * If the refCount reached zero, close the actual channel.
     */

    if (statePtr->refCount <= 0) {









	Tcl_Preserve(statePtr);
	if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
	    /*
	     * We don't want to re-enter Tcl_Close().
	     */

	    if (!GotFlag(statePtr, CHANNEL_CLOSED)) {
1739
1740
1741
1742
1743
1744
1745




1746
1747
1748
1749
1750
1751
1752
    if ((mask & TCL_WRITABLE) != 0) {
	CopyState *csPtrR = statePtr->csPtrR;
	CopyState *csPtrW = statePtr->csPtrW;

	statePtr->csPtrR = NULL;
	statePtr->csPtrW = NULL;





	if (Tcl_Flush((Tcl_Channel) prevChanPtr) != TCL_OK) {
	    statePtr->csPtrR = csPtrR;
	    statePtr->csPtrW = csPtrW;
	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                        "could not flush channel \"%s\"",
			Tcl_GetChannelName(prevChan)));







>
>
>
>







1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
    if ((mask & TCL_WRITABLE) != 0) {
	CopyState *csPtrR = statePtr->csPtrR;
	CopyState *csPtrW = statePtr->csPtrW;

	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;
	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                        "could not flush channel \"%s\"",
			Tcl_GetChannelName(prevChan)));
1770
1771
1772
1773
1774
1775
1776

1777
1778
1779

1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
     * the channel itself. We use the buffers in the channel below the new
     * transformation to hold the data. In the future this allows us to write
     * transformations which pre-read data and push the unused part back when
     * they are going away.
     */

    if (((mask & TCL_READABLE) != 0) && (statePtr->inQueueHead != NULL)) {

	/*
	 * Remark: It is possible that the channel buffers contain data from
	 * some earlier push-backs.

	 */

	statePtr->inQueueTail->nextPtr = prevChanPtr->inQueueHead;
	prevChanPtr->inQueueHead = statePtr->inQueueHead;

	if (prevChanPtr->inQueueTail == NULL) {
	    prevChanPtr->inQueueTail = statePtr->inQueueTail;
	}

	statePtr->inQueueHead = NULL;
	statePtr->inQueueTail = NULL;
    }

    chanPtr = ckalloc(sizeof(Channel));








>

<
|
>


|
|

|
|
<







1828
1829
1830
1831
1832
1833
1834
1835
1836

1837
1838
1839
1840
1841
1842
1843
1844
1845

1846
1847
1848
1849
1850
1851
1852
     * the channel itself. We use the buffers in the channel below the new
     * transformation to hold the data. In the future this allows us to write
     * transformations which pre-read data and push the unused part back when
     * they are going away.
     */

    if (((mask & TCL_READABLE) != 0) && (statePtr->inQueueHead != NULL)) {

	/*

	 * When statePtr->inQueueHead is not NULL, we know
	 * prevChanPtr->inQueueHead must be NULL.
	 */

	assert(prevChanPtr->inQueueHead == NULL);
	assert(prevChanPtr->inQueueTail == NULL);

	prevChanPtr->inQueueHead = statePtr->inQueueHead;
	prevChanPtr->inQueueTail = statePtr->inQueueTail;


	statePtr->inQueueHead = NULL;
	statePtr->inQueueTail = NULL;
    }

    chanPtr = ckalloc(sizeof(Channel));

1868
1869
1870
1871
1872
1873
1874







1875
1876
1877
1878
1879
1880
1881
	/*
	 * Instead of manipulating the per-thread / per-interp list/hashtable
	 * of registered channels we wind down the state of the
	 * transformation, and then restore the state of underlying channel
	 * into the old structure.
	 */








	Channel *downChanPtr = chanPtr->downChanPtr;

	/*
	 * Flush the buffers. This ensures that any data still in them at this
	 * time _is_ handled by the transformation we are unstacking right
	 * now. Restrict this to writable channels. Take care to hide a
	 * possible bg-copy in progress from Tcl_Flush and the







>
>
>
>
>
>
>







1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
	/*
	 * Instead of manipulating the per-thread / per-interp list/hashtable
	 * of registered channels we wind down the state of the
	 * transformation, and then restore the state of underlying channel
	 * into the old structure.
	 */

	/*
	 * TODO: Figure out how to handle the situation where the chan
	 * operations called below by this unstacking operation cause
	 * another unstacking recursively.  In that case the downChanPtr
	 * value we're holding on to will not be the right thing.
	 */

	Channel *downChanPtr = chanPtr->downChanPtr;

	/*
	 * Flush the buffers. This ensures that any data still in them at this
	 * time _is_ handled by the transformation we are unstacking right
	 * now. Restrict this to writable channels. Take care to hide a
	 * possible bg-copy in progress from Tcl_Flush and the
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
	chanPtr->typePtr = NULL;

	/*
	 * AK: Tcl_NotifyChannel may hold a reference to this block of memory
	 */

	Tcl_EventuallyFree(chanPtr, TCL_DYNAMIC);
	UpdateInterest(downChanPtr);

	if (result != 0) {
	    Tcl_SetErrno(result);

	    /*
	     * TIP #219, Tcl Channel Reflection API.
	     * Move error messages put by the driver into the chan/ip bypass







|







2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
	chanPtr->typePtr = NULL;

	/*
	 * AK: Tcl_NotifyChannel may hold a reference to this block of memory
	 */

	Tcl_EventuallyFree(chanPtr, TCL_DYNAMIC);
	UpdateInterest(statePtr->topChanPtr);

	if (result != 0) {
	    Tcl_SetErrno(result);

	    /*
	     * TIP #219, Tcl Channel Reflection API.
	     * Move error messages put by the driver into the chan/ip bypass
2284
2285
2286
2287
2288
2289
2290

2291
2292



























2293
2294
2295
2296
2297
2298
2299

    n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING;
    bufPtr = ckalloc(n);
    bufPtr->nextAdded	= BUFFER_PADDING;
    bufPtr->nextRemoved	= BUFFER_PADDING;
    bufPtr->bufLength	= length + BUFFER_PADDING;
    bufPtr->nextPtr	= NULL;

    return bufPtr;
}




























/*
 *----------------------------------------------------------------------
 *
 * RecycleBuffer --
 *
 *	Helper function to recycle input and output buffers. Ensures that two







>


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392

    n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING;
    bufPtr = ckalloc(n);
    bufPtr->nextAdded	= BUFFER_PADDING;
    bufPtr->nextRemoved	= BUFFER_PADDING;
    bufPtr->bufLength	= length + BUFFER_PADDING;
    bufPtr->nextPtr	= NULL;
    bufPtr->refCount	= 1;
    return bufPtr;
}

static void
PreserveChannelBuffer(
    ChannelBuffer *bufPtr)
{
    if (bufPtr->refCount == 0) {
	Tcl_Panic("Reuse of ChannelBuffer! %p", bufPtr);
    }
    bufPtr->refCount++;
}

static void
ReleaseChannelBuffer(
    ChannelBuffer *bufPtr)
{
    if (--bufPtr->refCount) {
	return;
    }
    ckfree(bufPtr);
}

static int
IsShared(
    ChannelBuffer *bufPtr)
{
    return bufPtr->refCount > 1;
}

/*
 *----------------------------------------------------------------------
 *
 * RecycleBuffer --
 *
 *	Helper function to recycle input and output buffers. Ensures that two
2316
2317
2318
2319
2320
2321
2322


2323

2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
    ChannelBuffer *bufPtr,	/* The buffer to recycle. */
    int mustDiscard)		/* If nonzero, free the buffer to the OS,
				 * always. */
{
    /*
     * Do we have to free the buffer to the OS?
     */




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

    /*
     * Only save buffers which are at least as big as the requested buffersize
     * for the channel. This is to honor dynamic changes of the buffersize
     * made by the user.
     */

    if ((bufPtr->bufLength - BUFFER_PADDING) < statePtr->bufSize) {
	ckfree(bufPtr);
	return;
    }

    /*
     * Only save buffers for the input queue if the channel is readable.
     */








>
>
|
>

|




|
|



|
|







2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
    ChannelBuffer *bufPtr,	/* The buffer to recycle. */
    int mustDiscard)		/* If nonzero, free the buffer to the OS,
				 * always. */
{
    /*
     * Do we have to free the buffer to the OS?
     */
    if (IsShared(bufPtr)) {
	mustDiscard = 1;
    }

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

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

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

    /*
     * Only save buffers for the input queue if the channel is readable.
     */

2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
	}
    }

    /*
     * If we reached this code we return the buffer to the OS.
     */

    ckfree(bufPtr);
    return;

  keepBuffer:
    bufPtr->nextRemoved = BUFFER_PADDING;
    bufPtr->nextAdded = BUFFER_PADDING;
    bufPtr->nextPtr = NULL;
}







|







2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
	}
    }

    /*
     * If we reached this code we return the buffer to the OS.
     */

    ReleaseChannelBuffer(bufPtr);
    return;

  keepBuffer:
    bufPtr->nextRemoved = BUFFER_PADDING;
    bufPtr->nextAdded = BUFFER_PADDING;
    bufPtr->nextPtr = NULL;
}
2402
2403
2404
2405
2406
2407
2408





2409
2410
2411
2412
2413
2414
2415
    while (statePtr->outQueueHead != NULL) {
	bufPtr = statePtr->outQueueHead;
	statePtr->outQueueHead = bufPtr->nextPtr;
	RecycleBuffer(statePtr, bufPtr, 0);
    }
    statePtr->outQueueHead = NULL;
    statePtr->outQueueTail = NULL;





}

/*
 *----------------------------------------------------------------------
 *
 * CheckForDeadChannel --
 *







>
>
>
>
>







2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
    while (statePtr->outQueueHead != NULL) {
	bufPtr = statePtr->outQueueHead;
	statePtr->outQueueHead = bufPtr->nextPtr;
	RecycleBuffer(statePtr, bufPtr, 0);
    }
    statePtr->outQueueHead = NULL;
    statePtr->outQueueTail = NULL;
    bufPtr = statePtr->curOutPtr;
    if (bufPtr && BytesLeft(bufPtr)) {
	statePtr->curOutPtr = NULL;
	RecycleBuffer(statePtr, bufPtr, 0);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * CheckForDeadChannel --
 *
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494





































2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567

2568
2569
2570
2571
2572
2573
2574
    Channel *chanPtr,		/* The channel to flush on. */
    int calledFromAsyncFlush)	/* If nonzero then we are being called from an
				 * asynchronous flush callback. */
{
    ChannelState *statePtr = chanPtr->state;
				/* State of the channel stack. */
    ChannelBuffer *bufPtr;	/* Iterates over buffered output queue. */
    int toWrite;		/* Amount of output data in current buffer
				 * available to be written. */
    int written;		/* Amount of output data actually written in
				 * current round. */
    int errorCode = 0;		/* Stores POSIX error codes from channel
				 * driver operations. */
    int wroteSome = 0;		/* Set to one if any data was written to the
				 * driver. */

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

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






































    /*
     * Loop over the queued buffers and attempt to flush as much as possible
     * of the queued output to the channel.
     */

    Tcl_Preserve(chanPtr);
    while (1) {
	/*
	 * If the queue is empty and there is a ready current buffer, OR if
	 * the current buffer is full, then move the current buffer to the
	 * queue.
	 */

	if (((statePtr->curOutPtr != NULL) &&
		IsBufferFull(statePtr->curOutPtr))
		|| (GotFlag(statePtr, BUFFER_READY) &&
			(statePtr->outQueueHead == NULL))) {
	    ResetFlag(statePtr, BUFFER_READY);
	    statePtr->curOutPtr->nextPtr = NULL;
	    if (statePtr->outQueueHead == NULL) {
		statePtr->outQueueHead = statePtr->curOutPtr;
	    } else {
		statePtr->outQueueTail->nextPtr = statePtr->curOutPtr;
	    }
	    statePtr->outQueueTail = statePtr->curOutPtr;
	    statePtr->curOutPtr = NULL;
	}
	bufPtr = statePtr->outQueueHead;

	/*
	 * If we are not being called from an async flush and an async flush
	 * is active, we just return without producing any output.
	 */

	if (!calledFromAsyncFlush && GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
	    errorCode = 0;
	    goto done;
	}

	/*
	 * If the output queue is still empty, break out of the while loop.
	 */

	if (bufPtr == NULL) {
	    break;		/* Out of the "while (1)". */
	}

	/*
	 * Produce the output on the channel.
	 */

	toWrite = BytesLeft(bufPtr);
	if (toWrite == 0) {
            written = 0;
	} else {
	    written = ChanWrite(chanPtr, RemovePoint(bufPtr), toWrite,
		    &errorCode);
	}

	/*
	 * If the write failed completely attempt to start the asynchronous
	 * flush mechanism and break out of this loop - do not attempt to
	 * write any more output at this time.
	 */

	if (written < 0) {
	    /*
	     * If the last attempt to write was interrupted, simply retry.
	     */

	    if (errorCode == EINTR) {
		errorCode = 0;

		continue;
	    }

	    /*
	     * If the channel is non-blocking and we would have blocked, start
	     * a background flushing handler and break out of the loop.
	     */







<
<

















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




|
<
<
<
|
|
<














>







2570
2571
2572
2573
2574
2575
2576


2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637













2638







2639
2640


















2641
2642
2643
2644
2645



2646
2647

2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
    Channel *chanPtr,		/* The channel to flush on. */
    int calledFromAsyncFlush)	/* If nonzero then we are being called from an
				 * asynchronous flush callback. */
{
    ChannelState *statePtr = chanPtr->state;
				/* State of the channel stack. */
    ChannelBuffer *bufPtr;	/* Iterates over buffered output queue. */


    int written;		/* Amount of output data actually written in
				 * current round. */
    int errorCode = 0;		/* Stores POSIX error codes from channel
				 * driver operations. */
    int wroteSome = 0;		/* Set to one if any data was written to the
				 * driver. */

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

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

    /*
     * Should we shift the current output buffer over to the output queue?
     * First check that there are bytes in it.  If so then...
     * If the output queue is empty, then yes, trusting the caller called
     * us only when written bytes ought to be flushed.
     * If the current output buffer is full, then yes, so we can meet
     * the post-condition that on a successful return to caller we've
     * left space in the current output buffer for more writing (the flush
     * call was to make new room).
     * Otherwise, no.  Keep the current output buffer where it is so more
     * can be written to it, possibly filling it, to promote more efficient
     * buffer usage.
     */

    bufPtr = statePtr->curOutPtr;
    if (bufPtr && BytesLeft(bufPtr) && /* Keep empties off queue */
	    (statePtr->outQueueHead == NULL || IsBufferFull(bufPtr))) {
	if (statePtr->outQueueHead == NULL) {
	    statePtr->outQueueHead = bufPtr;
	} else {
	    statePtr->outQueueTail->nextPtr = bufPtr;
	}
	statePtr->outQueueTail = bufPtr;
	statePtr->curOutPtr = NULL;
    }

    assert(!IsBufferFull(statePtr->curOutPtr));

    /*
     * If we are not being called from an async flush and an async flush
     * is active, we just return without producing any output.
     */

    if (!calledFromAsyncFlush && GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
	return 0;
    }

    /*
     * Loop over the queued buffers and attempt to flush as much as possible
     * of the queued output to the channel.
     */

    Tcl_Preserve(chanPtr);













    while (statePtr->outQueueHead) {







	bufPtr = statePtr->outQueueHead;



















	/*
	 * Produce the output on the channel.
	 */

	PreserveChannelBuffer(bufPtr);



	written = ChanWrite(chanPtr, RemovePoint(bufPtr), BytesLeft(bufPtr),
		&errorCode);


	/*
	 * If the write failed completely attempt to start the asynchronous
	 * flush mechanism and break out of this loop - do not attempt to
	 * write any more output at this time.
	 */

	if (written < 0) {
	    /*
	     * If the last attempt to write was interrupted, simply retry.
	     */

	    if (errorCode == EINTR) {
		errorCode = 0;
		ReleaseChannelBuffer(bufPtr);
		continue;
	    }

	    /*
	     * If the channel is non-blocking and we would have blocked, start
	     * a background flushing handler and break out of the loop.
	     */
2582
2583
2584
2585
2586
2587
2588

2589
2590
2591
2592
2593
2594
2595
		 */

		if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED) && !TclInExit()) {
		    SetFlag(statePtr, BG_FLUSH_SCHEDULED);
		    UpdateInterest(chanPtr);
		}
		errorCode = 0;

		break;
	    }

	    /*
	     * Decide whether to report the error upwards or defer it.
	     */








>







2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
		 */

		if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED) && !TclInExit()) {
		    SetFlag(statePtr, BG_FLUSH_SCHEDULED);
		    UpdateInterest(chanPtr);
		}
		errorCode = 0;
		ReleaseChannelBuffer(bufPtr);
		break;
	    }

	    /*
	     * Decide whether to report the error upwards or defer it.
	     */

2643
2644
2645
2646
2647
2648
2649

2650
2651


2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669

2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684













2685
2686
2687
2688
2689
2690
2691

	    /*
	     * When we get an error we throw away all the output currently
	     * queued.
	     */

	    DiscardOutputQueued(statePtr);

	    continue;
	} else {


	    wroteSome = 1;
	}

	if (!IsBufferEmpty(bufPtr)) {
	    bufPtr->nextRemoved += written;
	}

	/*
	 * If this buffer is now empty, recycle it.
	 */

	if (IsBufferEmpty(bufPtr)) {
	    statePtr->outQueueHead = bufPtr->nextPtr;
	    if (statePtr->outQueueHead == NULL) {
		statePtr->outQueueTail = NULL;
	    }
	    RecycleBuffer(statePtr, bufPtr, 0);
	}

    }	/* Closes "while (1)". */

    /*
     * If we wrote some data while flushing in the background, we are done.
     * We can't finish the background flush until we run out of data and the
     * channel becomes writable again. This ensures that all of the pending
     * data has been flushed at the system level.
     */

    if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
	if (wroteSome) {
	    goto done;
	} else if (statePtr->outQueueHead == NULL) {
	    ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
	    ChanWatch(chanPtr, statePtr->interestMask);













	}
    }

    /*
     * If the channel is flagged as closed, delete it when the refCount drops
     * to zero, the output queue is empty and there is no output in the
     * current output buffer.







>
|

>
>



<
|
<












>
|














>
>
>
>
>
>
>
>
>
>
>
>
>







2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753

2754

2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802

	    /*
	     * When we get an error we throw away all the output currently
	     * queued.
	     */

	    DiscardOutputQueued(statePtr);
	    ReleaseChannelBuffer(bufPtr);
	    break;
	} else {
	    /* TODO: Consider detecting and reacting to short writes
	     * on blocking channels.  Ought not happen.  See iocmd-24.2. */
	    wroteSome = 1;
	}


	bufPtr->nextRemoved += written;


	/*
	 * If this buffer is now empty, recycle it.
	 */

	if (IsBufferEmpty(bufPtr)) {
	    statePtr->outQueueHead = bufPtr->nextPtr;
	    if (statePtr->outQueueHead == NULL) {
		statePtr->outQueueTail = NULL;
	    }
	    RecycleBuffer(statePtr, bufPtr, 0);
	}
	ReleaseChannelBuffer(bufPtr);
    }	/* Closes "while". */

    /*
     * If we wrote some data while flushing in the background, we are done.
     * We can't finish the background flush until we run out of data and the
     * channel becomes writable again. This ensures that all of the pending
     * data has been flushed at the system level.
     */

    if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
	if (wroteSome) {
	    goto done;
	} else if (statePtr->outQueueHead == NULL) {
	    ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
	    ChanWatch(chanPtr, statePtr->interestMask);
	} else {

	    /*
	     * When we are calledFromAsyncFlush, that means a writable
	     * state on the channel triggered the call, so we should be
	     * able to write something.  Either we did write something 
	     * and wroteSome should be set, or there was nothing left to
	     * write in this call, and we've completed the BG flush.
	     * These are the two cases above.  If we get here, that means
	     * there is some kind failure in the writable event machinery.
	     */

	    assert(!calledFromAsyncFlush);
	}
    }

    /*
     * If the channel is flagged as closed, delete it when the refCount drops
     * to zero, the output queue is empty and there is no output in the
     * current output buffer.
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
    DiscardInputQueued(statePtr, 1);

    /*
     * Discard a leftover buffer in the current output buffer field.
     */

    if (statePtr->curOutPtr != NULL) {
	ckfree(statePtr->curOutPtr);
	statePtr->curOutPtr = NULL;
    }

    /*
     * The caller guarantees that there are no more buffers queued for output.
     */








|







2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
    DiscardInputQueued(statePtr, 1);

    /*
     * Discard a leftover buffer in the current output buffer field.
     */

    if (statePtr->curOutPtr != NULL) {
	ReleaseChannelBuffer(statePtr->curOutPtr);
	statePtr->curOutPtr = NULL;
    }

    /*
     * The caller guarantees that there are no more buffers queued for output.
     */

3176
3177
3178
3179
3180
3181
3182
3183


3184


3185
3186




3187
3188
3189
3190
3191
3192
3193
    /*
     * When the channel has an escape sequence driven encoding such as
     * iso2022, the terminated escape sequence must write to the buffer.
     */

    stickyError = 0;

    if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL)


	    && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {


	statePtr->outputEncodingFlags |= TCL_ENCODING_END;
	if (WriteChars(chanPtr, "", 0) < 0) {




	    stickyError = Tcl_GetErrno();
	}

	/*
	 * TIP #219, Tcl Channel Reflection API.
	 * Move an error message found in the channel bypass into the
	 * interpreter bypass. Just clear it if there is no interpreter.







|
>
>
|
>
>
|
|
>
>
>
>







3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
    /*
     * When the channel has an escape sequence driven encoding such as
     * iso2022, the terminated escape sequence must write to the buffer.
     */

    stickyError = 0;

    if (GotFlag(statePtr, TCL_WRITABLE) && (statePtr->encoding != NULL)
	    && !(statePtr->outputEncodingFlags & TCL_ENCODING_START)) {

	int code = CheckChannelErrors(statePtr, TCL_WRITABLE);

	if (code == 0) {
	    statePtr->outputEncodingFlags |= TCL_ENCODING_END;
	    code = WriteChars(chanPtr, "", 0);
	    statePtr->outputEncodingFlags &= ~TCL_ENCODING_END;
	    statePtr->outputEncodingFlags |= TCL_ENCODING_START;
	}
	if (code < 0) {
	    stickyError = Tcl_GetErrno();
	}

	/*
	 * TIP #219, Tcl Channel Reflection API.
	 * Move an error message found in the channel bypass into the
	 * interpreter bypass. Just clear it if there is no interpreter.
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
	statePtr->closeCbPtr = cbPtr->nextPtr;
	cbPtr->proc(cbPtr->clientData);
	ckfree(cbPtr);
    }

    ResetFlag(statePtr, CHANNEL_INCLOSE);

    /*
     * Ensure that the last output buffer will be flushed.
     */

    if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) {
	SetFlag(statePtr, BUFFER_READY);
    }

    /*
     * If this channel supports it, close the read side, since we don't need
     * it anymore and this will help avoid deadlocks on some channel types.
     */

    if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) {
	result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp,







<
<
<
<
<
<
<
<







3332
3333
3334
3335
3336
3337
3338








3339
3340
3341
3342
3343
3344
3345
	statePtr->closeCbPtr = cbPtr->nextPtr;
	cbPtr->proc(cbPtr->clientData);
	ckfree(cbPtr);
    }

    ResetFlag(statePtr, CHANNEL_INCLOSE);









    /*
     * If this channel supports it, close the read side, since we don't need
     * it anymore and this will help avoid deadlocks on some channel types.
     */

    if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) {
	result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp,
3266
3267
3268
3269
3270
3271
3272








3273


3274
3275
3276
3277
3278
3279
3280

    if (stickyError != 0) {
	Tcl_SetErrno(stickyError);
	if (interp != NULL) {
	    Tcl_SetObjResult(interp,
			     Tcl_NewStringObj(Tcl_PosixError(interp), -1));
	}








	flushcode = -1;


    }
    if ((flushcode != 0) || (result != 0)) {
	return TCL_ERROR;
    }
    return TCL_OK;
}








>
>
>
>
>
>
>
>
|
>
>







3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401

    if (stickyError != 0) {
	Tcl_SetErrno(stickyError);
	if (interp != NULL) {
	    Tcl_SetObjResult(interp,
			     Tcl_NewStringObj(Tcl_PosixError(interp), -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;
    }
    return TCL_OK;
}

3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
	/*
	 * Call the finalization code directly. There are no events to handle,
	 * there cannot be for the read-side.
	 */

	return CloseChannelPart(interp, chanPtr, 0, flags);
    } else if (flags & TCL_CLOSE_WRITE) {
	if ((statePtr->curOutPtr != NULL) &&
		IsBufferReady(statePtr->curOutPtr)) {
	    SetFlag(statePtr, BUFFER_READY);
	}
	Tcl_Preserve(statePtr);
	if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
	    /*
	     * We don't want to re-enter CloseWrite().
	     */

	    if (!GotFlag(statePtr, CHANNEL_CLOSEDWRITE)) {







<
<
<
<







3500
3501
3502
3503
3504
3505
3506




3507
3508
3509
3510
3511
3512
3513
	/*
	 * Call the finalization code directly. There are no events to handle,
	 * there cannot be for the read-side.
	 */

	return CloseChannelPart(interp, chanPtr, 0, flags);
    } else if (flags & TCL_CLOSE_WRITE) {




	Tcl_Preserve(statePtr);
	if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
	    /*
	     * We don't want to re-enter CloseWrite().
	     */

	    if (!GotFlag(statePtr, CHANNEL_CLOSEDWRITE)) {
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
    /* No close cllbacks are run - channel is still open (read side) */

    ChannelState *statePtr = chanPtr->state;
                                /* State of real IO channel. */
    int flushcode;
    int result = 0;

    /*
     * Ensure that the last output buffer will be flushed.
     */

    if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) {
	SetFlag(statePtr, BUFFER_READY);
    }

    /*
     * The call to FlushChannel will flush any queued output and invoke the
     * close function of the channel driver, or it will set up the channel to
     * be flushed and closed asynchronously.
     */

    SetFlag(statePtr, CHANNEL_CLOSEDWRITE);







<
<
<
<
<
<
<
<







3560
3561
3562
3563
3564
3565
3566








3567
3568
3569
3570
3571
3572
3573
    /* No close cllbacks are run - channel is still open (read side) */

    ChannelState *statePtr = chanPtr->state;
                                /* State of real IO channel. */
    int flushcode;
    int result = 0;









    /*
     * The call to FlushChannel will flush any queued output and invoke the
     * close function of the channel driver, or it will set up the channel to
     * be flushed and closed asynchronously.
     */

    SetFlag(statePtr, CHANNEL_CLOSEDWRITE);
3963
3964
3965
3966
3967
3968
3969






3970
3971
3972
3973
3974









3975
3976
3977
3978
3979
3980
3981
3982
    }
}

static int
WillRead(
    Channel *chanPtr)
{






    if ((chanPtr->typePtr->seekProc != NULL)
            && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) {
        if ((chanPtr->state->curOutPtr != NULL)
                && IsBufferReady(chanPtr->state->curOutPtr)) {
            SetFlag(chanPtr->state, BUFFER_READY);









        }
        if (FlushChannel(NULL, chanPtr, 0) != 0) {
            return -1;
        }
    }
    return 0;
}








>
>
>
>
>
>


|
<
<
>
>
>
>
>
>
>
>
>
|







4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087


4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
    }
}

static int
WillRead(
    Channel *chanPtr)
{
    if (chanPtr->typePtr == NULL) {
	/* Prevent read attempts on a closed channel */
        DiscardInputQueued(chanPtr->state, 0);
	Tcl_SetErrno(EINVAL);
	return -1;
    }
    if ((chanPtr->typePtr->seekProc != NULL)
            && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) {



	/*
	 * CAVEAT - The assumption here is that FlushChannel() will
	 * push out the bytes of any writes that are in progress.
	 * Since this is a seekable channel, we assume it is not one
	 * that can block and force bg flushing.  Channels we know that
	 * can do that -- sockets, pipes -- are not seekable.  If the
	 * assumption is wrong, more drastic measures may be required here
	 * like temporarily setting the channel into blocking mode.
	 */

        if (FlushChannel(NULL, chanPtr, 0) != 0) {
            return -1;
        }
    }
    return 0;
}

4049
4050
4051
4052
4053
4054
4055

4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068

4069
4070
4071
4072
4073
4074
4075
	     * that we need to stick at the beginning of this buffer.
	     */

	    memcpy(InsertPoint(bufPtr), safe, (size_t) saved);
	    bufPtr->nextAdded += saved;
	    saved = 0;
	}

	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 */

	    if (total == 0) {
		Tcl_SetErrno(EINVAL);
		return -1;
	    }
	    break;
	}








>













>







4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
	     * that we need to stick at the beginning of this buffer.
	     */

	    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;
	}

4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
	    }
	
	    result |= Tcl_UtfToExternal(NULL, encoding, nl, nlLen,
		statePtr->outputEncodingFlags,
		&statePtr->outputEncodingState, dst,
		dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL);

	    if (srcRead != nlLen) {
		Tcl_Panic("Can This Happen?");
	    }

	    bufPtr->nextAdded += dstWrote;
	    src++;
	    srcLen--;
	    total += dstWrote;
	    dst += dstWrote;
	    dstLen -= dstWrote;







|
<
<







4228
4229
4230
4231
4232
4233
4234
4235


4236
4237
4238
4239
4240
4241
4242
	    }
	
	    result |= Tcl_UtfToExternal(NULL, encoding, nl, nlLen,
		statePtr->outputEncodingFlags,
		&statePtr->outputEncodingState, dst,
		dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL);

	    assert (srcRead == nlLen);



	    bufPtr->nextAdded += dstWrote;
	    src++;
	    srcLen--;
	    total += dstWrote;
	    dst += dstWrote;
	    dstLen -= dstWrote;
4138
4139
4140
4141
4142
4143
4144

4145
4146
4147
4148
4149
4150
4151

4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162

	if ((srcLen + saved == 0) && (result == TCL_OK)) {
	    endEncoding = 0;
	}

	if (IsBufferFull(bufPtr)) {
	    if (FlushChannel(NULL, chanPtr, 0) != 0) {

		return -1;
	    }
	    flushed += statePtr->bufSize;
	    if (saved == 0 || src[-1] != '\n') {
		needNlFlush = 0;
	    }
	}

    }
    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 total;
}







>







>



<







4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278

4279
4280
4281
4282
4283
4284
4285

	if ((srcLen + saved == 0) && (result == TCL_OK)) {
	    endEncoding = 0;
	}

	if (IsBufferFull(bufPtr)) {
	    if (FlushChannel(NULL, chanPtr, 0) != 0) {
		ReleaseChannelBuffer(bufPtr);
		return -1;
	    }
	    flushed += statePtr->bufSize;
	    if (saved == 0 || src[-1] != '\n') {
		needNlFlush = 0;
	    }
	}
	ReleaseChannelBuffer(bufPtr);
    }
    if ((flushed < total) && (GotFlag(statePtr, CHANNEL_UNBUFFERED) ||
	    (needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED)))) {

	if (FlushChannel(NULL, chanPtr, 0) != 0) {
	    return -1;
	}
    }

    return total;
}
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263

4264
4265
4266
4267
4268
4269
4270
    ChannelBuffer *bufPtr;
    int inEofChar, skip, copiedTotal, oldLength, oldFlags, oldRemoved;
    Tcl_Encoding encoding;
    char *dst, *dstEnd, *eol, *eof;
    Tcl_EncodingState oldState;

    if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
	copiedTotal = -1;
	goto done;
    }

    /*
     * A binary version of Tcl_GetsObj. This could also handle encodings that
     * are ascii-7 pure (iso8859, utf-8, ...) with a final encoding conversion
     * done on objPtr.
     */

    if ((statePtr->encoding == NULL)
	    && ((statePtr->inputTranslation == TCL_TRANSLATE_LF)
		    || (statePtr->inputTranslation == TCL_TRANSLATE_CR))) {
	return TclGetsObjBinary(chan, objPtr);
    }

    /*
     * This operation should occur at the top of a channel stack.
     */

    chanPtr = statePtr->topChanPtr;


    bufPtr = statePtr->inQueueHead;
    encoding = statePtr->encoding;

    /*
     * Preserved so we can restore the channel's state in case we don't find a
     * newline in the available input.







|
<



















>







4359
4360
4361
4362
4363
4364
4365
4366

4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
    ChannelBuffer *bufPtr;
    int inEofChar, skip, copiedTotal, oldLength, oldFlags, oldRemoved;
    Tcl_Encoding encoding;
    char *dst, *dstEnd, *eol, *eof;
    Tcl_EncodingState oldState;

    if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
	return -1;

    }

    /*
     * A binary version of Tcl_GetsObj. This could also handle encodings that
     * are ascii-7 pure (iso8859, utf-8, ...) with a final encoding conversion
     * done on objPtr.
     */

    if ((statePtr->encoding == NULL)
	    && ((statePtr->inputTranslation == TCL_TRANSLATE_LF)
		    || (statePtr->inputTranslation == TCL_TRANSLATE_CR))) {
	return TclGetsObjBinary(chan, objPtr);
    }

    /*
     * This operation should occur at the top of a channel stack.
     */

    chanPtr = statePtr->topChanPtr;
    Tcl_Preserve(chanPtr);

    bufPtr = statePtr->inQueueHead;
    encoding = statePtr->encoding;

    /*
     * Preserved so we can restore the channel's state in case we don't find a
     * newline in the available input.
4469
4470
4471
4472
4473
4474
4475

4476
4477
4478
4479
4480
4481
4482
		 * If we didn't append any bytes before encountering EOF,
		 * caller needs to see -1.
		 */

		Tcl_SetObjLength(objPtr, oldLength);
		CommonGetsCleanup(chanPtr);
		copiedTotal = -1;

		goto done;
	    }
	    goto gotEOL;
	}
	dst = dstEnd;
    }








>







4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
		 * If we didn't append any bytes before encountering EOF,
		 * caller needs to see -1.
		 */

		Tcl_SetObjLength(objPtr, oldLength);
		CommonGetsCleanup(chanPtr);
		copiedTotal = -1;
		ResetFlag(statePtr, CHANNEL_BLOCKED);
		goto done;
	    }
	    goto gotEOL;
	}
	dst = dstEnd;
    }

4490
4491
4492
4493
4494
4495
4496


4497


4498
4499
4500
4501
4502
4503
4504

  gotEOL:
    /*
     * Regenerate the top channel, in case it was changed due to
     * self-modifying reflected transforms.
     */



    chanPtr = statePtr->topChanPtr;



    bufPtr = gs.bufPtr;
    if (bufPtr == NULL) {
	Tcl_Panic("Tcl_GetsObj: gotEOL reached with bufPtr==NULL");
    }
    statePtr->inputEncodingState = gs.state;
    Tcl_ExternalToUtf(NULL, gs.encoding, RemovePoint(bufPtr), gs.rawRead,







>
>
|
>
>







4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632

  gotEOL:
    /*
     * Regenerate the top channel, in case it was changed due to
     * self-modifying reflected transforms.
     */

    if (chanPtr != statePtr->topChanPtr) {
	Tcl_Release(chanPtr);
	chanPtr = statePtr->topChanPtr;
	Tcl_Preserve(chanPtr);
    }

    bufPtr = gs.bufPtr;
    if (bufPtr == NULL) {
	Tcl_Panic("Tcl_GetsObj: gotEOL reached with bufPtr==NULL");
    }
    statePtr->inputEncodingState = gs.state;
    Tcl_ExternalToUtf(NULL, gs.encoding, RemovePoint(bufPtr), gs.rawRead,
4524
4525
4526
4527
4528
4529
4530
4531

4532

4533
4534
4535

4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
     */

  restore:
    /*
     * Regenerate the top channel, in case it was changed due to
     * self-modifying reflected transforms.
     */


    chanPtr = statePtr->topChanPtr;


    bufPtr = statePtr->inQueueHead;
    if (bufPtr == NULL) {

	Tcl_Panic("Tcl_GetsObj: restore reached with bufPtr==NULL");
    }
    bufPtr->nextRemoved = oldRemoved;

    for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) {
	bufPtr->nextRemoved = BUFFER_PADDING;
    }
    CommonGetsCleanup(chanPtr);

    statePtr->inputEncodingState = oldState;
    statePtr->inputEncodingFlags = oldFlags;
    Tcl_SetObjLength(objPtr, oldLength);







|
>
|
>
|

|
>
|

<

|







4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668

4669
4670
4671
4672
4673
4674
4675
4676
4677
     */

  restore:
    /*
     * Regenerate the top channel, in case it was changed due to
     * self-modifying reflected transforms.
     */
    if (chanPtr != statePtr->topChanPtr) {
	Tcl_Release(chanPtr);
	chanPtr = statePtr->topChanPtr;
	Tcl_Preserve(chanPtr);
    }
    bufPtr = statePtr->inQueueHead;
    if (bufPtr != NULL) {
	bufPtr->nextRemoved = oldRemoved;
	bufPtr = bufPtr->nextPtr;
    }


    for ( ; bufPtr != NULL; bufPtr = bufPtr->nextPtr) {
	bufPtr->nextRemoved = BUFFER_PADDING;
    }
    CommonGetsCleanup(chanPtr);

    statePtr->inputEncodingState = oldState;
    statePtr->inputEncodingFlags = oldFlags;
    Tcl_SetObjLength(objPtr, oldLength);
4566
4567
4568
4569
4570
4571
4572
4573

4574

4575
4576

4577
4578
4579
4580
4581
4582
4583
     */

  done:
    /*
     * Regenerate the top channel, in case it was changed due to
     * self-modifying reflected transforms.
     */


    chanPtr = statePtr->topChanPtr;


    UpdateInterest(chanPtr);

    return copiedTotal;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclGetsObjBinary --







|
>
|
>
|

>







4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
     */

  done:
    /*
     * Regenerate the top channel, in case it was changed due to
     * self-modifying reflected transforms.
     */
    if (chanPtr != statePtr->topChanPtr) {
	Tcl_Release(chanPtr);
	chanPtr = statePtr->topChanPtr;
	Tcl_Preserve(chanPtr);
    }
    UpdateInterest(chanPtr);
    Tcl_Release(chanPtr);
    return copiedTotal;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclGetsObjBinary --
4615
4616
4617
4618
4619
4620
4621

4622
4623
4624
4625
4626
4627
4628
    unsigned char *dst, *dstEnd, *eol, *eof, *byteArray;

    /*
     * This operation should occur at the top of a channel stack.
     */

    chanPtr = statePtr->topChanPtr;


    bufPtr = statePtr->inQueueHead;

    /*
     * Preserved so we can restore the channel's state in case we don't find a
     * newline in the available input.
     */







>







4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
    unsigned char *dst, *dstEnd, *eol, *eof, *byteArray;

    /*
     * This operation should occur at the top of a channel stack.
     */

    chanPtr = statePtr->topChanPtr;
    Tcl_Preserve(chanPtr);

    bufPtr = statePtr->inQueueHead;

    /*
     * Preserved so we can restore the channel's state in case we don't find a
     * newline in the available input.
     */
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678



4679
4680
4681
4682
4683
4684
4685
	if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) {
	    /*
	     * All channel buffers were exhausted and the caller still
	     * hasn't seen EOL. Need to read more bytes from the channel
	     * device. Side effect is to allocate another channel buffer.
	     */

	    if (GotFlag(statePtr, CHANNEL_BLOCKED)) {
		if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
		    goto restore;
		}
		ResetFlag(statePtr, CHANNEL_BLOCKED);
	    }
	    if (GetInput(chanPtr) != 0) {
		goto restore;
	    }
	    bufPtr = statePtr->inQueueTail;



	}

	dst = (unsigned char *) RemovePoint(bufPtr);
	dstEnd = dst + BytesLeft(bufPtr);

	/*
	 * Remember if EOF char is seen, then look for EOL anyhow, because the







|
|
|
<
<





>
>
>







4796
4797
4798
4799
4800
4801
4802
4803
4804
4805


4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
	if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) {
	    /*
	     * All channel buffers were exhausted and the caller still
	     * hasn't seen EOL. Need to read more bytes from the channel
	     * device. Side effect is to allocate another channel buffer.
	     */

	    if (GotFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_NONBLOCKING)
		    == (CHANNEL_BLOCKED|CHANNEL_NONBLOCKING)) {
		goto restore;


	    }
	    if (GetInput(chanPtr) != 0) {
		goto restore;
	    }
	    bufPtr = statePtr->inQueueTail;
	    if (bufPtr == NULL) {
		goto restore;
	    }
	}

	dst = (unsigned char *) RemovePoint(bufPtr);
	dstEnd = dst + BytesLeft(bufPtr);

	/*
	 * Remember if EOF char is seen, then look for EOL anyhow, because the
4726
4727
4728
4729
4730
4731
4732

4733
4734
4735
4736
4737
4738
4739
		 * If we didn't append any bytes before encountering EOF,
		 * caller needs to see -1.
		 */

		byteArray = Tcl_SetByteArrayLength(objPtr, oldLength);
		CommonGetsCleanup(chanPtr);
		copiedTotal = -1;

		goto done;
	    }
	    goto gotEOL;
	}

	/*
	 * Copy bytes from the channel buffer to the ByteArray.







>







4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
		 * If we didn't append any bytes before encountering EOF,
		 * caller needs to see -1.
		 */

		byteArray = Tcl_SetByteArrayLength(objPtr, oldLength);
		CommonGetsCleanup(chanPtr);
		copiedTotal = -1;
		ResetFlag(statePtr, CHANNEL_BLOCKED);
		goto done;
	    }
	    goto gotEOL;
	}

	/*
	 * Copy bytes from the channel buffer to the ByteArray.
4784
4785
4786
4787
4788
4789
4790
4791

4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
     * Couldn't get a complete line. This only happens if we get a error
     * reading from the channel or we are non-blocking and there wasn't an EOL
     * or EOF in the data available.
     */

  restore:
    bufPtr = statePtr->inQueueHead;
    if (bufPtr == NULL) {

	Tcl_Panic("TclGetsObjBinary: restore reached with bufPtr==NULL");
    }
    bufPtr->nextRemoved = oldRemoved;

    for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) {
	bufPtr->nextRemoved = BUFFER_PADDING;
    }
    CommonGetsCleanup(chanPtr);

    statePtr->inputEncodingFlags = oldFlags;
    byteArray = Tcl_SetByteArrayLength(objPtr, oldLength);








|
>
|

<

|







4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930

4931
4932
4933
4934
4935
4936
4937
4938
4939
     * Couldn't get a complete line. This only happens if we get a error
     * reading from the channel or we are non-blocking and there wasn't an EOL
     * or EOF in the data available.
     */

  restore:
    bufPtr = statePtr->inQueueHead;
    if (bufPtr) {
	bufPtr->nextRemoved = oldRemoved;
	bufPtr = bufPtr->nextPtr;
    }


    for ( ; bufPtr != NULL; bufPtr = bufPtr->nextPtr) {
	bufPtr->nextRemoved = BUFFER_PADDING;
    }
    CommonGetsCleanup(chanPtr);

    statePtr->inputEncodingFlags = oldFlags;
    byteArray = Tcl_SetByteArrayLength(objPtr, oldLength);

4818
4819
4820
4821
4822
4823
4824

4825
4826
4827
4828
4829
4830
4831
    /*
     * Update the notifier state so we don't block while there is still data
     * in the buffers.
     */

  done:
    UpdateInterest(chanPtr);

    return copiedTotal;
}

/*
 *---------------------------------------------------------------------------
 *
 * FreeBinaryEncoding --







>







4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
    /*
     * Update the notifier state so we don't block while there is still data
     * in the buffers.
     */

  done:
    UpdateInterest(chanPtr);
    Tcl_Release(chanPtr);
    return copiedTotal;
}

/*
 *---------------------------------------------------------------------------
 *
 * FreeBinaryEncoding --
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
FilterInputBytes(
    Channel *chanPtr,		/* Channel to read. */
    GetsState *gsPtr)		/* Current state of gets operation. */
{
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */
    ChannelBuffer *bufPtr;
    char *raw, *rawStart, *dst;
    int offset, toRead, dstNeeded, spaceLeft, result, rawLen;
    Tcl_Obj *objPtr;
#define ENCODING_LINESIZE 20	/* Lower bound on how many bytes to convert at
				 * a time. Since we don't know a priori how
				 * many bytes of storage this many source
				 * bytes will use, we actually need at least
				 * ENCODING_LINESIZE * TCL_MAX_UTF bytes of







|







5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
FilterInputBytes(
    Channel *chanPtr,		/* Channel to read. */
    GetsState *gsPtr)		/* Current state of gets operation. */
{
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */
    ChannelBuffer *bufPtr;
    char *raw, *dst;
    int offset, toRead, dstNeeded, spaceLeft, result, rawLen;
    Tcl_Obj *objPtr;
#define ENCODING_LINESIZE 20	/* Lower bound on how many bytes to convert at
				 * a time. Since we don't know a priori how
				 * many bytes of storage this many source
				 * bytes will use, we actually need at least
				 * ENCODING_LINESIZE * TCL_MAX_UTF bytes of
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949





4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
	/*
	 * All channel buffers were exhausted and the caller still hasn't seen
	 * EOL. Need to read more bytes from the channel device. Side effect
	 * is to allocate another channel buffer.
	 */

    read:
	if (GotFlag(statePtr, CHANNEL_BLOCKED)) {
	    if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
		gsPtr->charsWrote = 0;
		gsPtr->rawRead = 0;
		return -1;
	    }
	    ResetFlag(statePtr, CHANNEL_BLOCKED);
	}
	if (GetInput(chanPtr) != 0) {
	    gsPtr->charsWrote = 0;
	    gsPtr->rawRead = 0;
	    return -1;
	}
	bufPtr = statePtr->inQueueTail;
	gsPtr->bufPtr = bufPtr;





    }

    /*
     * Convert some of the bytes from the channel buffer to UTF-8. Space in
     * objPtr's string rep is used to hold the UTF-8 characters. Grow the
     * string rep if we need more space.
     */

    rawStart = RemovePoint(bufPtr);
    raw = rawStart;
    rawLen = BytesLeft(bufPtr);

    dst = *gsPtr->dstPtr;
    offset = dst - objPtr->bytes;
    toRead = ENCODING_LINESIZE;
    if (toRead > rawLen) {
	toRead = rawLen;







<
<
<
<
<
<
<
<







>
>
>
>
>








|
<







5065
5066
5067
5068
5069
5070
5071








5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092

5093
5094
5095
5096
5097
5098
5099
	/*
	 * All channel buffers were exhausted and the caller still hasn't seen
	 * EOL. Need to read more bytes from the channel device. Side effect
	 * is to allocate another channel buffer.
	 */

    read:








	if (GetInput(chanPtr) != 0) {
	    gsPtr->charsWrote = 0;
	    gsPtr->rawRead = 0;
	    return -1;
	}
	bufPtr = statePtr->inQueueTail;
	gsPtr->bufPtr = bufPtr;
	if (bufPtr == NULL) {
	    gsPtr->charsWrote = 0;
	    gsPtr->rawRead = 0;
	    return -1;
	}
    }

    /*
     * Convert some of the bytes from the channel buffer to UTF-8. Space in
     * objPtr's string rep is used to hold the UTF-8 characters. Grow the
     * string rep if we need more space.
     */

    raw = RemovePoint(bufPtr);

    rawLen = BytesLeft(bufPtr);

    dst = *gsPtr->dstPtr;
    offset = dst - objPtr->bytes;
    toRead = ENCODING_LINESIZE;
    if (toRead > rawLen) {
	toRead = rawLen;
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028






5029
5030
5031
5032
5033
5034
5035
		 * device. Fall through, returning that nothing was found.
		 */

		bufPtr->nextRemoved = bufPtr->nextAdded;
	    } else {
		/*
		 * There are no more cached raw bytes left. See if we can get
		 * some more.
		 */







		goto read;
	    }
	} else {
	    if (nextPtr == NULL) {
		nextPtr = AllocChannelBuffer(statePtr->bufSize);
		bufPtr->nextPtr = nextPtr;
		statePtr->inQueueTail = nextPtr;







|


>
>
>
>
>
>







5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
		 * device. Fall through, returning that nothing was found.
		 */

		bufPtr->nextRemoved = bufPtr->nextAdded;
	    } else {
		/*
		 * There are no more cached raw bytes left. See if we can get
		 * some more, but avoid blocking on a non-blocking channel.
		 */

		if (GotFlag(statePtr, CHANNEL_NONBLOCKING|CHANNEL_BLOCKED)
			== (CHANNEL_NONBLOCKING|CHANNEL_BLOCKED)) {
		    gsPtr->charsWrote = 0;
		    gsPtr->rawRead = 0;
		    return -1;
		}
		goto read;
	    }
	} else {
	    if (nextPtr == NULL) {
		nextPtr = AllocChannelBuffer(statePtr->bufSize);
		bufPtr->nextPtr = nextPtr;
		statePtr->inQueueTail = nextPtr;
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298


5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314


5315
5316

5317

5318
5319

5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340

5341
5342

5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370



5371
5372
5373
5374



5375



5376

5377
5378
5379
5380
5381




5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ReadRaw(
    Tcl_Channel chan,		/* The channel from which to read. */
    char *bufPtr,		/* Where to store input read. */
    int bytesToRead)		/* Maximum number of bytes to read. */
{
    Channel *chanPtr = (Channel *) chan;
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */
    int nread, result, copied, copiedNow;

    /*
     * The check below does too much because it will reject a call to this
     * function with a channel which is part of an 'fcopy'. But we have to
     * allow this here or else the chaining in the transformation drivers will
     * fail with 'file busy' error instead of retrieving and transforming the
     * data to copy.
     *
     * We let the check procedure now believe that there is no fcopy in
     * progress. A better solution than this might be an additional flag
     * argument to switch off specific checks.
     */

    if (CheckChannelErrors(statePtr, TCL_READABLE | CHANNEL_RAW_MODE) != 0) {
	return -1;
    }

    /*
     * Check for information in the push-back buffers. If there is some, use
     * it. Go to the driver only if there is none (anymore) and the caller
     * requests more bytes.
     */

    for (copied = 0; copied < bytesToRead; copied += copiedNow) {
	copiedNow = CopyBuffer(chanPtr, bufPtr + copied,


		bytesToRead - copied);
	if (copiedNow == 0) {
	    if (GotFlag(statePtr, CHANNEL_EOF)) {
		goto done;
	    }
	    if (GotFlag(statePtr, CHANNEL_BLOCKED)) {
		if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
		    goto done;
		}
		ResetFlag(statePtr, CHANNEL_BLOCKED);
	    }

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
	    /*
	     * [Bug 943274]. Better emulation of non-blocking channels for
	     * channels without BlockModeProc, by keeping track of true


	     * fileevents generated by the OS == Data waiting and reading if
	     * and only if we are sure to have data.

	     */


	    if (GotFlag(statePtr, CHANNEL_NONBLOCKING) &&

		    (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) &&
		    !GotFlag(statePtr, CHANNEL_HAS_MORE_DATA)) {
		/*
		 * We bypass the driver; it would block as no data is
		 * available.
		 */

		nread = -1;
		result = EWOULDBLOCK;
	    } else
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
	    {
		/*
		 * Now go to the driver to get as much as is possible to fill
		 * the remaining request. Do all the error handling by
		 * ourselves. The code was stolen from 'GetInput' and slightly
		 * adapted (different return value here).
		 *
		 * The case of 'bytesToRead == 0' at this point cannot happen.
		 */


		nread = ChanRead(chanPtr, bufPtr + copied,
			bytesToRead - copied, &result);

	    }

	    if (nread > 0) {
		/*
		 * If we get a short read, signal up that we may be BLOCKED.
		 * We should avoid calling the driver because on some
		 * platforms we will block in the low level reading code even
		 * though the channel is set into nonblocking mode.
		 */

		if (nread < (bytesToRead - copied)) {
		    SetFlag(statePtr, CHANNEL_BLOCKED);
		}

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
		if (nread <= (bytesToRead - copied)) {
		    /*
		     * [Bug 943274] We have read the available data, clear
		     * flag.
		     */

		    ResetFlag(statePtr, CHANNEL_HAS_MORE_DATA);
		}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
	    } else if (nread == 0) {
		SetFlag(statePtr, CHANNEL_EOF);
		statePtr->inputEncodingFlags |= TCL_ENCODING_END;




	    } else if (nread < 0) {
		if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
		    if (copied > 0) {
			/*



			 * Information that was copied earlier has precedence



			 * over EAGAIN/WOULDBLOCK handling.

			 */

			return copied;
		    }





		    SetFlag(statePtr, CHANNEL_BLOCKED);
		    result = EAGAIN;
		}

		Tcl_SetErrno(result);
		return -1;
	    }

	    return copied + nread;
	}
    }

  done:
    return copied;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_ReadChars --







|





<
|
<
<
<
<
<
<
<
<
<
<
<





<
|
<
<
<

|
|
>
>
|
<
<
<
|
<
<
|
|
<
<
|
<
<
<
<
>
>
|
<
>
|
>

|
>
|
<
<
<
|
<
|
<
<
<
<
<
<
<
<
<
|
<
<
<
|
>
|
<
>
|
<
<
<
<
<
<
<
<
<
|
<
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<

>
>
>
|
<
<
|
>
>
>
|
>
>
>
|
>
|
|
|
|
|
>
>
>
>
|
<
|
|
<
<
<
<
<
<
<
<
<







5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411

5412











5413
5414
5415
5416
5417

5418



5419
5420
5421
5422
5423
5424



5425


5426
5427


5428




5429
5430
5431

5432
5433
5434
5435
5436
5437
5438



5439

5440









5441



5442
5443
5444

5445
5446









5447

5448
5449













5450
5451
5452
5453
5454


5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474

5475
5476









5477
5478
5479
5480
5481
5482
5483
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ReadRaw(
    Tcl_Channel chan,		/* The channel from which to read. */
    char *readBuf,		/* Where to store input read. */
    int bytesToRead)		/* Maximum number of bytes to read. */
{
    Channel *chanPtr = (Channel *) chan;
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */

    int copied = 0;












    if (CheckChannelErrors(statePtr, TCL_READABLE | CHANNEL_RAW_MODE) != 0) {
	return -1;
    }


    /* First read bytes from the push-back buffers. */




    while (chanPtr->inQueueHead && bytesToRead > 0) {
	ChannelBuffer *bufPtr = chanPtr->inQueueHead;
	int bytesInBuffer = BytesLeft(bufPtr);
	int toCopy = (bytesInBuffer < bytesToRead) ? bytesInBuffer
		: bytesToRead;






	/* Copy the current chunk into the read buffer. */



	memcpy(readBuf, RemovePoint(bufPtr), (size_t) toCopy);




	bufPtr->nextRemoved += toCopy;
	copied += toCopy;
	readBuf += toCopy;

	bytesToRead -= toCopy;

	/* If the current buffer is empty recycle it. */

	if (IsBufferEmpty(bufPtr)) {
	    chanPtr->inQueueHead = bufPtr->nextPtr;
	    if (chanPtr->inQueueHead == NULL) {



		chanPtr->inQueueTail = NULL;

	    }









	    RecycleBuffer(chanPtr->state, bufPtr, 0);



	}
    }


    /* Go to the driver if more data needed. */










    if (bytesToRead > 0) {


	int nread = ChanRead(chanPtr, readBuf+copied, bytesToRead);














	if (nread > 0) {
	    /* Successful read (short is OK) - add to bytes copied */
	    copied += nread;
	} else if (nread < 0) {


	    /*
	     * An error signaled.  If CHANNEL_BLOCKED, then the error
	     * is not real, but an indication of blocked state.  In
	     * that case, retain the flag and let caller receive the
	     * short read of copied bytes from the pushback.
	     * HOWEVER, if copied==0 bytes from pushback then repeat
	     * signalling the blocked state as an error to caller so
	     * there is no false report of an EOF.
	     * When !CHANNEL_BLOCKED, the error is real and passes on
	     * to caller.
	     */
	    if (!GotFlag(statePtr, CHANNEL_BLOCKED) || copied == 0) {
		copied = -1;
	    }
	} else if (copied > 0) {
	    /*
	     * nread == 0.  Driver is at EOF, but if copied>0 bytes
	     * from pushback, then we should not signal it yet.
	     */
	    ResetFlag(statePtr, CHANNEL_EOF);

	}
    }









    return copied;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_ReadChars --
5484
5485
5486
5487
5488
5489
5490
5491
5492

5493
5494
5495
5496
5497
5498
5499
5500
5501

5502




5503
5504
5505
5506
5507
5508
5509
5510
5511
5512


5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525

5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
				 * will be appended to the object. Otherwise,
				 * the data will replace the existing contents
				 * of the object. */
{
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */
    ChannelBuffer *bufPtr;
    int offset, factor, copied, copiedNow, result;
    Tcl_Encoding encoding;

#define UTF_EXPANSION_FACTOR	1024

    /*
     * This operation should occur at the top of a channel stack.
     */

    chanPtr = statePtr->topChanPtr;
    encoding = statePtr->encoding;
    factor = UTF_EXPANSION_FACTOR;






    if (appendFlag == 0) {
	if (encoding == NULL) {
	    Tcl_SetByteArrayLength(objPtr, 0);
	} else {
	    Tcl_SetObjLength(objPtr, 0);

	    /*
	     * We're going to access objPtr->bytes directly, so we must ensure
	     * that this is actually a string object (otherwise it might have
	     * been pure Unicode).


	     */

	    TclGetString(objPtr);
	}
	offset = 0;
    } else {
	if (encoding == NULL) {
	    Tcl_GetByteArrayFromObj(objPtr, &offset);
	} else {
	    TclGetStringFromObj(objPtr, &offset);
	}
    }


    for (copied = 0; (unsigned) toRead > 0; ) {
	copiedNow = -1;
	if (statePtr->inQueueHead != NULL) {
	    if (encoding == NULL) {
		copiedNow = ReadBytes(statePtr, objPtr, toRead, &offset);
	    } else {
		copiedNow = ReadChars(statePtr, objPtr, toRead, &offset,
			&factor);
	    }

	    /*
	     * If the current buffer is empty recycle it.
	     */

	    bufPtr = statePtr->inQueueHead;







|

>









>

>
>
>
>

|








>
>




<
<
<
<
<
<
|
|
|
>



|
|

|
<







5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606






5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617

5618
5619
5620
5621
5622
5623
5624
				 * will be appended to the object. Otherwise,
				 * the data will replace the existing contents
				 * of the object. */
{
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */
    ChannelBuffer *bufPtr;
    int factor, copied, copiedNow, result;
    Tcl_Encoding encoding;
    int binaryMode;
#define UTF_EXPANSION_FACTOR	1024

    /*
     * This operation should occur at the top of a channel stack.
     */

    chanPtr = statePtr->topChanPtr;
    encoding = statePtr->encoding;
    factor = UTF_EXPANSION_FACTOR;
    Tcl_Preserve(chanPtr);

    binaryMode = (encoding == NULL)
	    && (statePtr->inputTranslation == TCL_TRANSLATE_LF) 
	    && (statePtr->inEofChar == '\0');

    if (appendFlag == 0) {
	if (binaryMode) {
	    Tcl_SetByteArrayLength(objPtr, 0);
	} else {
	    Tcl_SetObjLength(objPtr, 0);

	    /*
	     * We're going to access objPtr->bytes directly, so we must ensure
	     * that this is actually a string object (otherwise it might have
	     * been pure Unicode).
	     *
	     * Probably not needed anymore.
	     */

	    TclGetString(objPtr);
	}






    }

    /* Must clear the BLOCKED flag here since we check before reading */
    ResetFlag(statePtr, CHANNEL_BLOCKED);
    for (copied = 0; (unsigned) toRead > 0; ) {
	copiedNow = -1;
	if (statePtr->inQueueHead != NULL) {
	    if (binaryMode) {
		copiedNow = ReadBytes(statePtr, objPtr, toRead);
	    } else {
		copiedNow = ReadChars(statePtr, objPtr, toRead, &factor);

	    }

	    /*
	     * If the current buffer is empty recycle it.
	     */

	    bufPtr = statePtr->inQueueHead;
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559



5560

5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575






5576

5577
5578





5579

5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596

5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620

5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
5669
5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
	    }
	}

	if (copiedNow < 0) {
	    if (GotFlag(statePtr, CHANNEL_EOF)) {
		break;
	    }
	    if (GotFlag(statePtr, CHANNEL_BLOCKED)) {
		if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
		    break;
		}



		ResetFlag(statePtr, CHANNEL_BLOCKED);

	    }
	    result = GetInput(chanPtr);
	    if (result != 0) {
		if (result == EAGAIN) {
		    break;
		}
		copied = -1;
		goto done;
	    }
	} else {
	    copied += copiedNow;
	    toRead -= copiedNow;
	}
    }







    ResetFlag(statePtr, CHANNEL_BLOCKED);

    if (encoding == NULL) {
	Tcl_SetByteArrayLength(objPtr, offset);





    } else {

	Tcl_SetObjLength(objPtr, offset);
    }

    /*
     * Update the notifier state so we don't block while there is still data
     * in the buffers.
     */

  done:
    /*
     * Regenerate the top channel, in case it was changed due to
     * self-modifying reflected transforms.
     */

    chanPtr = statePtr->topChanPtr;

    UpdateInterest(chanPtr);

    return copied;
}

/*
 *---------------------------------------------------------------------------
 *
 * ReadBytes --
 *
 *	Reads from the channel until the requested number of bytes have been
 *	seen, EOF is seen, or the channel would block. Bytes from the channel
 *	are stored in objPtr as a ByteArray object. EOL and EOF translation
 *	are done.
 *
 *	'bytesToRead' can safely be a very large number because space is only
 *	allocated to hold data read from the channel as needed.
 *
 * Results:
 *	The return value is the number of bytes appended to the object and
 *	*offsetPtr is filled with the total number of bytes in the object
 *	(greater than the return value if there were already bytes in the
 *	object).
 *
 * Side effects:
 *	None.

 *
 *---------------------------------------------------------------------------
 */

static int
ReadBytes(
    ChannelState *statePtr,	/* State of the channel to read. */
    Tcl_Obj *objPtr,		/* Input data is appended to this ByteArray
				 * object. Its length is how much space has
				 * been allocated to hold data, not how many
				 * bytes of data have been stored in the
				 * object. */
    int bytesToRead,		/* Maximum number of bytes to store, or < 0 to
				 * get all available bytes. Bytes are obtained
				 * from the first buffer in the queue - even
				 * if this number is larger than the number of
				 * bytes available in the first buffer, only
				 * the bytes from the first buffer are
				 * returned. */
    int *offsetPtr)		/* On input, contains how many bytes of objPtr
				 * have been used to hold data. On output,
				 * filled with how many bytes are now being
				 * used. */
{
    int toRead, srcLen, offset, length, srcRead, dstWrote;
    ChannelBuffer *bufPtr;
    char *src, *dst;

    offset = *offsetPtr;

    bufPtr = statePtr->inQueueHead;
    src = RemovePoint(bufPtr);
    srcLen = BytesLeft(bufPtr);

    toRead = bytesToRead;
    if ((unsigned) toRead > (unsigned) srcLen) {
	toRead = srcLen;
    }

    dst = (char *) Tcl_GetByteArrayFromObj(objPtr, &length);
    if (toRead > length - offset - 1) {
	/*
	 * Double the existing size of the object or make enough room to hold
	 * all the characters we may get from the source buffer, whichever is
	 * larger.
	 */

	length = offset * 2;
	if (offset < toRead) {
	    length = offset + toRead + 1;
	}
	dst = (char *) Tcl_SetByteArrayLength(objPtr, length);
    }
    dst += offset;

    if (GotFlag(statePtr, INPUT_NEED_NL)) {
	ResetFlag(statePtr, INPUT_NEED_NL);
	if ((srcLen == 0) || (*src != '\n')) {
	    *dst = '\r';
	    *offsetPtr += 1;
	    return 1;
	}
	*dst++ = '\n';
	src++;
	srcLen--;
	toRead--;
    }

    srcRead = srcLen;
    dstWrote = toRead;
    if (TranslateInputEOL(statePtr, dst, src, &dstWrote, &srcRead) != 0) {
	if (dstWrote == 0) {
	    return -1;
	}
    }
    bufPtr->nextRemoved += srcRead;
    *offsetPtr += dstWrote;
    return dstWrote;
}

/*
 *---------------------------------------------------------------------------
 *
 * ReadChars --
 *







|
|
|
|
>
>
>
|
>

<

|
|

<
|







>
>
>
>
>
>
|
>
|
<
>
>
>
>
>
|
>
|






<
<
<
<
<
<
<
<
<

>

















|
|
<
<


<
>












|






<
<
<
<

<
|
<
<
<
<
<
<
|
<
|
<
<
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
|
<
|







5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649

5650
5651
5652
5653

5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
5669
5670

5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684









5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705


5706
5707

5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727




5728

5729






5730

5731


5732
5733


























5734









5735

5736
5737
5738
5739
5740
5741
5742
5743
	    }
	}

	if (copiedNow < 0) {
	    if (GotFlag(statePtr, CHANNEL_EOF)) {
		break;
	    }
	    if (GotFlag(statePtr, CHANNEL_NONBLOCKING|CHANNEL_BLOCKED)
		    == (CHANNEL_NONBLOCKING|CHANNEL_BLOCKED)) {
		break;
	    }
	    result = GetInput(chanPtr);
	    if (chanPtr != statePtr->topChanPtr) {
		Tcl_Release(chanPtr);
		chanPtr = statePtr->topChanPtr;
		Tcl_Preserve(chanPtr);
	    }

	    if (result != 0) {
		if (!GotFlag(statePtr, CHANNEL_BLOCKED)) {
		    copied = -1;
		}

		break;
	    }
	} else {
	    copied += copiedNow;
	    toRead -= copiedNow;
	}
    }

    /*
     * Failure to fill a channel buffer may have left channel reporting
     * a "blocked" state, but so long as we fulfilled the request here,
     * the caller does not consider us blocked.
     */
    if (toRead == 0) {
	ResetFlag(statePtr, CHANNEL_BLOCKED);
    }


    /*
     * Regenerate the top channel, in case it was changed due to
     * self-modifying reflected transforms.
     */
    if (chanPtr != statePtr->topChanPtr) {
	Tcl_Release(chanPtr);
	chanPtr = statePtr->topChanPtr;
	Tcl_Preserve(chanPtr);
    }

    /*
     * Update the notifier state so we don't block while there is still data
     * in the buffers.
     */









    UpdateInterest(chanPtr);
    Tcl_Release(chanPtr);
    return copied;
}

/*
 *---------------------------------------------------------------------------
 *
 * ReadBytes --
 *
 *	Reads from the channel until the requested number of bytes have been
 *	seen, EOF is seen, or the channel would block. Bytes from the channel
 *	are stored in objPtr as a ByteArray object. EOL and EOF translation
 *	are done.
 *
 *	'bytesToRead' can safely be a very large number because space is only
 *	allocated to hold data read from the channel as needed.
 *
 * Results:
 *	The return value is the number of bytes appended to the object, or
 *	-1 to indicate that zero bytes were read due to an EOF.


 *
 * Side effects:

 *	The storage of bytes in objPtr can cause (re-)allocation of memory.
 *
 *---------------------------------------------------------------------------
 */

static int
ReadBytes(
    ChannelState *statePtr,	/* State of the channel to read. */
    Tcl_Obj *objPtr,		/* Input data is appended to this ByteArray
				 * object. Its length is how much space has
				 * been allocated to hold data, not how many
				 * bytes of data have been stored in the
				 * object. */
    int bytesToRead)		/* Maximum number of bytes to store, or < 0 to
				 * get all available bytes. Bytes are obtained
				 * from the first buffer in the queue - even
				 * if this number is larger than the number of
				 * bytes available in the first buffer, only
				 * the bytes from the first buffer are
				 * returned. */




{

    ChannelBuffer *bufPtr = statePtr->inQueueHead;






    int srcLen = BytesLeft(bufPtr);

    int toRead = bytesToRead>srcLen || bytesToRead<0 ? srcLen : bytesToRead;



    TclAppendBytesToByteArray(objPtr, (unsigned char *) RemovePoint(bufPtr),


























	    toRead);









    bufPtr->nextRemoved += toRead;

    return toRead;
}

/*
 *---------------------------------------------------------------------------
 *
 * ReadChars --
 *
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
5746
5747
5748
5749
5750
5751
5752
5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766



5767
5768
5769


5770

5771
5772
5773
5774
5775
5776
5777

5778
5779








5780
5781
5782
5783







5784
5785





5786
5787



5788




5789
5790
5791
5792
5793
5794
5795

5796






5797
5798


5799

5800
5801
5802
5803


5804
5805
5806
5807
5808
5809






5810
5811
5812
5813
5814
5815

5816
5817
5818
5819
5820


5821
5822
5823
5824
5825
5826
5827


5828
5829
5830
5831
5832
5833
5834
5835

5836
5837


5838
5839
5840
5841
5842
5843






5844

5845
5846
5847





5848


5849






5850
5851


5852
5853


5854
5855
5856

5857
5858
5859


5860
5861
5862
5863
5864
5865

5866
5867
5868

5869
5870













5871
5872
5873
5874


5875


5876

5877
5878
5879
5880
5881
5882
5883




5884



5885
5886
5887




5888

5889
5890
5891
5892
5893





5894

5895

5896
5897
5898
5899

5900

5901
5902









5903
5904

5905
5906
5907
5908
5909
5910
5911
5912
5913




5914
5915
5916
5917




5918















5919
5920

5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944

5945
5946
5947
5948
5949
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
5964
5965
5966

5967
5968
5969
5970
5971
5972
5973
5974
5975
5976
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
5992
5993
5994
5995
5996
5997

5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
6010
6011
6012
6013
6014
6015
6016
6017
6018
6019
6020
6021
6022
6023
6024
6025
6026
6027
6028
6029
6030
6031
6032
6033
6034
6035
6036
6037
6038
6039
6040
6041
6042
6043
6044
6045


6046
6047
6048





6049
6050
6051
6052
6053
6054

6055
6056
6057
6058
6059
6060
6061





6062





6063
6064

6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085

6086
6087

6088
6089
6090
6091
6092
6093
6094
6095
6096
6097
6098
6099
6100

6101
6102

6103



6104
6105

6106


6107

6108
6109
6110
6111
6112
6113
6114
6115
6116
6117
6118
6119
6120
6121
6122
6123
6124
6125
6126




6127
6128

6129
6130
6131
6132
6133
6134
6135
6136
6137
6138
6139
6140
6141
6142

6143
6144
6145
6146
6147
6148

6149
6150

6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
6165
6166
6167
6168
6169
6170
6171
6172
6173
    int charsToRead,		/* Maximum number of characters to store, or
				 * -1 to get all available characters.
				 * Characters are obtained from the first
				 * buffer in the queue -- even if this number
				 * is larger than the number of characters
				 * available in the first buffer, only the
				 * characters from the first buffer are
				 * returned. */
    int *offsetPtr,		/* On input, contains how many bytes of objPtr
				 * have been used to hold data. On output,
				 * filled with how many bytes are now being
				 * used. */
    int *factorPtr)		/* On input, contains a guess of how many
				 * bytes need to be allocated to hold the
				 * result of converting N source bytes to
				 * UTF-8. On output, contains another guess
				 * based on the data seen so far. */
{
    int toRead, factor, offset, spaceLeft, srcLen, dstNeeded;
    int srcRead, dstWrote, numChars, dstRead;
    ChannelBuffer *bufPtr;
    char *src, *dst;
    Tcl_EncodingState oldState;
    int encEndFlagSuppressed = 0;

    factor = *factorPtr;
    offset = *offsetPtr;

    bufPtr = statePtr->inQueueHead;
    src = RemovePoint(bufPtr);
    srcLen = BytesLeft(bufPtr);




    toRead = charsToRead;
    if ((unsigned) toRead > (unsigned) srcLen) {
	toRead = srcLen;


    }


    /*
     * 'factor' is how much we guess that the bytes in the source buffer will
     * expand when converted to UTF-8 chars. This guess comes from analyzing
     * how many characters were produced by the previous pass.
     */


    dstNeeded = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR;
    spaceLeft = objPtr->length - offset;









    if (dstNeeded > spaceLeft) {
	/*
	 * Double the existing size of the object or make enough room to hold







	 * all the characters we want from the source buffer, whichever is
	 * larger.





	 */




	int length = offset + ((offset < dstNeeded) ? dstNeeded : offset);





	if (Tcl_AttemptSetObjLength(objPtr, length) == 0) {
	    length = offset + dstNeeded;
	    if (Tcl_AttemptSetObjLength(objPtr, length) == 0) {
		dstNeeded = TCL_UTF_MAX - 1 + toRead;
		length = offset + dstNeeded;
		Tcl_SetObjLength(objPtr, length);

	    }






	}
	spaceLeft = length - offset;


    }

    if (toRead == srcLen) {
	/*
	 * Want to convert the whole buffer in one pass. If we have enough
	 * space, convert it using all available space in object rather than


	 * using the factor.
	 */

	dstNeeded = spaceLeft;
    }
    dst = objPtr->bytes + offset;







    /*
     * [Bug 1462248]: The cause of the crash reported in this bug is this:
     *
     * - ReadChars, called with a single buffer, with a incomplete
     *	 multi-byte character at the end (only the first byte of it).

     * - Encoding translation fails, asks for more data
     * - Data is read, and eof is reached, TCL_ENCODING_END (TEE) is set.
     * - ReadChar is called again, converts the first buffer, but due to TEE
     *	 it does not check for incomplete multi-byte data, and the character
     *	 just after the end of the first buffer is a valid completion of the


     *	 multi-byte header in the actual buffer. The conversion reads more
     *	 characters from the buffer then present. This causes nextRemoved to
     *	 overshoot nextAdded and the next reads compute a negative srcLen,
     *	 cause further translations to fail, causing copying of data into the
     *	 next buffer using bad arguments, causing the mecpy for to eventually
     *	 fail.
     *


     * In the end it is a memory access bug spiraling out of control if the
     * conditions are _just so_. And ultimate cause is that TEE is given to a
     * conversion where it should not. TEE signals that this is the last
     * buffer. Except in our case it is not.
     *
     * My solution is to suppress TEE if the first buffer is not the last. We
     * will eventually need it given that EOF has been reached, but not right
     * now. This is what the new flag "endEncSuppressFlag" is for.

     *
     * The bug in 'Tcl_Utf2UtfProc' where it read from memory behind the


     * actual buffer has been fixed as well, and fixes the problem with the
     * crash too, but this would still allow the generic layer to
     * accidentially break a multi-byte sequence if the conditions are just
     * right, because again the ExternalToUtf would be successful where it
     * should not.
     */








    if ((statePtr->inputEncodingFlags & TCL_ENCODING_END) &&
	    (bufPtr->nextPtr != NULL)) {
	/*





	 * TEE is set for a buffer which is not the last. Squash it for now,


	 * and restore it later, before yielding control to our caller.






	 */



	statePtr->inputEncodingFlags &= ~TCL_ENCODING_END;
	encEndFlagSuppressed = 1;


    }

    oldState = statePtr->inputEncodingState;

    if (GotFlag(statePtr, INPUT_NEED_NL)) {
	/*
	 * We want a '\n' because the last character we saw was '\r'.


	 */

	ResetFlag(statePtr, INPUT_NEED_NL);
	Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen,
		statePtr->inputEncodingFlags, &statePtr->inputEncodingState,
		dst, TCL_UTF_MAX + 1, &srcRead, &dstWrote, &numChars);

	if ((dstWrote > 0) && (*dst == '\n')) {
	    /*
	     * The next char was a '\n'. Consume it and produce a '\n'.

	     */














	    bufPtr->nextRemoved += srcRead;
	} else {
	    /*
	     * The next char was not a '\n'. Produce a '\r'.


	     */




	    *dst = '\r';
	}
	statePtr->inputEncodingFlags &= ~TCL_ENCODING_START;
	*offsetPtr += 1;

	if (encEndFlagSuppressed) {
	    statePtr->inputEncodingFlags |= TCL_ENCODING_END;




	}



	return 1;
    }





    Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen,

	    statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst,
	    dstNeeded + 1, &srcRead, &dstWrote, &numChars);

    if (encEndFlagSuppressed) {
	statePtr->inputEncodingFlags |= TCL_ENCODING_END;





    }



    if (srcRead == 0) {
	/*
	 * Not enough bytes in src buffer to make a complete char. Copy the
	 * bytes to the next buffer to make a new contiguous string, then tell

	 * the caller to fill the buffer with more bytes.

	 */










	ChannelBuffer *nextPtr;


	nextPtr = bufPtr->nextPtr;
	if (nextPtr == NULL) {
	    if (srcLen > 0) {
		/*
		 * There isn't enough data in the buffers to complete the next
		 * character, so we need to wait for more data before the next
		 * file event can be delivered. [Bug 478856]
		 *
		 * The exception to this is if the input buffer was completely




		 * empty before we tried to convert its contents. Nothing in,
		 * nothing out, and no incomplete character data. The
		 * conversion before the current one was complete.
		 */




















		SetFlag(statePtr, CHANNEL_NEED_MORE_DATA);
	    }

	    return -1;
	}

	/*
	 * Space is made at the beginning of the buffer to copy the previous
	 * unused bytes there. Check first if the buffer we are using actually
	 * has enough space at its beginning for the data we are copying.
	 * Because if not we will write over the buffer management
	 * information, especially the 'nextPtr'.
	 *
	 * Note that the BUFFER_PADDING (See AllocChannelBuffer) is used to
	 * prevent exactly this situation. I.e. it should never happen.
	 * Therefore it is ok to panic should it happen despite the
	 * precautions.
	 */

	if (nextPtr->nextRemoved - srcLen < 0) {
	    Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough");
	}

	nextPtr->nextRemoved -= srcLen;
	memcpy(RemovePoint(nextPtr), src, (size_t) srcLen);
	RecycleBuffer(statePtr, bufPtr, 0);
	statePtr->inQueueHead = nextPtr;

	return ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr);
    }

    dstRead = dstWrote;
    if (TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead) != 0) {
	/*
	 * Hit EOF char. How many bytes of src correspond to where the EOF was
	 * located in dst? Run the conversion again with an output buffer just
	 * big enough to hold the data so we can get the correct value for
	 * srcRead.
	 */

	if (dstWrote == 0) {
	    return -1;
	}
	statePtr->inputEncodingState = oldState;
	Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen,
		statePtr->inputEncodingFlags, &statePtr->inputEncodingState,
		dst, dstRead + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars);
	TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead);
    }


    /*
     * The number of characters that we got may be less than the number that
     * we started with because "\r\n" sequences may have been turned into just
     * '\n' in dst.
     */

    numChars -= dstRead - dstWrote;

    if ((unsigned) numChars > (unsigned) toRead) {
	/*
	 * Got too many chars.
	 */

	const char *eof = Tcl_UtfAtIndex(dst, toRead);

	statePtr->inputEncodingState = oldState;
	Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen,
		statePtr->inputEncodingFlags, &statePtr->inputEncodingState,
		dst, eof - dst + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars);
	dstRead = dstWrote;
	TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead);
	numChars -= (dstRead - dstWrote);
    }
    statePtr->inputEncodingFlags &= ~TCL_ENCODING_START;

    bufPtr->nextRemoved += srcRead;
    if (dstWrote > srcRead + 1) {
	*factorPtr = dstWrote * UTF_EXPANSION_FACTOR / srcRead;
    }
    *offsetPtr += dstWrote;
    return numChars;

}

/*
 *---------------------------------------------------------------------------
 *
 * TranslateInputEOL --
 *
 *	Perform input EOL and EOF translation on the source buffer, leaving
 *	the translated result in the destination buffer.
 *
 * Results:
 *	The return value is 1 if the EOF character was found when copying
 *	bytes to the destination buffer, 0 otherwise.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static int
TranslateInputEOL(
    ChannelState *statePtr,	/* Channel being read, for EOL translation and
				 * EOF character. */
    char *dstStart,		/* Output buffer filled with chars by applying
				 * appropriate EOL translation to source
				 * characters. */
    const char *srcStart,	/* Source characters. */
    int *dstLenPtr,		/* On entry, the maximum length of output
				 * buffer in bytes; must be <= *srcLenPtr. 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. */
{
    int dstLen, srcLen, inEofChar;
    const char *eof;

    dstLen = *dstLenPtr;

    eof = NULL;
    inEofChar = statePtr->inEofChar;
    if (inEofChar != '\0') {
	/*
	 * Find EOF in translated buffer then compress out the EOL. The source
	 * buffer may be much longer than the destination buffer - we only
	 * want to return EOF if the EOF has been copied to the destination


	 * buffer.
	 */






	const char *src, *srcMax = srcStart + *srcLenPtr;

	for (src = srcStart; src < srcMax; src++) {
	    if (*src == inEofChar) {
		eof = src;
		srcLen = src - srcStart;

		if (srcLen < dstLen) {
		    dstLen = srcLen;
		}
		*srcLenPtr = srcLen;
		break;
	    }
	}





    }





    switch (statePtr->inputTranslation) {
    case TCL_TRANSLATE_LF:

	if (dstStart != srcStart) {
	    memcpy(dstStart, srcStart, (size_t) dstLen);
	}
	srcLen = dstLen;
	break;
    case TCL_TRANSLATE_CR: {
	char *dst, *dstEnd;

	if (dstStart != srcStart) {
	    memcpy(dstStart, srcStart, (size_t) dstLen);
	}
	dstEnd = dstStart + dstLen;
	for (dst = dstStart; dst < dstEnd; dst++) {
	    if (*dst == '\r') {
		*dst = '\n';
	    }
	}
	srcLen = dstLen;
	break;
    }
    case TCL_TRANSLATE_CRLF: {

	char *dst;
	const char *src, *srcEnd, *srcMax;


	dst = dstStart;
	src = srcStart;
	srcEnd = srcStart + dstLen;
	srcMax = srcStart + *srcLenPtr;

	for ( ; src < srcEnd; ) {
	    if (*src == '\r') {
		src++;
		if (src >= srcMax) {
		    SetFlag(statePtr, INPUT_NEED_NL);
		} else if (*src == '\n') {
		    *dst++ = *src++;

		} else {
		    *dst++ = '\r';

		}



	    } else {
		*dst++ = *src++;

	    }


	}

	srcLen = src - srcStart;
	dstLen = dst - dstStart;
	break;
    }
    case TCL_TRANSLATE_AUTO: {
	char *dst;
	const char *src, *srcEnd, *srcMax;

	dst = dstStart;
	src = srcStart;
	srcEnd = srcStart + dstLen;
	srcMax = srcStart + *srcLenPtr;

	if (GotFlag(statePtr, INPUT_SAW_CR) && (src < srcMax)) {
	    if (*src == '\n') {
		src++;
	    }
	    ResetFlag(statePtr, INPUT_SAW_CR);
	}




	for ( ; src < srcEnd; ) {
	    if (*src == '\r') {

		src++;
		if (src >= srcMax) {
		    SetFlag(statePtr, INPUT_SAW_CR);
		} else if (*src == '\n') {
		    if (srcEnd < srcMax) {
			srcEnd++;
		    }
		    src++;
		}
		*dst++ = '\n';
	    } else {
		*dst++ = *src++;
	    }
	}

	srcLen = src - srcStart;
	dstLen = dst - dstStart;
	break;
    }
    default:
	return 0;

    }
    *dstLenPtr = dstLen;


    if ((eof != NULL) && (srcStart + srcLen >= eof)) {
	/*
	 * EOF character was seen in EOL translated range. Leave current file
	 * position pointing at the EOF character, but don't store the EOF
	 * character in the output string.
	 */

	SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF);
	statePtr->inputEncodingFlags |= TCL_ENCODING_END;
	ResetFlag(statePtr, INPUT_SAW_CR | INPUT_NEED_NL);
	return 1;
    }

    *srcLenPtr = srcLen;
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Ungets --
 *







|
|
|
|
|






|
<
<
|
|
<
|
<
<
|
|
|
|

>
>
>
|
<
|
>
>
|
>






|
>
|
|
>
>
>
>
>
>
>
>
|
|
|
<
>
>
>
>
>
>
>
|
<
>
>
>
>
>
|

>
>
>
|
>
>
>
>

<
<
<
|
|
|
>
|
>
>
>
>
>
>
|
|
>
>
|
>
|
|
<
<
>
>
|
|

<
<
|
>
>
>
>
>
>
|
|
<
|
<
<
>
|
|
|
|
|
>
>
|
|
|
<
<
|
|
>
>
|
|
|
|
|
|
|
<
>
|
<
>
>
|
<
|
|
|
|
>
>
>
>
>
>
|
>
|
<
|
>
>
>
>
>
|
>
>
|
>
>
>
>
>
>
|

>
>
|
<
>
>
|

|
>
|
|
|
>
>
|

<
<
|
|
>
|
|
<
>
|

>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
<
|
>
>
|
>
>

>
|
|
<
<

|
|
>
>
>
>
|
>
>
>
|
|

>
>
>
>
|
>
|
|
|
|
<
>
>
>
>
>
|
>

>
|
|
<
|
>
|
>
|

>
>
>
>
>
>
>
>
>
|

>
|
|
|
|
|
<
<
<
|
>
>
>
>
|
<
<
|
>
>
>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
|
|

|
|
|
|
|
|
|
|
|
|
|
|

|
|
|

|
|
|
|
>
|
|

<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
|
|
>
|
<
<
<
<
|
<
|
<
<
<

|
<
|
<
<
<
<
<
<
<
|
<
|
<
<
<
<
<
|
>




















|








<
|
|




<
|
<
|
|
<
|
|
|
|
<
<
>
>
|
|

>
>
>
>
>
|
|
<
<
|
|
>
|
|
|
<
|
|
|
>
>
>
>
>
|
>
>
>
>
>


>

|

<
<
|
|
|
<
<
|
|
<
<
|


|

<

>
|
<
>

|
|
|
<

|
|
|
|
<
|
|
>

|
>

>
>
>

|
>

>
>

>
|
|



<
|
<
|
<
|
<

|
|
<
<


>
>
>
>
|
|
>
|
|
|
|
<
<
<
|
|
|
<
<
|
<
>
|
|



<
>


>

|








|
<

<
<
<







5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
5783
5784
5785
5786
5787
5788
5789
5790
5791


5792
5793

5794


5795
5796
5797
5798
5799
5800
5801
5802
5803

5804
5805
5806
5807
5808
5809
5810
5811
5812
5813
5814
5815
5816
5817
5818
5819
5820
5821
5822
5823
5824
5825
5826
5827
5828
5829

5830
5831
5832
5833
5834
5835
5836
5837

5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
5853



5854
5855
5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
5871
5872


5873
5874
5875
5876
5877


5878
5879
5880
5881
5882
5883
5884
5885
5886

5887


5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898


5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909

5910
5911

5912
5913
5914

5915
5916
5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927

5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
5945
5946
5947
5948

5949
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961


5962
5963
5964
5965
5966

5967
5968
5969
5970
5971
5972
5973
5974
5975
5976
5977
5978
5979
5980
5981
5982
5983
5984

5985
5986
5987
5988
5989
5990
5991
5992
5993
5994


5995
5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
6010
6011
6012
6013
6014
6015
6016
6017
6018

6019
6020
6021
6022
6023
6024
6025
6026
6027
6028
6029

6030
6031
6032
6033
6034
6035
6036
6037
6038
6039
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052



6053
6054
6055
6056
6057
6058


6059
6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
6086
6087
6088
6089
6090
6091
6092
6093
6094
6095
6096
6097
6098
6099
6100
6101
6102
6103
6104
6105
6106
6107
6108
6109
6110














6111


6112
6113
6114
6115




6116

6117



6118
6119

6120







6121

6122





6123
6124
6125
6126
6127
6128
6129
6130
6131
6132
6133
6134
6135
6136
6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
6153

6154
6155
6156
6157
6158
6159

6160

6161
6162

6163
6164
6165
6166


6167
6168
6169
6170
6171
6172
6173
6174
6175
6176
6177
6178


6179
6180
6181
6182
6183
6184

6185
6186
6187
6188
6189
6190
6191
6192
6193
6194
6195
6196
6197
6198
6199
6200
6201
6202
6203
6204


6205
6206
6207


6208
6209


6210
6211
6212
6213
6214

6215
6216
6217

6218
6219
6220
6221
6222

6223
6224
6225
6226
6227

6228
6229
6230
6231
6232
6233
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243
6244
6245
6246
6247
6248
6249
6250

6251

6252

6253

6254
6255
6256


6257
6258
6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269



6270
6271
6272


6273

6274
6275
6276
6277
6278
6279

6280
6281
6282
6283
6284
6285
6286
6287
6288
6289
6290
6291
6292
6293
6294

6295



6296
6297
6298
6299
6300
6301
6302
    int charsToRead,		/* Maximum number of characters to store, or
				 * -1 to get all available characters.
				 * Characters are obtained from the first
				 * buffer in the queue -- even if this number
				 * is larger than the number of characters
				 * available in the first buffer, only the
				 * characters from the first buffer are
				 * returned. The execption is when there is
				 * not any complete character in the first
				 * buffer.  In that case, a recursive call
				 * effectively obtains chars from the
				 * second buffer. */
    int *factorPtr)		/* On input, contains a guess of how many
				 * bytes need to be allocated to hold the
				 * result of converting N source bytes to
				 * UTF-8. On output, contains another guess
				 * based on the data seen so far. */
{
    Tcl_Encoding encoding = statePtr->encoding? statePtr->encoding


	    : GetBinaryEncoding();
    Tcl_EncodingState savedState = statePtr->inputEncodingState;

    ChannelBuffer *bufPtr = statePtr->inQueueHead;


    int savedIEFlags = statePtr->inputEncodingFlags;
    int savedFlags = statePtr->flags;
    char *dst, *src = RemovePoint(bufPtr);
    int dstLimit, numBytes, srcLen = BytesLeft(bufPtr);

    /*
     * One src byte can yield at most one character.  So when the
     * number of src bytes we plan to read is less than the limit on
     * character count to be read, clearly we will remain within that

     * limit, and we can use the value of "srcLen" as a tighter limit
     * for sizing receiving buffers.
     */

    int toRead = ((charsToRead<0)||(charsToRead > srcLen)) ? srcLen : charsToRead;

    /*
     * 'factor' is how much we guess that the bytes in the source buffer will
     * expand when converted to UTF-8 chars. This guess comes from analyzing
     * how many characters were produced by the previous pass.
     */
    
    int factor = *factorPtr;
    int dstNeeded = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR;

    (void) TclGetStringFromObj(objPtr, &numBytes);
    Tcl_AppendToObj(objPtr, NULL, dstNeeded);
    if (toRead == srcLen) {
	unsigned int size;
	dst = TclGetStringStorage(objPtr, &size) + numBytes;
	dstNeeded = size - numBytes;
    } else {
	dst = TclGetString(objPtr) + numBytes;
    }

    /*

     * This routine is burdened with satisfying several constraints.
     * It cannot append more than 'charsToRead` chars onto objPtr.
     * This is measured after encoding and translation transformations
     * are completed.  There is no precise number of src bytes that can
     * be associated with the limit.  Yet, when we are done, we must know
     * precisely the number of src bytes that were consumed to produce
     * the appended chars, so that all subsequent bytes are left in
     * the buffers for future read operations.

     *
     * The consequence is that we have no choice but to implement a
     * "trial and error" approach, where in general we may need to
     * perform transformations and copies multiple times to achieve
     * a consistent set of results.  This takes the shape of a loop.
     */

    dstLimit = dstNeeded + 1;
    while (1) {
	int dstDecoded, dstRead, dstWrote, srcRead, numChars;

	/*
	 * Perform the encoding transformation.  Read no more than
	 * srcLen bytes, write no more than dstLimit bytes.
	 */




	int code = Tcl_ExternalToUtf(NULL, encoding, src, srcLen,
		statePtr->inputEncodingFlags & (bufPtr->nextPtr
		? ~0 : ~TCL_ENCODING_END), &statePtr->inputEncodingState,
		dst, dstLimit, &srcRead, &dstDecoded, &numChars);

	/*
	 * Perform the translation transformation in place.  Read no more
	 * than the dstDecoded bytes the encoding transformation actually
	 * produced.  Capture the number of bytes written in dstWrote.
	 * Capture the number of bytes actually consumed in dstRead.
	 */

	dstWrote = dstLimit;
	dstRead = dstDecoded;
	TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead);

	if (dstRead < dstDecoded) {

	    /*


	     * The encoding transformation produced bytes that the
	     * translation transformation did not consume.  Why did
	     * this happen?
	     */



	    if (statePtr->inEofChar && dst[dstRead] == statePtr->inEofChar) {
		/*
		 * 1) There's an eof char set on the channel, and
		 *    we saw it and stopped translating at that point.
		 *
		 * NOTE the bizarre spec of TranslateInputEOL in this case.
		 * Clearly the eof char had to be read in order to account
		 * for the stopping, but the value of dstRead does not
		 * include it.

		 *


		 * Also rather bizarre, our caller can only notice an
		 * EOF condition if we return the value -1 as the number
		 * of chars read.  This forces us to perform a 2-call
		 * dance where the first call can read all the chars
		 * up to the eof char, and the second call is solely
		 * for consuming the encoded eof char then pointed at
		 * by src so that we can return that magic -1 value.
		 * This seems really wasteful, especially since
		 * the first decoding pass of each call is likely to
		 * decode many bytes beyond that eof char that's all we
		 * care about.


		 */

		if (dstRead == 0) {
		    /*
		     * Curious choice in the eof char handling.  We leave
		     * the eof char in the buffer.  So, no need to compute
		     * a proper srcRead value.  At this point, there
		     * are no chars before the eof char in the buffer.
		     */
		    Tcl_SetObjLength(objPtr, numBytes);
		    return -1;

		}


		{
		    /*
		     * There are chars leading the buffer before the eof

		     * char.  Adjust the dstLimit so we go back and read
		     * only those and do not encounter the eof char this
		     * time.
		     */

		    dstLimit = dstRead + TCL_UTF_MAX;
		    statePtr->flags = savedFlags;
		    statePtr->inputEncodingFlags = savedIEFlags;
		    statePtr->inputEncodingState = savedState;
		    continue;
		}
	    }


	    /*
	     * 2) The other way to read fewer bytes than are decoded
	     *    is when the final byte is \r and we're in a CRLF
	     *    translation mode so we cannot decide whether to
	     *	  record \r or \n yet.
	     */

	    assert(dst[dstRead] == '\r');
	    assert(statePtr->inputTranslation == TCL_TRANSLATE_CRLF);

	    if (dstWrote > 0) {
		/*
		 * There are chars we can read before we hit the bare cr.
		 * Go back with a smaller dstLimit so we get them in the
		 * next pass, compute a matching srcRead, and don't end
		 * up back here in this call.
		 */

		dstLimit = dstRead + TCL_UTF_MAX;
		statePtr->flags = savedFlags;
		statePtr->inputEncodingFlags = savedIEFlags;

		statePtr->inputEncodingState = savedState;
		continue;
	    }

	    assert(dstWrote == 0);
	    assert(dstRead == 0);

	    /*
	     * We decoded only the bare cr, and we cannot read a
	     * translated char from that alone.  We have to know what's
	     * next.  So why do we only have the one decoded char?
	     */



	    if (code != TCL_OK) {
		char buffer[TCL_UTF_MAX + 2];
		int read, decoded, count;

		/* 

		 * Didn't get everything the buffer could offer
		 */

		statePtr->flags = savedFlags;
		statePtr->inputEncodingFlags = savedIEFlags;
		statePtr->inputEncodingState = savedState;

		Tcl_ExternalToUtf(NULL, encoding, src, srcLen,
		statePtr->inputEncodingFlags & (bufPtr->nextPtr
		? ~0 : ~TCL_ENCODING_END), &statePtr->inputEncodingState,
		buffer, TCL_UTF_MAX + 2, &read, &decoded, &count);

		if (count == 2) {
		    if (buffer[1] == '\n') {
			/* \r\n translate to \n */
			dst[0] = '\n';
			bufPtr->nextRemoved += read;
		    } else {

			dst[0] = '\r';
			bufPtr->nextRemoved += srcRead;
		    }

		    dst[1] = '\0';
		    statePtr->inputEncodingFlags &= ~TCL_ENCODING_START;

		    Tcl_SetObjLength(objPtr, numBytes + 1);
		    return 1;
		}



	    } else if (statePtr->flags & CHANNEL_EOF) {

		/*
		 * The bare \r is the only char and we will never read
		 * a subsequent char to make the determination.
		 */

		dst[0] = '\r';
		bufPtr->nextRemoved = bufPtr->nextAdded;
		Tcl_SetObjLength(objPtr, numBytes + 1);
		return 1;
	    }

	    /*
	     * Revise the dstRead value so that the numChars calc
	     * below correctly computes zero characters read.
	     */

	    dstRead = numChars;

	    /* FALL THROUGH - get more data (dstWrote == 0) */
	}


	/* 
	 * The translation transformation can only reduce the number
	 * of chars when it converts \r\n into \n.  The reduction in
	 * the number of chars is the difference in bytes read and written.
	 */

	numChars -= (dstRead - dstWrote);

	if (charsToRead > 0 && numChars > charsToRead) {

	    /* 

	     * We read more chars than allowed.  Reset limits to
	     * prevent that and try again.  Don't forget the extra
	     * padding of TCL_UTF_MAX - 1 bytes demanded by the
	     * Tcl_ExternalToUtf() call!
	     */

	    dstLimit = Tcl_UtfAtIndex(dst, charsToRead + 1) 
		    + TCL_UTF_MAX - 1 - dst;
	    statePtr->flags = savedFlags;
	    statePtr->inputEncodingFlags = savedIEFlags;
	    statePtr->inputEncodingState = savedState;
	    continue;
	}

	if (dstWrote == 0) {
	    ChannelBuffer *nextPtr;

	    /* We were not able to read any chars. */

	    assert (numChars == 0);

	    /* 
	     * There is one situation where this is the correct final



	     * result.  If the src buffer contains only a single \n
	     * byte, and we are in TCL_TRANSLATE_AUTO mode, and
	     * when the translation pass was made the INPUT_SAW_CR
	     * flag was set on the channel.  In that case, the
	     * correct behavior is to consume that \n and produce the
	     * empty string.


	     */

	    if (dst[0] == '\n') {
		assert(statePtr->inputTranslation == TCL_TRANSLATE_AUTO);
		assert(dstRead == 1);

		goto consume;
	    }

	    /* Otherwise, reading zero characters indicates there's
	     * something incomplete at the end of the src buffer.
	     * Maybe there were not enough src bytes to decode into
	     * a char.  Maybe a lone \r could not be translated (crlf
	     * mode).  Need to combine any unused src bytes we have
	     * in the first buffer with subsequent bytes to try again.
	     */

	    nextPtr = bufPtr->nextPtr;

	    if (nextPtr == NULL) {
		if (srcLen > 0) {
		    SetFlag(statePtr, CHANNEL_NEED_MORE_DATA);
		}
		Tcl_SetObjLength(objPtr, numBytes);
		return -1;
	    }

	    /*
	     * Space is made at the beginning of the buffer to copy the
	     * previous unused bytes there. Check first if the buffer we
	     * are using actually has enough space at its beginning for
	     * the data we are copying.  Because if not we will write over
	     * the buffer management information, especially the 'nextPtr'.
	     *
	     * Note that the BUFFER_PADDING (See AllocChannelBuffer) is
	     * used to prevent exactly this situation. I.e. it should never
	     * happen.  Therefore it is ok to panic should it happen despite
	     * the precautions.
	     */

	    if (nextPtr->nextRemoved - srcLen < 0) {
		Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough");
	    }

	    nextPtr->nextRemoved -= srcLen;
	    memcpy(RemovePoint(nextPtr), src, (size_t) srcLen);
	    RecycleBuffer(statePtr, bufPtr, 0);
	    statePtr->inQueueHead = nextPtr;
	    Tcl_SetObjLength(objPtr, numBytes);
	    return ReadChars(statePtr, objPtr, charsToRead, factorPtr);
	}















	statePtr->inputEncodingFlags &= ~TCL_ENCODING_START;



    consume:
	bufPtr->nextRemoved += srcRead;
	/*




	 * If this read contained multibyte characters, revise factorPtr

	 * so the next read will allocate bigger buffers.



	 */
	if (numChars && numChars < srcRead) {

	    *factorPtr = srcRead * UTF_EXPANSION_FACTOR / numChars;







	}

	Tcl_SetObjLength(objPtr, numBytes + dstWrote);





	return numChars;
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * TranslateInputEOL --
 *
 *	Perform input EOL and EOF translation on the source buffer, leaving
 *	the translated result in the destination buffer.
 *
 * Results:
 *	The return value is 1 if the EOF character was found when copying
 *	bytes to the destination buffer, 0 otherwise.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static void 
TranslateInputEOL(
    ChannelState *statePtr,	/* Channel being read, for EOL translation and
				 * EOF character. */
    char *dstStart,		/* Output buffer filled with chars by applying
				 * appropriate EOL translation to source
				 * characters. */
    const char *srcStart,	/* Source 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. */
{

    const char *eof = NULL;

    int dstLen = *dstLenPtr;
    int srcLen = *srcLenPtr;

    int inEofChar = statePtr->inEofChar;

    /*
     * Depending on the translation mode in use, there's no need


     * to scan more srcLen bytes at srcStart than can possibly transform
     * to dstLen bytes.  This keeps the scan for eof char below from
     * being pointlessly long.
     */

    switch (statePtr->inputTranslation) {
    case TCL_TRANSLATE_LF:
    case TCL_TRANSLATE_CR:
	if (srcLen > dstLen) {
	/* In these modes, each src byte become a dst byte. */
	    srcLen = dstLen;
	}


	break;
    default:
	/* In other modes, at most 2 src bytes become a dst byte. */
	if (srcLen > 2 * dstLen) {
	    srcLen = 2 * dstLen;
	}

	break;
    }

    if (inEofChar != '\0') {
	/*
	 * Make sure we do not read past any logical end of channel input
	 * created by the presence of the input eof char.
	 */

	if ((eof = memchr(srcStart, inEofChar, srcLen))) {
	    srcLen = eof - srcStart;
	}
    }

    switch (statePtr->inputTranslation) {
    case TCL_TRANSLATE_LF:
    case TCL_TRANSLATE_CR:
	if (dstStart != srcStart) {
	    memcpy(dstStart, srcStart, (size_t) srcLen);
	}


	if (statePtr->inputTranslation == TCL_TRANSLATE_CR) {
	    char *dst = dstStart;
	    char *dstEnd = dstStart + srcLen;



	    while ((dst = memchr(dst, '\r', dstEnd - dst))) {


		*dst++ = '\n';
	    }
	}
	dstLen = srcLen;
	break;

    case TCL_TRANSLATE_CRLF: {
	const char *crFound, *src = srcStart;
	char *dst = dstStart;

	int lesser = (dstLen < srcLen) ? dstLen : srcLen;

	while ((crFound = memchr(src, '\r', lesser))) {
	    int numBytes = crFound - src;
	    memmove(dst, src, numBytes);


	    dst += numBytes; dstLen -= numBytes;
	    src += numBytes; srcLen -= numBytes;
	    if (srcLen == 1) {
		/* valid src bytes end in \r */

		if (eof) {
		    *dst++ = '\r';
		    src++; srcLen--;
		} else {
		    lesser = 0;
		    break;
		}
	    } else if (src[1] == '\n') {
		*dst++ = '\n';
		src += 2; srcLen -= 2;
	    } else {
		*dst++ = '\r';
		src++; srcLen--;
	    }
	    dstLen--;
	    lesser = (dstLen < srcLen) ? dstLen : srcLen;
	}
	memmove(dst, src, lesser);
	srcLen = src + lesser - srcStart;
	dstLen = dst + lesser - dstStart;
	break;
    }
    case TCL_TRANSLATE_AUTO: {

	const char *crFound, *src = srcStart;

	char *dst = dstStart;

	int lesser;


	if ((statePtr->flags & INPUT_SAW_CR) && srcLen) {
	    if (*src == '\n') { src++; srcLen--; }


	    ResetFlag(statePtr, INPUT_SAW_CR);
	}
	lesser = (dstLen < srcLen) ? dstLen : srcLen;
	while ((crFound = memchr(src, '\r', lesser))) {
	    int numBytes = crFound - src;
	    memmove(dst, src, numBytes);

	    dst[numBytes] = '\n';
	    dst += numBytes + 1; dstLen -= numBytes + 1;
	    src += numBytes + 1; srcLen -= numBytes + 1;
	    if (srcLen == 0) {
		SetFlag(statePtr, INPUT_SAW_CR);
	    } else if (*src == '\n') {



		src++; srcLen--;
	    }
	    lesser = (dstLen < srcLen) ? dstLen : srcLen;


	}

	memmove(dst, src, lesser);
	srcLen = src + lesser - srcStart;
	dstLen = dst + lesser - dstStart;
	break;
    }
    default:

	Tcl_Panic("unknown input translation %d", statePtr->inputTranslation);
    }
    *dstLenPtr = dstLen;
    *srcLenPtr = srcLen;

    if (srcStart + srcLen == eof) {
	/*
	 * EOF character was seen in EOL translated range. Leave current file
	 * position pointing at the EOF character, but don't store the EOF
	 * character in the output string.
	 */

	SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF);
	statePtr->inputEncodingFlags |= TCL_ENCODING_END;
	ResetFlag(statePtr, INPUT_SAW_CR);

    }



}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Ungets --
 *
6213
6214
6215
6216
6217
6218
6219
6220
6221
6222
6223
6224
6225
6226
6227
6228
6229
6230
6231
6232
6233
6234
6235
6236
    if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
	len = -1;
	goto done;
    }
    statePtr->flags = flags;

    /*
     * If we have encountered a sticky EOF, just punt without storing (sticky
     * EOF is set if we have seen the input eofChar, to prevent reading beyond
     * the eofChar). Otherwise, clear the EOF flags, and clear the BLOCKED
     * bit. We want to discover these conditions anew in each operation.
     */

    if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) {
	goto done;
    }
    ResetFlag(statePtr, CHANNEL_BLOCKED | CHANNEL_EOF);

    bufPtr = AllocChannelBuffer(len);
    memcpy(InsertPoint(bufPtr), str, (size_t) len);
    bufPtr->nextAdded += len;

    if (statePtr->inQueueHead == NULL) {
	bufPtr->nextPtr = NULL;







<
<
|
<


|
<
<
|







6342
6343
6344
6345
6346
6347
6348


6349

6350
6351
6352


6353
6354
6355
6356
6357
6358
6359
6360
    if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
	len = -1;
	goto done;
    }
    statePtr->flags = flags;

    /*


     * Clear the EOF flags, and clear the BLOCKED bit.

     */

    ResetFlag(statePtr,


	    CHANNEL_BLOCKED | CHANNEL_STICKY_EOF | CHANNEL_EOF | INPUT_SAW_CR);

    bufPtr = AllocChannelBuffer(len);
    memcpy(InsertPoint(bufPtr), str, (size_t) len);
    bufPtr->nextAdded += len;

    if (statePtr->inQueueHead == NULL) {
	bufPtr->nextPtr = NULL;
6287
6288
6289
6290
6291
6292
6293
6294
6295
6296
6297
6298
6299
6300
6301
6302
6303
6304
6305
6306
6307
6308

    chanPtr = statePtr->topChanPtr;

    if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
	return -1;
    }

    /*
     * Force current output buffer to be output also.
     */

    if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) {
	SetFlag(statePtr, BUFFER_READY);
    }

    result = FlushChannel(NULL, chanPtr, 0);
    if (result != 0) {
	return TCL_ERROR;
    }

    return TCL_OK;
}







<
<
<
<
<
<
<
<







6411
6412
6413
6414
6415
6416
6417








6418
6419
6420
6421
6422
6423
6424

    chanPtr = statePtr->topChanPtr;

    if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
	return -1;
    }









    result = FlushChannel(NULL, chanPtr, 0);
    if (result != 0) {
	return TCL_ERROR;
    }

    return TCL_OK;
}
6345
6346
6347
6348
6349
6350
6351
6352
6353
6354
6355
6356
6357
6358
6359
6360
6361
6362



6363
6364
6365
6366
6367
6368
6369

    /*
     * If discardSavedBuffers is nonzero, must also discard any previously
     * saved buffer in the saveInBufPtr field.
     */

    if (discardSavedBuffers && statePtr->saveInBufPtr != NULL) {
	ckfree(statePtr->saveInBufPtr);
	statePtr->saveInBufPtr = NULL;
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * GetInput --
 *
 *	Reads input data from a device into a channel buffer.



 *
 * Results:
 *	The return value is the Posix error code if an error occurred while
 *	reading from the file, or 0 otherwise.
 *
 * Side effects:
 *	Reads from the underlying device.







|










>
>
>







6461
6462
6463
6464
6465
6466
6467
6468
6469
6470
6471
6472
6473
6474
6475
6476
6477
6478
6479
6480
6481
6482
6483
6484
6485
6486
6487
6488

    /*
     * If discardSavedBuffers is nonzero, must also discard any previously
     * saved buffer in the saveInBufPtr field.
     */

    if (discardSavedBuffers && statePtr->saveInBufPtr != NULL) {
	ReleaseChannelBuffer(statePtr->saveInBufPtr);
	statePtr->saveInBufPtr = NULL;
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * GetInput --
 *
 *	Reads input data from a device into a channel buffer.
 *
 *	IMPORTANT!  This routine is only called on a chanPtr argument
 *	that is the top channel of a stack!
 *
 * Results:
 *	The return value is the Posix error code if an error occurred while
 *	reading from the file, or 0 otherwise.
 *
 * Side effects:
 *	Reads from the underlying device.
6388
6389
6390
6391
6392
6393
6394












6395
6396
6397
6398
6399
6400
6401
6402
6403
6404
6405
6406
6407
6408
6409
6410

6411
6412
6413
6414
6415
6416
6417
6418
6419
6420
6421
6422
6423
6424
6425
6426
6427
6428
6429
6430
6431
6432
6433
6434
6435
6436
6437
6438
6439
6440
6441
6442
6443
6444
6445
6446
6447
6448
6449
6450
6451
6452
6453
6454
6455
6456
6457
6458
6459
6460
6461
6462
6463
6464
6465
6466
6467
6468

6469
6470
6471
6472
6473
6474
6475
6476
6477
6478
6479
6480
6481
6482
6483
6484
6485
6486
6487
6488
6489
6490
6491
6492
6493
6494
6495
6496
6497
6498
6499
6500
6501
6502
6503
6504
6505
6506
6507
6508
6509
6510
6511
6512
6513
6514
6515
6516
6517
6518
6519
6520
6521
6522
6523
6524
6525
6526
6527
6528
6529
6530
6531
6532
6533
6534
6535
6536
6537
6538
6539
6540
6541
6542
6543
6544
6545
6546
6547
6548
6549
6550
6551
     * channel cleanup has run but the channel is still registered in some
     * interpreter.
     */

    if (CheckForDeadChannel(NULL, statePtr)) {
	return EINVAL;
    }













    /*
     * First check for more buffers in the pushback area of the topmost
     * channel in the stack and use them. They can be the result of a
     * transformation which went away without reading all the information
     * placed in the area when it was stacked.
     *
     * Two possibilities for the state: No buffers in it, or a single empty
     * buffer. In the latter case we can recycle it now.
     */

    if (chanPtr->inQueueHead != NULL) {
	if (statePtr->inQueueHead != NULL) {
	    RecycleBuffer(statePtr, statePtr->inQueueHead, 0);
	    statePtr->inQueueHead = NULL;
	}


	statePtr->inQueueHead = chanPtr->inQueueHead;
	statePtr->inQueueTail = chanPtr->inQueueTail;
	chanPtr->inQueueHead = NULL;
	chanPtr->inQueueTail = NULL;
	return 0;
    }

    /*
     * Nothing in the pushback area, fall back to the usual handling (driver,
     * etc.)
     */

    /*
     * See if we can fill an existing buffer. If we can, read only as much as
     * will fit in it. Otherwise allocate a new buffer, add it to the input
     * queue and attempt to fill it to the max.
     */

    bufPtr = statePtr->inQueueTail;
    if ((bufPtr != NULL) && !IsBufferFull(bufPtr)) {
	toRead = SpaceLeft(bufPtr);
    } else {
	bufPtr = statePtr->saveInBufPtr;
	statePtr->saveInBufPtr = NULL;

	/*
	 * Check the actual buffersize against the requested buffersize.
	 * Buffers which are smaller than requested are squashed. This is done
	 * to honor dynamic changes of the buffersize made by the user.
	 */

	if ((bufPtr != NULL)
		&& (bufPtr->bufLength - BUFFER_PADDING < statePtr->bufSize)) {
	    ckfree(bufPtr);
	    bufPtr = NULL;
	}

	if (bufPtr == NULL) {
	    bufPtr = AllocChannelBuffer(statePtr->bufSize);
	}
	bufPtr->nextPtr = NULL;

	/*
	 * SF #427196: Use the actual size of the buffer to determine the
	 * number of bytes to read from the channel and not the size for new
	 * buffers. They can be different if the buffersize was changed
	 * between reads.
	 *
	 * Note: This affects performance negatively if the buffersize was
	 * extended but this small buffer is reused for all subsequent reads.
	 * The system never uses buffers with the requested bigger size in
	 * that case. An adjunct patch could try and delete all unused buffers
	 * it encounters and which are smaller than the formally requested
	 * buffersize.
	 */

	toRead = SpaceLeft(bufPtr);


	if (statePtr->inQueueTail == NULL) {
	    statePtr->inQueueHead = bufPtr;
	} else {
	    statePtr->inQueueTail->nextPtr = bufPtr;
	}
	statePtr->inQueueTail = bufPtr;
    }

    /*
     * If EOF is set, we should avoid calling the driver because on some
     * platforms it is impossible to read from a device after EOF.
     */

    if (GotFlag(statePtr, CHANNEL_EOF)) {
	return 0;
    }

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
    /*
     * [Bug 943274]: Better emulation of non-blocking channels for channels
     * without BlockModeProc, by keeping track of true fileevents generated by
     * the OS == Data waiting and reading if and only if we are sure to have
     * data.
     */

    if (GotFlag(statePtr, CHANNEL_NONBLOCKING) &&
	    (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) &&
	    !GotFlag(statePtr, CHANNEL_HAS_MORE_DATA)) {
	/*
	 * Bypass the driver, it would block, as no data is available
	 */

	nread = -1;
	result = EWOULDBLOCK;
    } else
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
    {
	nread = ChanRead(chanPtr, InsertPoint(bufPtr), toRead, &result);
    }

    if (nread > 0) {
	bufPtr->nextAdded += nread;

	/*
	 * If we get a short read, signal up that we may be BLOCKED. We should
	 * avoid calling the driver because on some platforms we will block in
	 * the low level reading code even though the channel is set into
	 * nonblocking mode.
	 */

	if (nread < toRead) {
	    SetFlag(statePtr, CHANNEL_BLOCKED);
	}

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
	if (nread <= toRead) {
	    /*
	     * [Bug 943274]: We have read the available data, clear flag.
	     */

	    ResetFlag(statePtr, CHANNEL_HAS_MORE_DATA);
	}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
    } else if (nread == 0) {
	SetFlag(statePtr, CHANNEL_EOF);
	statePtr->inputEncodingFlags |= TCL_ENCODING_END;
    } else if (nread < 0) {
	if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
	    SetFlag(statePtr, CHANNEL_BLOCKED);
	    result = EAGAIN;
	}
	Tcl_SetErrno(result);
	return result;
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Seek --
 *







>
>
>
>
>
>
>
>
>
>
>
>






<
<
<



<
<
<
|
>




















|
|
<





|




|
|








<
<
<
<
<
<
<
<
<
<
<
<
<
<

>







|
|
<
<
<
<
|
<
<
|
|
<
<
<
<
<
<
<
|
<
<
<
<
<
<

|
|
|
<
<
<
<
|
<

|
<
<
<
<
<
<

<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<







6507
6508
6509
6510
6511
6512
6513
6514
6515
6516
6517
6518
6519
6520
6521
6522
6523
6524
6525
6526
6527
6528
6529
6530
6531



6532
6533
6534



6535
6536
6537
6538
6539
6540
6541
6542
6543
6544
6545
6546
6547
6548
6549
6550
6551
6552
6553
6554
6555
6556
6557
6558

6559
6560
6561
6562
6563
6564
6565
6566
6567
6568
6569
6570
6571
6572
6573
6574
6575
6576
6577
6578














6579
6580
6581
6582
6583
6584
6585
6586
6587
6588
6589




6590


6591
6592







6593






6594
6595
6596
6597




6598

6599
6600






6601



6602


















6603


6604
6605
6606
6607
6608
6609
6610
     * channel cleanup has run but the channel is still registered in some
     * interpreter.
     */

    if (CheckForDeadChannel(NULL, statePtr)) {
	return EINVAL;
    }

    /* 
     * For a channel at EOF do not bother allocating buffers; there's
     * nothing more to read.  Avoid calling the driver inputproc in
     * case some of them do not react well to additional calls after
     * they've reported an eof state..
     * TODO: Candidate for a can't happen panic.
     */

    if (GotFlag(statePtr, CHANNEL_EOF)) {
	return 0;
    }

    /*
     * First check for more buffers in the pushback area of the topmost
     * channel in the stack and use them. They can be the result of a
     * transformation which went away without reading all the information
     * placed in the area when it was stacked.



     */

    if (chanPtr->inQueueHead != NULL) {




	assert(statePtr->inQueueHead == NULL);

	statePtr->inQueueHead = chanPtr->inQueueHead;
	statePtr->inQueueTail = chanPtr->inQueueTail;
	chanPtr->inQueueHead = NULL;
	chanPtr->inQueueTail = NULL;
	return 0;
    }

    /*
     * Nothing in the pushback area, fall back to the usual handling (driver,
     * etc.)
     */

    /*
     * See if we can fill an existing buffer. If we can, read only as much as
     * will fit in it. Otherwise allocate a new buffer, add it to the input
     * queue and attempt to fill it to the max.
     */

    bufPtr = statePtr->inQueueTail;

    if ((bufPtr == NULL) || IsBufferFull(bufPtr)) {

	bufPtr = statePtr->saveInBufPtr;
	statePtr->saveInBufPtr = NULL;

	/*
	 * Check the actual buffersize against the requested buffersize.
	 * Saved buffers of the wrong size are squashed. This is done
	 * to honor dynamic changes of the buffersize made by the user.
	 */

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

	if (bufPtr == NULL) {
	    bufPtr = AllocChannelBuffer(statePtr->bufSize);
	}
	bufPtr->nextPtr = NULL;















	toRead = SpaceLeft(bufPtr);
	assert(toRead == statePtr->bufSize);

	if (statePtr->inQueueTail == NULL) {
	    statePtr->inQueueHead = bufPtr;
	} else {
	    statePtr->inQueueTail->nextPtr = bufPtr;
	}
	statePtr->inQueueTail = bufPtr;
    } else {
	toRead = SpaceLeft(bufPtr);




    }



    PreserveChannelBuffer(bufPtr);







    nread = ChanRead(chanPtr, InsertPoint(bufPtr), toRead);







    if (nread < 0) {
	result = Tcl_GetErrno();
    } else {




	result = 0;

	bufPtr->nextAdded += nread;
    }










    ReleaseChannelBuffer(bufPtr);


















    return result;


}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Seek --
 *
6664
6665
6666
6667
6668
6669
6670
6671
6672
6673
6674
6675
6676
6677
6678
6679
6680
6681
6682
6683
6684
6685
6686
	}
	ResetFlag(statePtr, CHANNEL_NONBLOCKING);
	if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
	    ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
	}
    }

    /*
     * If there is data buffered in statePtr->curOutPtr then mark the channel
     * as ready to flush before invoking FlushChannel.
     */

    if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) {
	SetFlag(statePtr, BUFFER_READY);
    }

    /*
     * If the flush fails we cannot recover the original position. In that
     * case the seek is not attempted because we do not know where the access
     * position is - instead we return the error. FlushChannel has already
     * called Tcl_SetErrno() to report the error upwards. If the flush
     * succeeds we do the seek also.
     */







<
<
<
<
<
<
<
<
<







6723
6724
6725
6726
6727
6728
6729









6730
6731
6732
6733
6734
6735
6736
	}
	ResetFlag(statePtr, CHANNEL_NONBLOCKING);
	if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
	    ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
	}
    }










    /*
     * If the flush fails we cannot recover the original position. In that
     * case the seek is not attempted because we do not know where the access
     * position is - instead we return the error. FlushChannel has already
     * called Tcl_SetErrno() to report the error upwards. If the flush
     * succeeds we do the seek also.
     */
6997
6998
6999
7000
7001
7002
7003
7004
7005
7006
7007
7008
7009
7010
7011
7012
7013
7014
7015
7016
7017
7018
7019
7020
7021

    if (BUSY_STATE(statePtr, flags) && ((flags & CHANNEL_RAW_MODE) == 0)) {
	Tcl_SetErrno(EBUSY);
	return -1;
    }

    if (direction == TCL_READABLE) {
	/*
	 * If we have not encountered a sticky EOF, clear the EOF bit (sticky
	 * EOF is set if we have seen the input eofChar, to prevent reading
	 * beyond the eofChar). Also, always clear the BLOCKED bit. We want to
	 * discover these conditions anew in each operation.
	 */

	if (!GotFlag(statePtr, CHANNEL_STICKY_EOF)) {
	    ResetFlag(statePtr, CHANNEL_EOF);
	}
	ResetFlag(statePtr, CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA);
    }

    return 0;
}

/*
 *----------------------------------------------------------------------







<
<
<
<
<
<
<
<
|
<
<







7047
7048
7049
7050
7051
7052
7053








7054


7055
7056
7057
7058
7059
7060
7061

    if (BUSY_STATE(statePtr, flags) && ((flags & CHANNEL_RAW_MODE) == 0)) {
	Tcl_SetErrno(EBUSY);
	return -1;
    }

    if (direction == TCL_READABLE) {








	ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA);


    }

    return 0;
}

/*
 *----------------------------------------------------------------------
7223
7224
7225
7226
7227
7228
7229




7230
















7231
7232
7233
7234
7235
7236
7237
    if (sz < 1) {
	sz = 1;
    } else if (sz > MAX_CHANNEL_BUFFER_SIZE) {
	sz = MAX_CHANNEL_BUFFER_SIZE;
    }

    statePtr = ((Channel *) chan)->state;




    statePtr->bufSize = sz;
















}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetChannelBufferSize --
 *







>
>
>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







7263
7264
7265
7266
7267
7268
7269
7270
7271
7272
7273
7274
7275
7276
7277
7278
7279
7280
7281
7282
7283
7284
7285
7286
7287
7288
7289
7290
7291
7292
7293
7294
7295
7296
7297
    if (sz < 1) {
	sz = 1;
    } else if (sz > MAX_CHANNEL_BUFFER_SIZE) {
	sz = MAX_CHANNEL_BUFFER_SIZE;
    }

    statePtr = ((Channel *) chan)->state;

    if (statePtr->bufSize == sz) {
	return;
    }
    statePtr->bufSize = sz;

    /*
     * If bufsize changes, need to get rid of old utility buffer.
     */

    if (statePtr->saveInBufPtr != NULL) {
	RecycleBuffer(statePtr, statePtr->saveInBufPtr, 1);
	statePtr->saveInBufPtr = NULL;
    }
    if ((statePtr->inQueueHead != NULL)
	    && (statePtr->inQueueHead->nextPtr == NULL)
	    && IsBufferEmpty(statePtr->inQueueHead)) {
	RecycleBuffer(statePtr, statePtr->inQueueHead, 1);
	statePtr->inQueueHead = NULL;
	statePtr->inQueueTail = NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetChannelBufferSize --
 *
7658
7659
7660
7661
7662
7663
7664

7665
7666
7667
7668
7669
7670
7671
7672
7673
7674
7675
7676
7677
7678
7679
7680
7681
7682

7683
7684
7685
7686
7687
7688
7689
7690
7691
7692
7693
7694

7695
7696
7697
7698
7699
7700
7701
    } else if (HaveOpt(7, "-buffersize")) {
	int newBufferSize;

	if (Tcl_GetInt(interp, newValue, &newBufferSize) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	Tcl_SetChannelBufferSize(chan, newBufferSize);

    } else if (HaveOpt(2, "-encoding")) {
	Tcl_Encoding encoding;

	if ((newValue[0] == '\0') || (strcmp(newValue, "binary") == 0)) {
	    encoding = NULL;
	} else {
	    encoding = Tcl_GetEncoding(interp, newValue);
	    if (encoding == NULL) {
		return TCL_ERROR;
	    }
	}

	/*
	 * When the channel has an escape sequence driven encoding such as
	 * iso2022, the terminated escape sequence must write to the buffer.
	 */

	if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL)

		&& (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
	    statePtr->outputEncodingFlags |= TCL_ENCODING_END;
	    WriteChars(chanPtr, "", 0);
	}
	Tcl_FreeEncoding(statePtr->encoding);
	statePtr->encoding = encoding;
	statePtr->inputEncodingState = NULL;
	statePtr->inputEncodingFlags = TCL_ENCODING_START;
	statePtr->outputEncodingState = NULL;
	statePtr->outputEncodingFlags = TCL_ENCODING_START;
	ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA);
	UpdateInterest(chanPtr);

    } else if (HaveOpt(2, "-eofchar")) {
	if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if (argc == 0) {
	    statePtr->inEofChar = 0;
	    statePtr->outEofChar = 0;







>

















|
>












>







7718
7719
7720
7721
7722
7723
7724
7725
7726
7727
7728
7729
7730
7731
7732
7733
7734
7735
7736
7737
7738
7739
7740
7741
7742
7743
7744
7745
7746
7747
7748
7749
7750
7751
7752
7753
7754
7755
7756
7757
7758
7759
7760
7761
7762
7763
7764
    } else if (HaveOpt(7, "-buffersize")) {
	int newBufferSize;

	if (Tcl_GetInt(interp, newValue, &newBufferSize) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	Tcl_SetChannelBufferSize(chan, newBufferSize);
	return TCL_OK;
    } else if (HaveOpt(2, "-encoding")) {
	Tcl_Encoding encoding;

	if ((newValue[0] == '\0') || (strcmp(newValue, "binary") == 0)) {
	    encoding = NULL;
	} else {
	    encoding = Tcl_GetEncoding(interp, newValue);
	    if (encoding == NULL) {
		return TCL_ERROR;
	    }
	}

	/*
	 * When the channel has an escape sequence driven encoding such as
	 * iso2022, the terminated escape sequence must write to the buffer.
	 */

	if ((statePtr->encoding != NULL)
		&& !(statePtr->outputEncodingFlags & TCL_ENCODING_START)
		&& (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
	    statePtr->outputEncodingFlags |= TCL_ENCODING_END;
	    WriteChars(chanPtr, "", 0);
	}
	Tcl_FreeEncoding(statePtr->encoding);
	statePtr->encoding = encoding;
	statePtr->inputEncodingState = NULL;
	statePtr->inputEncodingFlags = TCL_ENCODING_START;
	statePtr->outputEncodingState = NULL;
	statePtr->outputEncodingFlags = TCL_ENCODING_START;
	ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA);
	UpdateInterest(chanPtr);
	return TCL_OK;
    } else if (HaveOpt(2, "-eofchar")) {
	if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if (argc == 0) {
	    statePtr->inEofChar = 0;
	    statePtr->outEofChar = 0;
7848
7849
7850
7851
7852
7853
7854
7855
7856
7857
7858
7859
7860
7861
7862
7863
7864
7865
7866
7867
7868
7869
7870
7871
7872
7873
7874
7875
7876
7877
    } else if (chanPtr->typePtr->setOptionProc != NULL) {
	return chanPtr->typePtr->setOptionProc(chanPtr->instanceData, interp,
		optionName, newValue);
    } else {
	return Tcl_BadChannelOption(interp, optionName, NULL);
    }

    /*
     * If bufsize changes, need to get rid of old utility buffer.
     */

    if (statePtr->saveInBufPtr != NULL) {
	RecycleBuffer(statePtr, statePtr->saveInBufPtr, 1);
	statePtr->saveInBufPtr = NULL;
    }
    if ((statePtr->inQueueHead != NULL)
	    && (statePtr->inQueueHead->nextPtr == NULL)
	    && IsBufferEmpty(statePtr->inQueueHead)) {
	RecycleBuffer(statePtr, statePtr->inQueueHead, 1);
	statePtr->inQueueHead = NULL;
	statePtr->inQueueTail = NULL;
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * CleanupChannelHandlers --







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







7911
7912
7913
7914
7915
7916
7917
















7918
7919
7920
7921
7922
7923
7924
    } else if (chanPtr->typePtr->setOptionProc != NULL) {
	return chanPtr->typePtr->setOptionProc(chanPtr->instanceData, interp,
		optionName, newValue);
    } else {
	return Tcl_BadChannelOption(interp, optionName, NULL);
    }

















    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * CleanupChannelHandlers --
7955
7956
7957
7958
7959
7960
7961
7962
7963
7964
7965
7966
7967
7968
7969
7970
7971
7972
7973
7974
7975
7976
7977
7978
7979
7980
7981
7982
7983
				/* State info for channel */
    ChannelHandler *chPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    NextChannelHandler nh;
    Channel *upChanPtr;
    const Tcl_ChannelType *upTypePtr;

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
    /*
     * [SF Tcl Bug 943274] For a non-blocking channel without blockmodeproc we
     * keep track of actual input coming from the OS so that we can do a
     * credible imitation of non-blocking behaviour.
     */

    if ((mask & TCL_READABLE) &&
	    GotFlag(statePtr, CHANNEL_NONBLOCKING) &&
	    (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) &&
	    !GotFlag(statePtr, CHANNEL_TIMER_FEV)) {
	SetFlag(statePtr, CHANNEL_HAS_MORE_DATA);
    }
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

    /*
     * In contrast to the other API functions this procedure walks towards the
     * top of a stack and not down from it.
     *
     * The channel calling this procedure is the one who generated the event,
     * and thus does not take part in handling it. IOW, its HandlerProc is not
     * called, instead we begin with the channel above it.







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







8002
8003
8004
8005
8006
8007
8008















8009
8010
8011
8012
8013
8014
8015
				/* State info for channel */
    ChannelHandler *chPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    NextChannelHandler nh;
    Channel *upChanPtr;
    const Tcl_ChannelType *upTypePtr;
















    /*
     * In contrast to the other API functions this procedure walks towards the
     * top of a stack and not down from it.
     *
     * The channel calling this procedure is the one who generated the event,
     * and thus does not take part in handling it. IOW, its HandlerProc is not
     * called, instead we begin with the channel above it.
8029
8030
8031
8032
8033
8034
8035
8036
8037

8038
8039
8040
8041
8042
8043
8044
    /*
     * If we are flushing in the background, be sure to call FlushChannel for
     * writable events. Note that we have to discard the writable event so we
     * don't call any write handlers before the flush is complete.
     */

    if (GotFlag(statePtr, BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) {
	FlushChannel(NULL, chanPtr, 1);
	mask &= ~TCL_WRITABLE;

    }

    /*
     * Add this invocation to the list of recursive invocations of
     * ChannelHandlerEventProc.
     */








|
|
>







8061
8062
8063
8064
8065
8066
8067
8068
8069
8070
8071
8072
8073
8074
8075
8076
8077
    /*
     * If we are flushing in the background, be sure to call FlushChannel for
     * writable events. Note that we have to discard the writable event so we
     * don't call any write handlers before the flush is complete.
     */

    if (GotFlag(statePtr, BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) {
	if (0 == FlushChannel(NULL, chanPtr, 1)) {
	    mask &= ~TCL_WRITABLE;
	}
    }

    /*
     * Add this invocation to the list of recursive invocations of
     * ChannelHandlerEventProc.
     */

8097
8098
8099
8100
8101
8102
8103





8104
8105
8106
8107
8108
8109
8110
static void
UpdateInterest(
    Channel *chanPtr)		/* Channel to update. */
{
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */
    int mask = statePtr->interestMask;






    /*
     * If there are flushed buffers waiting to be written, then we need to
     * watch for the channel to become writable.
     */

    if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {







>
>
>
>
>







8130
8131
8132
8133
8134
8135
8136
8137
8138
8139
8140
8141
8142
8143
8144
8145
8146
8147
8148
static void
UpdateInterest(
    Channel *chanPtr)		/* Channel to update. */
{
    ChannelState *statePtr = chanPtr->state;
				/* 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.
     */

    if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
8205
8206
8207
8208
8209
8210
8211
8212
8213
8214
8215
8216
8217
8218
8219
8220
8221
8222
8223
8224
8225
8226
8227
8228
8229
8230
8231
8232
8233
8234
8235
8236
8237
8238
8239
8240
8241
	/*
	 * Restart the timer in case a channel handler reenters the event loop
	 * before UpdateInterest gets called by Tcl_NotifyChannel.
	 */

	statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
                ChannelTimerProc,chanPtr);

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
	/*
	 * Set the TIMER flag to notify the higher levels that the driver
	 * might have no data for us. We do this only if we are in
	 * non-blocking mode and the driver has no BlockModeProc because only
	 * then we really don't know if the driver will block or not. A
	 * similar test is done in "PeekAhead".
	 */

	if (GotFlag(statePtr, CHANNEL_NONBLOCKING) &&
		(Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL)) {
	    SetFlag(statePtr, CHANNEL_TIMER_FEV);
	}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

	Tcl_Preserve(statePtr);
	Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
	ResetFlag(statePtr, CHANNEL_TIMER_FEV);
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

	Tcl_Release(statePtr);
    } else {
	statePtr->timer = NULL;
	UpdateInterest(chanPtr);
    }
}








<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


<
<
<
<
<







8243
8244
8245
8246
8247
8248
8249
















8250
8251





8252
8253
8254
8255
8256
8257
8258
	/*
	 * Restart the timer in case a channel handler reenters the event loop
	 * before UpdateInterest gets called by Tcl_NotifyChannel.
	 */

	statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
                ChannelTimerProc,chanPtr);
















	Tcl_Preserve(statePtr);
	Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);





	Tcl_Release(statePtr);
    } else {
	statePtr->timer = NULL;
	UpdateInterest(chanPtr);
    }
}

9167
9168
9169
9170
9171
9172
9173


9174
9175
9176
9177
9178

9179








9180
9181
9182
9183
9184
9185
9186
9187
9188
9189
9190
9191
9192
9193
9194
9195
9196
9197
9198
9199
9200
9201


9202
9203
9204

9205
9206
9207
9208

9209
9210
9211
9212
9213
9214
9215
9216
9217

9218
9219
9220
9221
9222
9223
9224
9225
9226
9227

9228
9229
9230
9231
9232
9233
9234

9235
9236
9237
9238
9239
9240
9241
9242
9243
9244
9245
9246
9247
9248
9249
9250
9251
9252
9253
9254
9255
9256
9257
9258
9259
9260
9261
9262
9263
9264
9265

9266
9267
9268



9269
9270
9271
9272
9273
9274
9275
9276
9277
9278
9279
9280
9281
9282
9283
9284
9285
9286
9287
9288
9289
9290
9291
9292
9293

9294
9295
9296
9297
9298
9299
9300
9301
9302
9303
9304
9305
9306
9307
9308
9309
9310
9311
9312

9313
9314
9315
9316
9317
9318
9319
9320
9321
9322
9323
9324
9325
9326
9327
9328

9329
9330
9331
9332
9333
9334
9335
9336
9337
9338
9339
9340
9341
9342
9343
9344
9345
9346
9347

9348
9349
9350
9351
9352
9353
9354
9355
9356
9357
9358
9359
9360
9361
9362
9363
9364
9365
9366
9367
9368
9369
9370
9371
9372
9373
9374
9375
9376
9377
9378
9379
9380
9381
9382
9383
9384
9385
9386
9387
9388
9389


9390
9391

9392



9393
9394
9395
9396
9397
9398

9399
9400
9401
9402
9403
9404
9405

9406
9407
9408
9409
9410
9411
9412
9413
9414
9415
9416
9417
9418
9419

9420
9421
9422

9423
9424
9425
9426
9427
9428
9429
9430
9431
9432


9433
9434
9435
9436
9437
9438
9439
9440
9441
9442
9443
9444
9445
9446
9447
9448
9449
9450
9451
9452
9453
9454
9455
9456
9457
9458
9459
9460
9461
9462
9463
9464
9465
9466
9467
9468
9469
9470
9471
9472
9473
9474
9475
9476
9477
9478
9479
9480
9481
9482
9483
9484
9485
9486
9487
9488
9489
9490
9491
9492
9493
9494
9495
9496
9497
9498
9499
9500
9501
9502
9503
9504
9505
9506
9507
9508
9509
9510
9511
9512
9513
9514
9515
9516
9517
9518
9519
9520
9521
9522
9523
9524
9525
9526
9527
9528
9529
9530
9531
9532
9533
9534
9535
9536
9537
9538
9539
9540
9541
9542
9543
9544
9545
9546
9547
9548
9549
9550
9551
9552
9553
9554
9555
9556
9557
9558
9559
9560
9561
9562
9563
9564
9565
9566
9567
9568
9569
9570
9571
9572
}

/*
 *----------------------------------------------------------------------
 *
 * DoRead --
 *


 *	Reads a given number of bytes from a channel. No encoding conversions
 *	are applied to the bytes being read.
 *
 * Results:
 *	The number of characters read, or -1 on error. Use Tcl_GetErrno() to

 *	retrieve the error code for the error that occurred.








 *
 * Side effects:
 *	May cause input to be buffered.
 *
 *----------------------------------------------------------------------
 */

static int
DoRead(
    Channel *chanPtr,		/* The channel from which to read. */
    char *bufPtr,		/* Where to store input read. */
    int toRead,			/* Maximum number of bytes to read. */
    int allowShortReads)	/* Allow half-blocking (pipes,sockets) */
{
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */
    int copied;			/* How many characters were copied into the
				 * result string? */
    int copiedNow;		/* How many characters were copied from the
				 * current input buffer? */
    int result;			/* Of calling GetInput. */



    /*
     * If we have not encountered a sticky EOF, clear the EOF bit. Either way
     * clear the BLOCKED bit. We want to discover these anew during each

     * operation.
     */

    if (!GotFlag(statePtr, CHANNEL_STICKY_EOF)) {

	ResetFlag(statePtr, CHANNEL_EOF);
    }
    ResetFlag(statePtr, CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA);

    for (copied = 0; copied < toRead; copied += copiedNow) {
	copiedNow = CopyAndTranslateBuffer(statePtr, bufPtr + copied,
		toRead - copied);
	if (copiedNow == 0) {
	    if (GotFlag(statePtr, CHANNEL_EOF)) {

		goto done;
	    }
	    if (GotFlag(statePtr, CHANNEL_BLOCKED)) {
		if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
		    goto done;
		}
		ResetFlag(statePtr, CHANNEL_BLOCKED);
	    }
	    result = GetInput(chanPtr);
	    if (result != 0) {

		if (result != EAGAIN) {
		    copied = -1;
		}
		goto done;
	    }
	} else if (allowShortReads) {
            copied += copiedNow;

            break;
        }
    }

    ResetFlag(statePtr, CHANNEL_BLOCKED);

    /*
     * Update the notifier state so we don't block while there is still data
     * in the buffers.
     */

  done:
    UpdateInterest(chanPtr);
    return copied;
}

/*
 *----------------------------------------------------------------------
 *
 * CopyAndTranslateBuffer --
 *
 *	Copy at most one buffer of input to the result space, doing eol
 *	translations according to mode in effect currently.
 *
 * Results:
 *	Number of bytes stored in the result buffer (as opposed to the number
 *	of bytes read from the channel). May return zero if no input is
 *	available to be translated.
 *
 * Side effects:
 *	Consumes buffered input. May deallocate one buffer.

 *
 *----------------------------------------------------------------------
 */




static int
CopyAndTranslateBuffer(
    ChannelState *statePtr,	/* Channel state from which to read input. */
    char *result,		/* Where to store the copied input. */
    int space)			/* How many bytes are available in result to
				 * store the copied input? */
{
    ChannelBuffer *bufPtr;	/* The buffer from which to copy bytes. */
    int bytesInBuffer;		/* How many bytes are available to be copied
				 * in the current input buffer? */
    int copied;			/* How many characters were already copied
				 * into the destination space? */
    int i;			/* Iterates over the copied input looking for
				 * the input eofChar. */

    /*
     * If there is no input at all, return zero. The invariant is that either
     * there is no buffer in the queue, or if the first buffer is empty, it is
     * also the last buffer (and thus there is no input in the queue). Note
     * also that if the buffer is empty, we leave it in the queue.
     */

    if (statePtr->inQueueHead == NULL) {
	return 0;

    }
    bufPtr = statePtr->inQueueHead;
    bytesInBuffer = BytesLeft(bufPtr);

    copied = 0;
    switch (statePtr->inputTranslation) {
    case TCL_TRANSLATE_LF:
	if (bytesInBuffer == 0) {
	    return 0;
	}

	/*
	 * Copy the current chunk into the result buffer.
	 */

	if (bytesInBuffer < space) {
	    space = bytesInBuffer;
	}
	memcpy(result, RemovePoint(bufPtr), (size_t) space);

	bufPtr->nextRemoved += space;
	copied = space;
	break;
    case TCL_TRANSLATE_CR: {
	char *end;

	if (bytesInBuffer == 0) {
	    return 0;
	}

	/*
	 * Copy the current chunk into the result buffer, then replace all \r
	 * with \n.
	 */

	if (bytesInBuffer < space) {

	    space = bytesInBuffer;
	}
	memcpy(result, RemovePoint(bufPtr), (size_t) space);
	bufPtr->nextRemoved += space;
	copied = space;

	for (end = result + copied; result < end; result++) {
	    if (*result == '\r') {
		*result = '\n';
	    }
	}
	break;
    }
    case TCL_TRANSLATE_CRLF: {
	char *src, *end, *dst;
	int curByte;

	/*
	 * If there is a held-back "\r" at EOF, produce it now.

	 */

	if (bytesInBuffer == 0) {
	    if ((statePtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) ==
		    (INPUT_SAW_CR | CHANNEL_EOF)) {
		result[0] = '\r';
		ResetFlag(statePtr, INPUT_SAW_CR);
		return 1;
	    }
	    return 0;
	}

	/*
	 * Copy the current chunk and replace "\r\n" with "\n" (but not
	 * standalone "\r"!).
	 */

	if (bytesInBuffer < space) {
	    space = bytesInBuffer;
	}
	memcpy(result, RemovePoint(bufPtr), (size_t) space);
	bufPtr->nextRemoved += space;
	copied = space;

	end = result + copied;
	dst = result;
	for (src = result; src < end; src++) {
	    curByte = *src;
	    if (curByte == '\n') {
		ResetFlag(statePtr, INPUT_SAW_CR);
	    } else if (GotFlag(statePtr, INPUT_SAW_CR)) {
		ResetFlag(statePtr, INPUT_SAW_CR);
		*dst = '\r';
		dst++;
	    }
	    if (curByte == '\r') {
		SetFlag(statePtr, INPUT_SAW_CR);
	    } else {
		*dst = (char) curByte;
		dst++;
	    }
	}


	copied = dst - result;
	break;

    }



    case TCL_TRANSLATE_AUTO: {
	char *src, *end, *dst;
	int curByte;

	if (bytesInBuffer == 0) {
	    return 0;

	}

	/*
	 * Loop over the current buffer, converting "\r" and "\r\n" to "\n".
	 */

	if (bytesInBuffer < space) {

	    space = bytesInBuffer;
	}
	memcpy(result, RemovePoint(bufPtr), (size_t) space);
	bufPtr->nextRemoved += space;
	copied = space;

	end = result + copied;
	dst = result;
	for (src = result; src < end; src++) {
	    curByte = *src;
	    if (curByte == '\r') {
		SetFlag(statePtr, INPUT_SAW_CR);
		*dst = '\n';
		dst++;

	    } else {
		if ((curByte != '\n') || !GotFlag(statePtr, INPUT_SAW_CR)) {
		    *dst = (char) curByte;

		    dst++;
		}
		ResetFlag(statePtr, INPUT_SAW_CR);
	    }
	}
	copied = dst - result;
	break;
    }
    default:
	Tcl_Panic("unknown eol translation mode");


    }

    /*
     * If an in-stream EOF character is set for this channel, check that the
     * input we copied so far does not contain the EOF char. If it does, copy
     * only up to and excluding that character.
     */

    if (statePtr->inEofChar != 0) {
	for (i = 0; i < copied; i++) {
	    if (result[i] == (char) statePtr->inEofChar) {
		/*
		 * Set sticky EOF so that no further input is presented to the
		 * caller.
		 */

		SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF);
		statePtr->inputEncodingFlags |= TCL_ENCODING_END;
		copied = i;
		break;
	    }
	}
    }

    /*
     * If the current buffer is empty recycle it.
     */

    if (IsBufferEmpty(bufPtr)) {
	statePtr->inQueueHead = bufPtr->nextPtr;
	if (statePtr->inQueueHead == NULL) {
	    statePtr->inQueueTail = NULL;
	}
	RecycleBuffer(statePtr, bufPtr, 0);
    }

    /*
     * Return the number of characters copied into the result buffer. This may
     * be different from the number of bytes consumed, because of EOL
     * translations.
     */

    return copied;
}

/*
 *----------------------------------------------------------------------
 *
 * CopyBuffer --
 *
 *	Copy at most one buffer of input to the result space.
 *
 * Results:
 *	Number of bytes stored in the result buffer. May return zero if no
 *	input is available.
 *
 * Side effects:
 *	Consumes buffered input. May deallocate one buffer.
 *
 *----------------------------------------------------------------------
 */

static int
CopyBuffer(
    Channel *chanPtr,		/* Channel from which to read input. */
    char *result,		/* Where to store the copied input. */
    int space)			/* How many bytes are available in result to
				 * store the copied input? */
{
    ChannelBuffer *bufPtr;	/* The buffer from which to copy bytes. */
    int bytesInBuffer;		/* How many bytes are available to be copied
				 * in the current input buffer? */
    int copied;			/* How many characters were already copied
				 * into the destination space? */

    /*
     * If there is no input at all, return zero. The invariant is that either
     * there is no buffer in the queue, or if the first buffer is empty, it is
     * also the last buffer (and thus there is no input in the queue). Note
     * also that if the buffer is empty, we don't leave it in the queue, but
     * recycle it.
     */

    if (chanPtr->inQueueHead == NULL) {
	return 0;
    }
    bufPtr = chanPtr->inQueueHead;
    bytesInBuffer = BytesLeft(bufPtr);

    copied = 0;

    if (bytesInBuffer == 0) {
	RecycleBuffer(chanPtr->state, bufPtr, 0);
	chanPtr->inQueueHead = NULL;
	chanPtr->inQueueTail = NULL;
	return 0;
    }

    /*
     * Copy the current chunk into the result buffer.
     */

    if (bytesInBuffer < space) {
	space = bytesInBuffer;
    }

    memcpy(result, RemovePoint(bufPtr), (size_t) space);
    bufPtr->nextRemoved += space;
    copied = space;

    /*
     * We don't care about in-stream EOF characters here as the data read here
     * may still flow through one or more transformations, i.e. is not in its
     * final state yet.
     */

    /*
     * If the current buffer is empty recycle it.
     */

    if (IsBufferEmpty(bufPtr)) {
	chanPtr->inQueueHead = bufPtr->nextPtr;
	if (chanPtr->inQueueHead == NULL) {
	    chanPtr->inQueueTail = NULL;
	}
	RecycleBuffer(chanPtr->state, bufPtr, 0);
    }

    /*
     * Return the number of characters copied into the result buffer.
     */

    return copied;
}

/*
 *----------------------------------------------------------------------
 *
 * CopyEventProc --
 *







>
>
|



|
>
|
>
>
>
>
>
>
>
>










|
|



|
<
<
<
<
<

>
>
|
<
<
>
|
|

<
>
|
|
<
|
<
<
<
<
<
>
|
<
<
<
<
<
<
<
<
<
>
<
<
|
<
<
|
<
>
|
|
|
|
<

<
|
|
<

|
|
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
>
|
<
<
>
>
>
|
<
<
<
<
<
<
|
<
<
<
<
<
<
<
|
|
<
<
<
<
<
|
|
|
>
|
<
|
|
<
<
<
<
<
|
|
<
<
<

|
|
|
|
>
|
<
<
<
<
|
<
<
<
|
<
<
<
<

|
>
|
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
|
<
<
>
|

|
<
<
|
<
|

<
|
<
|
|
<
|

|
<
<
|
<
<
|
<
|
<
<
<
<
<
<
<
<

<
<
<
<
<
|
<
>
>
|
<
>
|
>
>
>
<
<
<

|
<
>
|
|
|
<
<

<
>
|
<
<
|
<
|
|
<
<
<
<
|
<
|
>
|
<
<
>
|
<
<
|
|
<
<
|
<
<
>
>
|
|
<
<
<
<
<

|
<
<
<
<
<
<
|
<
|
<
<


<
<
<
<
<

|
|
|
|
|
|
|

<
<
<
<
<
|
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
|
<
<
<
<
<
|
<
<
<
|
<
<
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|







9184
9185
9186
9187
9188
9189
9190
9191
9192
9193
9194
9195
9196
9197
9198
9199
9200
9201
9202
9203
9204
9205
9206
9207
9208
9209
9210
9211
9212
9213
9214
9215
9216
9217
9218
9219
9220
9221
9222
9223





9224
9225
9226
9227


9228
9229
9230
9231

9232
9233
9234

9235





9236
9237









9238


9239


9240

9241
9242
9243
9244
9245

9246

9247
9248

9249
9250
9251


9252












9253


9254
9255


9256
9257
9258
9259






9260







9261
9262





9263
9264
9265
9266
9267

9268
9269





9270
9271



9272
9273
9274
9275
9276
9277
9278




9279



9280




9281
9282
9283
9284




9285










9286


9287
9288
9289
9290


9291

9292
9293

9294

9295
9296

9297
9298
9299


9300


9301

9302








9303





9304

9305
9306
9307

9308
9309
9310
9311
9312



9313
9314

9315
9316
9317
9318


9319

9320
9321


9322

9323
9324




9325

9326
9327
9328


9329
9330


9331
9332


9333


9334
9335
9336
9337





9338
9339






9340

9341


9342
9343





9344
9345
9346
9347
9348
9349
9350
9351
9352





9353


9354
















9355












9356







9357








9358





9359



9360


9361
9362


























9363
9364
9365
9366
9367
9368
9369
9370
}

/*
 *----------------------------------------------------------------------
 *
 * DoRead --
 *
 *	Stores up to "bytesToRead" bytes in memory pointed to by "dst".
 *	These bytes come from reading the channel "chanPtr" and 
 *	performing the configured translations.  No encoding conversions
 *	are applied to the bytes being read.
 *
 * Results:
 *	The number of bytes actually stored (<= bytesToRead),
 * 	or -1 if there is an error in reading the channel.  Use
 * 	Tcl_GetErrno() to retrieve the error code for the error
 *	that occurred.
 *
 *	The number of bytes stored can be less than the number
 * 	requested when
 *	  - EOF is reached on the channel; or
 *	  - the channel is non-blocking, and we've read all we can
 *	    without blocking.
 *	  - a channel reading error occurs (and we return -1)
 *
 * Side effects:
 *	May cause input to be buffered.
 *
 *----------------------------------------------------------------------
 */

static int
DoRead(
    Channel *chanPtr,		/* The channel from which to read. */
    char *dst,			/* Where to store input read. */
    int bytesToRead,		/* Maximum number of bytes to read. */
    int allowShortReads)	/* Allow half-blocking (pipes,sockets) */
{
    ChannelState *statePtr = chanPtr->state;
    char *p = dst;






    Tcl_Preserve(chanPtr);
    while (bytesToRead) {
	/*


	 * Each pass through the loop is intended to process up to 
	 * one channel buffer.
	 */


	int bytesRead, bytesWritten;
	ChannelBuffer *bufPtr = statePtr->inQueueHead;


	/*





	 * When there's no buffered data to read, and we're at EOF,
	 * escape to the caller.









	 */





	if (statePtr->flags & CHANNEL_EOF

		&& (bufPtr == NULL || IsBufferEmpty(bufPtr))) {
	    break;
	}

	/* If there is no full buffer, attempt to create and/or fill one. */



	while (!IsBufferFull(bufPtr)) {
	    int code;


	moreData:
	    code = GetInput(chanPtr);


	    bufPtr = statePtr->inQueueHead;















	    assert (bufPtr != NULL);



	    if (statePtr->flags & (CHANNEL_EOF|CHANNEL_BLOCKED)) {
		/* Further reads cannot do any more */
		break;
	    }






	    







	    if (code) {
		/* Read error */





		UpdateInterest(chanPtr);
		Tcl_Release(chanPtr);
		return -1;
	    }


	    assert (IsBufferFull(bufPtr));
	}






	assert (bufPtr != NULL);




	bytesRead = BytesLeft(bufPtr);
	bytesWritten = bytesToRead;

	TranslateInputEOL(statePtr, p, RemovePoint(bufPtr),
		&bytesWritten, &bytesRead);
	bufPtr->nextRemoved += bytesRead;




	p += bytesWritten;



	bytesToRead -= bytesWritten;





	if (!IsBufferEmpty(bufPtr)) {
	    /*
	     * Buffer is not empty.  How can that be?




	     *










	     * 0) We stopped early because we got all the bytes


	     *    we were seeking.  That's fine.
	     */

	    if (bytesToRead == 0) {


		UpdateInterest(chanPtr);

		break;
	    }



	    /*
	     * 1) We're @EOF because we saw eof char.

	     */

	    if (statePtr->inEofChar


		    && RemovePoint(bufPtr)[0] == statePtr->inEofChar) {


		UpdateInterest(chanPtr);

		break;








	    }







	    /*
	     * 2) The buffer holds a \r while in CRLF translation,
	     *    followed by the end of the buffer.

	     */

	    assert(statePtr->inputTranslation == TCL_TRANSLATE_CRLF);
	    assert(RemovePoint(bufPtr)[0] == '\r');
	    assert(BytesLeft(bufPtr) == 1);




	    if (bufPtr->nextPtr == NULL) {

		/* There's no more buffered data.... */

		if (statePtr->flags & CHANNEL_EOF) {
		    /* ...and there never will be. */




		    *p++ = '\r';
		    bytesToRead--;


		    bufPtr->nextRemoved++;

		} else if (statePtr->flags & CHANNEL_BLOCKED) {
		    /* ...and we cannot get more now. */




		    SetFlag(statePtr, CHANNEL_NEED_MORE_DATA);

		    UpdateInterest(chanPtr);
		    break;
		} else {


		    /* ... so we need to get some. */
		    goto moreData;


		}
	    }





	    if (bufPtr->nextPtr) {
		/* There's a next buffer.  Shift orphan \r to it. */

		ChannelBuffer *nextPtr = bufPtr->nextPtr;






		nextPtr->nextRemoved -= 1;






		RemovePoint(nextPtr)[0] = '\r';

		bufPtr->nextRemoved++;


	    }
	}






	if (IsBufferEmpty(bufPtr)) {
	    statePtr->inQueueHead = bufPtr->nextPtr;
	    if (statePtr->inQueueHead == NULL) {
		statePtr->inQueueTail = NULL;
	    }
	    RecycleBuffer(statePtr, bufPtr, 0);
	}






	if ((GotFlag(statePtr, CHANNEL_NONBLOCKING) || allowShortReads)


		&& GotFlag(statePtr, CHANNEL_BLOCKED)) {
















	    break;












	}







    }








    if (bytesToRead == 0) {





	ResetFlag(statePtr, CHANNEL_BLOCKED);



    }



    Tcl_Release(chanPtr);


























    return (int)(p - dst);
}

/*
 *----------------------------------------------------------------------
 *
 * CopyEventProc --
 *
9678
9679
9680
9681
9682
9683
9684

9685
9686
9687


9688
9689
9690
9691
9692
9693
9694
9695
9696
9697
StackSetBlockMode(
    Channel *chanPtr,		/* Channel to modify. */
    int mode)			/* One of TCL_MODE_BLOCKING or
				 * TCL_MODE_NONBLOCKING. */
{
    int result = 0;
    Tcl_DriverBlockModeProc *blockModeProc;


    /*
     * Start at the top of the channel stack


     */

    chanPtr = chanPtr->state->topChanPtr;
    while (chanPtr != NULL) {
	blockModeProc = Tcl_ChannelBlockModeProc(chanPtr->typePtr);
	if (blockModeProc != NULL) {
	    result = blockModeProc(chanPtr->instanceData, mode);
	    if (result != 0) {
		Tcl_SetErrno(result);
		return result;







>



>
>


|







9476
9477
9478
9479
9480
9481
9482
9483
9484
9485
9486
9487
9488
9489
9490
9491
9492
9493
9494
9495
9496
9497
9498
StackSetBlockMode(
    Channel *chanPtr,		/* Channel to modify. */
    int mode)			/* One of TCL_MODE_BLOCKING or
				 * TCL_MODE_NONBLOCKING. */
{
    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 = statePtr->topChanPtr;
    while (chanPtr != NULL) {
	blockModeProc = Tcl_ChannelBlockModeProc(chanPtr->typePtr);
	if (blockModeProc != NULL) {
	    result = blockModeProc(chanPtr->instanceData, mode);
	    if (result != 0) {
		Tcl_SetErrno(result);
		return result;
10822
10823
10824
10825
10826
10827
10828

10829
10830
10831
10832
10833
10834
10835
    ChannelState *statePtr;

    if (interp == NULL) {
	return TCL_ERROR;
    }
    if (objPtr->typePtr == &chanObjType) {
	/*

	 * The channel is valid until any call to DetachChannel occurs.
	 * Ensure consistency checks are done.
	 */

	statePtr = GET_CHANNELSTATE(objPtr);
	if (GotFlag(statePtr, CHANNEL_TAINTED|CHANNEL_CLOSED)) {
	    ResetFlag(statePtr, CHANNEL_TAINTED);







>







10623
10624
10625
10626
10627
10628
10629
10630
10631
10632
10633
10634
10635
10636
10637
    ChannelState *statePtr;

    if (interp == NULL) {
	return TCL_ERROR;
    }
    if (objPtr->typePtr == &chanObjType) {
	/*
	 * TODO: TAINT Flag and dup'd channel values?
	 * The channel is valid until any call to DetachChannel occurs.
	 * Ensure consistency checks are done.
	 */

	statePtr = GET_CHANNELSTATE(objPtr);
	if (GotFlag(statePtr, CHANNEL_TAINTED|CHANNEL_CLOSED)) {
	    ResetFlag(statePtr, CHANNEL_TAINTED);
10898
10899
10900
10901
10902
10903
10904
10905
10906
10907
10908
10909
10910
10911
10912
10913
10914
10915
10916
10917
10918
10919
10920
10921
10922
10923
10924
10925
#define ChanFlag(chr, bit)      (buf[i++] = ((flags & (bit)) ? (chr) : '_'))

    ChanFlag('r', TCL_READABLE);
    ChanFlag('w', TCL_WRITABLE);
    ChanFlag('n', CHANNEL_NONBLOCKING);
    ChanFlag('l', CHANNEL_LINEBUFFERED);
    ChanFlag('u', CHANNEL_UNBUFFERED);
    ChanFlag('R', BUFFER_READY);
    ChanFlag('F', BG_FLUSH_SCHEDULED);
    ChanFlag('c', CHANNEL_CLOSED);
    ChanFlag('E', CHANNEL_EOF);
    ChanFlag('S', CHANNEL_STICKY_EOF);
    ChanFlag('B', CHANNEL_BLOCKED);
    ChanFlag('/', INPUT_SAW_CR);
    ChanFlag('*', INPUT_NEED_NL);
    ChanFlag('D', CHANNEL_DEAD);
    ChanFlag('R', CHANNEL_RAW_MODE);
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
    ChanFlag('T', CHANNEL_TIMER_FEV);
    ChanFlag('H', CHANNEL_HAS_MORE_DATA);
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
    ChanFlag('x', CHANNEL_INCLOSE);

    buf[i] ='\0';

    fprintf(stderr, "%s: %s\n", str, buf);
    return 0;
}







<






<


<
<
<
<







10700
10701
10702
10703
10704
10705
10706

10707
10708
10709
10710
10711
10712

10713
10714




10715
10716
10717
10718
10719
10720
10721
#define ChanFlag(chr, bit)      (buf[i++] = ((flags & (bit)) ? (chr) : '_'))

    ChanFlag('r', TCL_READABLE);
    ChanFlag('w', TCL_WRITABLE);
    ChanFlag('n', CHANNEL_NONBLOCKING);
    ChanFlag('l', CHANNEL_LINEBUFFERED);
    ChanFlag('u', CHANNEL_UNBUFFERED);

    ChanFlag('F', BG_FLUSH_SCHEDULED);
    ChanFlag('c', CHANNEL_CLOSED);
    ChanFlag('E', CHANNEL_EOF);
    ChanFlag('S', CHANNEL_STICKY_EOF);
    ChanFlag('B', CHANNEL_BLOCKED);
    ChanFlag('/', INPUT_SAW_CR);

    ChanFlag('D', CHANNEL_DEAD);
    ChanFlag('R', CHANNEL_RAW_MODE);




    ChanFlag('x', CHANNEL_INCLOSE);

    buf[i] ='\0';

    fprintf(stderr, "%s: %s\n", str, buf);
    return 0;
}
Changes to generic/tclIO.h.
32
33
34
35
36
37
38

39
40
41
42
43
44
45
/*
 * struct ChannelBuffer:
 *
 * Buffers data being sent to or from a channel.
 */

typedef struct ChannelBuffer {

    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
				 * the buffer. */
    int bufLength;		/* How big is the buffer? */
    struct ChannelBuffer *nextPtr;
    				/* Next buffer in chain. */







>







32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
/*
 * struct ChannelBuffer:
 *
 * Buffers data being sent to or from a channel.
 */

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
				 * the buffer. */
    int bufLength;		/* How big is the buffer? */
    struct ChannelBuffer *nextPtr;
    				/* Next buffer in chain. */
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240

#define CHANNEL_NONBLOCKING	(1<<3)	/* Channel is currently in nonblocking
					 * mode. */
#define CHANNEL_LINEBUFFERED	(1<<4)	/* Output to the channel must be
					 * flushed after every newline. */
#define CHANNEL_UNBUFFERED	(1<<5)	/* Output to the channel must always
					 * be flushed immediately. */
#define BUFFER_READY		(1<<6)	/* Current output buffer (the
					 * curOutPtr field in the channel
					 * structure) should be output as soon
					 * as possible even though it may not
					 * be full. */
#define BG_FLUSH_SCHEDULED	(1<<7)	/* A background flush of the queued
					 * output buffers has been
					 * scheduled. */
#define CHANNEL_CLOSED		(1<<8)	/* Channel has been closed. No further
					 * Tcl-level IO on the channel is
					 * allowed. */
#define CHANNEL_EOF		(1<<9)	/* EOF occurred on this channel. This







<
<
<
<
<







223
224
225
226
227
228
229





230
231
232
233
234
235
236

#define CHANNEL_NONBLOCKING	(1<<3)	/* Channel is currently in nonblocking
					 * mode. */
#define CHANNEL_LINEBUFFERED	(1<<4)	/* Output to the channel must be
					 * flushed after every newline. */
#define CHANNEL_UNBUFFERED	(1<<5)	/* Output to the channel must always
					 * be flushed immediately. */





#define BG_FLUSH_SCHEDULED	(1<<7)	/* A background flush of the queued
					 * output buffers has been
					 * scheduled. */
#define CHANNEL_CLOSED		(1<<8)	/* Channel has been closed. No further
					 * Tcl-level IO on the channel is
					 * allowed. */
#define CHANNEL_EOF		(1<<9)	/* EOF occurred on this channel. This
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
#define CHANNEL_BLOCKED		(1<<11)	/* EWOULDBLOCK or EAGAIN occurred on
					 * this channel. This bit is cleared
					 * before every input or output
					 * operation. */
#define INPUT_SAW_CR		(1<<12)	/* Channel is in CRLF eol input
					 * translation mode and the last byte
					 * seen was a "\r". */
#define INPUT_NEED_NL		(1<<15)	/* Saw a '\r' at end of last buffer,
					 * and there should be a '\n' at
					 * beginning of next buffer. */
#define CHANNEL_DEAD		(1<<13)	/* The channel has been closed by the
					 * exit handler (on exit) but not
					 * deallocated. When any IO operation
					 * sees this flag on a channel, it
					 * does not call driver level
					 * functions to avoid referring to
					 * deallocated data. */
#define CHANNEL_NEED_MORE_DATA	(1<<14)	/* The last input operation failed
					 * because there was not enough data
					 * to complete the operation. This
					 * flag is set when gets fails to get
					 * a complete line or when read fails
					 * to get a complete character. When
					 * set, file events will not be
					 * delivered for buffered data until
					 * the state of the channel
					 * changes. */
#define CHANNEL_RAW_MODE	(1<<16)	/* When set, notes that the Raw API is
					 * being used. */
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
#define CHANNEL_TIMER_FEV	(1<<17)	/* When set the event we are notified
					 * by is a fileevent generated by a
					 * timer. We don't know if the driver
					 * has more data and should not try to
					 * read from it. If the system needs
					 * more than is in the buffers out
					 * read routines will simulate a short
					 * read (0 characters read) */
#define CHANNEL_HAS_MORE_DATA   (1<<18) /* Set by NotifyChannel for a channel
					 * if and only if the channel is
					 * configured non-blocking, the driver
					 * for said channel has no
					 * blockmodeproc, and data has arrived
					 * for reading at the OS level). A
					 * GetInput will pass reading from the
					 * driver if the channel is
					 * non-blocking, without blockmode
					 * proc and the flag has not been set.
					 * A read will be performed if the
					 * flag is set. This will reset the
					 * flag as well. */
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

#define CHANNEL_INCLOSE		(1<<19)	/* Channel is currently being closed.
					 * Its structures are still live and
					 * usable, but it may not be closed
					 * again from within the close
					 * handler. */
#define CHANNEL_TAINTED		(1<<20)	/* Channel stack structure has changed.







<
<
<



















<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







244
245
246
247
248
249
250



251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269























270
271
272
273
274
275
276
#define CHANNEL_BLOCKED		(1<<11)	/* EWOULDBLOCK or EAGAIN occurred on
					 * this channel. This bit is cleared
					 * before every input or output
					 * operation. */
#define INPUT_SAW_CR		(1<<12)	/* Channel is in CRLF eol input
					 * translation mode and the last byte
					 * seen was a "\r". */



#define CHANNEL_DEAD		(1<<13)	/* The channel has been closed by the
					 * exit handler (on exit) but not
					 * deallocated. When any IO operation
					 * sees this flag on a channel, it
					 * does not call driver level
					 * functions to avoid referring to
					 * deallocated data. */
#define CHANNEL_NEED_MORE_DATA	(1<<14)	/* The last input operation failed
					 * because there was not enough data
					 * to complete the operation. This
					 * flag is set when gets fails to get
					 * a complete line or when read fails
					 * to get a complete character. When
					 * set, file events will not be
					 * delivered for buffered data until
					 * the state of the channel
					 * changes. */
#define CHANNEL_RAW_MODE	(1<<16)	/* When set, notes that the Raw API is
					 * being used. */
























#define CHANNEL_INCLOSE		(1<<19)	/* Channel is currently being closed.
					 * Its structures are still live and
					 * usable, but it may not be closed
					 * again from within the close
					 * handler. */
#define CHANNEL_TAINTED		(1<<20)	/* Channel stack structure has changed.
Changes to generic/tclIOCmd.c.
177
178
179
180
181
182
183

184
185
186
187
188
189
190
191
192
193

194
195
196
197
198
199
200
201
202
203
204
205
206
207

208
209
210
211
212
213
214
    if (!(mode & TCL_WRITABLE)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"channel \"%s\" wasn't opened for writing",
		TclGetString(chanObjPtr)));
	return TCL_ERROR;
    }


    result = Tcl_WriteObj(chan, string);
    if (result < 0) {
	goto error;
    }
    if (newline != 0) {
	result = Tcl_WriteChars(chan, "\n", 1);
	if (result < 0) {
	    goto error;
	}
    }

    return TCL_OK;

    /*
     * TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result. Fall back to the regular
     * message if nothing was found in the bypass.
     */

  error:
    if (!TclChanCaughtErrorBypass(interp, chan)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s",
		TclGetString(chanObjPtr), Tcl_PosixError(interp)));
    }

    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FlushObjCmd --







>










>














>







177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
    if (!(mode & TCL_WRITABLE)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"channel \"%s\" wasn't opened for writing",
		TclGetString(chanObjPtr)));
	return TCL_ERROR;
    }

    Tcl_Preserve(chan);
    result = Tcl_WriteObj(chan, string);
    if (result < 0) {
	goto error;
    }
    if (newline != 0) {
	result = Tcl_WriteChars(chan, "\n", 1);
	if (result < 0) {
	    goto error;
	}
    }
    Tcl_Release(chan);
    return TCL_OK;

    /*
     * TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result. Fall back to the regular
     * message if nothing was found in the bypass.
     */

  error:
    if (!TclChanCaughtErrorBypass(interp, chan)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s",
		TclGetString(chanObjPtr), Tcl_PosixError(interp)));
    }
    Tcl_Release(chan);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FlushObjCmd --
248
249
250
251
252
253
254

255
256
257
258
259
260
261
262
263
264
265
266
267

268
269

270
271
272
273
274
275
276
    if (!(mode & TCL_WRITABLE)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"channel \"%s\" wasn't opened for writing",
		TclGetString(chanObjPtr)));
	return TCL_ERROR;
    }


    if (Tcl_Flush(chan) != TCL_OK) {
	/*
	 * TIP #219.
	 * Capture error messages put by the driver into the bypass area and
	 * put them into the regular interpreter result. Fall back to the
	 * regular message if nothing was found in the bypass.
	 */

	if (!TclChanCaughtErrorBypass(interp, chan)) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "error flushing \"%s\": %s",
		    TclGetString(chanObjPtr), Tcl_PosixError(interp)));
	}

	return TCL_ERROR;
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetsObjCmd --







>













>


>







251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
    if (!(mode & TCL_WRITABLE)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"channel \"%s\" wasn't opened for writing",
		TclGetString(chanObjPtr)));
	return TCL_ERROR;
    }

    Tcl_Preserve(chan);
    if (Tcl_Flush(chan) != TCL_OK) {
	/*
	 * TIP #219.
	 * Capture error messages put by the driver into the bypass area and
	 * put them into the regular interpreter result. Fall back to the
	 * regular message if nothing was found in the bypass.
	 */

	if (!TclChanCaughtErrorBypass(interp, chan)) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "error flushing \"%s\": %s",
		    TclGetString(chanObjPtr), Tcl_PosixError(interp)));
	}
	Tcl_Release(chan);
	return TCL_ERROR;
    }
    Tcl_Release(chan);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetsObjCmd --
295
296
297
298
299
300
301

302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317

318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336

337
338
339
340
341
342
343

344
345
346
347
348


349
350
351
352
353
354
355
356
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to read from. */
    int lineLen;		/* Length of line just read. */
    int mode;			/* Mode in which channel is opened. */
    Tcl_Obj *linePtr, *chanObjPtr;


    if ((objc != 2) && (objc != 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
	return TCL_ERROR;
    }
    chanObjPtr = objv[1];
    if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
	return TCL_ERROR;
    }
    if (!(mode & TCL_READABLE)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"channel \"%s\" wasn't opened for reading",
		TclGetString(chanObjPtr)));
	return TCL_ERROR;
    }


    linePtr = Tcl_NewObj();
    lineLen = Tcl_GetsObj(chan, linePtr);
    if (lineLen < 0) {
	if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
	    Tcl_DecrRefCount(linePtr);

	    /*
	     * TIP #219.
	     * Capture error messages put by the driver into the bypass area
	     * and put them into the regular interpreter result. Fall back to
	     * the regular message if nothing was found in the bypass.
	     */

	    if (!TclChanCaughtErrorBypass(interp, chan)) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"error reading \"%s\": %s",
			TclGetString(chanObjPtr), Tcl_PosixError(interp)));
	    }
	    return TCL_ERROR;

	}
	lineLen = -1;
    }
    if (objc == 3) {
	if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
		TCL_LEAVE_ERR_MSG) == NULL) {
	    return TCL_ERROR;

	}
	Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen));
    } else {
	Tcl_SetObjResult(interp, linePtr);
    }


    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ReadObjCmd --
 *







>
















>


















|
>






|
>





>
>
|







301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to read from. */
    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?");
	return TCL_ERROR;
    }
    chanObjPtr = objv[1];
    if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
	return TCL_ERROR;
    }
    if (!(mode & TCL_READABLE)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"channel \"%s\" wasn't opened for reading",
		TclGetString(chanObjPtr)));
	return TCL_ERROR;
    }

    Tcl_Preserve(chan);
    linePtr = Tcl_NewObj();
    lineLen = Tcl_GetsObj(chan, linePtr);
    if (lineLen < 0) {
	if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
	    Tcl_DecrRefCount(linePtr);

	    /*
	     * TIP #219.
	     * Capture error messages put by the driver into the bypass area
	     * and put them into the regular interpreter result. Fall back to
	     * the regular message if nothing was found in the bypass.
	     */

	    if (!TclChanCaughtErrorBypass(interp, chan)) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"error reading \"%s\": %s",
			TclGetString(chanObjPtr), Tcl_PosixError(interp)));
	    }
	    code = TCL_ERROR;
	    goto done;
	}
	lineLen = -1;
    }
    if (objc == 3) {
	if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
		TCL_LEAVE_ERR_MSG) == NULL) {
	    code = TCL_ERROR;
	    goto done;
	}
	Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen));
    } else {
	Tcl_SetObjResult(interp, linePtr);
    }
  done:
    Tcl_Release(chan);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ReadObjCmd --
 *
449
450
451
452
453
454
455

456
457
458
459
460
461
462
463
464
465
466
467
468
469

470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487

488
489
490
491
492
493
494
	    newline = 1;
#endif
	}
    }

    resultPtr = Tcl_NewObj();
    Tcl_IncrRefCount(resultPtr);

    charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
    if (charactersRead < 0) {
	/*
	 * TIP #219.
	 * Capture error messages put by the driver into the bypass area and
	 * put them into the regular interpreter result. Fall back to the
	 * regular message if nothing was found in the bypass.
	 */

	if (!TclChanCaughtErrorBypass(interp, chan)) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "error reading \"%s\": %s",
		    TclGetString(chanObjPtr), Tcl_PosixError(interp)));
	}

	Tcl_DecrRefCount(resultPtr);
	return TCL_ERROR;
    }

    /*
     * If requested, remove the last newline in the channel if at EOF.
     */

    if ((charactersRead > 0) && (newline != 0)) {
	const char *result;
	int length;

	result = TclGetStringFromObj(resultPtr, &length);
	if (result[length - 1] == '\n') {
	    Tcl_SetObjLength(resultPtr, length - 1);
	}
    }
    Tcl_SetObjResult(interp, resultPtr);

    Tcl_DecrRefCount(resultPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







>














>


















>







461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
	    newline = 1;
#endif
	}
    }

    resultPtr = Tcl_NewObj();
    Tcl_IncrRefCount(resultPtr);
    Tcl_Preserve(chan);
    charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
    if (charactersRead < 0) {
	/*
	 * TIP #219.
	 * Capture error messages put by the driver into the bypass area and
	 * put them into the regular interpreter result. Fall back to the
	 * regular message if nothing was found in the bypass.
	 */

	if (!TclChanCaughtErrorBypass(interp, chan)) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "error reading \"%s\": %s",
		    TclGetString(chanObjPtr), Tcl_PosixError(interp)));
	}
	Tcl_Release(chan);
	Tcl_DecrRefCount(resultPtr);
	return TCL_ERROR;
    }

    /*
     * If requested, remove the last newline in the channel if at EOF.
     */

    if ((charactersRead > 0) && (newline != 0)) {
	const char *result;
	int length;

	result = TclGetStringFromObj(resultPtr, &length);
	if (result[length - 1] == '\n') {
	    Tcl_SetObjLength(resultPtr, length - 1);
	}
    }
    Tcl_SetObjResult(interp, resultPtr);
    Tcl_Release(chan);
    Tcl_DecrRefCount(resultPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
540
541
542
543
544
545
546

547
548
549
550
551
552
553
554
555
556
557
558
559
560

561
562

563
564
565
566
567
568
569
	if (Tcl_GetIndexFromObj(interp, objv[3], originOptions, "origin", 0,
		&optionIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	mode = modeArray[optionIndex];
    }


    result = Tcl_Seek(chan, offset, mode);
    if (result == Tcl_LongAsWide(-1)) {
	/*
	 * TIP #219.
	 * Capture error messages put by the driver into the bypass area and
	 * put them into the regular interpreter result. Fall back to the
	 * regular message if nothing was found in the bypass.
	 */

	if (!TclChanCaughtErrorBypass(interp, chan)) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "error during seek on \"%s\": %s",
		    TclGetString(objv[1]), Tcl_PosixError(interp)));
	}

	return TCL_ERROR;
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TellObjCmd --







>














>


>







555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
	if (Tcl_GetIndexFromObj(interp, objv[3], originOptions, "origin", 0,
		&optionIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	mode = modeArray[optionIndex];
    }

    Tcl_Preserve(chan);
    result = Tcl_Seek(chan, offset, mode);
    if (result == Tcl_LongAsWide(-1)) {
	/*
	 * TIP #219.
	 * Capture error messages put by the driver into the bypass area and
	 * put them into the regular interpreter result. Fall back to the
	 * regular message if nothing was found in the bypass.
	 */

	if (!TclChanCaughtErrorBypass(interp, chan)) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "error during seek on \"%s\": %s",
		    TclGetString(objv[1]), Tcl_PosixError(interp)));
	}
	Tcl_Release(chan);
	return TCL_ERROR;
    }
    Tcl_Release(chan);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TellObjCmd --
586
587
588
589
590
591
592

593
594
595
596
597
598
599
600
601
602
603
604
605
606
607

608
609
610
611
612
613
614
615

616


617
618
619
620
621
622
623
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to tell on. */
    Tcl_WideInt newLoc;


    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
	return TCL_ERROR;
    }

    /*
     * Try to find a channel with the right name and permissions in the IO
     * channel table of this interpreter.
     */

    if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
	return TCL_ERROR;
    }


    newLoc = Tcl_Tell(chan);

    /*
     * TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result.
     */


    if (TclChanCaughtErrorBypass(interp, chan)) {


	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(newLoc));
    return TCL_OK;
}








>















>








>
|
>
>







604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to tell on. */
    Tcl_WideInt newLoc;
    int code;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
	return TCL_ERROR;
    }

    /*
     * Try to find a channel with the right name and permissions in the IO
     * channel table of this interpreter.
     */

    if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
	return TCL_ERROR;
    }

    Tcl_Preserve(chan);
    newLoc = Tcl_Tell(chan);

    /*
     * TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result.
     */


    code  = TclChanCaughtErrorBypass(interp, chan);
    Tcl_Release(chan);
    if (code) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(newLoc));
    return TCL_OK;
}

892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
    keepNewline = 0;
    ignoreStderr = 0;
    for (skip = 1; skip < objc; skip++) {
	string = TclGetString(objv[skip]);
	if (string[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch",
		TCL_EXACT, &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (index == EXEC_KEEPNEWLINE) {
	    keepNewline = 1;
	} else if (index == EXEC_IGNORESTDERR) {
	    ignoreStderr = 1;
	} else {
	    skip++;
	    break;
	}
    }
    if (objc <= skip) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-switch ...? arg ?arg ...?");
	return TCL_ERROR;
    }

    /*
     * See if the command is to be run in background.
     */








|













|







915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
    keepNewline = 0;
    ignoreStderr = 0;
    for (skip = 1; skip < objc; skip++) {
	string = TclGetString(objv[skip]);
	if (string[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[skip], options, "option",
		TCL_EXACT, &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (index == EXEC_KEEPNEWLINE) {
	    keepNewline = 1;
	} else if (index == EXEC_IGNORESTDERR) {
	    ignoreStderr = 1;
	} else {
	    skip++;
	    break;
	}
    }
    if (objc <= skip) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-option ...? arg ?arg ...?");
	return TCL_ERROR;
    }

    /*
     * See if the command is to be run in background.
     */

1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
		TclGetString(objv[2])));
	return TCL_ERROR;
    }

    toRead = -1;
    cmdPtr = NULL;
    for (i = 3; i < objc; i += 2) {
	if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0,
		&index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (index) {
	case FcopySize:
	    if (Tcl_GetWideIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) {
		return TCL_ERROR;







|







1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
		TclGetString(objv[2])));
	return TCL_ERROR;
    }

    toRead = -1;
    cmdPtr = NULL;
    for (i = 3; i < objc; i += 2) {
	if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0,
		&index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (index) {
	case FcopySize:
	    if (Tcl_GetWideIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) {
		return TCL_ERROR;
Changes to generic/tclIOGT.c.
206
207
208
209
210
211
212

213



















214
215
216
217
218
219
220
				 * the transformation. Used to execute the
				 * code below. */
    Tcl_Obj *command;		/* Tcl code to execute for a buffer */
    ResultBuffer result;	/* Internal buffer used to store the result of
				 * a transformation of incoming data. Also
				 * serves as buffer of all data not yet
				 * consumed by the reader. */

};




















/*
 *----------------------------------------------------------------------
 *
 * TclChannelTransform --
 *
 *	Implements the Tcl "testchannel transform" debugging command. This is







>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
				 * the transformation. Used to execute the
				 * code below. */
    Tcl_Obj *command;		/* Tcl code to execute for a buffer */
    ResultBuffer result;	/* Internal buffer used to store the result of
				 * 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);
}

/*
 *----------------------------------------------------------------------
 *
 * TclChannelTransform --
 *
 *	Implements the Tcl "testchannel transform" debugging command. This is
236
237
238
239
240
241
242

243
244
245
246
247
248






249
250
251
252
253
254
255
256
257
258
259
260
261
262
263

264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293

294
295
296
297
298

299
300
301

302
303
304
305
306
307
308
309

310
311
312

313
314
315
316
317
318
319
    Tcl_Interp *interp,		/* Interpreter for result. */
    Tcl_Channel chan,		/* Channel to transform. */
    Tcl_Obj *cmdObjPtr)		/* Script to use for transform. */
{
    Channel *chanPtr;		/* The actual channel. */
    ChannelState *statePtr;	/* State info for channel. */
    int mode;			/* Read/write mode of the channel. */

    TransformChannelData *dataPtr;
    Tcl_DString ds;

    if (chan == NULL) {
	return TCL_ERROR;
    }







    chanPtr = (Channel *) chan;
    statePtr = chanPtr->state;
    chanPtr = statePtr->topChanPtr;
    chan = (Tcl_Channel) chanPtr;
    mode = (statePtr->flags & (TCL_READABLE|TCL_WRITABLE));

    /*
     * Now initialize the transformation state and stack it upon the specified
     * channel. One of the necessary things to do is to retrieve the blocking
     * regime of the underlying channel and to use the same for us too.
     */

    dataPtr = ckalloc(sizeof(TransformChannelData));


    Tcl_DStringInit(&ds);
    Tcl_GetChannelOption(interp, chan, "-blocking", &ds);
    dataPtr->readIsFlushed = 0;
    dataPtr->flags = 0;
    if (ds.string[0] == '0') {
	dataPtr->flags |= CHANNEL_ASYNC;
    }
    Tcl_DStringFree(&ds);

    dataPtr->self = chan;
    dataPtr->watchMask = 0;
    dataPtr->mode = mode;
    dataPtr->timer = NULL;
    dataPtr->maxRead = 4096;	/* Initial value not relevant. */
    dataPtr->interp = interp;
    dataPtr->command = cmdObjPtr;
    Tcl_IncrRefCount(dataPtr->command);

    ResultInit(&dataPtr->result);

    dataPtr->self = Tcl_StackChannel(interp, &transformChannelType, dataPtr,
	    mode, chan);
    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);
	return TCL_ERROR;
    }


    /*
     * At last initialize the transformation at the script level.
     */


    if ((dataPtr->mode & TCL_WRITABLE) && ExecuteCallback(dataPtr, NULL,
	    A_CREATE_WRITE, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE) != TCL_OK){
	Tcl_UnstackChannel(interp, chan);

	return TCL_ERROR;
    }

    if ((dataPtr->mode & TCL_READABLE) && ExecuteCallback(dataPtr, NULL,
	    A_CREATE_READ, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE) != TCL_OK) {
	ExecuteCallback(dataPtr, NULL, A_DELETE_WRITE, NULL, 0, TRANSMIT_DONT,
		P_NO_PRESERVE);
	Tcl_UnstackChannel(interp, chan);

	return TCL_ERROR;
    }


    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ExecuteCallback --







>






>
>
>
>
>
>















>









<















<
<
|


>





>



>








>



>







256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300

301
302
303
304
305
306
307
308
309
310
311
312
313
314
315


316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
    Tcl_Interp *interp,		/* Interpreter for result. */
    Tcl_Channel chan,		/* Channel to transform. */
    Tcl_Obj *cmdObjPtr)		/* Script to use for transform. */
{
    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;

    if (chan == NULL) {
	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;
    chan = (Tcl_Channel) chanPtr;
    mode = (statePtr->flags & (TCL_READABLE|TCL_WRITABLE));

    /*
     * Now initialize the transformation state and stack it upon the specified
     * channel. One of the necessary things to do is to retrieve the blocking
     * regime of the underlying channel and to use the same for us too.
     */

    dataPtr = ckalloc(sizeof(TransformChannelData));

    dataPtr->refCount = 1;
    Tcl_DStringInit(&ds);
    Tcl_GetChannelOption(interp, chan, "-blocking", &ds);
    dataPtr->readIsFlushed = 0;
    dataPtr->flags = 0;
    if (ds.string[0] == '0') {
	dataPtr->flags |= CHANNEL_ASYNC;
    }
    Tcl_DStringFree(&ds);


    dataPtr->watchMask = 0;
    dataPtr->mode = mode;
    dataPtr->timer = NULL;
    dataPtr->maxRead = 4096;	/* Initial value not relevant. */
    dataPtr->interp = interp;
    dataPtr->command = cmdObjPtr;
    Tcl_IncrRefCount(dataPtr->command);

    ResultInit(&dataPtr->result);

    dataPtr->self = Tcl_StackChannel(interp, &transformChannelType, dataPtr,
	    mode, chan);
    if (dataPtr->self == NULL) {
	Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp),
		"\nfailed to stack channel \"%s\"", Tcl_GetChannelName(chan));


	ReleaseData(dataPtr);
	return TCL_ERROR;
    }
    Tcl_Preserve(dataPtr->self);

    /*
     * 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;
    }

    if ((dataPtr->mode & TCL_READABLE) && ExecuteCallback(dataPtr, NULL,
	    A_CREATE_READ, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE) != TCL_OK) {
	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;
}

/*
 *----------------------------------------------------------------------
 *
 * ExecuteCallback --
346
347
348
349
350
351
352
353



354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399

400
401
402
403
404
405
406
407
408
409
410
411
412
413



414
415
416
417
418
419
420



421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
				 * interpreters. */
{
    Tcl_Obj *resObj;		/* See below, switch (transmit). */
    int resLen;
    unsigned char *resBuf;
    Tcl_InterpState state = NULL;
    int res = TCL_OK;
    Tcl_Obj *command = Tcl_DuplicateObj(dataPtr->command);




    /*
     * Step 1, create the complete command to execute. Do this by appending
     * operation and buffer to operate upon to a copy of the callback
     * definition. We *cannot* create a list containing 3 objects and then use
     * 'Tcl_EvalObjv', because the command may contain additional prefixed
     * arguments. Feather's curried commands would come in handy here.
     */

    if (preserve == P_PRESERVE) {
	state = Tcl_SaveInterpState(dataPtr->interp, res);
    }

    Tcl_IncrRefCount(command);
    res = Tcl_ListObjAppendElement(dataPtr->interp, command,
	    Tcl_NewStringObj((char *) op, -1));
    if (res != TCL_OK) {
	goto cleanup;
    }

    /*
     * 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;
    }

    /*
     * Step 2, execute the command at the global level of the interpreter used
     * to create the transformation. Destroy the command afterward. If an
     * error occured and the current interpreter is defined and not equal to
     * the interpreter for the callback, then copy the error message into
     * current interpreter. Don't copy if in preservation mode.
     */

    res = Tcl_EvalObjEx(dataPtr->interp, command, TCL_EVAL_GLOBAL);
    Tcl_DecrRefCount(command);
    command = NULL;

    if ((res != TCL_OK) && (interp != NULL) && (dataPtr->interp != interp)
	    && (preserve == P_NO_PRESERVE)) {
	Tcl_SetObjResult(interp, Tcl_GetObjResult(dataPtr->interp));

	return res;
    }

    /*
     * Step 3, transmit a possible conversion result to the underlying
     * channel, or ourselves.
     */

    switch (transmit) {
    case TRANSMIT_DONT:
	/* nothing to do */
	break;

    case TRANSMIT_DOWN:



	resObj = Tcl_GetObjResult(dataPtr->interp);
	resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
	Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf,
		resLen);
	break;

    case TRANSMIT_SELF:



	resObj = Tcl_GetObjResult(dataPtr->interp);
	resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
	Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen);
	break;

    case TRANSMIT_IBUF:
	resObj = Tcl_GetObjResult(dataPtr->interp);
	resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
	ResultAdd(&dataPtr->result, resBuf, resLen);
	break;

    case TRANSMIT_NUM:
	/*
	 * Interpret result as integer number.
	 */

	resObj = Tcl_GetObjResult(dataPtr->interp);
	TclGetIntFromObj(dataPtr->interp, resObj, &dataPtr->maxRead);
	break;
    }

    Tcl_ResetResult(dataPtr->interp);
    if (preserve == P_PRESERVE) {
	(void) Tcl_RestoreInterpState(dataPtr->interp, state);
    }
    return res;

  cleanup:
    if (preserve == P_PRESERVE) {
	(void) Tcl_RestoreInterpState(dataPtr->interp, state);
    }
    if (command != NULL) {
	Tcl_DecrRefCount(command);
    }
    return res;
}

/*
 *----------------------------------------------------------------------
 *
 * TransformBlockModeProc --







|
>
>
>










|



<
|
<
<
<






<
|
<
<
<









|



|

|
>














>
>
>
|






>
>
>
|





|









|
|



|

|

<
|
<
<
<
<
<
<
<







376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400

401



402
403
404
405
406
407

408



409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477

478







479
480
481
482
483
484
485
				 * interpreters. */
{
    Tcl_Obj *resObj;		/* See below, switch (transmit). */
    int resLen;
    unsigned char *resBuf;
    Tcl_InterpState state = NULL;
    int res = TCL_OK;
    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
     * operation and buffer to operate upon to a copy of the callback
     * definition. We *cannot* create a list containing 3 objects and then use
     * 'Tcl_EvalObjv', because the command may contain additional prefixed
     * arguments. Feather's curried commands would come in handy here.
     */

    if (preserve == P_PRESERVE) {
	state = Tcl_SaveInterpState(eval, res);
    }

    Tcl_IncrRefCount(command);

    Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, -1));




    /*
     * Use a byte-array to prevent the misinterpretation of binary data coming
     * through as UTF while at the tcl level.
     */


    Tcl_ListObjAppendElement(NULL, command, Tcl_NewByteArrayObj(buf, bufLen));




    /*
     * Step 2, execute the command at the global level of the interpreter used
     * to create the transformation. Destroy the command afterward. If an
     * error occured and the current interpreter is defined and not equal to
     * the interpreter for the callback, then copy the error message into
     * current interpreter. Don't copy if in preservation mode.
     */

    res = Tcl_EvalObjEx(eval, command, TCL_EVAL_GLOBAL);
    Tcl_DecrRefCount(command);
    command = NULL;

    if ((res != TCL_OK) && (interp != NULL) && (eval != interp)
	    && (preserve == P_NO_PRESERVE)) {
	Tcl_SetObjResult(interp, Tcl_GetObjResult(eval));
	Tcl_Release(eval);
	return res;
    }

    /*
     * Step 3, transmit a possible conversion result to the underlying
     * channel, or ourselves.
     */

    switch (transmit) {
    case TRANSMIT_DONT:
	/* nothing to do */
	break;

    case TRANSMIT_DOWN:
	if (dataPtr->self == NULL) {
	    break;
	}
	resObj = Tcl_GetObjResult(eval);
	resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
	Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf,
		resLen);
	break;

    case TRANSMIT_SELF:
	if (dataPtr->self == NULL) {
	    break;
	}
	resObj = Tcl_GetObjResult(eval);
	resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
	Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen);
	break;

    case TRANSMIT_IBUF:
	resObj = Tcl_GetObjResult(eval);
	resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
	ResultAdd(&dataPtr->result, resBuf, resLen);
	break;

    case TRANSMIT_NUM:
	/*
	 * Interpret result as integer number.
	 */

	resObj = Tcl_GetObjResult(eval);
	TclGetIntFromObj(eval, resObj, &dataPtr->maxRead);
	break;
    }

    Tcl_ResetResult(eval);
    if (preserve == P_PRESERVE) {
	(void) Tcl_RestoreInterpState(eval, state);
    }

    Tcl_Release(eval);







    return res;
}

/*
 *----------------------------------------------------------------------
 *
 * TransformBlockModeProc --
531
532
533
534
535
536
537

538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556

557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
    /*
     * Now flush data waiting in internal buffers to output and input. The
     * input must be done despite the fact that there is no real receiver for
     * it anymore. But the scripts might have sideeffects other parts of the
     * system rely on (f.e. signaling the close to interested parties).
     */


    if (dataPtr->mode & TCL_WRITABLE) {
	ExecuteCallback(dataPtr, interp, A_FLUSH_WRITE, NULL, 0,
		TRANSMIT_DOWN, P_PRESERVE);
    }

    if ((dataPtr->mode & TCL_READABLE) && !dataPtr->readIsFlushed) {
	dataPtr->readIsFlushed = 1;
	ExecuteCallback(dataPtr, interp, A_FLUSH_READ, NULL, 0, TRANSMIT_IBUF,
		P_PRESERVE);
    }

    if (dataPtr->mode & TCL_WRITABLE) {
	ExecuteCallback(dataPtr, interp, A_DELETE_WRITE, NULL, 0,
		TRANSMIT_DONT, P_PRESERVE);
    }
    if (dataPtr->mode & TCL_READABLE) {
	ExecuteCallback(dataPtr, interp, A_DELETE_READ, NULL, 0,
		TRANSMIT_DONT, P_PRESERVE);
    }


    /*
     * General cleanup.
     */

    ResultClear(&dataPtr->result);
    Tcl_DecrRefCount(dataPtr->command);
    ckfree(dataPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TransformInputProc --







>



















>





|
|
|







555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
    /*
     * Now flush data waiting in internal buffers to output and input. The
     * input must be done despite the fact that there is no real receiver for
     * it anymore. But the scripts might have sideeffects other parts of the
     * system rely on (f.e. signaling the close to interested parties).
     */

    PreserveData(dataPtr);
    if (dataPtr->mode & TCL_WRITABLE) {
	ExecuteCallback(dataPtr, interp, A_FLUSH_WRITE, NULL, 0,
		TRANSMIT_DOWN, P_PRESERVE);
    }

    if ((dataPtr->mode & TCL_READABLE) && !dataPtr->readIsFlushed) {
	dataPtr->readIsFlushed = 1;
	ExecuteCallback(dataPtr, interp, A_FLUSH_READ, NULL, 0, TRANSMIT_IBUF,
		P_PRESERVE);
    }

    if (dataPtr->mode & TCL_WRITABLE) {
	ExecuteCallback(dataPtr, interp, A_DELETE_WRITE, NULL, 0,
		TRANSMIT_DONT, P_PRESERVE);
    }
    if (dataPtr->mode & TCL_READABLE) {
	ExecuteCallback(dataPtr, interp, A_DELETE_READ, NULL, 0,
		TRANSMIT_DONT, P_PRESERVE);
    }
    ReleaseData(dataPtr);

    /*
     * General cleanup.
     */

    Tcl_Release(dataPtr->self);
    dataPtr->self = NULL;
    ReleaseData(dataPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TransformInputProc --
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608

609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
    int gotBytes, read, copied;
    Tcl_Channel downChan;

    /*
     * Should assert(dataPtr->mode & TCL_READABLE);
     */

    if (toRead == 0) {
	/*
	 * Catch a no-op.
	 */
	return 0;
    }

    gotBytes = 0;
    downChan = Tcl_GetStackedChannel(dataPtr->self);


    while (toRead > 0) {
	/*
	 * Loop until the request is satisfied (or no data is available from
	 * below, possibly EOF).
	 */

	copied = ResultCopy(&dataPtr->result, UCHARP(buf), toRead);
	toRead -= copied;
	buf += copied;
	gotBytes += copied;

	if (toRead == 0) {
	    /*
	     * The request was completely satisfied from our buffers. We can
	     * break out of the loop and return to the caller.
	     */

	    return gotBytes;
	}

	/*
	 * Length (dataPtr->result) == 0, toRead > 0 here. Use the incoming
	 * 'buf'! as target to store the intermediary information read from
	 * the underlying channel.
	 *







|









>

















|







618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
    int gotBytes, read, copied;
    Tcl_Channel downChan;

    /*
     * Should assert(dataPtr->mode & TCL_READABLE);
     */

    if (toRead == 0 || dataPtr->self == NULL) {
	/*
	 * Catch a no-op.
	 */
	return 0;
    }

    gotBytes = 0;
    downChan = Tcl_GetStackedChannel(dataPtr->self);

    PreserveData(dataPtr);
    while (toRead > 0) {
	/*
	 * Loop until the request is satisfied (or no data is available from
	 * below, possibly EOF).
	 */

	copied = ResultCopy(&dataPtr->result, UCHARP(buf), toRead);
	toRead -= copied;
	buf += copied;
	gotBytes += copied;

	if (toRead == 0) {
	    /*
	     * The request was completely satisfied from our buffers. We can
	     * break out of the loop and return to the caller.
	     */

	    break;
	}

	/*
	 * Length (dataPtr->result) == 0, toRead > 0 here. Use the incoming
	 * 'buf'! as target to store the intermediary information read from
	 * the underlying channel.
	 *
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658

659
660
661
662

663
664
665
666
667
668
669
670
671
672
673
674
675
676


677
678
679
680


681
682
683
684
685
686
687
688


689




690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722

723
724

725
726
727
728
729
730
731

	if (dataPtr->maxRead >= 0) {
	    if (dataPtr->maxRead < toRead) {
		toRead = dataPtr->maxRead;
	    }
	} /* else: 'maxRead < 0' == Accept the current value of toRead. */
	if (toRead <= 0) {
	    return gotBytes;
	}

	/*
	 * Get bytes from the underlying channel.
	 */

	read = Tcl_ReadRaw(downChan, buf, toRead);
	if (read < 0) {

	    /*
	     * Report errors to caller. EAGAIN is a special situation. If we
	     * had some data before we report that instead of the request to
	     * re-try.

	     */
		int error = Tcl_GetErrno();

	    if ((error == EAGAIN) && (gotBytes > 0)) {
		return gotBytes;
	    }

	    *errorCodePtr = error;
	    return -1;
	} else if (read == 0) {
	    /*
	     * Check wether we hit on EOF in the underlying channel or not. If
	     * not differentiate between blocking and non-blocking modes. In
	     * non-blocking mode we ran temporarily out of data. Signal this


	     * to the caller via EWOULDBLOCK and error return (-1). In the
	     * other cases we simply return what we got and let the caller
	     * wait for more. On the other hand, if we got an EOF we have to
	     * convert and flush all waiting partial data.


	     */

	    if (!Tcl_Eof(downChan)) {
		if ((gotBytes == 0) && (dataPtr->flags & CHANNEL_ASYNC)) {
		    *errorCodePtr = EWOULDBLOCK;
		    return -1;
		}
		return gotBytes;


	    }





	    if (dataPtr->readIsFlushed) {
		/*
		 * Already flushed, nothing to do anymore.
		 */

		return gotBytes;
	    }

	    dataPtr->readIsFlushed = 1;
	    ExecuteCallback(dataPtr, NULL, A_FLUSH_READ, NULL, 0,
		    TRANSMIT_IBUF, P_PRESERVE);

	    if (ResultEmpty(&dataPtr->result)) {
		/*
		 * We had nothing to flush.
		 */

		return gotBytes;
	    }

	    continue;		/* at: while (toRead > 0) */
	} /* read == 0 */

	/*
	 * Transform the read chunk and add the result to our read buffer
	 * (dataPtr->result).
	 */

	if (ExecuteCallback(dataPtr, NULL, A_READ, UCHARP(buf), read,
		TRANSMIT_IBUF, P_PRESERVE) != TCL_OK) {
	    *errorCodePtr = EINVAL;
	    return -1;

	}
    } /* while toRead > 0 */


    return gotBytes;
}

/*
 *----------------------------------------------------------------------
 *







|








>
|
<
|
|
>
|
<

<
|


<
<
<

<
<
<
>
>
|
<
<
<
>
>


<
<
|
<
<
|
>
>
|
>
>
>
>






|











|













|
>


>







670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687

688
689
690
691

692

693
694
695



696



697
698
699



700
701
702
703


704


705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756

	if (dataPtr->maxRead >= 0) {
	    if (dataPtr->maxRead < toRead) {
		toRead = dataPtr->maxRead;
	    }
	} /* else: 'maxRead < 0' == Accept the current value of toRead. */
	if (toRead <= 0) {
	    break;
	}

	/*
	 * Get bytes from the underlying channel.
	 */

	read = Tcl_ReadRaw(downChan, buf, toRead);
	if (read < 0) {
	    if (Tcl_InputBlocked(downChan) && (gotBytes > 0)) {
		/*

		 * Zero bytes available from downChan because blocked.
		 * But nonzero bytes already copied, so total is a
		 * valid blocked short read. Return to caller.
		 */



		break;
	    }




	    /*



	     * Either downChan is not blocked (there's a real error).
	     * or it is and there are no bytes copied yet.  In either
	     * case we want to pass the "error" along to the caller,



	     * either to report an error, or to signal to the caller
	     * that zero bytes are available because blocked.
	     */



	    *errorCodePtr = Tcl_GetErrno();


	    gotBytes = -1;
	    break;
	} else if (read == 0) {

	    /*
	     * Zero returned from Tcl_ReadRaw() always indicates EOF
	     * on the down channel.
	     */

	    if (dataPtr->readIsFlushed) {
		/*
		 * Already flushed, nothing to do anymore.
		 */

		break;
	    }

	    dataPtr->readIsFlushed = 1;
	    ExecuteCallback(dataPtr, NULL, A_FLUSH_READ, NULL, 0,
		    TRANSMIT_IBUF, P_PRESERVE);

	    if (ResultEmpty(&dataPtr->result)) {
		/*
		 * We had nothing to flush.
		 */

		break;
	    }

	    continue;		/* at: while (toRead > 0) */
	} /* read == 0 */

	/*
	 * Transform the read chunk and add the result to our read buffer
	 * (dataPtr->result).
	 */

	if (ExecuteCallback(dataPtr, NULL, A_READ, UCHARP(buf), read,
		TRANSMIT_IBUF, P_PRESERVE) != TCL_OK) {
	    *errorCodePtr = EINVAL;
	    gotBytes = -1;
	    break;
	}
    } /* while toRead > 0 */
    ReleaseData(dataPtr);

    return gotBytes;
}

/*
 *----------------------------------------------------------------------
 *
759
760
761
762
763
764
765

766
767
768
769
770

771
772
773
774
775
776
777
	/*
	 * Catch a no-op.
	 */

	return 0;
    }


    if (ExecuteCallback(dataPtr, NULL, A_WRITE, UCHARP(buf), toWrite,
	    TRANSMIT_DOWN, P_NO_PRESERVE) != TCL_OK) {
	*errorCodePtr = EINVAL;
	return -1;
    }


    return toWrite;
}

/*
 *----------------------------------------------------------------------
 *







>



|

>







784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
	/*
	 * Catch a no-op.
	 */

	return 0;
    }

    PreserveData(dataPtr);
    if (ExecuteCallback(dataPtr, NULL, A_WRITE, UCHARP(buf), toWrite,
	    TRANSMIT_DOWN, P_NO_PRESERVE) != TCL_OK) {
	*errorCodePtr = EINVAL;
	toWrite = -1;
    }
    ReleaseData(dataPtr);

    return toWrite;
}

/*
 *----------------------------------------------------------------------
 *
816
817
818
819
820
821
822

823
824
825
826
827
828
829
830
831
832
833

834
835
836
837
838
839
840

    /*
     * It is a real request to change the position. Flush all data waiting for
     * output and discard everything in the input buffers. Then pass the
     * request down, unchanged.
     */


    if (dataPtr->mode & TCL_WRITABLE) {
	ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN,
		P_NO_PRESERVE);
    }

    if (dataPtr->mode & TCL_READABLE) {
	ExecuteCallback(dataPtr, NULL, A_CLEAR_READ, NULL, 0, TRANSMIT_DONT,
		P_NO_PRESERVE);
	ResultClear(&dataPtr->result);
	dataPtr->readIsFlushed = 0;
    }


    return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode,
	    errorCodePtr);
}

/*
 *----------------------------------------------------------------------







>











>







843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869

    /*
     * It is a real request to change the position. Flush all data waiting for
     * output and discard everything in the input buffers. Then pass the
     * request down, unchanged.
     */

    PreserveData(dataPtr);
    if (dataPtr->mode & TCL_WRITABLE) {
	ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN,
		P_NO_PRESERVE);
    }

    if (dataPtr->mode & TCL_READABLE) {
	ExecuteCallback(dataPtr, NULL, A_CLEAR_READ, NULL, 0, TRANSMIT_DONT,
		P_NO_PRESERVE);
	ResultClear(&dataPtr->result);
	dataPtr->readIsFlushed = 0;
    }
    ReleaseData(dataPtr);

    return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode,
	    errorCodePtr);
}

/*
 *----------------------------------------------------------------------
887
888
889
890
891
892
893

894
895
896
897
898
899
900
901
902
903
904

905
906
907
908
909
910
911

    /*
     * It is a real request to change the position. Flush all data waiting for
     * output and discard everything in the input buffers. Then pass the
     * request down, unchanged.
     */


    if (dataPtr->mode & TCL_WRITABLE) {
	ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN,
		P_NO_PRESERVE);
    }

    if (dataPtr->mode & TCL_READABLE) {
	ExecuteCallback(dataPtr, NULL, A_CLEAR_READ, NULL, 0, TRANSMIT_DONT,
		P_NO_PRESERVE);
	ResultClear(&dataPtr->result);
	dataPtr->readIsFlushed = 0;
    }


    /*
     * If we have a wide seek capability, we should stick with that.
     */

    if (parentWideSeekProc != NULL) {
	return parentWideSeekProc(parentData, offset, mode, errorCodePtr);







>











>







916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942

    /*
     * It is a real request to change the position. Flush all data waiting for
     * output and discard everything in the input buffers. Then pass the
     * request down, unchanged.
     */

    PreserveData(dataPtr);
    if (dataPtr->mode & TCL_WRITABLE) {
	ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN,
		P_NO_PRESERVE);
    }

    if (dataPtr->mode & TCL_READABLE) {
	ExecuteCallback(dataPtr, NULL, A_CLEAR_READ, NULL, 0, TRANSMIT_DONT,
		P_NO_PRESERVE);
	ResultClear(&dataPtr->result);
	dataPtr->readIsFlushed = 0;
    }
    ReleaseData(dataPtr);

    /*
     * If we have a wide seek capability, we should stick with that.
     */

    if (parentWideSeekProc != NULL) {
	return parentWideSeekProc(parentData, offset, mode, errorCodePtr);
1052
1053
1054
1055
1056
1057
1058



1059
1060
1061
1062
1063
1064
1065
     * events on the channel below via a call to our 'TransformNotifyProc'.
     * But we have to pass the interest down now. We are allowed to add
     * additional 'interest' to the mask if we want to. But this
     * transformation has no such interest. It just passes the request down,
     * unchanged.
     */




    downChan = Tcl_GetStackedChannel(dataPtr->self);

    Tcl_GetChannelType(downChan)->watchProc(
	    Tcl_GetChannelInstanceData(downChan), mask);

    /*
     * Management of the internal timer.







>
>
>







1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
     * events on the channel below via a call to our 'TransformNotifyProc'.
     * But we have to pass the interest down now. We are allowed to add
     * additional 'interest' to the mask if we want to. But this
     * transformation has no such interest. It just passes the request down,
     * unchanged.
     */

    if (dataPtr->self == NULL) {
	return;
    }
    downChan = Tcl_GetStackedChannel(dataPtr->self);

    Tcl_GetChannelType(downChan)->watchProc(
	    Tcl_GetChannelInstanceData(downChan), mask);

    /*
     * Management of the internal timer.
Changes to generic/tclIORChan.c.
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
				 * interpreter/thread containing its Tcl
				 * command is gone.
				 */
#ifdef TCL_THREADS
    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?
     */

    int mode;			/* Mask of R/W mode */
    int interest;		/* Mask of events the channel is interested
				 * in. */

    int dead;			/* Boolean signal that some operations
				 * should no longer be attempted. */







|
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
|
<
<
<
<







95
96
97
98
99
100
101
102










103








104




105
106
107
108
109
110
111
				 * interpreter/thread containing its Tcl
				 * command is gone.
				 */
#ifdef TCL_THREADS
    Tcl_ThreadId thread;	/* Thread the 'interp' belongs to. == Handler thread */
    Tcl_ThreadId owner;         /* Thread owning the structure.    == Channel thread */
#endif
    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
				 * in. */

    int dead;			/* Boolean signal that some operations
				 * should no longer be attempted. */
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479

480
481
482
483
484
485
486
static int		EncodeEventMask(Tcl_Interp *interp,
			    const char *objName, Tcl_Obj *obj, int *mask);
static Tcl_Obj *	DecodeEventMask(int mask);
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,
			    Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr);

static ReflectedChannelMap *	GetReflectedChannelMap(Tcl_Interp *interp);
static void		DeleteReflectedChannelMap(ClientData clientData,
			    Tcl_Interp *interp);
static int		ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj *resObj);

/*
 * Global constant strings (messages). ==================
 * These string are used directly as bypass errors, thus they have to be valid
 * Tcl lists where the last element is the message itself. Hence the
 * 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}";
#ifdef TCL_THREADS
static const char *msg_send_originlost = "{Channel thread lost}";
static const char *msg_send_dstlost    = "{Owner lost}";
#endif /* TCL_THREADS */

static const char *msg_dstlost    = "-code 1 -level 0 -errorcode NONE -errorinfo {} -errorline 1 {Owner lost}";

/*
 * Main methods to plug into the 'chan' ensemble'. ==================
 */

/*







<

|














<

<





<

>







424
425
426
427
428
429
430

431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446

447

448
449
450
451
452

453
454
455
456
457
458
459
460
461
static int		EncodeEventMask(Tcl_Interp *interp,
			    const char *objName, Tcl_Obj *obj, int *mask);
static Tcl_Obj *	DecodeEventMask(int mask);
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 int		InvokeTclMethod(ReflectedChannel *rcPtr,
			    MethodName method, Tcl_Obj *argOneObj,
			    Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr);

static ReflectedChannelMap *	GetReflectedChannelMap(Tcl_Interp *interp);
static void		DeleteReflectedChannelMap(ClientData clientData,
			    Tcl_Interp *interp);
static int		ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj *resObj);

/*
 * Global constant strings (messages). ==================
 * These string are used directly as bypass errors, thus they have to be valid
 * Tcl lists where the last element is the message itself. Hence the
 * list-quoting to keep the words of the message together. See also [x].
 */


static const char *msg_read_toomuch = "{read delivered more than requested}";

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}";
#ifdef TCL_THREADS
static const char *msg_send_originlost = "{Channel thread lost}";

#endif /* TCL_THREADS */
static const char *msg_send_dstlost    = "{Owner lost}";
static const char *msg_dstlost    = "-code 1 -level 0 -errorcode NONE -errorinfo {} -errorline 1 {Owner lost}";

/*
 * Main methods to plug into the 'chan' ensemble'. ==================
 */

/*
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610

    /*
     * Now create the channel.
     */

    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.
     * Squash the channel if not.
     *
     * Note: The conversion of 'mode' back into a Tcl_Obj ensures that
     * 'initialize' is invoked with canonical mode names, and no
     * abbreviations. Using modeObj directly could feed abbreviations into the
     * handler, and the handler is not specified to handle such.
     */

    modeObj = DecodeEventMask(mode);
    /* assert modeObj.refCount == 1 */
    result = InvokeTclMethod(rcPtr, "initialize", modeObj, NULL, &resObj);
    Tcl_DecrRefCount(modeObj);

    if (result != TCL_OK) {
	UnmarshallErrorResult(interp, resObj);
	Tcl_DecrRefCount(resObj);	/* Remove reference held from invoke */
	goto error;
    }







<
<
<
<













|







554
555
556
557
558
559
560




561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581

    /*
     * Now create the channel.
     */

    rcId = NextHandle();
    rcPtr = NewReflectedChannel(interp, cmdObj, mode, rcId);





    /*
     * Invoke 'initialize' and validate that the handler is present and ok.
     * Squash the channel if not.
     *
     * Note: The conversion of 'mode' back into a Tcl_Obj ensures that
     * 'initialize' is invoked with canonical mode names, and no
     * abbreviations. Using modeObj directly could feed abbreviations into the
     * handler, and the handler is not specified to handle such.
     */

    modeObj = DecodeEventMask(mode);
    /* assert modeObj.refCount == 1 */
    result = InvokeTclMethod(rcPtr, METH_INIT, modeObj, NULL, &resObj);
    Tcl_DecrRefCount(modeObj);

    if (result != TCL_OK) {
	UnmarshallErrorResult(interp, resObj);
	Tcl_DecrRefCount(resObj);	/* Remove reference held from invoke */
	goto error;
    }
679
680
681
682
683
684
685


686


687
688
689
690
691
692
693

    Tcl_ResetResult(interp);

    /*
     * Everything is fine now.
     */



    rcPtr->methods = methods;



    if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) {
	/*
	 * Some of the nullable methods are not supported. We clone the
	 * channel type, null the associated C functions, and use the result
	 * as the actual channel type.
	 */







>
>
|
>
>







650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668

    Tcl_ResetResult(interp);

    /*
     * Everything is fine now.
     */

    chan = Tcl_CreateChannel(&tclRChannelType, TclGetString(rcId), rcPtr,
	    mode);
    rcPtr->chan = chan;
    Tcl_Preserve(chan);
    chanPtr = (Channel *) chan;

    if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) {
	/*
	 * Some of the nullable methods are not supported. We clone the
	 * channel type, null the associated C functions, and use the result
	 * as the actual channel type.
	 */
740
741
742
743
744
745
746
747
748
749
750
751
752

753
754
755
756
757
758
759
     */

    Tcl_SetObjResult(interp,
            Tcl_NewStringObj(chanPtr->state->channelName, -1));
    return TCL_OK;

  error:
    /*
     * Signal to ReflectClose to not call 'finalize'.
     */

    rcPtr->methods = 0;
    Tcl_Close(interp, chan);

    return TCL_ERROR;

#undef MODE
#undef CMD
}

/*







<
<
<
|
|
|
>







715
716
717
718
719
720
721



722
723
724
725
726
727
728
729
730
731
732
     */

    Tcl_SetObjResult(interp,
            Tcl_NewStringObj(chanPtr->state->channelName, -1));
    return TCL_OK;

  error:



    Tcl_DecrRefCount(rcPtr->name);
    Tcl_DecrRefCount(rcPtr->methods);
    Tcl_DecrRefCount(rcPtr->cmd);
    ckfree((char*) rcPtr);
    return TCL_ERROR;

#undef MODE
#undef CMD
}

/*
1134
1135
1136
1137
1138
1139
1140

1141
1142
1143
1144
1145
1146
1147
{
    ReflectedChannel *rcPtr = clientData;
    int result;			/* Result code for 'close' */
    Tcl_Obj *resObj;		/* Result data for 'close' */
    ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in
				 * this interp */
    Tcl_HashEntry *hPtr;	/* Entry in the above map */


    if (TclInThreadExit()) {
	/*
	 * This call comes from TclFinalizeIOSystem. There are no
	 * interpreters, and therefore we cannot call upon the handler command
	 * anymore. Threading is irrelevant as well. We simply clean up all
	 * our C level data structures and leave the Tcl level to the other







>







1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
{
    ReflectedChannel *rcPtr = clientData;
    int result;			/* Result code for 'close' */
    Tcl_Obj *resObj;		/* Result data for 'close' */
    ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in
				 * this interp */
    Tcl_HashEntry *hPtr;	/* Entry in the above map */
    const Tcl_ChannelType *tctPtr;

    if (TclInThreadExit()) {
	/*
	 * This call comes from TclFinalizeIOSystem. There are no
	 * interpreters, and therefore we cannot call upon the handler command
	 * anymore. Threading is irrelevant as well. We simply clean up all
	 * our C level data structures and leave the Tcl level to the other
1168
1169
1170
1171
1172
1173
1174

1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
             */

            Tcl_DeleteEvents(ReflectEventDelete, rcPtr);

	    if (result != TCL_OK) {
		FreeReceivedError(&p);
	    }

	}
#endif

        Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
	return EOK;
    }

    /*
     * -- 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?
     */







>



|
|
<
|
<
|
<
<
<
<
|
<







1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154

1155

1156




1157

1158
1159
1160
1161
1162
1163
1164
             */

            Tcl_DeleteEvents(ReflectEventDelete, rcPtr);

	    if (result != TCL_OK) {
		FreeReceivedError(&p);
	    }
	    return EOK;
	}
#endif

	tctPtr = ((Channel *)rcPtr->chan)->typePtr;
	if (tctPtr && tctPtr != &tclRChannelType) {

	    ckfree((char *)tctPtr);

	    ((Channel *)rcPtr->chan)->typePtr = NULL;




	}

        Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
	return EOK;
    }

    /*
     * Are we in the correct thread?
     */
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225

        /*
         * Now squash the pending reflection events for this channel.
         */

        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);
	if ((result != TCL_OK) && (interp != NULL)) {
	    Tcl_SetChannelErrorInterp(interp, resObj);
	}

	Tcl_DecrRefCount(resObj);	/* Remove reference we held from the
					 * invoke */








<
<





|







1172
1173
1174
1175
1176
1177
1178


1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191

        /*
         * Now squash the pending reflection events for this channel.
         */

        Tcl_DeleteEvents(ReflectEventDelete, rcPtr);



	if (result != TCL_OK) {
	    PassReceivedErrorInterp(interp, &p);
	}
    } else {
#endif
	result = InvokeTclMethod(rcPtr, METH_FINAL, NULL, NULL, &resObj);
	if ((result != TCL_OK) && (interp != NULL)) {
	    Tcl_SetChannelErrorInterp(interp, resObj);
	}

	Tcl_DecrRefCount(resObj);	/* Remove reference we held from the
					 * invoke */

1249
1250
1251
1252
1253
1254
1255





1256
1257
1258
1259
1260
1261
1262
	hPtr = Tcl_FindHashEntry(&rcmPtr->map,
		Tcl_GetChannelName(rcPtr->chan));
	if (hPtr) {
	    Tcl_DeleteHashEntry(hPtr);
	}
#endif






        Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
#ifdef TCL_THREADS
    }
#endif
    return (result == TCL_OK) ? EOK : EINVAL;
}








>
>
>
>
>







1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
	hPtr = Tcl_FindHashEntry(&rcmPtr->map,
		Tcl_GetChannelName(rcPtr->chan));
	if (hPtr) {
	    Tcl_DeleteHashEntry(hPtr);
	}
#endif

	tctPtr = ((Channel *)rcPtr->chan)->typePtr;
	if (tctPtr && tctPtr != &tclRChannelType) {
	    ckfree((char *)tctPtr);
	    ((Channel *)rcPtr->chan)->typePtr = NULL;
	}
        Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
#ifdef TCL_THREADS
    }
#endif
    return (result == TCL_OK) ? EOK : EINVAL;
}

1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
{
    ReflectedChannel *rcPtr = clientData;
    Tcl_Obj *toReadObj;
    int bytec;			/* Number of returned bytes */
    unsigned char *bytev;	/* Array of returned bytes */
    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?
     */

#ifdef TCL_THREADS
    if (rcPtr->thread != Tcl_GetCurrentThread()) {
	ForwardParam p;







<
<
<
<
<
<
<
<
<
<
<
<







1256
1257
1258
1259
1260
1261
1262












1263
1264
1265
1266
1267
1268
1269
{
    ReflectedChannel *rcPtr = clientData;
    Tcl_Obj *toReadObj;
    int bytec;			/* Number of returned bytes */
    unsigned char *bytev;	/* Array of returned bytes */
    Tcl_Obj *resObj;		/* Result data for 'read' */













    /*
     * Are we in the correct thread?
     */

#ifdef TCL_THREADS
    if (rcPtr->thread != Tcl_GetCurrentThread()) {
	ForwardParam p;
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
    /* ASSERT: rcPtr->mode & TCL_READABLE */

    Tcl_Preserve(rcPtr);

    toReadObj = Tcl_NewIntObj(toRead);
    Tcl_IncrRefCount(toReadObj);

    if (InvokeTclMethod(rcPtr, "read", toReadObj, NULL, &resObj)!=TCL_OK) {
	int code = ErrnoReturn(rcPtr, resObj);

	if (code < 0) {
	    *errorCodePtr = -code;
            goto error;
	}








|







1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
    /* ASSERT: rcPtr->mode & TCL_READABLE */

    Tcl_Preserve(rcPtr);

    toReadObj = Tcl_NewIntObj(toRead);
    Tcl_IncrRefCount(toReadObj);

    if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK) {
	int code = ErrnoReturn(rcPtr, resObj);

	if (code < 0) {
	    *errorCodePtr = -code;
            goto error;
	}

1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
    int *errorCodePtr)
{
    ReflectedChannel *rcPtr = clientData;
    Tcl_Obj *bufObj;
    Tcl_Obj *resObj;		/* Result data for 'write' */
    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?
     */

#ifdef TCL_THREADS
    if (rcPtr->thread != Tcl_GetCurrentThread()) {
	ForwardParam p;







<
<
<
<
<
<
<
<
<
<
<
<







1359
1360
1361
1362
1363
1364
1365












1366
1367
1368
1369
1370
1371
1372
    int *errorCodePtr)
{
    ReflectedChannel *rcPtr = clientData;
    Tcl_Obj *bufObj;
    Tcl_Obj *resObj;		/* Result data for 'write' */
    int written;













    /*
     * Are we in the correct thread?
     */

#ifdef TCL_THREADS
    if (rcPtr->thread != Tcl_GetCurrentThread()) {
	ForwardParam p;
1446
1447
1448
1449
1450
1451
1452

1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468








1469
1470
1471
1472
1473
1474
1475
    }
#endif

    /* ASSERT: rcPtr->method & FLAG(METH_WRITE) */
    /* ASSERT: rcPtr->mode & TCL_WRITABLE */

    Tcl_Preserve(rcPtr);


    bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toWrite);
    Tcl_IncrRefCount(bufObj);

    if (InvokeTclMethod(rcPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
	int code = ErrnoReturn(rcPtr, resObj);

	if (code < 0) {
	    *errorCodePtr = -code;
            goto error;
	}

	Tcl_SetChannelError(rcPtr->chan, resObj);
        goto invalid;
    }









    if (Tcl_GetIntFromObj(rcPtr->interp, resObj, &written) != TCL_OK) {
	Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp));
        goto invalid;
    }

    if ((written == 0) && (toWrite > 0)) {
	/*







>




|











>
>
>
>
>
>
>
>







1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
    }
#endif

    /* ASSERT: rcPtr->method & FLAG(METH_WRITE) */
    /* ASSERT: rcPtr->mode & TCL_WRITABLE */

    Tcl_Preserve(rcPtr);
    Tcl_Preserve(rcPtr->interp);

    bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toWrite);
    Tcl_IncrRefCount(bufObj);

    if (InvokeTclMethod(rcPtr, METH_WRITE, bufObj, NULL, &resObj) != TCL_OK) {
	int code = ErrnoReturn(rcPtr, resObj);

	if (code < 0) {
	    *errorCodePtr = -code;
            goto error;
	}

	Tcl_SetChannelError(rcPtr->chan, resObj);
        goto invalid;
    }

    if (Tcl_InterpDeleted(rcPtr->interp)) {
	/*
	 * The interp was destroyed during InvokeTclMethod().
	 */

	SetChannelErrorStr(rcPtr->chan, msg_send_dstlost);
        goto invalid;
    }
    if (Tcl_GetIntFromObj(rcPtr->interp, resObj, &written) != TCL_OK) {
	Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp));
        goto invalid;
    }

    if ((written == 0) && (toWrite > 0)) {
	/*
1491
1492
1493
1494
1495
1496
1497

1498
1499
1500
1501
1502
1503
1504
        goto invalid;
    }

    *errorCodePtr = EOK;
 stop:
    Tcl_DecrRefCount(bufObj);
    Tcl_DecrRefCount(resObj);		/* Remove reference held from invoke */

    Tcl_Release(rcPtr);
    return written;
 invalid:
    *errorCodePtr = EINVAL;
 error:
    written = -1;
    goto stop;







>







1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
        goto invalid;
    }

    *errorCodePtr = EOK;
 stop:
    Tcl_DecrRefCount(bufObj);
    Tcl_DecrRefCount(resObj);		/* Remove reference held from invoke */
    Tcl_Release(rcPtr->interp);
    Tcl_Release(rcPtr);
    return written;
 invalid:
    *errorCodePtr = EINVAL;
 error:
    written = -1;
    goto stop;
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
    offObj  = Tcl_NewWideIntObj(offset);
    baseObj = Tcl_NewStringObj(
            (seekMode == SEEK_SET) ? "start" :
            (seekMode == SEEK_CUR) ? "current" : "end", -1);
    Tcl_IncrRefCount(offObj);
    Tcl_IncrRefCount(baseObj);

    if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj) != TCL_OK) {
	Tcl_SetChannelError(rcPtr->chan, resObj);
        goto invalid;
    }

    if (Tcl_GetWideIntFromObj(rcPtr->interp, resObj, &newLoc) != TCL_OK) {
	Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp));
        goto invalid;







|







1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
    offObj  = Tcl_NewWideIntObj(offset);
    baseObj = Tcl_NewStringObj(
            (seekMode == SEEK_SET) ? "start" :
            (seekMode == SEEK_CUR) ? "current" : "end", -1);
    Tcl_IncrRefCount(offObj);
    Tcl_IncrRefCount(baseObj);

    if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK) {
	Tcl_SetChannelError(rcPtr->chan, resObj);
        goto invalid;
    }

    if (Tcl_GetWideIntFromObj(rcPtr->interp, resObj, &newLoc) != TCL_OK) {
	Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp));
        goto invalid;
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
ReflectWatch(
    ClientData clientData,
    int mask)
{
    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.
     * Analoguously for read events and non-readable channels.
     */

    mask &= rcPtr->mode;







<
<







1592
1593
1594
1595
1596
1597
1598


1599
1600
1601
1602
1603
1604
1605
ReflectWatch(
    ClientData clientData,
    int mask)
{
    ReflectedChannel *rcPtr = clientData;
    Tcl_Obj *maskObj;



    /*
     * We restrict the interest to what the channel can support. IOW there
     * will never be write events for a channel which is not writable.
     * Analoguously for read events and non-readable channels.
     */

    mask &= rcPtr->mode;
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
    }
#endif

    Tcl_Preserve(rcPtr);

    maskObj = DecodeEventMask(mask);
    /* assert maskObj.refCount == 1 */
    (void) InvokeTclMethod(rcPtr, "watch", maskObj, NULL, NULL);
    Tcl_DecrRefCount(maskObj);

    Tcl_Release(rcPtr);
}

/*
 *----------------------------------------------------------------------







|







1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
    }
#endif

    Tcl_Preserve(rcPtr);

    maskObj = DecodeEventMask(mask);
    /* assert maskObj.refCount == 1 */
    (void) InvokeTclMethod(rcPtr, METH_WATCH, maskObj, NULL, NULL);
    Tcl_DecrRefCount(maskObj);

    Tcl_Release(rcPtr);
}

/*
 *----------------------------------------------------------------------
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
#endif

    blockObj = Tcl_NewBooleanObj(!nonblocking);
    Tcl_IncrRefCount(blockObj);

    Tcl_Preserve(rcPtr);

    if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL, &resObj)!=TCL_OK) {
	Tcl_SetChannelError(rcPtr->chan, resObj);
	errorNum = EINVAL;
    } else {
	errorNum = EOK;
    }

    Tcl_DecrRefCount(blockObj);







|







1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
#endif

    blockObj = Tcl_NewBooleanObj(!nonblocking);
    Tcl_IncrRefCount(blockObj);

    Tcl_Preserve(rcPtr);

    if (InvokeTclMethod(rcPtr,METH_BLOCKING,blockObj,NULL,&resObj)!=TCL_OK) {
	Tcl_SetChannelError(rcPtr->chan, resObj);
	errorNum = EINVAL;
    } else {
	errorNum = EOK;
    }

    Tcl_DecrRefCount(blockObj);
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864

    optionObj = Tcl_NewStringObj(optionName, -1);
    valueObj = Tcl_NewStringObj(newValue, -1);

    Tcl_IncrRefCount(optionObj);
    Tcl_IncrRefCount(valueObj);

    result = InvokeTclMethod(rcPtr, "configure",optionObj,valueObj, &resObj);
    if (result != TCL_OK) {
	UnmarshallErrorResult(interp, resObj);
    }

    Tcl_DecrRefCount(optionObj);
    Tcl_DecrRefCount(valueObj);
    Tcl_DecrRefCount(resObj);		/* Remove reference held from invoke */







|







1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819

    optionObj = Tcl_NewStringObj(optionName, -1);
    valueObj = Tcl_NewStringObj(newValue, -1);

    Tcl_IncrRefCount(optionObj);
    Tcl_IncrRefCount(valueObj);

    result = InvokeTclMethod(rcPtr, METH_CONFIGURE,optionObj,valueObj, &resObj);
    if (result != TCL_OK) {
	UnmarshallErrorResult(interp, resObj);
    }

    Tcl_DecrRefCount(optionObj);
    Tcl_DecrRefCount(valueObj);
    Tcl_DecrRefCount(resObj);		/* Remove reference held from invoke */
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
     */

    ReflectedChannel *rcPtr = clientData;
    Tcl_Obj *optionObj;
    Tcl_Obj *resObj;		/* Result data for 'configure' */
    int listc, result = TCL_OK;
    Tcl_Obj **listv;
    const char *method;

    /*
     * Are we in the correct thread?
     */

#ifdef TCL_THREADS
    if (rcPtr->thread != Tcl_GetCurrentThread()) {







|







1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
     */

    ReflectedChannel *rcPtr = clientData;
    Tcl_Obj *optionObj;
    Tcl_Obj *resObj;		/* Result data for 'configure' */
    int listc, result = TCL_OK;
    Tcl_Obj **listv;
    MethodName method;

    /*
     * Are we in the correct thread?
     */

#ifdef TCL_THREADS
    if (rcPtr->thread != Tcl_GetCurrentThread()) {
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
#endif

    if (optionName == NULL) {
	/*
	 * Retrieve all options.
	 */

	method = "cgetall";
	optionObj = NULL;
    } else {
	/*
	 * Retrieve the value of one option.
	 */

	method = "cget";
	optionObj = Tcl_NewStringObj(optionName, -1);
        Tcl_IncrRefCount(optionObj);
    }

    Tcl_Preserve(rcPtr);

    if (InvokeTclMethod(rcPtr, method, optionObj, NULL, &resObj)!=TCL_OK) {







|






|







1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
#endif

    if (optionName == NULL) {
	/*
	 * Retrieve all options.
	 */

	method = METH_CGETALL;
	optionObj = NULL;
    } else {
	/*
	 * Retrieve the value of one option.
	 */

	method = METH_CGET;
	optionObj = Tcl_NewStringObj(optionName, -1);
        Tcl_IncrRefCount(optionObj);
    }

    Tcl_Preserve(rcPtr);

    if (InvokeTclMethod(rcPtr, method, optionObj, NULL, &resObj)!=TCL_OK) {
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
NewReflectedChannel(
    Tcl_Interp *interp,
    Tcl_Obj *cmdpfxObj,
    int mode,
    Tcl_Obj *handleObj)
{
    ReflectedChannel *rcPtr;
    int i, listc;
    Tcl_Obj **listv;

    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
    rcPtr->thread = Tcl_GetCurrentThread();
#endif
    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.
     */

    return rcPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * NextHandle --







|
<




<


<








<
<
<
<

|
<
|
<
<
<
|
<
<
<
<
<
|
<
<
|
<
<
<
|
<
<
|
|
<
<
<
<
<
<
<
<
|
|
<
<
<
<
<
<
<
<
<







2110
2111
2112
2113
2114
2115
2116
2117

2118
2119
2120
2121

2122
2123

2124
2125
2126
2127
2128
2129
2130
2131




2132
2133

2134



2135





2136


2137



2138


2139
2140








2141
2142









2143
2144
2145
2146
2147
2148
2149
NewReflectedChannel(
    Tcl_Interp *interp,
    Tcl_Obj *cmdpfxObj,
    int mode,
    Tcl_Obj *handleObj)
{
    ReflectedChannel *rcPtr;
    MethodName mn = METH_BLOCKING;


    rcPtr = ckalloc(sizeof(ReflectedChannel));

    /* rcPtr->chan: Assigned by caller. Dummy data here. */


    rcPtr->chan = NULL;

    rcPtr->interp = interp;
    rcPtr->dead = 0;
#ifdef TCL_THREADS
    rcPtr->thread = Tcl_GetCurrentThread();
#endif
    rcPtr->mode = mode;
    rcPtr->interest = 0;		/* Initially no interest registered */





    /* ASSERT: cmdpfxObj is a Tcl List */
    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;
}

/*
 *----------------------------------------------------------------------
 *
 * NextHandle --
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
    Tcl_MutexLock(&rcCounterMutex);
    resObj = Tcl_ObjPrintf("rc%lu", rcCounter);
    rcCounter++;
    Tcl_MutexUnlock(&rcCounterMutex);

    return resObj;
}

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)
{
    Channel *chanPtr = (Channel *) rcPtr->chan;

    if (chanPtr->typePtr != &tclRChannelType) {
	/*
	 * Delete a cloned ChannelType structure.
	 */

	ckfree(chanPtr->typePtr);
	chanPtr->typePtr = NULL;
    }

    FreeReflectedChannelArgs(rcPtr);

    ckfree(rcPtr->argv);
    ckfree(rcPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * InvokeTclMethod --







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







<
<
<
<
<
|
<
<
|
<
|
|







2180
2181
2182
2183
2184
2185
2186






















2187
2188
2189
2190
2191
2192
2193





2194


2195

2196
2197
2198
2199
2200
2201
2202
2203
2204
    Tcl_MutexLock(&rcCounterMutex);
    resObj = Tcl_ObjPrintf("rc%lu", rcCounter);
    rcCounter++;
    Tcl_MutexUnlock(&rcCounterMutex);

    return resObj;
}























static void
FreeReflectedChannel(
    ReflectedChannel *rcPtr)
{
    Channel *chanPtr = (Channel *) rcPtr->chan;






    Tcl_Release(chanPtr);


    Tcl_DecrRefCount(rcPtr->name);

    Tcl_DecrRefCount(rcPtr->methods);
    Tcl_DecrRefCount(rcPtr->cmd);
    ckfree(rcPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * InvokeTclMethod --
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352

2353
2354
2355
2356
2357
2358
2359
 *
 *----------------------------------------------------------------------
 */

static int
InvokeTclMethod(
    ReflectedChannel *rcPtr,
    const char *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. */


    if (rcPtr->dead) {
	/*
	 * The channel is marked as dead. Bail out immediately, with an
	 * appropriate error.
	 */








|




<




>







2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232

2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
 *
 *----------------------------------------------------------------------
 */

static int
InvokeTclMethod(
    ReflectedChannel *rcPtr,
    MethodName method,
    Tcl_Obj *argOneObj,		/* NULL'able */
    Tcl_Obj *argTwoObj,		/* NULL'able */
    Tcl_Obj **resultObjPtr)	/* NULL'able */
{

    Tcl_Obj *methObj = NULL;	/* Method name in object form */
    Tcl_InterpState sr;		/* State of handler interp */
    int result;			/* Result code of method invokation */
    Tcl_Obj *resObj = NULL;	/* Result of method invokation. */
    Tcl_Obj *cmd;

    if (rcPtr->dead) {
	/*
	 * The channel is marked as dead. Bail out immediately, with an
	 * appropriate error.
	 */

2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384

2385
2386
2387

2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411

2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
         * See the contract as well.
         */

	return TCL_ERROR;
    }

    /*
     * 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,
     * before the channel id.
     */


    methObj = Tcl_NewStringObj(method, -1);
    Tcl_IncrRefCount(methObj);
    rcPtr->argv[rcPtr->argc - 2] = methObj;


    /*
     * Append the additional argument containing method specific details
     * behind the channel id. If specified.
     *
     * Because of the contract there is no need to increment the refcounts.
     * The objects will survive the Tcl_EvalObjv without change.
     */

    cmdc = rcPtr->argc;
    if (argOneObj) {
	rcPtr->argv[cmdc] = argOneObj;
	cmdc++;
	if (argTwoObj) {
	    rcPtr->argv[cmdc] = argTwoObj;
	    cmdc++;
	}
    }

    /*
     * And run the handler... This is done in auch a manner which leaves any
     * existing state intact.
     */


    sr = Tcl_SaveInterpState(rcPtr->interp, 0 /* Dummy */);
    Tcl_Preserve(rcPtr->interp);
    result = Tcl_EvalObjv(rcPtr->interp, cmdc, rcPtr->argv, TCL_EVAL_GLOBAL);

    /*
     * We do not try to extract the result information if the caller has no
     * interest in it. I.e. there is no need to put effort into creating
     * something which is discarded immediately after.
     */








<
<
<
<
<
<
|



>
|
|
|
>









<

|
<

|
<








>


|







2253
2254
2255
2256
2257
2258
2259






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

2278
2279

2280
2281

2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
         * See the contract as well.
         */

	return TCL_ERROR;
    }

    /*






     * Insert method into the callback command, after the command prefix,
     * before the channel id.
     */

    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
     * behind the channel id. If specified.
     *
     * Because of the contract there is no need to increment the refcounts.
     * The objects will survive the Tcl_EvalObjv without change.
     */


    if (argOneObj) {
	Tcl_ListObjAppendElement(NULL, cmd, argOneObj);

	if (argTwoObj) {
	    Tcl_ListObjAppendElement(NULL, cmd, argTwoObj);

	}
    }

    /*
     * And run the handler... This is done in auch a manner which leaves any
     * existing state intact.
     */

    Tcl_IncrRefCount(cmd);
    sr = Tcl_SaveInterpState(rcPtr->interp, 0 /* Dummy */);
    Tcl_Preserve(rcPtr->interp);
    result = Tcl_EvalObjEx(rcPtr->interp, cmd, TCL_EVAL_GLOBAL);

    /*
     * We do not try to extract the result information if the caller has no
     * interest in it. I.e. there is no need to put effort into creating
     * something which is discarded immediately after.
     */

2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454

2455
2456
2457
2458

2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
	     * the full state of the result, including additional options.
	     *
	     * This is complex and ugly, and would be completely unnecessary
	     * if we only added support for a TCL_FORBID_EXCEPTIONS flag.
	     */

	    if (result != TCL_ERROR) {
		Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rcPtr->argv);
		int cmdLen;
		const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen);

		Tcl_IncrRefCount(cmd);
		Tcl_ResetResult(rcPtr->interp);
		Tcl_SetObjResult(rcPtr->interp, Tcl_ObjPrintf(
			"chan handler returned bad code: %d", result));
		Tcl_LogCommandInfo(rcPtr->interp, cmdString, cmdString,
			cmdLen);
		Tcl_DecrRefCount(cmd);
		result = TCL_ERROR;
	    }
	    Tcl_AppendObjToErrorInfo(rcPtr->interp, Tcl_ObjPrintf(
		    "\n    (chan handler subcommand \"%s\")", method));

	    resObj = MarshallError(rcPtr->interp);
	}
	Tcl_IncrRefCount(resObj);
    }

    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).
     */

    if (resultObjPtr != NULL) {







<













|
>




>



<
<
<
<
<
<
<
<
<
<







2312
2313
2314
2315
2316
2317
2318

2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341










2342
2343
2344
2345
2346
2347
2348
	     * the full state of the result, including additional options.
	     *
	     * This is complex and ugly, and would be completely unnecessary
	     * if we only added support for a TCL_FORBID_EXCEPTIONS flag.
	     */

	    if (result != TCL_ERROR) {

		int cmdLen;
		const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen);

		Tcl_IncrRefCount(cmd);
		Tcl_ResetResult(rcPtr->interp);
		Tcl_SetObjResult(rcPtr->interp, Tcl_ObjPrintf(
			"chan handler returned bad code: %d", result));
		Tcl_LogCommandInfo(rcPtr->interp, cmdString, cmdString,
			cmdLen);
		Tcl_DecrRefCount(cmd);
		result = TCL_ERROR;
	    }
	    Tcl_AppendObjToErrorInfo(rcPtr->interp, Tcl_ObjPrintf(
		    "\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);











    /*
     * 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).
     */

    if (resultObjPtr != NULL) {
2653
2654
2655
2656
2657
2658
2659





2660
2661
2662
2663
2664
2665
2666
2667
2668



2669
2670
2671
2672
2673
2674
2675

	    continue;
	}

	/*
	 * The receiver for the event exited, before processing the event. We
	 * detach the result now, wake the originator up and signal failure.





	 */

	evPtr = resultPtr->evPtr;

	/* Basic crash safety until this routine can get revised [3411310] */
	if (evPtr == NULL) {
	    continue;
	}
	paramPtr = evPtr->param;




	evPtr->resultPtr = NULL;
	resultPtr->evPtr = NULL;
	resultPtr->result = TCL_ERROR;

	ForwardSetStaticError(paramPtr, msg_send_dstlost);








>
>
>
>
>









>
>
>







2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553

	    continue;
	}

	/*
	 * The receiver for the event exited, before processing the event. We
	 * detach the result now, wake the originator up and signal failure.
         *
         * Attention: Results may have been detached already, by either the
         * receiver, or this thread, as part of other parts in the thread
         * teardown. Such results are ignored. See ticket [b47b176adf] for the
         * identical race condition in Tcl 8.6 IORTrans.
	 */

	evPtr = resultPtr->evPtr;

	/* Basic crash safety until this routine can get revised [3411310] */
	if (evPtr == NULL) {
	    continue;
	}
	paramPtr = evPtr->param;
	if (!evPtr) {
	    continue;
	}

	evPtr->resultPtr = NULL;
	resultPtr->evPtr = NULL;
	resultPtr->result = TCL_ERROR;

	ForwardSetStaticError(paramPtr, msg_send_dstlost);

2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
	     * Ignore entries for other interpreters.
	     */

	    continue;
	}

	rcPtr->dead = 1;
	FreeReflectedChannelArgs(rcPtr);
	Tcl_DeleteHashEntry(hPtr);
    }
#endif
}

#ifdef TCL_THREADS
/*







<







2574
2575
2576
2577
2578
2579
2580

2581
2582
2583
2584
2585
2586
2587
	     * Ignore entries for other interpreters.
	     */

	    continue;
	}

	rcPtr->dead = 1;

	Tcl_DeleteHashEntry(hPtr);
    }
#endif
}

#ifdef TCL_THREADS
/*
2793
2794
2795
2796
2797
2798
2799





2800
2801
2802
2803
2804
2805
2806
2807
2808



2809
2810
2811
2812
2813
2814
2815

	    continue;
	}

	/*
	 * The receiver for the event exited, before processing the event. We
	 * detach the result now, wake the originator up and signal failure.





	 */

	evPtr = resultPtr->evPtr;

	/* Basic crash safety until this routine can get revised [3411310] */
	if (evPtr == NULL ) {
	    continue;
	}
	paramPtr = evPtr->param;




	evPtr->resultPtr = NULL;
	resultPtr->evPtr = NULL;
	resultPtr->result = TCL_ERROR;

	ForwardSetStaticError(paramPtr, msg_send_dstlost);








>
>
>
>
>









>
>
>







2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700

	    continue;
	}

	/*
	 * The receiver for the event exited, before processing the event. We
	 * detach the result now, wake the originator up and signal failure.
         *
         * Attention: Results may have been detached already, by either the
         * receiver, or this thread, as part of other parts in the thread
         * teardown. Such results are ignored. See ticket [b47b176adf] for the
         * identical race condition in Tcl 8.6 IORTrans.
	 */

	evPtr = resultPtr->evPtr;

	/* Basic crash safety until this routine can get revised [3411310] */
	if (evPtr == NULL ) {
	    continue;
	}
	paramPtr = evPtr->param;
	if (!evPtr) {
	    continue;
	}

	evPtr->resultPtr = NULL;
	resultPtr->evPtr = NULL;
	resultPtr->result = TCL_ERROR;

	ForwardSetStaticError(paramPtr, msg_send_dstlost);

2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
    for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
	    hPtr != NULL;
	    hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
	Tcl_Channel chan = Tcl_GetHashValue(hPtr);
	ReflectedChannel *rcPtr = Tcl_GetChannelInstanceData(chan);

	rcPtr->dead = 1;
	FreeReflectedChannelArgs(rcPtr);
	Tcl_DeleteHashEntry(hPtr);
    }
    ckfree(rcmPtr);
}

static void
ForwardOpToHandlerThread(







<







2721
2722
2723
2724
2725
2726
2727

2728
2729
2730
2731
2732
2733
2734
    for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
	    hPtr != NULL;
	    hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
	Tcl_Channel chan = Tcl_GetHashValue(hPtr);
	ReflectedChannel *rcPtr = Tcl_GetChannelInstanceData(chan);

	rcPtr->dead = 1;

	Tcl_DeleteHashEntry(hPtr);
    }
    ckfree(rcmPtr);
}

static void
ForwardOpToHandlerThread(
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025


3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049





3050
3051

3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
    switch (evPtr->op) {
	/*
	 * The destination thread for the following operations is
	 * rcPtr->thread, which contains rcPtr->interp, the interp we have to
	 * call upon for the driver.
	 */

    case ForwardedClose:
	/*
	 * No parameters/results.
	 */



	if (InvokeTclMethod(rcPtr, "finalize", NULL, NULL, &resObj)!=TCL_OK) {
	    ForwardSetObjError(paramPtr, resObj);
	}

	/*
	 * Freeing is done here, in the origin thread, because the argv[]
	 * objects belong to this thread. Deallocating them in a different
	 * thread is not allowed
	 *
	 * We remove the channel from both interpreter and thread maps before
	 * releasing the memory, to prevent future accesses (like by
	 * 'postevent') from finding and dereferencing a dangling pointer.
	 */

	rcmPtr = GetReflectedChannelMap(interp);
	hPtr = Tcl_FindHashEntry(&rcmPtr->map,
                Tcl_GetChannelName(rcPtr->chan));
	Tcl_DeleteHashEntry(hPtr);

	rcmPtr = GetThreadReflectedChannelMap();
	hPtr = Tcl_FindHashEntry(&rcmPtr->map,
                Tcl_GetChannelName(rcPtr->chan));
	Tcl_DeleteHashEntry(hPtr);






	FreeReflectedChannelArgs(rcPtr);
	break;


    case ForwardedInput: {
	Tcl_Obj *toReadObj = Tcl_NewIntObj(paramPtr->input.toRead);
        Tcl_IncrRefCount(toReadObj);

        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, "read", toReadObj, NULL, &resObj)!=TCL_OK){
	    int code = ErrnoReturn(rcPtr, resObj);

	    if (code < 0) {
		paramPtr->base.code = code;
	    } else {
		ForwardSetObjError(paramPtr, resObj);
	    }







|




>
>
|




|


















>
>
>
>
>
|

>






|







2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
    switch (evPtr->op) {
	/*
	 * The destination thread for the following operations is
	 * rcPtr->thread, which contains rcPtr->interp, the interp we have to
	 * call upon for the driver.
	 */

    case ForwardedClose: {
	/*
	 * No parameters/results.
	 */

	const Tcl_ChannelType *tctPtr;

	if (InvokeTclMethod(rcPtr, METH_FINAL, NULL, NULL, &resObj)!=TCL_OK) {
	    ForwardSetObjError(paramPtr, resObj);
	}

	/*
	 * Freeing is done here, in the origin thread, callback command
	 * objects belong to this thread. Deallocating them in a different
	 * thread is not allowed
	 *
	 * We remove the channel from both interpreter and thread maps before
	 * releasing the memory, to prevent future accesses (like by
	 * 'postevent') from finding and dereferencing a dangling pointer.
	 */

	rcmPtr = GetReflectedChannelMap(interp);
	hPtr = Tcl_FindHashEntry(&rcmPtr->map,
                Tcl_GetChannelName(rcPtr->chan));
	Tcl_DeleteHashEntry(hPtr);

	rcmPtr = GetThreadReflectedChannelMap();
	hPtr = Tcl_FindHashEntry(&rcmPtr->map,
                Tcl_GetChannelName(rcPtr->chan));
	Tcl_DeleteHashEntry(hPtr);

	tctPtr = ((Channel *)rcPtr->chan)->typePtr;
	if (tctPtr && tctPtr != &tclRChannelType) {
	    ckfree((char *)tctPtr);
	    ((Channel *)rcPtr->chan)->typePtr = NULL;
	}
        Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
	break;
    }

    case ForwardedInput: {
	Tcl_Obj *toReadObj = Tcl_NewIntObj(paramPtr->input.toRead);
        Tcl_IncrRefCount(toReadObj);

        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK){
	    int code = ErrnoReturn(rcPtr, resObj);

	    if (code < 0) {
		paramPtr->base.code = code;
	    } else {
		ForwardSetObjError(paramPtr, resObj);
	    }
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105

    case ForwardedOutput: {
	Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *)
                paramPtr->output.buf, paramPtr->output.toWrite);
        Tcl_IncrRefCount(bufObj);

        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
	    int code = ErrnoReturn(rcPtr, resObj);

	    if (code < 0) {
		paramPtr->base.code = code;
	    } else {
		ForwardSetObjError(paramPtr, resObj);
	    }







|







2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997

    case ForwardedOutput: {
	Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *)
                paramPtr->output.buf, paramPtr->output.toWrite);
        Tcl_IncrRefCount(bufObj);

        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, METH_WRITE, bufObj, NULL, &resObj) != TCL_OK) {
	    int code = ErrnoReturn(rcPtr, resObj);

	    if (code < 0) {
		paramPtr->base.code = code;
	    } else {
		ForwardSetObjError(paramPtr, resObj);
	    }
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
                (paramPtr->seek.seekMode==SEEK_SET) ? "start" :
                (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1);

        Tcl_IncrRefCount(offObj);
        Tcl_IncrRefCount(baseObj);

        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj)!=TCL_OK){
	    ForwardSetObjError(paramPtr, resObj);
	    paramPtr->seek.offset = -1;
	} else {
	    /*
	     * Process a regular result. If the type is wrong this may change
	     * into an error.
	     */







|







3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
                (paramPtr->seek.seekMode==SEEK_SET) ? "start" :
                (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1);

        Tcl_IncrRefCount(offObj);
        Tcl_IncrRefCount(baseObj);

        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK){
	    ForwardSetObjError(paramPtr, resObj);
	    paramPtr->seek.offset = -1;
	} else {
	    /*
	     * Process a regular result. If the type is wrong this may change
	     * into an error.
	     */
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
    }

    case ForwardedWatch: {
	Tcl_Obj *maskObj = DecodeEventMask(paramPtr->watch.mask);
        /* assert maskObj.refCount == 1 */

        Tcl_Preserve(rcPtr);
	(void) InvokeTclMethod(rcPtr, "watch", maskObj, NULL, NULL);
	Tcl_DecrRefCount(maskObj);
        Tcl_Release(rcPtr);
	break;
    }

    case ForwardedBlock: {
	Tcl_Obj *blockObj = Tcl_NewBooleanObj(!paramPtr->block.nonblocking);

        Tcl_IncrRefCount(blockObj);
        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL,
                &resObj) != TCL_OK) {
	    ForwardSetObjError(paramPtr, resObj);
	}
        Tcl_Release(rcPtr);
        Tcl_DecrRefCount(blockObj);
	break;
    }

    case ForwardedSetOpt: {
	Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->setOpt.name, -1);
	Tcl_Obj *valueObj  = Tcl_NewStringObj(paramPtr->setOpt.value, -1);

        Tcl_IncrRefCount(optionObj);
        Tcl_IncrRefCount(valueObj);
        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, "configure", optionObj, valueObj,
                &resObj) != TCL_OK) {
	    ForwardSetObjError(paramPtr, resObj);
	}
        Tcl_Release(rcPtr);
        Tcl_DecrRefCount(optionObj);
        Tcl_DecrRefCount(valueObj);
	break;
    }

    case ForwardedGetOpt: {
	/*
	 * Retrieve the value of one option.
	 */

	Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->getOpt.name, -1);

        Tcl_IncrRefCount(optionObj);
        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, "cget", optionObj, NULL, &resObj)!=TCL_OK){
	    ForwardSetObjError(paramPtr, resObj);
	} else {
	    TclDStringAppendObj(paramPtr->getOpt.value, resObj);
	}
        Tcl_Release(rcPtr);
        Tcl_DecrRefCount(optionObj);
	break;
    }

    case ForwardedGetOptAll:
	/*
	 * Retrieve all options.
	 */

        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, "cgetall", NULL, NULL, &resObj) != TCL_OK){
	    ForwardSetObjError(paramPtr, resObj);
	} else {
	    /*
	     * Extract list, validate that it is a list, and #elements. See
	     * NOTE (4) as well.
	     */








|










|















|


















|















|







3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
    }

    case ForwardedWatch: {
	Tcl_Obj *maskObj = DecodeEventMask(paramPtr->watch.mask);
        /* assert maskObj.refCount == 1 */

        Tcl_Preserve(rcPtr);
	(void) InvokeTclMethod(rcPtr, METH_WATCH, maskObj, NULL, NULL);
	Tcl_DecrRefCount(maskObj);
        Tcl_Release(rcPtr);
	break;
    }

    case ForwardedBlock: {
	Tcl_Obj *blockObj = Tcl_NewBooleanObj(!paramPtr->block.nonblocking);

        Tcl_IncrRefCount(blockObj);
        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, METH_BLOCKING, blockObj, NULL,
                &resObj) != TCL_OK) {
	    ForwardSetObjError(paramPtr, resObj);
	}
        Tcl_Release(rcPtr);
        Tcl_DecrRefCount(blockObj);
	break;
    }

    case ForwardedSetOpt: {
	Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->setOpt.name, -1);
	Tcl_Obj *valueObj  = Tcl_NewStringObj(paramPtr->setOpt.value, -1);

        Tcl_IncrRefCount(optionObj);
        Tcl_IncrRefCount(valueObj);
        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, METH_CONFIGURE, optionObj, valueObj,
                &resObj) != TCL_OK) {
	    ForwardSetObjError(paramPtr, resObj);
	}
        Tcl_Release(rcPtr);
        Tcl_DecrRefCount(optionObj);
        Tcl_DecrRefCount(valueObj);
	break;
    }

    case ForwardedGetOpt: {
	/*
	 * Retrieve the value of one option.
	 */

	Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->getOpt.name, -1);

        Tcl_IncrRefCount(optionObj);
        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, METH_CGET, optionObj, NULL, &resObj)!=TCL_OK){
	    ForwardSetObjError(paramPtr, resObj);
	} else {
	    TclDStringAppendObj(paramPtr->getOpt.value, resObj);
	}
        Tcl_Release(rcPtr);
        Tcl_DecrRefCount(optionObj);
	break;
    }

    case ForwardedGetOptAll:
	/*
	 * Retrieve all options.
	 */

        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, METH_CGETALL, NULL, NULL, &resObj) != TCL_OK){
	    ForwardSetObjError(paramPtr, resObj);
	} else {
	    /*
	     * Extract list, validate that it is a list, and #elements. See
	     * NOTE (4) as well.
	     */

Changes to generic/tclIORTrans.c.
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
 * control flow in callers easier.
 */

static void		TimerKill(ReflectedTransform *rtPtr);
static void		TimerSetup(ReflectedTransform *rtPtr);
static void		TimerRun(ClientData clientData);
static int		TransformRead(ReflectedTransform *rtPtr,
			    int *errorCodePtr, unsigned char *buf,
			    int toRead);
static int		TransformWrite(ReflectedTransform *rtPtr,
			    int *errorCodePtr, unsigned char *buf,
			    int toWrite);
static int		TransformDrain(ReflectedTransform *rtPtr,
			    int *errorCodePtr);
static int		TransformFlush(ReflectedTransform *rtPtr,
			    int *errorCodePtr, int op);







|
<







453
454
455
456
457
458
459
460

461
462
463
464
465
466
467
 * control flow in callers easier.
 */

static void		TimerKill(ReflectedTransform *rtPtr);
static void		TimerSetup(ReflectedTransform *rtPtr);
static void		TimerRun(ClientData clientData);
static int		TransformRead(ReflectedTransform *rtPtr,
			    int *errorCodePtr, Tcl_Obj *bufObj);

static int		TransformWrite(ReflectedTransform *rtPtr,
			    int *errorCodePtr, unsigned char *buf,
			    int toWrite);
static int		TransformDrain(ReflectedTransform *rtPtr,
			    int *errorCodePtr);
static int		TransformFlush(ReflectedTransform *rtPtr,
			    int *errorCodePtr, int op);
1059
1060
1061
1062
1063
1064
1065

1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080



1081
1082
1083
1084
1085
1086
1087
    ClientData clientData,
    char *buf,
    int toRead,
    int *errorCodePtr)
{
    ReflectedTransform *rtPtr = clientData;
    int gotBytes, copied, readBytes;


    /*
     * 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 (!(rtPtr->methods & FLAG(METH_READ))) {
	SetChannelErrorStr(rtPtr->chan, msg_read_unsup);
	*errorCodePtr = EINVAL;
	return -1;
    }

    Tcl_Preserve(rtPtr);




    gotBytes = 0;
    while (toRead > 0) {
	/*
	 * Loop until the request is satisfied (or no data available from
	 * below, possibly EOF).
	 */








>















>
>
>







1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
    ClientData clientData,
    char *buf,
    int toRead,
    int *errorCodePtr)
{
    ReflectedTransform *rtPtr = clientData;
    int gotBytes, copied, readBytes;
    Tcl_Obj *bufObj;

    /*
     * 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 (!(rtPtr->methods & FLAG(METH_READ))) {
	SetChannelErrorStr(rtPtr->chan, msg_read_unsup);
	*errorCodePtr = EINVAL;
	return -1;
    }

    Tcl_Preserve(rtPtr);

    /* TODO: Consider a more appropriate buffer size. */
    bufObj = Tcl_NewByteArrayObj(NULL, toRead);
    Tcl_IncrRefCount(bufObj);
    gotBytes = 0;
    while (toRead > 0) {
	/*
	 * Loop until the request is satisfied (or no data available from
	 * below, possibly EOF).
	 */

1125
1126
1127
1128
1129
1130
1131

1132

1133
1134
1135
1136
1137
1138
1139
1140


1141
1142
1143
1144
1145
1146
1147








1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
	    } /* else: 'maxRead < 0' == Accept the current value of toRead */
	}

	if (toRead <= 0) {
	    goto stop;
	}


	readBytes = Tcl_ReadRaw(rtPtr->parent, buf, toRead);

	if (readBytes < 0) {
	    /*
	     * Report errors to caller. The state of the seek system is
	     * unchanged!
	     */

	    if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) {
		/*


		 * EAGAIN is a special situation. If we had some data before
		 * we report that instead of the request to re-try.
		 */

		goto stop;
	    }









	    *errorCodePtr = Tcl_GetErrno();
	    goto error;
	}

	if (readBytes == 0) {
	    /*
	     * Check wether we hit on EOF in 'parent' or not. If not
	     * differentiate between blocking and non-blocking modes. In
	     * non-blocking mode we ran temporarily out of data. Signal this
	     * to the caller via EWOULDBLOCK and error return (-1). In the
	     * other cases we simply return what we got and let the caller
	     * wait for more. On the other hand, if we got an EOF we have to
	     * convert and flush all waiting partial data.
	     */

	    if (!Tcl_Eof(rtPtr->parent)) {
		/*
		 * The state of the seek system is unchanged!
		 */

		if ((gotBytes == 0) && rtPtr->nonblocking) {
		    *errorCodePtr = EWOULDBLOCK;
		    goto error;
		}
		goto stop;
	    } else {
		/*
		 * Eof in parent.
		 */

		if (rtPtr->readIsDrained) {
		    goto stop;
		}

		/*
		 * Now this is a bit different. The partial data waiting is
		 * converted and returned.







>
|
>

<
<
|
<

<

>
>
|
<





>
>
>
>
>
>
>
>





<
<
<
<
<
<
<
<
<

<
|
<
<
|
<
<
<
<
<
|
<
<
|
|







1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138


1139

1140

1141
1142
1143
1144

1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162









1163

1164


1165





1166


1167
1168
1169
1170
1171
1172
1173
1174
1175
	    } /* else: 'maxRead < 0' == Accept the current value of toRead */
	}

	if (toRead <= 0) {
	    goto stop;
	}


	readBytes = Tcl_ReadRaw(rtPtr->parent,
		(char *) Tcl_SetByteArrayLength(bufObj, toRead), toRead);
	if (readBytes < 0) {


	    if (Tcl_InputBlocked(rtPtr->parent) && (gotBytes > 0)) {



		/*
		 * Down channel is blocked and offers zero additional bytes.
		 * The nonzero gotBytes already returned makes the total
		 * operation a valid short read.  Return to caller.

		 */

		goto stop;
	    }

	    /*
	     * Either the down channel is not blocked (a real error)
	     * or it is and there are gotBytes==0 byte copied so far.
	     * In either case, pass up the error, so we either report
	     * any real error, or do not mistakenly signal EOF by
	     * returning 0 to the caller.
	     */

	    *errorCodePtr = Tcl_GetErrno();
	    goto error;
	}

	if (readBytes == 0) {











	    /*


	     * Zero returned from Tcl_ReadRaw() always indicates EOF





	     * on the down channel.


	     */
	
		if (rtPtr->readIsDrained) {
		    goto stop;
		}

		/*
		 * Now this is a bit different. The partial data waiting is
		 * converted and returned.
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215

1216
1217
1218






1219
1220
1221

1222
1223
1224
1225
1226
1227
1228
		    /*
		     * The drain delivered nothing.
		     */

		    goto stop;
		}

		/*
		 * Reset eof, force caller to drain result buffer.
		 */

		((Channel *) rtPtr->parent)->state->flags &= ~CHANNEL_EOF;
		continue; /* at: while (toRead > 0) */
	    }
	} /* readBytes == 0 */

	/*
	 * Transform the read chunk, which was not empty. Anything we got back
	 * is a transformation result is put into our buffers, and the next
	 * iteration will put it into the result.
	 */


	if (!TransformRead(rtPtr, errorCodePtr, UCHARP(buf), readBytes)) {
	    goto error;
	}






    } /* while toRead > 0 */

 stop:

    Tcl_Release(rtPtr);
    return gotBytes;

 error:
    gotBytes = -1;
    goto stop;
}







<
<
<
<
<

<








>
|


>
>
>
>
>
>



>







1185
1186
1187
1188
1189
1190
1191





1192

1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
		    /*
		     * The drain delivered nothing.
		     */

		    goto stop;
		}






		continue; /* at: while (toRead > 0) */

	} /* readBytes == 0 */

	/*
	 * Transform the read chunk, which was not empty. Anything we got back
	 * is a transformation result is put into our buffers, and the next
	 * iteration will put it into the result.
	 */

	Tcl_SetByteArrayLength(bufObj, readBytes);
	if (!TransformRead(rtPtr, errorCodePtr, bufObj)) {
	    goto error;
	}
	if (Tcl_IsShared(bufObj)) {
	    Tcl_DecrRefCount(bufObj);
	    bufObj = Tcl_NewObj();
	    Tcl_IncrRefCount(bufObj);
	}
	Tcl_SetByteArrayLength(bufObj, 0);
    } /* while toRead > 0 */

 stop:
    Tcl_DecrRefCount(bufObj);
    Tcl_Release(rtPtr);
    return gotBytes;

 error:
    gotBytes = -1;
    goto stop;
}
2006
2007
2008
2009
2010
2011
2012

2013
2014
2015
2016
2017
2018
2019
    /*
     * And run the handler... This is done in auch a manner which leaves any
     * existing state intact.
     */

    sr = Tcl_SaveInterpState(rtPtr->interp, 0 /* Dummy */);
    Tcl_Preserve(rtPtr);

    result = Tcl_EvalObjv(rtPtr->interp, cmdc, rtPtr->argv, TCL_EVAL_GLOBAL);

    /*
     * We do not try to extract the result information if the caller has no
     * interest in it. I.e. there is no need to put effort into creating
     * something which is discarded immediately after.
     */







>







1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
    /*
     * And run the handler... This is done in auch a manner which leaves any
     * existing state intact.
     */

    sr = Tcl_SaveInterpState(rtPtr->interp, 0 /* Dummy */);
    Tcl_Preserve(rtPtr);
    Tcl_Preserve(rtPtr->interp);
    result = Tcl_EvalObjv(rtPtr->interp, cmdc, rtPtr->argv, TCL_EVAL_GLOBAL);

    /*
     * We do not try to extract the result information if the caller has no
     * interest in it. I.e. there is no need to put effort into creating
     * something which is discarded immediately after.
     */
2050
2051
2052
2053
2054
2055
2056

2057
2058
2059
2060
2061
2062
2063
	    Tcl_AppendObjToErrorInfo(rtPtr->interp, Tcl_ObjPrintf(
		    "\n    (chan handler subcommand \"%s\")", method));
	    resObj = MarshallError(rtPtr->interp);
	}
	Tcl_IncrRefCount(resObj);
    }
    Tcl_RestoreInterpState(rtPtr->interp, sr);

    Tcl_Release(rtPtr);

    /*
     * 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







>







2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
	    Tcl_AppendObjToErrorInfo(rtPtr->interp, Tcl_ObjPrintf(
		    "\n    (chan handler subcommand \"%s\")", method));
	    resObj = MarshallError(rtPtr->interp);
	}
	Tcl_IncrRefCount(resObj);
    }
    Tcl_RestoreInterpState(rtPtr->interp, sr);
    Tcl_Release(rtPtr->interp);
    Tcl_Release(rtPtr);

    /*
     * 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
2226
2227
2228
2229
2230
2231
2232



2233
2234
2235
2236
2237
2238
2239

	/*
	 * The receiver for the event exited, before processing the event. We
	 * detach the result now, wake the originator up and signal failure.
	 */

	evPtr = resultPtr->evPtr;



	paramPtr = evPtr->param;

	evPtr->resultPtr = NULL;
	resultPtr->evPtr = NULL;
	resultPtr->result = TCL_ERROR;

	ForwardSetStaticError(paramPtr, msg_send_dstlost);







>
>
>







2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237

	/*
	 * The receiver for the event exited, before processing the event. We
	 * detach the result now, wake the originator up and signal failure.
	 */

	evPtr = resultPtr->evPtr;
	if (evPtr == NULL) {
	    continue;
	}
	paramPtr = evPtr->param;

	evPtr->resultPtr = NULL;
	resultPtr->evPtr = NULL;
	resultPtr->result = TCL_ERROR;

	ForwardSetStaticError(paramPtr, msg_send_dstlost);
2351
2352
2353
2354
2355
2356
2357



2358
2359
2360
2361
2362
2363
2364

	/*
	 * The receiver for the event exited, before processing the event. We
	 * detach the result now, wake the originator up and signal failure.
	 */

	evPtr = resultPtr->evPtr;



	paramPtr = evPtr->param;

	evPtr->resultPtr = NULL;
	resultPtr->evPtr = NULL;
	resultPtr->result = TCL_ERROR;

	ForwardSetStaticError(paramPtr, msg_send_dstlost);







>
>
>







2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365

	/*
	 * The receiver for the event exited, before processing the event. We
	 * detach the result now, wake the originator up and signal failure.
	 */

	evPtr = resultPtr->evPtr;
	if (evPtr == NULL) {
	    continue;
	}
	paramPtr = evPtr->param;

	evPtr->resultPtr = NULL;
	resultPtr->evPtr = NULL;
	resultPtr->result = TCL_ERROR;

	ForwardSetStaticError(paramPtr, msg_send_dstlost);
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
    return copied;
}

static int
TransformRead(
    ReflectedTransform *rtPtr,
    int *errorCodePtr,
    unsigned char *buf,
    int toRead)
{
    Tcl_Obj *bufObj;
    Tcl_Obj *resObj;
    int bytec;			/* Number of returned bytes */
    unsigned char *bytev;	/* Array of returned bytes */

    /*
     * Are we in the correct thread?
     */

#ifdef TCL_THREADS
    if (rtPtr->thread != Tcl_GetCurrentThread()) {
	ForwardParam p;

	p.transform.buf = (char *) buf;
	p.transform.size = toRead;

	ForwardOpToOwnerThread(rtPtr, ForwardedInput, &p);

	if (p.base.code != TCL_OK) {
	    PassReceivedError(rtPtr->chan, &p);
	    *errorCodePtr = EINVAL;
	    return 0;
	}

	*errorCodePtr = EOK;
	ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size);
	ckfree(p.transform.buf);
	return 1;
    }
#endif /* TCL_THREADS */

    /* ASSERT: rtPtr->method & FLAG(METH_READ) */
    /* ASSERT: rtPtr->mode & TCL_READABLE */

    bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toRead);
    Tcl_IncrRefCount(bufObj);

    if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) {
	Tcl_SetChannelError(rtPtr->chan, resObj);
	Tcl_DecrRefCount(bufObj);
	Tcl_DecrRefCount(resObj);	/* Remove reference held from invoke */
	*errorCodePtr = EINVAL;
	return 0;
    }

    bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
    ResultAdd(&rtPtr->result, bytev, bytec);

    Tcl_DecrRefCount(bufObj);
    Tcl_DecrRefCount(resObj);		/* Remove reference held from invoke */
    return 1;
}

static int
TransformWrite(
    ReflectedTransform *rtPtr,







|
<

<












|
|



















<
<
<


<








<







3062
3063
3064
3065
3066
3067
3068
3069

3070

3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103



3104
3105

3106
3107
3108
3109
3110
3111
3112
3113

3114
3115
3116
3117
3118
3119
3120
    return copied;
}

static int
TransformRead(
    ReflectedTransform *rtPtr,
    int *errorCodePtr,
    Tcl_Obj *bufObj)

{

    Tcl_Obj *resObj;
    int bytec;			/* Number of returned bytes */
    unsigned char *bytev;	/* Array of returned bytes */

    /*
     * Are we in the correct thread?
     */

#ifdef TCL_THREADS
    if (rtPtr->thread != Tcl_GetCurrentThread()) {
	ForwardParam p;

	p.transform.buf = (char *) Tcl_GetByteArrayFromObj(bufObj,
		&(p.transform.size));

	ForwardOpToOwnerThread(rtPtr, ForwardedInput, &p);

	if (p.base.code != TCL_OK) {
	    PassReceivedError(rtPtr->chan, &p);
	    *errorCodePtr = EINVAL;
	    return 0;
	}

	*errorCodePtr = EOK;
	ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size);
	ckfree(p.transform.buf);
	return 1;
    }
#endif /* TCL_THREADS */

    /* ASSERT: rtPtr->method & FLAG(METH_READ) */
    /* ASSERT: rtPtr->mode & TCL_READABLE */




    if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) {
	Tcl_SetChannelError(rtPtr->chan, resObj);

	Tcl_DecrRefCount(resObj);	/* Remove reference held from invoke */
	*errorCodePtr = EINVAL;
	return 0;
    }

    bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
    ResultAdd(&rtPtr->result, bytev, bytec);


    Tcl_DecrRefCount(resObj);		/* Remove reference held from invoke */
    return 1;
}

static int
TransformWrite(
    ReflectedTransform *rtPtr,
Changes to generic/tclIOUtil.c.
15
16
17
18
19
20
21
22
23
24
25






26
27
28
29
30
31
32
 * Copyright (c) 2001-2004 Vincent Darley.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#ifdef __WIN32__
#   include "tclWinInt.h"
#endif
#include "tclFileSystem.h"







/*
 * struct FilesystemRecord --
 *
 * A filesystem record is used to keep track of each filesystem currently
 * registered with the core, in a linked list.
 */







|



>
>
>
>
>
>







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
 * Copyright (c) 2001-2004 Vincent Darley.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#ifdef _WIN32
#   include "tclWinInt.h"
#endif
#include "tclFileSystem.h"

#ifdef TCL_TEMPLOAD_NO_UNLINK
#ifndef NO_FSTATFS
#include <sys/statfs.h>
#endif
#endif

/*
 * struct FilesystemRecord --
 *
 * A filesystem record is used to keep track of each filesystem currently
 * registered with the core, in a linked list.
 */
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
    filesystemList = NULL;

    /*
     * Now filesystemList is NULL. This means that any attempt to use the
     * filesystem is likely to fail.
     */

#ifdef __WIN32__
    TclWinEncodingsCleanup();
#endif
}

/*
 *----------------------------------------------------------------------
 *







|







794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
    filesystemList = NULL;

    /*
     * Now filesystemList is NULL. This means that any attempt to use the
     * filesystem is likely to fail.
     */

#ifdef _WIN32
    TclWinEncodingsCleanup();
#endif
}

/*
 *----------------------------------------------------------------------
 *
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829

void
TclResetFilesystem(void)
{
    filesystemList = &nativeFilesystemRecord;
    theFilesystemEpoch++;

#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.
     */

    TclWinResetInterfaces();
#endif







|







821
822
823
824
825
826
827
828
829
830
831
832
833
834
835

void
TclResetFilesystem(void)
{
    filesystemList = &nativeFilesystemRecord;
    theFilesystemEpoch++;

#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.
     */

    TclWinResetInterfaces();
#endif
3105
3106
3107
3108
3109
3110
3111












































































3112
3113
3114
3115
3116
3117
3118
 *
 * Side effects:
 *	New code suddenly appears in memory. This may later be unloaded by
 *	calling TclFS_UnloadFile.
 *
 *----------------------------------------------------------------------
 */













































































int
Tcl_LoadFile(
    Tcl_Interp *interp,		/* Used for error reporting. */
    Tcl_Obj *pathPtr,		/* Name of the file containing the desired
				 * code. */
    const char *const symbols[],/* Names of functions to look up in the file's







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
 *
 * Side effects:
 *	New code suddenly appears in memory. This may later be unloaded by
 *	calling TclFS_UnloadFile.
 *
 *----------------------------------------------------------------------
 */

/*
 * Workaround for issue with modern HPUX which do allow the unlink (no ETXTBSY
 * error) yet somehow trash some internal data structures which prevents the
 * second and further shared libraries from getting properly loaded. Only the
 * first is ok. We try to get around the issue by not unlinking,
 * i.e. emulating the behaviour of the older HPUX which denied removal.
 *
 * Doing the unlink is also an issue within docker containers, whose AUFS
 * bungles this as well, see
 *     https://github.com/dotcloud/docker/issues/1911
 *
 * For these situations the change below makes the execution of the unlink
 * semi-controllable at runtime.
 *
 *     An AUFS filesystem (if it can be detected) will force avoidance of
 *     unlink. The env variable TCL_TEMPLOAD_NO_UNLINK allows detection of a
 *     users general request (unlink and not.
 *
 * By default the unlink is done (if not in AUFS). However if the variable is
 * present and set to true (any integer > 0) then the unlink is skipped.
 */

int
TclSkipUnlink (Tcl_Obj* shlibFile)
{
    /* Order of testing:
     * 1. On hpux we generally want to skip unlink in general
     *
     * Outside of hpux then:
     * 2. For a general user request   (TCL_TEMPLOAD_NO_UNLINK present, non-empty, => int)
     * 3. For general AUFS environment (statfs, if available).
     *
     * Ad 2: This variable can disable/override the AUFS detection, i.e. for
     * testing if a newer AUFS does not have the bug any more.
     * 
     * Ad 3: This is conditionally compiled in. Condition currently must be set manually.
     *       This part needs proper tests in the configure(.in).
     */

#ifdef hpux
    return 1;
#else
    char* skipstr;

    skipstr = getenv ("TCL_TEMPLOAD_NO_UNLINK");
    if (skipstr && (skipstr[0] != '\0')) {
	return atoi(skipstr);
    }

#ifdef TCL_TEMPLOAD_NO_UNLINK
#ifndef NO_FSTATFS
    {
	struct statfs fs;
	/* Have fstatfs. May not have the AUFS super magic ... Indeed our build
	 * box is too old to have it directly in the headers. Define taken from
	 *     http://mooon.googlecode.com/svn/trunk/linux_include/linux/aufs_type.h
	 *     http://aufs.sourceforge.net/
	 * Better reference will be gladly taken.
	 */
#ifndef AUFS_SUPER_MAGIC
#define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's')
#endif /* AUFS_SUPER_MAGIC */
	if ((statfs(Tcl_GetString (shlibFile), &fs) == 0) &&
	    (fs.f_type == AUFS_SUPER_MAGIC)) {
	    return 1;
	}
    }
#endif /* ... NO_FSTATFS */
#endif /* ... TCL_TEMPLOAD_NO_UNLINK */

    /* Fallback: !hpux, no EV override, no AUFS (detection, nor detected):
     * Don't skip */
    return 0;
#endif /* hpux */
}

int
Tcl_LoadFile(
    Tcl_Interp *interp,		/* Used for error reporting. */
    Tcl_Obj *pathPtr,		/* Name of the file containing the desired
				 * code. */
    const char *const symbols[],/* Names of functions to look up in the file's
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
	 */

	Tcl_FSDeleteFile(copyToPtr);
	Tcl_DecrRefCount(copyToPtr);
	return TCL_ERROR;
    }

#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
     * attributes, and set any that are called "-permissions" to 0700. However
     * we just do this directly, like this:
     */








|







3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
	 */

	Tcl_FSDeleteFile(copyToPtr);
	Tcl_DecrRefCount(copyToPtr);
	return TCL_ERROR;
    }

#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
     * attributes, and set any that are called "-permissions" to 0700. However
     * we just do this directly, like this:
     */

3296
3297
3298
3299
3300
3301
3302


3303
3304
3305
3306
3307
3308
3309
3310
    }

    /*
     * Try to delete the file immediately - this is possible in some OSes, and
     * avoids any worries about leaving the copy laying around on exit.
     */



    if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) {
	Tcl_DecrRefCount(copyToPtr);

	/*
	 * We tell our caller about the real shared library which was loaded.
	 * Note that this does mean that the package list maintained by 'load'
	 * will store the original (vfs) path alongside the temporary load
	 * handle and unload proc ptr.







>
>
|







3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
    }

    /*
     * Try to delete the file immediately - this is possible in some OSes, and
     * avoids any worries about leaving the copy laying around on exit.
     */

    if (
	!TclSkipUnlink (copyToPtr) &&
	(Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) {
	Tcl_DecrRefCount(copyToPtr);

	/*
	 * We tell our caller about the real shared library which was loaded.
	 * Note that this does mean that the package list maintained by 'load'
	 * will store the original (vfs) path alongside the temporary load
	 * handle and unload proc ptr.
Changes to generic/tclInt.h.
2448
2449
2450
2451
2452
2453
2454
























2455
2456
2457
2458
2459
2460
2461
#else
#define TclGetIntFromObj(interp, objPtr, intPtr) \
    Tcl_GetIntFromObj((interp), (objPtr), (intPtr))
#define TclGetIntForIndexM(interp, objPtr, ignore, idxPtr)	\
    TclGetIntForIndex(interp, objPtr, ignore, idxPtr)
#endif

























/*
 * Flag values for TclTraceDictPath().
 *
 * DICT_PATH_READ indicates that all entries on the path must exist but no
 * updates will be needed.
 *
 * DICT_PATH_UPDATE indicates that we are going to be doing an update at the







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
#else
#define TclGetIntFromObj(interp, objPtr, intPtr) \
    Tcl_GetIntFromObj((interp), (objPtr), (intPtr))
#define TclGetIntForIndexM(interp, objPtr, ignore, idxPtr)	\
    TclGetIntForIndex(interp, objPtr, ignore, idxPtr)
#endif

/*
 * Macro used to save a function call for common uses of
 * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is:
 *
 * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
 *			Tcl_WideInt *wideIntPtr);
 */

#ifdef TCL_WIDE_INT_IS_LONG
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
    (((objPtr)->typePtr == &tclIntType)					\
	? (*(wideIntPtr) = (Tcl_WideInt)				\
		((objPtr)->internalRep.longValue), TCL_OK) :		\
	Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
#else /* !TCL_WIDE_INT_IS_LONG */
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr)		\
    (((objPtr)->typePtr == &tclWideIntType)				\
	? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) :	\
    ((objPtr)->typePtr == &tclIntType)					\
	? (*(wideIntPtr) = (Tcl_WideInt)				\
		((objPtr)->internalRep.longValue), TCL_OK) :		\
	Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
#endif /* TCL_WIDE_INT_IS_LONG */

/*
 * Flag values for TclTraceDictPath().
 *
 * DICT_PATH_READ indicates that all entries on the path must exist but no
 * updates will be needed.
 *
 * DICT_PATH_UPDATE indicates that we are going to be doing an update at the
2853
2854
2855
2856
2857
2858
2859




2860
2861
2862
2863
2864
2865
2866
			    int start, int *clNext);
MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr);
MODULE_SCOPE void	TclContinuationsCopy(Tcl_Obj *objPtr,
			    Tcl_Obj *originObjPtr);
MODULE_SCOPE int	TclConvertElement(const char *src, int length,
			    char *dst, int flags);
MODULE_SCOPE void	TclDeleteNamespaceVars(Namespace *nsPtr);




/* TIP #280 - Modified token based evulation, with line information. */
MODULE_SCOPE int	TclEvalEx(Tcl_Interp *interp, const char *script,
			    int numBytes, int flags, int line,
			    int *clNextOuter, const char *outerScript);
MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd;







>
>
>
>







2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
			    int start, int *clNext);
MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr);
MODULE_SCOPE void	TclContinuationsCopy(Tcl_Obj *objPtr,
			    Tcl_Obj *originObjPtr);
MODULE_SCOPE int	TclConvertElement(const char *src, int length,
			    char *dst, int flags);
MODULE_SCOPE void	TclDeleteNamespaceVars(Namespace *nsPtr);
MODULE_SCOPE int	TclFindDictElement(Tcl_Interp *interp,
			    const char *dict, int dictLength,
			    const char **elementPtr, const char **nextPtr,
			    int *sizePtr, int *literalPtr);
/* TIP #280 - Modified token based evulation, with line information. */
MODULE_SCOPE int	TclEvalEx(Tcl_Interp *interp, const char *script,
			    int numBytes, int flags, int line,
			    int *clNextOuter, const char *outerScript);
MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd;
2892
2893
2894
2895
2896
2897
2898

2899
2900
2901
2902
2903
2904
2905
MODULE_SCOPE void	TclFinalizeLock(void);
MODULE_SCOPE void	TclFinalizeMemorySubsystem(void);
MODULE_SCOPE void	TclFinalizeNotifier(void);
MODULE_SCOPE void	TclFinalizeObjects(void);
MODULE_SCOPE void	TclFinalizePreserve(void);
MODULE_SCOPE void	TclFinalizeSynchronization(void);
MODULE_SCOPE void	TclFinalizeThreadAlloc(void);

MODULE_SCOPE void	TclFinalizeThreadData(void);
MODULE_SCOPE void	TclFinalizeThreadObjects(void);
MODULE_SCOPE double	TclFloor(const mp_int *a);
MODULE_SCOPE void	TclFormatNaN(double value, char *buffer);
MODULE_SCOPE int	TclFSFileAttrIndex(Tcl_Obj *pathPtr,
			    const char *attributeName, int *indexPtr);
MODULE_SCOPE int	TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,







>







2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
MODULE_SCOPE void	TclFinalizeLock(void);
MODULE_SCOPE void	TclFinalizeMemorySubsystem(void);
MODULE_SCOPE void	TclFinalizeNotifier(void);
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);
MODULE_SCOPE void	TclFormatNaN(double value, char *buffer);
MODULE_SCOPE int	TclFSFileAttrIndex(Tcl_Obj *pathPtr,
			    const char *attributeName, int *indexPtr);
MODULE_SCOPE int	TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
2917
2918
2919
2920
2921
2922
2923


2924
2925
2926
2927
2928
2929
2930
			    int *typePtr);
MODULE_SCOPE int	TclGetOpenModeEx(Tcl_Interp *interp,
			    const char *modeString, int *seekFlagPtr,
			    int *binaryPtr);
MODULE_SCOPE Tcl_Obj *	TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr);
MODULE_SCOPE Tcl_Obj *	TclGetSourceFromFrame(CmdFrame *cfPtr, int objc,
			    Tcl_Obj *const objv[]);


MODULE_SCOPE int	TclGlob(Tcl_Interp *interp, char *pattern,
			    Tcl_Obj *unquotedPrefix, int globFlags,
			    Tcl_GlobTypeData *types);
MODULE_SCOPE int	TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr,
			    Tcl_Obj *incrPtr);
MODULE_SCOPE Tcl_Obj *	TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
			    Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags);







>
>







2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
			    int *typePtr);
MODULE_SCOPE int	TclGetOpenModeEx(Tcl_Interp *interp,
			    const char *modeString, int *seekFlagPtr,
			    int *binaryPtr);
MODULE_SCOPE Tcl_Obj *	TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr);
MODULE_SCOPE Tcl_Obj *	TclGetSourceFromFrame(CmdFrame *cfPtr, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE char *	TclGetStringStorage(Tcl_Obj *objPtr,
			    unsigned int *sizePtr);
MODULE_SCOPE int	TclGlob(Tcl_Interp *interp, char *pattern,
			    Tcl_Obj *unquotedPrefix, int globFlags,
			    Tcl_GlobTypeData *types);
MODULE_SCOPE int	TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr,
			    Tcl_Obj *incrPtr);
MODULE_SCOPE Tcl_Obj *	TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
			    Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags);
Changes to generic/tclIntPlatDecls.h.
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * All rights reserved.
 */

#ifndef _TCLINTPLATDECLS
#define _TCLINTPLATDECLS

#ifdef __WIN32__
#   define Tcl_DirEntry void
#   define DIR void
#endif

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
#   define TCL_STORAGE_CLASS DLLEXPORT







|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * All rights reserved.
 */

#ifndef _TCLINTPLATDECLS
#define _TCLINTPLATDECLS

#ifdef _WIN32
#   define Tcl_DirEntry void
#   define DIR void
#endif

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
#   define TCL_STORAGE_CLASS DLLEXPORT
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
extern "C" {
#endif

/*
 * Exported function declarations:
 */

#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
/* 0 */
EXTERN void		TclGetAndDetachPids(Tcl_Interp *interp,
				Tcl_Channel chan);
/* 1 */
EXTERN int		TclpCloseFile(TclFile file);
/* 2 */
EXTERN Tcl_Channel	TclpCreateCommandChannel(TclFile readFile,







|







41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
extern "C" {
#endif

/*
 * Exported function declarations:
 */

#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
/* 0 */
EXTERN void		TclGetAndDetachPids(Tcl_Interp *interp,
				Tcl_Channel chan);
/* 1 */
EXTERN int		TclpCloseFile(TclFile file);
/* 2 */
EXTERN Tcl_Channel	TclpCreateCommandChannel(TclFile readFile,
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
/* 29 */
EXTERN int		TclWinCPUID(unsigned int index, unsigned int *regs);
/* 30 */
EXTERN int		TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
				Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
				Tcl_Obj *resultingNameObj);
#endif /* UNIX */
#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
/* 0 */
EXTERN void		TclWinConvertError(DWORD errCode);
/* 1 */
EXTERN void		TclWinConvertWSAError(DWORD errCode);
/* 2 */
EXTERN struct servent *	 TclWinGetServByName(const char *nm,
				const char *proto);







|







100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
/* 29 */
EXTERN int		TclWinCPUID(unsigned int index, unsigned int *regs);
/* 30 */
EXTERN int		TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
				Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
				Tcl_Obj *resultingNameObj);
#endif /* UNIX */
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
/* 0 */
EXTERN void		TclWinConvertError(DWORD errCode);
/* 1 */
EXTERN void		TclWinConvertWSAError(DWORD errCode);
/* 2 */
EXTERN struct servent *	 TclWinGetServByName(const char *nm,
				const char *proto);
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
				Tcl_Obj *resultingNameObj);
#endif /* MACOSX */

typedef struct TclIntPlatStubs {
    int magic;
    void *hooks;

#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
    void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
    int (*tclpCloseFile) (TclFile file); /* 1 */
    Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
    int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
    int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
    void (*reserved5)(void);
    TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */







|







254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
				Tcl_Obj *resultingNameObj);
#endif /* MACOSX */

typedef struct TclIntPlatStubs {
    int magic;
    void *hooks;

#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
    void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
    int (*tclpCloseFile) (TclFile file); /* 1 */
    Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
    int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
    int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
    void (*reserved5)(void);
    TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
    void (*reserved25)(void);
    void (*reserved26)(void);
    void (*reserved27)(void);
    void (*reserved28)(void);
    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 */
    void (*tclWinConvertError) (DWORD errCode); /* 0 */
    void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */
    struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */
    int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char *optval, int *optlen); /* 3 */
    HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */
    int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */
    unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */







|







287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
    void (*reserved25)(void);
    void (*reserved26)(void);
    void (*reserved27)(void);
    void (*reserved28)(void);
    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 */
    void (*tclWinConvertError) (DWORD errCode); /* 0 */
    void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */
    struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */
    int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char *optval, int *optlen); /* 3 */
    HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */
    int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */
    unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381

#if defined(USE_TCL_STUBS)

/*
 * Inline function declarations:
 */

#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
#define TclGetAndDetachPids \
	(tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
#define TclpCloseFile \
	(tclIntPlatStubsPtr->tclpCloseFile) /* 1 */
#define TclpCreateCommandChannel \
	(tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */
#define TclpCreatePipe \







|







367
368
369
370
371
372
373
374
375
376
377
378
379
380
381

#if defined(USE_TCL_STUBS)

/*
 * Inline function declarations:
 */

#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
#define TclGetAndDetachPids \
	(tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
#define TclpCloseFile \
	(tclIntPlatStubsPtr->tclpCloseFile) /* 1 */
#define TclpCreateCommandChannel \
	(tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */
#define TclpCreatePipe \
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
/* Slot 27 is reserved */
/* Slot 28 is reserved */
#define TclWinCPUID \
	(tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
#define TclUnixOpenTemporaryFile \
	(tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */
#endif /* UNIX */
#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
#define TclWinConvertError \
	(tclIntPlatStubsPtr->tclWinConvertError) /* 0 */
#define TclWinConvertWSAError \
	(tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */
#define TclWinGetServByName \
	(tclIntPlatStubsPtr->tclWinGetServByName) /* 2 */
#define TclWinGetSockOpt \







|







416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
/* Slot 27 is reserved */
/* Slot 28 is reserved */
#define TclWinCPUID \
	(tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
#define TclUnixOpenTemporaryFile \
	(tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */
#endif /* UNIX */
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
#define TclWinConvertError \
	(tclIntPlatStubsPtr->tclWinConvertError) /* 0 */
#define TclWinConvertWSAError \
	(tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */
#define TclWinGetServByName \
	(tclIntPlatStubsPtr->tclWinGetServByName) /* 2 */
#define TclWinGetSockOpt \
546
547
548
549
550
551
552
553
554



555



556
557
558
559
560
561
#undef TclpLocaltime_unix
#undef TclpGmtime_unix
#undef TclWinConvertWSAError
#define TclWinConvertWSAError TclWinConvertError
#undef TclpInetNtoa
#define TclpInetNtoa inet_ntoa

#if defined(__WIN32__) || defined(__CYGWIN__)
#   undef TclWinNToHS



#   define TclWinNToHS ntohs



#else
#   undef TclpGetPid
#   define TclpGetPid(pid) ((unsigned long) (pid))
#endif

#endif /* _TCLINTPLATDECLS */







|

>
>
>

>
>
>






546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
#undef TclpLocaltime_unix
#undef TclpGmtime_unix
#undef TclWinConvertWSAError
#define TclWinConvertWSAError TclWinConvertError
#undef TclpInetNtoa
#define TclpInetNtoa inet_ntoa

#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))
#endif

#endif /* _TCLINTPLATDECLS */
Changes to generic/tclLoad.c.
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
    code = TCL_OK;
    if (pkgPtr->safeInterpRefCount <= 0 && pkgPtr->interpRefCount <= 0
	    && !keepLibrary) {
	/*
	 * Unload the shared library from the application memory...
	 */

#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
	 * a core on exit because it wants to call a function in the dll after
	 * it's been unloaded.
	 */








|







826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
    code = TCL_OK;
    if (pkgPtr->safeInterpRefCount <= 0 && pkgPtr->interpRefCount <= 0
	    && !keepLibrary) {
	/*
	 * Unload the shared library from the application memory...
	 */

#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
	 * a core on exit because it wants to call a function in the dll after
	 * it's been unloaded.
	 */

1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
     * subsystem left alive at this point is the memory allocator.
     */

    while (firstPackagePtr != NULL) {
	pkgPtr = firstPackagePtr;
	firstPackagePtr = pkgPtr->nextPtr;

#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
	 * a core on exit because it wants to call a function in the dll after
	 * it has been unloaded.
	 */








|







1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
     * subsystem left alive at this point is the memory allocator.
     */

    while (firstPackagePtr != NULL) {
	pkgPtr = firstPackagePtr;
	firstPackagePtr = pkgPtr->nextPtr;

#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
	 * a core on exit because it wants to call a function in the dll after
	 * it has been unloaded.
	 */

Changes to generic/tclMain.c.
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
/*
 * This file can be compiled on Windows in UNICODE mode, as well as on all
 * other platforms using the native encoding. This is done by using the normal
 * Windows functions like _tcscmp, but on platforms which don't have <tchar.h>
 * we have to translate that to strcmp here.
 */

#ifndef __WIN32__
#   define TCHAR char
#   define TEXT(arg) arg
#   define _tcscmp strcmp
#endif

/*
 * Further on, in UNICODE mode we just use Tcl_NewUnicodeObj, otherwise







|







43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
/*
 * This file can be compiled on Windows in UNICODE mode, as well as on all
 * other platforms using the native encoding. This is done by using the normal
 * Windows functions like _tcscmp, but on platforms which don't have <tchar.h>
 * we have to translate that to strcmp here.
 */

#ifndef _WIN32
#   define TCHAR char
#   define TEXT(arg) arg
#   define _tcscmp strcmp
#endif

/*
 * Further on, in UNICODE mode we just use Tcl_NewUnicodeObj, otherwise
Changes to generic/tclOO.decls.
14
15
16
17
18
19
20

21
22
23
24
25
26
27

######################################################################
# Public API, exposed for general users of TclOO.
#

interface tclOO
hooks tclOOInt


declare 0 {
    Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp,
	    Tcl_Object sourceObject, const char *targetName,
	    const char *targetNamespaceName)
}
declare 1 {







>







14
15
16
17
18
19
20
21
22
23
24
25
26
27
28

######################################################################
# Public API, exposed for general users of TclOO.
#

interface tclOO
hooks tclOOInt
scspec TCLAPI

declare 0 {
    Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp,
	    Tcl_Object sourceObject, const char *targetName,
	    const char *targetNamespaceName)
}
declare 1 {
Changes to generic/tclOODecls.h.
1
2
3
4
5
6
7
8
9
10
11




12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
/*
 * This file is (mostly) automatically generated from tclOO.decls.
 */

#ifndef _TCLOODECLS
#define _TCLOODECLS

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
#   define TCL_STORAGE_CLASS DLLEXPORT
#else




#   ifdef USE_TCL_STUBS
#      undef USE_TCLOO_STUBS
#      define USE_TCLOO_STUBS
#      define TCL_STORAGE_CLASS
#   else
#      define TCL_STORAGE_CLASS DLLIMPORT
#   endif
#endif

/* !BEGIN!: Do not edit below this line. */

#ifdef __cplusplus
extern "C" {
#endif

/*
 * Exported function declarations:
 */

/* 0 */
EXTERN Tcl_Object	Tcl_CopyObjectInstance(Tcl_Interp *interp,
				Tcl_Object sourceObject,
				const char *targetName,
				const char *targetNamespaceName);
/* 1 */
EXTERN Tcl_Object	Tcl_GetClassAsObject(Tcl_Class clazz);
/* 2 */
EXTERN Tcl_Class	Tcl_GetObjectAsClass(Tcl_Object object);
/* 3 */
EXTERN Tcl_Command	Tcl_GetObjectCommand(Tcl_Object object);
/* 4 */
EXTERN Tcl_Object	Tcl_GetObjectFromObj(Tcl_Interp *interp,
				Tcl_Obj *objPtr);
/* 5 */
EXTERN Tcl_Namespace *	Tcl_GetObjectNamespace(Tcl_Object object);
/* 6 */
EXTERN Tcl_Class	Tcl_MethodDeclarerClass(Tcl_Method method);
/* 7 */
EXTERN Tcl_Object	Tcl_MethodDeclarerObject(Tcl_Method method);
/* 8 */
EXTERN int		Tcl_MethodIsPublic(Tcl_Method method);
/* 9 */
EXTERN int		Tcl_MethodIsType(Tcl_Method method,
				const Tcl_MethodType *typePtr,
				ClientData *clientDataPtr);
/* 10 */
EXTERN Tcl_Obj *	Tcl_MethodName(Tcl_Method method);
/* 11 */
EXTERN Tcl_Method	Tcl_NewInstanceMethod(Tcl_Interp *interp,
				Tcl_Object object, Tcl_Obj *nameObj,
				int isPublic, const Tcl_MethodType *typePtr,
				ClientData clientData);
/* 12 */
EXTERN Tcl_Method	Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
				Tcl_Obj *nameObj, int isPublic,
				const Tcl_MethodType *typePtr,
				ClientData clientData);
/* 13 */
EXTERN Tcl_Object	Tcl_NewObjectInstance(Tcl_Interp *interp,
				Tcl_Class cls, const char *nameStr,
				const char *nsNameStr, int objc,
				Tcl_Obj *const *objv, int skip);
/* 14 */
EXTERN int		Tcl_ObjectDeleted(Tcl_Object object);
/* 15 */
EXTERN int		Tcl_ObjectContextIsFiltering(
				Tcl_ObjectContext context);
/* 16 */
EXTERN Tcl_Method	Tcl_ObjectContextMethod(Tcl_ObjectContext context);
/* 17 */
EXTERN Tcl_Object	Tcl_ObjectContextObject(Tcl_ObjectContext context);
/* 18 */
EXTERN int		Tcl_ObjectContextSkippedArgs(
				Tcl_ObjectContext context);
/* 19 */
EXTERN ClientData	Tcl_ClassGetMetadata(Tcl_Class clazz,
				const Tcl_ObjectMetadataType *typePtr);
/* 20 */
EXTERN void		Tcl_ClassSetMetadata(Tcl_Class clazz,
				const Tcl_ObjectMetadataType *typePtr,
				ClientData metadata);
/* 21 */
EXTERN ClientData	Tcl_ObjectGetMetadata(Tcl_Object object,
				const Tcl_ObjectMetadataType *typePtr);
/* 22 */
EXTERN void		Tcl_ObjectSetMetadata(Tcl_Object object,
				const Tcl_ObjectMetadataType *typePtr,
				ClientData metadata);
/* 23 */
EXTERN int		Tcl_ObjectContextInvokeNext(Tcl_Interp *interp,
				Tcl_ObjectContext context, int objc,
				Tcl_Obj *const *objv, int skip);
/* 24 */
EXTERN Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper(
				Tcl_Object object);
/* 25 */
EXTERN void		Tcl_ObjectSetMethodNameMapper(Tcl_Object object,
				Tcl_ObjectMapMethodNameProc *mapMethodNameProc);
/* 26 */
EXTERN void		Tcl_ClassSetConstructor(Tcl_Interp *interp,
				Tcl_Class clazz, Tcl_Method method);
/* 27 */
EXTERN void		Tcl_ClassSetDestructor(Tcl_Interp *interp,
				Tcl_Class clazz, Tcl_Method method);
/* 28 */
EXTERN Tcl_Obj *	Tcl_GetObjectName(Tcl_Interp *interp,
				Tcl_Object object);

typedef struct {
    const struct TclOOIntStubs *tclOOIntStubs;
} TclOOStubHooks;

typedef struct TclOOStubs {







|
|
|
|
>
>
>
>
|
|
|
<
<
<
<













|




|

|

|

|


|

|

|

|

|



|

|




|




|




|

|


|

|

|


|


|



|


|



|



|


|


|


|


|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18




19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
/*
 * This file is (mostly) automatically generated from tclOO.decls.
 */

#ifndef _TCLOODECLS
#define _TCLOODECLS

#ifndef TCLAPI
#   ifdef BUILD_tcl
#	define TCLAPI extern DLLEXPORT
#   else
#	define TCLAPI extern DLLIMPORT
#   endif
#endif

#ifdef USE_TCL_STUBS
#   undef USE_TCLOO_STUBS
#   define USE_TCLOO_STUBS




#endif

/* !BEGIN!: Do not edit below this line. */

#ifdef __cplusplus
extern "C" {
#endif

/*
 * Exported function declarations:
 */

/* 0 */
TCLAPI Tcl_Object	Tcl_CopyObjectInstance(Tcl_Interp *interp,
				Tcl_Object sourceObject,
				const char *targetName,
				const char *targetNamespaceName);
/* 1 */
TCLAPI Tcl_Object	Tcl_GetClassAsObject(Tcl_Class clazz);
/* 2 */
TCLAPI Tcl_Class	Tcl_GetObjectAsClass(Tcl_Object object);
/* 3 */
TCLAPI Tcl_Command	Tcl_GetObjectCommand(Tcl_Object object);
/* 4 */
TCLAPI Tcl_Object	Tcl_GetObjectFromObj(Tcl_Interp *interp,
				Tcl_Obj *objPtr);
/* 5 */
TCLAPI Tcl_Namespace *	Tcl_GetObjectNamespace(Tcl_Object object);
/* 6 */
TCLAPI Tcl_Class	Tcl_MethodDeclarerClass(Tcl_Method method);
/* 7 */
TCLAPI Tcl_Object	Tcl_MethodDeclarerObject(Tcl_Method method);
/* 8 */
TCLAPI int		Tcl_MethodIsPublic(Tcl_Method method);
/* 9 */
TCLAPI int		Tcl_MethodIsType(Tcl_Method method,
				const Tcl_MethodType *typePtr,
				ClientData *clientDataPtr);
/* 10 */
TCLAPI Tcl_Obj *	Tcl_MethodName(Tcl_Method method);
/* 11 */
TCLAPI Tcl_Method	Tcl_NewInstanceMethod(Tcl_Interp *interp,
				Tcl_Object object, Tcl_Obj *nameObj,
				int isPublic, const Tcl_MethodType *typePtr,
				ClientData clientData);
/* 12 */
TCLAPI Tcl_Method	Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
				Tcl_Obj *nameObj, int isPublic,
				const Tcl_MethodType *typePtr,
				ClientData clientData);
/* 13 */
TCLAPI Tcl_Object	Tcl_NewObjectInstance(Tcl_Interp *interp,
				Tcl_Class cls, const char *nameStr,
				const char *nsNameStr, int objc,
				Tcl_Obj *const *objv, int skip);
/* 14 */
TCLAPI int		Tcl_ObjectDeleted(Tcl_Object object);
/* 15 */
TCLAPI int		Tcl_ObjectContextIsFiltering(
				Tcl_ObjectContext context);
/* 16 */
TCLAPI Tcl_Method	Tcl_ObjectContextMethod(Tcl_ObjectContext context);
/* 17 */
TCLAPI Tcl_Object	Tcl_ObjectContextObject(Tcl_ObjectContext context);
/* 18 */
TCLAPI int		Tcl_ObjectContextSkippedArgs(
				Tcl_ObjectContext context);
/* 19 */
TCLAPI ClientData	Tcl_ClassGetMetadata(Tcl_Class clazz,
				const Tcl_ObjectMetadataType *typePtr);
/* 20 */
TCLAPI void		Tcl_ClassSetMetadata(Tcl_Class clazz,
				const Tcl_ObjectMetadataType *typePtr,
				ClientData metadata);
/* 21 */
TCLAPI ClientData	Tcl_ObjectGetMetadata(Tcl_Object object,
				const Tcl_ObjectMetadataType *typePtr);
/* 22 */
TCLAPI void		Tcl_ObjectSetMetadata(Tcl_Object object,
				const Tcl_ObjectMetadataType *typePtr,
				ClientData metadata);
/* 23 */
TCLAPI int		Tcl_ObjectContextInvokeNext(Tcl_Interp *interp,
				Tcl_ObjectContext context, int objc,
				Tcl_Obj *const *objv, int skip);
/* 24 */
TCLAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper(
				Tcl_Object object);
/* 25 */
TCLAPI void		Tcl_ObjectSetMethodNameMapper(Tcl_Object object,
				Tcl_ObjectMapMethodNameProc *mapMethodNameProc);
/* 26 */
TCLAPI void		Tcl_ClassSetConstructor(Tcl_Interp *interp,
				Tcl_Class clazz, Tcl_Method method);
/* 27 */
TCLAPI void		Tcl_ClassSetDestructor(Tcl_Interp *interp,
				Tcl_Class clazz, Tcl_Method method);
/* 28 */
TCLAPI Tcl_Obj *	Tcl_GetObjectName(Tcl_Interp *interp,
				Tcl_Object object);

typedef struct {
    const struct TclOOIntStubs *tclOOIntStubs;
} TclOOStubHooks;

typedef struct TclOOStubs {
227
228
229
230
231
232
233
234
235
236
#define Tcl_GetObjectName \
	(tclOOStubsPtr->tcl_GetObjectName) /* 28 */

#endif /* defined(USE_TCLOO_STUBS) */

/* !END!: Do not edit above this line. */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
#endif /* _TCLOODECLS */







<
<

227
228
229
230
231
232
233


234
#define Tcl_GetObjectName \
	(tclOOStubsPtr->tcl_GetObjectName) /* 28 */

#endif /* defined(USE_TCLOO_STUBS) */

/* !END!: Do not edit above this line. */



#endif /* _TCLOODECLS */
Changes to generic/tclOOIntDecls.h.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
/*
 * This file is (mostly) automatically generated from tclOO.decls.
 */

#ifndef _TCLOOINTDECLS
#define _TCLOOINTDECLS

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
#   define TCL_STORAGE_CLASS DLLEXPORT
#else
#   ifdef USE_TCL_STUBS
#      define TCL_STORAGE_CLASS
#   else
#      define TCL_STORAGE_CLASS DLLIMPORT
#   endif
#endif

/* !BEGIN!: Do not edit below this line. */

#ifdef __cplusplus
extern "C" {
#endif

/*
 * Exported function declarations:
 */

/* 0 */
EXTERN Tcl_Object	TclOOGetDefineCmdContext(Tcl_Interp *interp);
/* 1 */
EXTERN Tcl_Method	TclOOMakeProcInstanceMethod(Tcl_Interp *interp,
				Object *oPtr, int flags, Tcl_Obj *nameObj,
				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
				const Tcl_MethodType *typePtr,
				ClientData clientData, Proc **procPtrPtr);
/* 2 */
EXTERN Tcl_Method	TclOOMakeProcMethod(Tcl_Interp *interp,
				Class *clsPtr, int flags, Tcl_Obj *nameObj,
				const char *namePtr, Tcl_Obj *argsObj,
				Tcl_Obj *bodyObj,
				const Tcl_MethodType *typePtr,
				ClientData clientData, Proc **procPtrPtr);
/* 3 */
EXTERN Method *		TclOONewProcInstanceMethod(Tcl_Interp *interp,
				Object *oPtr, int flags, Tcl_Obj *nameObj,
				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
				ProcedureMethod **pmPtrPtr);
/* 4 */
EXTERN Method *		TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr,
				int flags, Tcl_Obj *nameObj,
				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
				ProcedureMethod **pmPtrPtr);
/* 5 */
EXTERN int		TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp,
				int objc, Tcl_Obj *const *objv,
				int publicOnly, Class *startCls);
/* 6 */
EXTERN int		TclOOIsReachable(Class *targetPtr, Class *startPtr);
/* 7 */
EXTERN Method *		TclOONewForwardMethod(Tcl_Interp *interp,
				Class *clsPtr, int isPublic,
				Tcl_Obj *nameObj, Tcl_Obj *prefixObj);
/* 8 */
EXTERN Method *		TclOONewForwardInstanceMethod(Tcl_Interp *interp,
				Object *oPtr, int isPublic, Tcl_Obj *nameObj,
				Tcl_Obj *prefixObj);
/* 9 */
EXTERN Tcl_Method	TclOONewProcInstanceMethodEx(Tcl_Interp *interp,
				Tcl_Object oPtr,
				TclOO_PreCallProc *preCallPtr,
				TclOO_PostCallProc *postCallPtr,
				ProcErrorProc *errProc,
				ClientData clientData, Tcl_Obj *nameObj,
				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
				int flags, void **internalTokenPtr);
/* 10 */
EXTERN Tcl_Method	TclOONewProcMethodEx(Tcl_Interp *interp,
				Tcl_Class clsPtr,
				TclOO_PreCallProc *preCallPtr,
				TclOO_PostCallProc *postCallPtr,
				ProcErrorProc *errProc,
				ClientData clientData, Tcl_Obj *nameObj,
				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
				int flags, void **internalTokenPtr);
/* 11 */
EXTERN int		TclOOInvokeObject(Tcl_Interp *interp,
				Tcl_Object object, Tcl_Class startCls,
				int publicPrivate, int objc,
				Tcl_Obj *const *objv);
/* 12 */
EXTERN void		TclOOObjectSetFilters(Object *oPtr, int numFilters,
				Tcl_Obj *const *filters);
/* 13 */
EXTERN void		TclOOClassSetFilters(Tcl_Interp *interp,
				Class *classPtr, int numFilters,
				Tcl_Obj *const *filters);
/* 14 */
EXTERN void		TclOOObjectSetMixins(Object *oPtr, int numMixins,
				Class *const *mixins);
/* 15 */
EXTERN void		TclOOClassSetMixins(Tcl_Interp *interp,
				Class *classPtr, int numMixins,
				Class *const *mixins);

typedef struct TclOOIntStubs {
    int magic;
    void *hooks;








<
<
<
<
<
<
<
<
<
<
<











|

|





|






|




|




|



|

|



|



|








|








|




|


|



|


|







1
2
3
4
5
6
7











8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
/*
 * This file is (mostly) automatically generated from tclOO.decls.
 */

#ifndef _TCLOOINTDECLS
#define _TCLOOINTDECLS












/* !BEGIN!: Do not edit below this line. */

#ifdef __cplusplus
extern "C" {
#endif

/*
 * Exported function declarations:
 */

/* 0 */
TCLAPI Tcl_Object	TclOOGetDefineCmdContext(Tcl_Interp *interp);
/* 1 */
TCLAPI Tcl_Method	TclOOMakeProcInstanceMethod(Tcl_Interp *interp,
				Object *oPtr, int flags, Tcl_Obj *nameObj,
				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
				const Tcl_MethodType *typePtr,
				ClientData clientData, Proc **procPtrPtr);
/* 2 */
TCLAPI Tcl_Method	TclOOMakeProcMethod(Tcl_Interp *interp,
				Class *clsPtr, int flags, Tcl_Obj *nameObj,
				const char *namePtr, Tcl_Obj *argsObj,
				Tcl_Obj *bodyObj,
				const Tcl_MethodType *typePtr,
				ClientData clientData, Proc **procPtrPtr);
/* 3 */
TCLAPI Method *		TclOONewProcInstanceMethod(Tcl_Interp *interp,
				Object *oPtr, int flags, Tcl_Obj *nameObj,
				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
				ProcedureMethod **pmPtrPtr);
/* 4 */
TCLAPI Method *		TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr,
				int flags, Tcl_Obj *nameObj,
				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
				ProcedureMethod **pmPtrPtr);
/* 5 */
TCLAPI int		TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp,
				int objc, Tcl_Obj *const *objv,
				int publicOnly, Class *startCls);
/* 6 */
TCLAPI int		TclOOIsReachable(Class *targetPtr, Class *startPtr);
/* 7 */
TCLAPI Method *		TclOONewForwardMethod(Tcl_Interp *interp,
				Class *clsPtr, int isPublic,
				Tcl_Obj *nameObj, Tcl_Obj *prefixObj);
/* 8 */
TCLAPI Method *		TclOONewForwardInstanceMethod(Tcl_Interp *interp,
				Object *oPtr, int isPublic, Tcl_Obj *nameObj,
				Tcl_Obj *prefixObj);
/* 9 */
TCLAPI Tcl_Method	TclOONewProcInstanceMethodEx(Tcl_Interp *interp,
				Tcl_Object oPtr,
				TclOO_PreCallProc *preCallPtr,
				TclOO_PostCallProc *postCallPtr,
				ProcErrorProc *errProc,
				ClientData clientData, Tcl_Obj *nameObj,
				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
				int flags, void **internalTokenPtr);
/* 10 */
TCLAPI Tcl_Method	TclOONewProcMethodEx(Tcl_Interp *interp,
				Tcl_Class clsPtr,
				TclOO_PreCallProc *preCallPtr,
				TclOO_PostCallProc *postCallPtr,
				ProcErrorProc *errProc,
				ClientData clientData, Tcl_Obj *nameObj,
				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
				int flags, void **internalTokenPtr);
/* 11 */
TCLAPI int		TclOOInvokeObject(Tcl_Interp *interp,
				Tcl_Object object, Tcl_Class startCls,
				int publicPrivate, int objc,
				Tcl_Obj *const *objv);
/* 12 */
TCLAPI void		TclOOObjectSetFilters(Object *oPtr, int numFilters,
				Tcl_Obj *const *filters);
/* 13 */
TCLAPI void		TclOOClassSetFilters(Tcl_Interp *interp,
				Class *classPtr, int numFilters,
				Tcl_Obj *const *filters);
/* 14 */
TCLAPI void		TclOOObjectSetMixins(Object *oPtr, int numMixins,
				Class *const *mixins);
/* 15 */
TCLAPI void		TclOOClassSetMixins(Tcl_Interp *interp,
				Class *classPtr, int numMixins,
				Class *const *mixins);

typedef struct TclOOIntStubs {
    int magic;
    void *hooks;

170
171
172
173
174
175
176
177
178
179
#define TclOOClassSetMixins \
	(tclOOIntStubsPtr->tclOOClassSetMixins) /* 15 */

#endif /* defined(USE_TCLOO_STUBS) */

/* !END!: Do not edit above this line. */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
#endif /* _TCLOOINTDECLS */







<
<

159
160
161
162
163
164
165


166
#define TclOOClassSetMixins \
	(tclOOIntStubsPtr->tclOOClassSetMixins) /* 15 */

#endif /* defined(USE_TCLOO_STUBS) */

/* !END!: Do not edit above this line. */



#endif /* _TCLOOINTDECLS */
Changes to generic/tclPathObj.c.
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
    if (fsPathPtr->cwdPtr == NULL) {
	return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr,
		NULL);
    }

    if (PATHFLAGS(pathPtr) == 0) {
	/* The path is not absolute... */
#ifdef __WIN32__
	/* ... on Windows we must make another call to determine whether
	 * it's relative or volumerelative [Bug 2571597]. */
	return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr,
		NULL);
#else
	/* On other systems, quickly deduce !absolute -> relative */
	return TCL_PATH_RELATIVE;







|







508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
    if (fsPathPtr->cwdPtr == NULL) {
	return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr,
		NULL);
    }

    if (PATHFLAGS(pathPtr) == 0) {
	/* The path is not absolute... */
#ifdef _WIN32
	/* ... on Windows we must make another call to determine whether
	 * it's relative or volumerelative [Bug 2571597]. */
	return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr,
		NULL);
#else
	/* On other systems, quickly deduce !absolute -> relative */
	return TCL_PATH_RELATIVE;
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
		Tcl_DecrRefCount(absolutePath);
		absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath);
		Tcl_IncrRefCount(absolutePath);

		/*
		 * We have a refCount on the cwd.
		 */
#ifdef __WIN32__
	    } else if (type == TCL_PATH_VOLUME_RELATIVE) {
		/*
		 * Only Windows has volume-relative paths.
		 */

		Tcl_DecrRefCount(absolutePath);
		absolutePath = TclWinVolumeRelativeNormalize(interp,
			path, &useThisCwd);
		if (absolutePath == NULL) {
		    return NULL;
		}
		pureNormalized = 0;
#endif /* __WIN32__ */
	    }
	}

	/*
	 * Already has refCount incremented.
	 */








|












|







1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
		Tcl_DecrRefCount(absolutePath);
		absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath);
		Tcl_IncrRefCount(absolutePath);

		/*
		 * We have a refCount on the cwd.
		 */
#ifdef _WIN32
	    } else if (type == TCL_PATH_VOLUME_RELATIVE) {
		/*
		 * Only Windows has volume-relative paths.
		 */

		Tcl_DecrRefCount(absolutePath);
		absolutePath = TclWinVolumeRelativeNormalize(interp,
			path, &useThisCwd);
		if (absolutePath == NULL) {
		    return NULL;
		}
		pureNormalized = 0;
#endif /* _WIN32 */
	    }
	}

	/*
	 * Already has refCount incremented.
	 */

Changes to generic/tclPlatDecls.h.
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
extern "C" {
#endif

/*
 * Exported function declarations:
 */

#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
/* 0 */
EXTERN TCHAR *		Tcl_WinUtfToTChar(const char *str, int len,
				Tcl_DString *dsPtr);
/* 1 */
EXTERN char *		Tcl_WinTCharToUtf(const TCHAR *str, int len,
				Tcl_DString *dsPtr);
#endif /* WIN */







|







46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
extern "C" {
#endif

/*
 * Exported function declarations:
 */

#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
/* 0 */
EXTERN TCHAR *		Tcl_WinUtfToTChar(const char *str, int len,
				Tcl_DString *dsPtr);
/* 1 */
EXTERN char *		Tcl_WinTCharToUtf(const TCHAR *str, int len,
				Tcl_DString *dsPtr);
#endif /* WIN */
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
				char *libraryPath);
#endif /* MACOSX */

typedef struct TclPlatStubs {
    int magic;
    void *hooks;

#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
    TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */
    char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
    int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */
    int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath); /* 1 */
#endif /* MACOSX */







|







71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
				char *libraryPath);
#endif /* MACOSX */

typedef struct TclPlatStubs {
    int magic;
    void *hooks;

#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
    TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */
    char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
    int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */
    int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath); /* 1 */
#endif /* MACOSX */
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107

#if defined(USE_TCL_STUBS)

/*
 * Inline function declarations:
 */

#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
#define Tcl_WinUtfToTChar \
	(tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */
#define Tcl_WinTCharToUtf \
	(tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
#define Tcl_MacOSXOpenBundleResources \







|







93
94
95
96
97
98
99
100
101
102
103
104
105
106
107

#if defined(USE_TCL_STUBS)

/*
 * Inline function declarations:
 */

#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
#define Tcl_WinUtfToTChar \
	(tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */
#define Tcl_WinTCharToUtf \
	(tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
#define Tcl_MacOSXOpenBundleResources \
Changes to generic/tclStringObj.c.
1119
1120
1121
1122
1123
1124
1125

1126
1127
1128
1129
1130
1131
1132
1133

    if (length <= limit) {
	toCopy = length;
    } else {
	if (ellipsis == NULL) {
	    ellipsis = "...";
	}

	toCopy = Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes;
    }

    /*
     * If objPtr has a valid Unicode rep, then append the Unicode conversion
     * of "bytes" to the objPtr's Unicode rep, otherwise append "bytes" to
     * objPtr's string rep.
     */







>
|







1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134

    if (length <= limit) {
	toCopy = length;
    } else {
	if (ellipsis == NULL) {
	    ellipsis = "...";
	}
	toCopy = (bytes == NULL) ? limit
		: Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes;
    }

    /*
     * If objPtr has a valid Unicode rep, then append the Unicode conversion
     * of "bytes" to the objPtr's Unicode rep, otherwise append "bytes" to
     * objPtr's string rep.
     */
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445

	/*
	 * Protect against case where unicode points into the existing
	 * stringPtr->unicode array. Force it to follow any relocations due to
	 * the reallocs below.
	 */

	if (unicode >= stringPtr->unicode
		&& unicode <= stringPtr->unicode + stringPtr->maxChars) {
	    offset = unicode - stringPtr->unicode;
	}

	GrowUnicodeBuffer(objPtr, numChars);
	stringPtr = GET_STRING(objPtr);








|







1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446

	/*
	 * Protect against case where unicode points into the existing
	 * stringPtr->unicode array. Force it to follow any relocations due to
	 * the reallocs below.
	 */

	if (unicode && unicode >= stringPtr->unicode
		&& unicode <= stringPtr->unicode + stringPtr->maxChars) {
	    offset = unicode - stringPtr->unicode;
	}

	GrowUnicodeBuffer(objPtr, numChars);
	stringPtr = GET_STRING(objPtr);

1453
1454
1455
1456
1457
1458
1459

1460
1461

1462
1463
1464
1465
1466
1467
1468
    }

    /*
     * Copy the new string onto the end of the old string, then add the
     * trailing null.
     */


    memmove(stringPtr->unicode + stringPtr->numChars, unicode,
	    appendNumChars * sizeof(Tcl_UniChar));

    stringPtr->unicode[numChars] = 0;
    stringPtr->numChars = numChars;
    stringPtr->allocated = 0;

    TclInvalidateStringRep(objPtr);
}








>
|
|
>







1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
    }

    /*
     * Copy the new string onto the end of the old string, then add the
     * trailing null.
     */

    if (unicode) {
	memmove(stringPtr->unicode + stringPtr->numChars, unicode,
		appendNumChars * sizeof(Tcl_UniChar));
    }
    stringPtr->unicode[numChars] = 0;
    stringPtr->numChars = numChars;
    stringPtr->allocated = 0;

    TclInvalidateStringRep(objPtr);
}

1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607

	/*
	 * Protect against case where unicode points into the existing
	 * stringPtr->unicode array. Force it to follow any relocations due to
	 * the reallocs below.
	 */

	if (bytes >= objPtr->bytes
		&& bytes <= objPtr->bytes + objPtr->length) {
	    offset = bytes - objPtr->bytes;
	}

	/*
	 * TODO: consider passing flag=1: no overalloc on first append. This
	 * would make test stringObj-8.1 fail.







|







1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610

	/*
	 * Protect against case where unicode points into the existing
	 * stringPtr->unicode array. Force it to follow any relocations due to
	 * the reallocs below.
	 */

	if (bytes && bytes >= objPtr->bytes
		&& bytes <= objPtr->bytes + objPtr->length) {
	    offset = bytes - objPtr->bytes;
	}

	/*
	 * TODO: consider passing flag=1: no overalloc on first append. This
	 * would make test stringObj-8.1 fail.
1621
1622
1623
1624
1625
1626
1627

1628

1629
1630
1631
1632
1633
1634
1635
    /*
     * Invalidate the unicode data.
     */

    stringPtr->numChars = -1;
    stringPtr->hasUnicode = 0;


    memmove(objPtr->bytes + oldLength, bytes, numBytes);

    objPtr->bytes[newLength] = 0;
    objPtr->length = newLength;
}

/*
 *----------------------------------------------------------------------
 *







>
|
>







1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
    /*
     * Invalidate the unicode data.
     */

    stringPtr->numChars = -1;
    stringPtr->hasUnicode = 0;

    if (bytes) {
	memmove(objPtr->bytes + oldLength, bytes, numBytes);
    }
    objPtr->bytes[newLength] = 0;
    objPtr->length = newLength;
}

/*
 *----------------------------------------------------------------------
 *
2654
2655
2656
2657
2658
2659
2660
































2661
2662
2663
2664
2665
2666
2667
    va_end(argList);
    return objPtr;
}

/*
 *---------------------------------------------------------------------------
 *
































 * TclStringObjReverse --
 *
 *	Implements the [string reverse] operation.
 *
 * Results:
 *	An unshared Tcl value which is the [string reverse] of the argument
 *	supplied. When sharing rules permit, the returned value might be the







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
    va_end(argList);
    return objPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclGetStringStorage --
 *
 *	Returns the string storage space of a Tcl_Obj.
 *
 * Results:
 *	The pointer value objPtr->bytes is returned and the number of bytes
 *	allocated there is written to *sizePtr (if known).
 *
 * Side effects:
 *	May set objPtr->bytes.
 *
 *---------------------------------------------------------------------------
 */

char *
TclGetStringStorage(
    Tcl_Obj *objPtr,
    unsigned int *sizePtr)
{
    String *stringPtr;

    if (objPtr->typePtr != &tclStringType || objPtr->bytes == NULL) {
	return TclGetStringFromObj(objPtr, (int *)sizePtr);
    }

    stringPtr = GET_STRING(objPtr);
    *sizePtr = stringPtr->allocated;
    return objPtr->bytes;
}
/*
 *---------------------------------------------------------------------------
 *
 * TclStringObjReverse --
 *
 *	Implements the [string reverse] operation.
 *
 * Results:
 *	An unshared Tcl value which is the [string reverse] of the argument
 *	supplied. When sharing rules permit, the returned value might be the
2844
2845
2846
2847
2848
2849
2850

2851



2852
2853
2854
2855
2856
2857
2858
	
    if (needed > stringPtr->maxChars) {
	GrowUnicodeBuffer(objPtr, needed);
	stringPtr = GET_STRING(objPtr);
    }

    stringPtr->hasUnicode = 1;

    stringPtr->numChars = needed;



    for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) {
	bytes += TclUtfToUniChar(bytes, dst);
    }
    *dst = 0;
}

/*







>
|
>
>
>







2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
	
    if (needed > stringPtr->maxChars) {
	GrowUnicodeBuffer(objPtr, needed);
	stringPtr = GET_STRING(objPtr);
    }

    stringPtr->hasUnicode = 1;
    if (bytes) {
	stringPtr->numChars = needed;
    } else {
	numAppendChars = 0;
    }
    for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) {
	bytes += TclUtfToUniChar(bytes, dst);
    }
    *dst = 0;
}

/*
Changes to generic/tclStubInit.c.
40
41
42
43
44
45
46



47
48
49
50
51
52
53
#undef Tcl_Panic
#undef Tcl_FindExecutable
#undef TclpGetPid
#undef TclSockMinimumBuffers
#define TclBackgroundException Tcl_BackgroundException
#undef Tcl_SetIntObj
#undef TclpInetNtoa




/* See bug 510001: TclSockMinimumBuffers needs plat imp */
#ifdef _WIN64
#   define TclSockMinimumBuffersOld 0
#else
#define TclSockMinimumBuffersOld sockMinimumBuffersOld
static int TclSockMinimumBuffersOld(int sock, int size)







>
>
>







40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
#undef Tcl_Panic
#undef Tcl_FindExecutable
#undef TclpGetPid
#undef TclSockMinimumBuffers
#define TclBackgroundException Tcl_BackgroundException
#undef Tcl_SetIntObj
#undef TclpInetNtoa
#undef TclWinGetServByName
#undef TclWinGetSockOpt
#undef TclWinSetSockOpt

/* See bug 510001: TclSockMinimumBuffers needs plat imp */
#ifdef _WIN64
#   define TclSockMinimumBuffersOld 0
#else
#define TclSockMinimumBuffersOld sockMinimumBuffersOld
static int TclSockMinimumBuffersOld(int sock, int size)
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113

114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129

130
131
132
133
134
135
136

137
138
139
140
141
142
143

144
145
146
147
148
149

150
151
152
153
154
155
156
157
#undef TclWinNToHS
#define TclWinNToHS winNToHS
static unsigned short TclWinNToHS(unsigned short ns) {
	return ntohs(ns);
}
#endif

#ifdef __WIN32__
#   define TclUnixWaitForFile 0
#   define TclUnixCopyFile 0
#   define TclUnixOpenTemporaryFile 0
#   define TclpReaddir 0
#   define TclpIsAtty 0
#elif defined(__CYGWIN__)
#   define TclpIsAtty TclPlatIsAtty
#   define TclWinSetInterfaces (void (*) (int)) doNothing
#   define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing
#   define TclWinFlushDirtyChannels doNothing
#   define TclWinResetInterfaces doNothing

static Tcl_Encoding winTCharEncoding;

static int
TclpIsAtty(int fd)
{
    return isatty(fd);
}


int
TclWinGetPlatformId()
{
    /* Don't bother to determine the real platform on cygwin,
     * because VER_PLATFORM_WIN32_NT is the only supported platform */
    return 2; /* VER_PLATFORM_WIN32_NT */;
}

void *TclWinGetTclInstance()
{
    void *hInstance = NULL;
    GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
	    (const char *)&winTCharEncoding, &hInstance);
    return hInstance;
}


int
TclWinSetSockOpt(SOCKET s, int level, int optname,
	    const char *optval, int optlen)
{
    return setsockopt((int) s, level, optname, optval, optlen);
}


int
TclWinGetSockOpt(SOCKET s, int level, int optname,
	    char *optval, int *optlen)
{
    return getsockopt((int) s, level, optname, optval, optlen);
}


struct servent *
TclWinGetServByName(const char *name, const char *proto)
{
    return getservbyname(name, proto);
}


char *
TclWinNoBackslash(char *path)
{
    char *p;

    for (p = path; *p != '\0'; p++) {
	if (*p == '\\') {
	    *p = '/';







|




















>
|















>
|






>
|






>
|





>
|







89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
#undef TclWinNToHS
#define TclWinNToHS winNToHS
static unsigned short TclWinNToHS(unsigned short ns) {
	return ntohs(ns);
}
#endif

#ifdef _WIN32
#   define TclUnixWaitForFile 0
#   define TclUnixCopyFile 0
#   define TclUnixOpenTemporaryFile 0
#   define TclpReaddir 0
#   define TclpIsAtty 0
#elif defined(__CYGWIN__)
#   define TclpIsAtty TclPlatIsAtty
#   define TclWinSetInterfaces (void (*) (int)) doNothing
#   define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing
#   define TclWinFlushDirtyChannels doNothing
#   define TclWinResetInterfaces doNothing

static Tcl_Encoding winTCharEncoding;

static int
TclpIsAtty(int fd)
{
    return isatty(fd);
}

#define TclWinGetPlatformId winGetPlatformId
static int
TclWinGetPlatformId()
{
    /* Don't bother to determine the real platform on cygwin,
     * because VER_PLATFORM_WIN32_NT is the only supported platform */
    return 2; /* VER_PLATFORM_WIN32_NT */;
}

void *TclWinGetTclInstance()
{
    void *hInstance = NULL;
    GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
	    (const char *)&winTCharEncoding, &hInstance);
    return hInstance;
}

#define TclWinSetSockOpt winSetSockOpt
static int
TclWinSetSockOpt(SOCKET s, int level, int optname,
	    const char *optval, int optlen)
{
    return setsockopt((int) s, level, optname, optval, optlen);
}

#define TclWinGetSockOpt winGetSockOpt
static int
TclWinGetSockOpt(SOCKET s, int level, int optname,
	    char *optval, int *optlen)
{
    return getsockopt((int) s, level, optname, optval, optlen);
}

#define TclWinGetServByName winGetServByName
static struct servent *
TclWinGetServByName(const char *name, const char *proto)
{
    return getservbyname(name, proto);
}

#define TclWinNoBackslash winNoBackslash
static char *
TclWinNoBackslash(char *path)
{
    char *p;

    for (p = path; *p != '\0'; p++) {
	if (*p == '\\') {
	    *p = '/';
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
    TclSetSlaveCancelFlags, /* 250 */
    TclRegisterLiteral, /* 251 */
};

static const TclIntPlatStubs tclIntPlatStubs = {
    TCL_STUB_MAGIC,
    0,
#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
    TclGetAndDetachPids, /* 0 */
    TclpCloseFile, /* 1 */
    TclpCreateCommandChannel, /* 2 */
    TclpCreatePipe, /* 3 */
    TclpCreateProcess, /* 4 */
    0, /* 5 */
    TclpMakeFile, /* 6 */







|







561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
    TclSetSlaveCancelFlags, /* 250 */
    TclRegisterLiteral, /* 251 */
};

static const TclIntPlatStubs tclIntPlatStubs = {
    TCL_STUB_MAGIC,
    0,
#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
    TclGetAndDetachPids, /* 0 */
    TclpCloseFile, /* 1 */
    TclpCreateCommandChannel, /* 2 */
    TclpCreatePipe, /* 3 */
    TclpCreateProcess, /* 4 */
    0, /* 5 */
    TclpMakeFile, /* 6 */
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
    0, /* 25 */
    0, /* 26 */
    0, /* 27 */
    0, /* 28 */
    TclWinCPUID, /* 29 */
    TclUnixOpenTemporaryFile, /* 30 */
#endif /* UNIX */
#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
    TclWinConvertError, /* 0 */
    TclWinConvertWSAError, /* 1 */
    TclWinGetServByName, /* 2 */
    TclWinGetSockOpt, /* 3 */
    TclWinGetTclInstance, /* 4 */
    TclUnixWaitForFile, /* 5 */
    TclWinNToHS, /* 6 */







|







594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
    0, /* 25 */
    0, /* 26 */
    0, /* 27 */
    0, /* 28 */
    TclWinCPUID, /* 29 */
    TclUnixOpenTemporaryFile, /* 30 */
#endif /* UNIX */
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
    TclWinConvertError, /* 0 */
    TclWinConvertWSAError, /* 1 */
    TclWinGetServByName, /* 2 */
    TclWinGetSockOpt, /* 3 */
    TclWinGetTclInstance, /* 4 */
    TclUnixWaitForFile, /* 5 */
    TclWinNToHS, /* 6 */
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
    TclUnixOpenTemporaryFile, /* 30 */
#endif /* MACOSX */
};

static const TclPlatStubs tclPlatStubs = {
    TCL_STUB_MAGIC,
    0,
#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
    Tcl_WinUtfToTChar, /* 0 */
    Tcl_WinTCharToUtf, /* 1 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
    Tcl_MacOSXOpenBundleResources, /* 0 */
    Tcl_MacOSXOpenVersionedBundleResources, /* 1 */
#endif /* MACOSX */







|







665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
    TclUnixOpenTemporaryFile, /* 30 */
#endif /* MACOSX */
};

static const TclPlatStubs tclPlatStubs = {
    TCL_STUB_MAGIC,
    0,
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
    Tcl_WinUtfToTChar, /* 0 */
    Tcl_WinTCharToUtf, /* 1 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
    Tcl_MacOSXOpenBundleResources, /* 0 */
    Tcl_MacOSXOpenVersionedBundleResources, /* 1 */
#endif /* MACOSX */
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
    Tcl_Panic, /* 2 */
    Tcl_Alloc, /* 3 */
    Tcl_Free, /* 4 */
    Tcl_Realloc, /* 5 */
    Tcl_DbCkalloc, /* 6 */
    Tcl_DbCkfree, /* 7 */
    Tcl_DbCkrealloc, /* 8 */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
    Tcl_CreateFileHandler, /* 9 */
#endif /* UNIX */
#if defined(__WIN32__) /* WIN */
    0, /* 9 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
    Tcl_CreateFileHandler, /* 9 */
#endif /* MACOSX */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
    Tcl_DeleteFileHandler, /* 10 */
#endif /* UNIX */
#if defined(__WIN32__) /* WIN */
    0, /* 10 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
    Tcl_DeleteFileHandler, /* 10 */
#endif /* MACOSX */
    Tcl_SetTimer, /* 11 */
    Tcl_Sleep, /* 12 */







|


|





|


|







762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
    Tcl_Panic, /* 2 */
    Tcl_Alloc, /* 3 */
    Tcl_Free, /* 4 */
    Tcl_Realloc, /* 5 */
    Tcl_DbCkalloc, /* 6 */
    Tcl_DbCkfree, /* 7 */
    Tcl_DbCkrealloc, /* 8 */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
    Tcl_CreateFileHandler, /* 9 */
#endif /* UNIX */
#if defined(_WIN32) /* WIN */
    0, /* 9 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
    Tcl_CreateFileHandler, /* 9 */
#endif /* MACOSX */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
    Tcl_DeleteFileHandler, /* 10 */
#endif /* UNIX */
#if defined(_WIN32) /* WIN */
    0, /* 10 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
    Tcl_DeleteFileHandler, /* 10 */
#endif /* MACOSX */
    Tcl_SetTimer, /* 11 */
    Tcl_Sleep, /* 12 */
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
    Tcl_GetCommandName, /* 160 */
    Tcl_GetErrno, /* 161 */
    Tcl_GetHostName, /* 162 */
    Tcl_GetInterpPath, /* 163 */
    Tcl_GetMaster, /* 164 */
    Tcl_GetNameOfExecutable, /* 165 */
    Tcl_GetObjResult, /* 166 */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
    Tcl_GetOpenFile, /* 167 */
#endif /* UNIX */
#if defined(__WIN32__) /* WIN */
    0, /* 167 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
    Tcl_GetOpenFile, /* 167 */
#endif /* MACOSX */
    Tcl_GetPathType, /* 168 */
    Tcl_Gets, /* 169 */







|


|







936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
    Tcl_GetCommandName, /* 160 */
    Tcl_GetErrno, /* 161 */
    Tcl_GetHostName, /* 162 */
    Tcl_GetInterpPath, /* 163 */
    Tcl_GetMaster, /* 164 */
    Tcl_GetNameOfExecutable, /* 165 */
    Tcl_GetObjResult, /* 166 */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
    Tcl_GetOpenFile, /* 167 */
#endif /* UNIX */
#if defined(_WIN32) /* WIN */
    0, /* 167 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
    Tcl_GetOpenFile, /* 167 */
#endif /* MACOSX */
    Tcl_GetPathType, /* 168 */
    Tcl_Gets, /* 169 */
Changes to generic/tclTest.c.
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
			    Tcl_Obj *const objv[]);
static int		TestNRELevels(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		TestInterpResolverCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
#if defined(HAVE_CPUID) || defined(__WIN32__)
static int		TestcpuidCmd(ClientData dummy,
			    Tcl_Interp* interp, int objc,
			    Tcl_Obj *const objv[]);
#endif

static const Tcl_Filesystem testReportingFilesystem = {
    "reporting",







|







410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
			    Tcl_Obj *const objv[]);
static int		TestNRELevels(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		TestInterpResolverCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
#if defined(HAVE_CPUID) || defined(_WIN32)
static int		TestcpuidCmd(ClientData dummy,
			    Tcl_Interp* interp, int objc,
			    Tcl_Obj *const objv[]);
#endif

static const Tcl_Filesystem testReportingFilesystem = {
    "reporting",
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
#endif /* TCL_NO_DEPRECATED */
    Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL,
	    NULL);
    Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd,
	    NULL, NULL);
    Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd,
	    NULL, NULL);
#if defined(HAVE_CPUID) || defined(__WIN32__)
    Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd,
	    (ClientData) 0, NULL);
#endif
#ifndef TCL_NO_DEPRECATED
    t3ArgTypes[0] = TCL_EITHER;
    t3ArgTypes[1] = TCL_EITHER;
    Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,







|







677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
#endif /* TCL_NO_DEPRECATED */
    Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL,
	    NULL);
    Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd,
	    NULL, NULL);
    Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd,
	    NULL, NULL);
#if defined(HAVE_CPUID) || defined(_WIN32)
    Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd,
	    (ClientData) 0, NULL);
#endif
#ifndef TCL_NO_DEPRECATED
    t3ArgTypes[0] = TCL_EITHER;
    t3ArgTypes[1] = TCL_EITHER;
    Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
6644
6645
6646
6647
6648
6649
6650
6651
6652
6653
6654
6655
6656
6657
6658
	}
	len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len);
	Tcl_SetObjResult(interp, Tcl_NewIntObj(len));
    }
    return TCL_OK;
}

#if defined(HAVE_CPUID) || defined(__WIN32__)
/*
 *----------------------------------------------------------------------
 *
 * TestcpuidCmd --
 *
 *	Retrieves CPU ID information.
 *







|







6644
6645
6646
6647
6648
6649
6650
6651
6652
6653
6654
6655
6656
6657
6658
	}
	len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len);
	Tcl_SetObjResult(interp, Tcl_NewIntObj(len));
    }
    return TCL_OK;
}

#if defined(HAVE_CPUID) || defined(_WIN32)
/*
 *----------------------------------------------------------------------
 *
 * TestcpuidCmd --
 *
 *	Retrieves CPU ID information.
 *
Changes to generic/tclThread.c.
335
336
337
338
339
340
341
342

343
344
345
346
347
348
349
350
351
352
353
354
355
356
357



358
359
360
361
362
363
364
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadData --
 *
 *	This function cleans up the thread-local storage. This is called once

 *	for each thread.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees up all thread local storage.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadData(void)
{
    TclFinalizeThreadDataThread();



}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeSynchronization --
 *







|
>
|














>
>
>







335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadData --
 *
 *	This function cleans up the thread-local storage. Secondary, it cleans
 *	thread alloc cache.
 *	This is called once for each thread before thread exits.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees up all thread local storage.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadData(void)
{
    TclFinalizeThreadDataThread();
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
    TclFinalizeThreadAllocThread();
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeSynchronization --
 *
Changes to generic/tclThreadAlloc.c.
1018
1019
1020
1021
1022
1023
1024



























1025
1026
1027
1028
1029
1030
1031
    objLockPtr = NULL;

    TclpFreeAllocMutex(listLockPtr);
    listLockPtr = NULL;

    TclpFreeAllocCache(NULL);
}




























#else /* !(TCL_THREADS && USE_THREAD_ALLOC) */
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetMemoryInfo --
 *







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
    objLockPtr = NULL;

    TclpFreeAllocMutex(listLockPtr);
    listLockPtr = NULL;

    TclpFreeAllocCache(NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadAllocThread --
 *
 *	This procedure is used to destroy single thread private resources used
 *	in this file. 
 * Called in TclpFinalizeThreadData when a thread exits (Tcl_FinalizeThread).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadAllocThread(void)
{
    Cache *cachePtr = TclpGetAllocCache();
    if (cachePtr != NULL) {
	TclpFreeAllocCache(cachePtr);
    }
}

#else /* !(TCL_THREADS && USE_THREAD_ALLOC) */
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetMemoryInfo --
 *
Changes to generic/tclThreadJoin.c.
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"

#ifdef WIN32

/*
 * The information about each joinable thread is remembered in a structure as
 * defined below.
 */

typedef struct JoinableThread {







|







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"

#ifdef _WIN32

/*
 * The information about each joinable thread is remembered in a structure as
 * defined below.
 */

typedef struct JoinableThread {
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316

    if (threadPtr->waitedUpon) {
	Tcl_ConditionNotify(&threadPtr->cond);
    }

    Tcl_MutexUnlock(&threadPtr->threadMutex);
}
#endif /* WIN32 */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







|








301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316

    if (threadPtr->waitedUpon) {
	Tcl_ConditionNotify(&threadPtr->cond);
    }

    Tcl_MutexUnlock(&threadPtr->threadMutex);
}
#endif /* _WIN32 */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */
Changes to generic/tclUtil.c.
107
108
109
110
111
112
113
114




115
116
117
118
119
120
121
static void		ClearHash(Tcl_HashTable *tablePtr);
static void		FreeProcessGlobalValue(ClientData clientData);
static void		FreeThreadHash(ClientData clientData);
static Tcl_HashTable *	GetThreadHash(Tcl_ThreadDataKey *keyPtr);
static int		SetEndOffsetFromAny(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);
static void		UpdateStringOfEndOffset(Tcl_Obj *objPtr);





/*
 * The following is the Tcl object type definition for an object that
 * represents a list index in the form, "end-offset". It is used as a
 * performance optimization in TclGetIntForIndex. The internal rep is an
 * integer, so no memory management is required for it.
 */








|
>
>
>
>







107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
static void		ClearHash(Tcl_HashTable *tablePtr);
static void		FreeProcessGlobalValue(ClientData clientData);
static void		FreeThreadHash(ClientData clientData);
static Tcl_HashTable *	GetThreadHash(Tcl_ThreadDataKey *keyPtr);
static int		SetEndOffsetFromAny(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);
static void		UpdateStringOfEndOffset(Tcl_Obj *objPtr);
static int		FindElement(Tcl_Interp *interp, const char *string,
			    int stringLength, const char *typeStr,
			    const char *typeCode, const char **elementPtr,
			    const char **nextPtr, int *sizePtr,
			    int *literalPtr);
/*
 * The following is the Tcl object type definition for an object that
 * represents a list index in the form, "end-offset". It is used as a
 * performance optimization in TclGetIntForIndex. The internal rep is an
 * integer, so no memory management is required for it.
 */

233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
 *
 *   NOTE: Any element value can be represented by this style of formatting,
 *   given suitable choice of backslash escape sequences, with one exception.
 *   The empty string cannot be represented as a list element without the use
 *   of either braces or quotes to delimit it.
 *
 * This collection of parsing rules is implemented in the routine
 * TclFindElement().
 *
 * In order to produce lists that can be parsed by these rules, we need the
 * ability to distinguish between characters that are part of a list element
 * value from characters providing syntax that define the structure of the
 * list. This means that our code that generates lists must at a minimum be
 * able to produce escape sequences for the 10 characters identified above
 * that have significance to a list parser.







|







237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
 *
 *   NOTE: Any element value can be represented by this style of formatting,
 *   given suitable choice of backslash escape sequences, with one exception.
 *   The empty string cannot be represented as a list element without the use
 *   of either braces or quotes to delimit it.
 *
 * This collection of parsing rules is implemented in the routine
 * FindElement().
 *
 * In order to produce lists that can be parsed by these rules, we need the
 * ability to distinguish between characters that are part of a list element
 * value from characters providing syntax that define the structure of the
 * list. This means that our code that generates lists must at a minimum be
 * able to produce escape sequences for the 10 characters identified above
 * that have significance to a list parser.
501
502
503
504
505
506
507





























































508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
    int *literalPtr)		/* If non-zero, fill in with non-zero/zero to
				 * indicate that the substring of *sizePtr
				 * bytes starting at **elementPtr is/is not
				 * the literal list element and therefore
				 * does not/does require a call to 
				 * TclCopyAndCollapse() by the caller. */
{





























































    const char *p = list;
    const char *elemStart;	/* Points to first byte of first element. */
    const char *limit;		/* Points just after list's last byte. */
    int openBraces = 0;		/* Brace nesting level during parse. */
    int inQuotes = 0;
    int size = 0;		/* lint. */
    int numChars;
    int literal = 1;
    const char *p2;

    /*
     * Skim off leading white space and check for an opening brace or quote.
     * We treat embedded NULLs in the list as bytes belonging to a list
     * element.
     */

    limit = (list + listLength);
    while ((p < limit) && (TclIsSpaceProc(*p))) {
	p++;
    }
    if (p == limit) {		/* no element found */
	elemStart = limit;
	goto done;
    }







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|

|









|
|


|







505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
    int *literalPtr)		/* If non-zero, fill in with non-zero/zero to
				 * indicate that the substring of *sizePtr
				 * bytes starting at **elementPtr is/is not
				 * the literal list element and therefore
				 * does not/does require a call to 
				 * TclCopyAndCollapse() by the caller. */
{
    return FindElement(interp, list, listLength, "list", "LIST", elementPtr,
	    nextPtr, sizePtr, literalPtr);
}

int
TclFindDictElement(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting. If
				 * NULL, then no error message is left after
				 * errors. */
    const char *dict,		/* Points to the first byte of a string
				 * containing a Tcl dictionary with zero or
				 * more keys and values (possibly in
				 * braces). */
    int dictLength,		/* Number of bytes in the dict's string. */
    const char **elementPtr,	/* Where to put address of first significant
				 * character in the first element (i.e., key
				 * or value) of dict. */
    const char **nextPtr,	/* Fill in with location of character just
				 * after all white space following end of
				 * element (next arg or end of list). */
    int *sizePtr,		/* If non-zero, fill in with size of
				 * element. */
    int *literalPtr)		/* If non-zero, fill in with non-zero/zero to
				 * indicate that the substring of *sizePtr
				 * bytes starting at **elementPtr is/is not
				 * the literal key or value and therefore
				 * does not/does require a call to 
				 * TclCopyAndCollapse() by the caller. */
{
    return FindElement(interp, dict, dictLength, "dict", "DICTIONARY",
	    elementPtr, nextPtr, sizePtr, literalPtr);
}

static int
FindElement(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting. If
				 * NULL, then no error message is left after
				 * errors. */
    const char *string,		/* Points to the first byte of a string
				 * containing a Tcl list or dictionary with
				 * zero or more elements (possibly in
				 * braces). */
    int stringLength,		/* Number of bytes in the string. */
    const char *typeStr,	/* The name of the type of thing we are
				 * parsing, for error messages. */
    const char *typeCode,	/* The type code for thing we are parsing, for
				 * error messages. */
    const char **elementPtr,	/* Where to put address of first significant
				 * character in first element. */
    const char **nextPtr,	/* Fill in with location of character just
				 * after all white space following end of
				 * argument (next arg or end of list/dict). */
    int *sizePtr,		/* If non-zero, fill in with size of
				 * element. */
    int *literalPtr)		/* If non-zero, fill in with non-zero/zero to
				 * indicate that the substring of *sizePtr
				 * bytes starting at **elementPtr is/is not
				 * the literal list/dict element and therefore
				 * does not/does require a call to 
				 * TclCopyAndCollapse() by the caller. */
{
    const char *p = string;
    const char *elemStart;	/* Points to first byte of first element. */
    const char *limit;		/* Points just after list/dict's last byte. */
    int openBraces = 0;		/* Brace nesting level during parse. */
    int inQuotes = 0;
    int size = 0;		/* lint. */
    int numChars;
    int literal = 1;
    const char *p2;

    /*
     * Skim off leading white space and check for an opening brace or quote.
     * We treat embedded NULLs in the list/dict as bytes belonging to a list 
     * element (or dictionary key or value).
     */

    limit = (string + stringLength);
    while ((p < limit) && (TclIsSpaceProc(*p))) {
	p++;
    }
    if (p == limit) {		/* no element found */
	elemStart = limit;
	goto done;
    }
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
		if (interp != NULL) {
		    p2 = p;
		    while ((p2 < limit) && (!TclIsSpaceProc(*p2))
			    && (p2 < p+20)) {
			p2++;
		    }
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "list element in braces followed by \"%.*s\" "
			    "instead of space", (int) (p2-p), p));
		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK",
			    NULL);
		}
		return TCL_ERROR;
	    }
	    break;

	    /*







|
|
|







643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
		if (interp != NULL) {
		    p2 = p;
		    while ((p2 < limit) && (!TclIsSpaceProc(*p2))
			    && (p2 < p+20)) {
			p2++;
		    }
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "%s element in braces followed by \"%.*s\" "
			    "instead of space", typeStr, (int) (p2-p), p));
		    Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK",
			    NULL);
		}
		return TCL_ERROR;
	    }
	    break;

	    /*
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
		if (interp != NULL) {
		    p2 = p;
		    while ((p2 < limit) && (!TclIsSpaceProc(*p2))
			    && (p2 < p+20)) {
			p2++;
		    }
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "list element in quotes followed by \"%.*s\" "
			    "instead of space", (int) (p2-p), p));
		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK",
			    NULL);
		}
		return TCL_ERROR;
	    }
	    break;
	}
	p++;
    }

    /*
     * End of list: terminate element.
     */

    if (p == limit) {
	if (openBraces != 0) {
	    if (interp != NULL) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"unmatched open brace in list", -1));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE",
			NULL);
	    }
	    return TCL_ERROR;
	} else if (inQuotes) {
	    if (interp != NULL) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"unmatched open quote in list", -1));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE",
			NULL);
	    }
	    return TCL_ERROR;
	}
	size = (p - elemStart);
    }








|
|
|










|





|
|
|





|
|
|







712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
		if (interp != NULL) {
		    p2 = p;
		    while ((p2 < limit) && (!TclIsSpaceProc(*p2))
			    && (p2 < p+20)) {
			p2++;
		    }
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "%s element in quotes followed by \"%.*s\" "
			    "instead of space", typeStr, (int) (p2-p), p));
		    Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK",
			    NULL);
		}
		return TCL_ERROR;
	    }
	    break;
	}
	p++;
    }

    /*
     * End of list/dict: terminate element.
     */

    if (p == limit) {
	if (openBraces != 0) {
	    if (interp != NULL) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"unmatched open brace in %s", typeStr));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "BRACE",
			NULL);
	    }
	    return TCL_ERROR;
	} else if (inQuotes) {
	    if (interp != NULL) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"unmatched open quote in %s", typeStr));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "QUOTE",
			NULL);
	    }
	    return TCL_ERROR;
	}
	size = (p - elemStart);
    }

Changes to generic/tclZlib.c.
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
	 *  2.	Got an error (readBytes < 0) which we should report up except
	 *	for the case where we can convert it to a short read.
	 *  3.	Got an end-of-data from EOF or blocking (readBytes == 0). If
	 *	it is EOF, try flushing the data out of the decompressor.
	 */

	if (readBytes < 0) {
	    /*
	     * Report errors to caller. The state of the seek system is
	     * unchanged!
	     */

	    if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) {
		/*
		 * EAGAIN is a special situation. If we had some data before
		 * we report that instead of the request to re-try.
		 */

		return gotBytes;
	    }

	    *errorCodePtr = Tcl_GetErrno();
	    return -1;
	} else if (readBytes == 0) {
	    /*
	     * Check wether we hit on EOF in 'parent' or not. If not,
	     * differentiate between blocking and non-blocking modes. In
	     * non-blocking mode we ran temporarily out of data. Signal this
	     * to the caller via EWOULDBLOCK and error return (-1). In the
	     * other cases we simply return what we got and let the caller
	     * wait for more. On the other hand, if we got an EOF we have to
	     * convert and flush all waiting partial data.
	     */

	    if (!Tcl_Eof(cd->parent)) {
		/*
		 * The state of the seek system is unchanged!
		 */

		if ((gotBytes == 0) && (cd->flags & ASYNC)) {
		    *errorCodePtr = EWOULDBLOCK;
		    return -1;
		}
		return gotBytes;
	    }

	    /*
	     * (Semi-)Eof in parent.
	     *
	     * Now this is a bit different. The partial data waiting is
	     * converted and returned.
	     */

	    if (ResultGenerate(cd, 0, Z_SYNC_FLUSH, errorCodePtr) != TCL_OK) {
		return -1;
	    }

	    if (Tcl_DStringLength(&cd->decompressed) == 0) {
		/*
		 * The drain delivered nothing. Time to deliver what we've
		 * got.
		 */

		return gotBytes;
	    }

	    /*
	     * Reset eof, force caller to drain result buffer.
	     */

	    ((Channel *) cd->parent)->state->flags &= ~CHANNEL_EOF;
	} else /* readBytes > 0 */ {
	    /*
	     * Transform the read chunk, which was not empty. Anything we get
	     * back is a transformation result to be put into our buffers, and
	     * the next iteration will put it into the result.
	     */








<
<
<
<

<
|
<
<
<
|





<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
|
<
<
<
<
<
<

|

















<
<
<
<
<
<







2990
2991
2992
2993
2994
2995
2996




2997

2998



2999
3000
3001
3002
3003
3004










3005





3006






3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025






3026
3027
3028
3029
3030
3031
3032
	 *  2.	Got an error (readBytes < 0) which we should report up except
	 *	for the case where we can convert it to a short read.
	 *  3.	Got an end-of-data from EOF or blocking (readBytes == 0). If
	 *	it is EOF, try flushing the data out of the decompressor.
	 */

	if (readBytes < 0) {






	    /* See ReflectInput() in tclIORTrans.c */



	    if (Tcl_InputBlocked(cd->parent) && (gotBytes > 0)) {
		return gotBytes;
	    }

	    *errorCodePtr = Tcl_GetErrno();
	    return -1;










	}





	if (readBytes == 0) {






	    /*
	     * Eof in parent.
	     *
	     * Now this is a bit different. The partial data waiting is
	     * converted and returned.
	     */

	    if (ResultGenerate(cd, 0, Z_SYNC_FLUSH, errorCodePtr) != TCL_OK) {
		return -1;
	    }

	    if (Tcl_DStringLength(&cd->decompressed) == 0) {
		/*
		 * The drain delivered nothing. Time to deliver what we've
		 * got.
		 */

		return gotBytes;
	    }






	} else /* readBytes > 0 */ {
	    /*
	     * Transform the read chunk, which was not empty. Anything we get
	     * back is a transformation result to be put into our buffers, and
	     * the next iteration will put it into the result.
	     */

Changes to library/clock.tcl.
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
		set locale [string tolower $value]
	    }
	    -t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone {
		set timezone $value
	    }
	    default {
		return -code error \
		    -errorcode [list CLOCK badSwitch $flag] \
		    "bad switch \"$flag\",\
                     must be -base, -format, -gmt, -locale or -timezone"
	    }
	}
    }

    # Check options for validity








|
|







1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
		set locale [string tolower $value]
	    }
	    -t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone {
		set timezone $value
	    }
	    default {
		return -code error \
		    -errorcode [list CLOCK badOption $flag] \
		    "bad option \"$flag\",\
                     must be -base, -format, -gmt, -locale or -timezone"
	    }
	}
    }

    # Check options for validity

4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
		    set locale [string tolower $b]
		}
		-t - -ti - -tim - -time - -timez - -timezo - -timezon -
		-timezone {
		    set timezone $b
		}
		default {
		    throw [list CLOCK badSwitch $a] \
			"bad switch \"$a\",\
                         must be -gmt, -locale or -timezone"
		}
	    }
	}
    }

    # Check options for validity







|
|







4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
		    set locale [string tolower $b]
		}
		-t - -ti - -tim - -time - -timez - -timezo - -timezon -
		-timezone {
		    set timezone $b
		}
		default {
		    throw [list CLOCK badOption $a] \
			"bad option \"$a\",\
                         must be -gmt, -locale or -timezone"
		}
	    }
	}
    }

    # Check options for validity
Changes to library/init.tcl.
394
395
396
397
398
399
400

401
402
403
404
405
406
407
408
	    dict incr ::tcl::UnknownOptions -level
	    return -options $::tcl::UnknownOptions $::tcl::UnknownResult
	}
	if {[llength $cmds]} {
	    return -code error "ambiguous command name \"$name\": [lsort $cmds]"
	}
    }

    return -code error "invalid command name \"$name\""
}

# auto_load --
# Checks a collection of library directories to see if a procedure
# is defined in one of them.  If so, it sources the appropriate
# library file to create the procedure.  Returns 1 if it successfully
# loaded the procedure, 0 otherwise.







>
|







394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
	    dict incr ::tcl::UnknownOptions -level
	    return -options $::tcl::UnknownOptions $::tcl::UnknownResult
	}
	if {[llength $cmds]} {
	    return -code error "ambiguous command name \"$name\": [lsort $cmds]"
	}
    }
    return -code error -errorcode [list TCL LOOKUP COMMAND $name] \
	"invalid command name \"$name\""
}

# auto_load --
# Checks a collection of library directories to see if a procedure
# is defined in one of them.  If so, it sources the appropriate
# library file to create the procedure.  Returns 1 if it successfully
# loaded the procedure, 0 otherwise.
Changes to library/tcltest/pkgIndex.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.5]} {return}
package ifneeded tcltest 2.3.7 [list source [file join $dir tcltest.tcl]]











|
1
2
3
4
5
6
7
8
9
10
11
12
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.5]} {return}
package ifneeded tcltest 2.3.8 [list source [file join $dir tcltest.tcl]]
Changes to library/tcltest/tcltest.tcl.
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

package require Tcl 8.5		;# -verbose line uses [info frame]
namespace eval tcltest {

    # When the version number changes, be sure to update the pkgIndex.tcl file,
    # and the install directory in the Makefiles.  When the minor version
    # changes (new feature) be sure to update the man page as well.
    variable Version 2.3.7

    # Compatibility support for dumb variables defined in tcltest 1
    # Do not use these.  Call [package provide Tcl] and [info patchlevel]
    # yourself.  You don't need tcltest to wrap it for you.
    variable version [package provide Tcl]
    variable patchLevel [info patchlevel]








|







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

package require Tcl 8.5		;# -verbose line uses [info frame]
namespace eval tcltest {

    # When the version number changes, be sure to update the pkgIndex.tcl file,
    # and the install directory in the Makefiles.  When the minor version
    # changes (new feature) be sure to update the man page as well.
    variable Version 2.3.8

    # Compatibility support for dumb variables defined in tcltest 1
    # Do not use these.  Call [package provide Tcl] and [info patchlevel]
    # yourself.  You don't need tcltest to wrap it for you.
    variable version [package provide Tcl]
    variable patchLevel [info patchlevel]

1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
	lassign $testResult actualAnswer returnCode
	if {$returnCode == 1} {
	    set errorInfo(body) $::errorInfo
	    set errorCode(body) $::errorCode
	}
    }

    # Always run the cleanup script
    set code [catch {uplevel 1 $cleanup} cleanupMsg]
    if {$code == 1} {
	set errorInfo(cleanup) $::errorInfo
	set errorCode(cleanup) $::errorCode
    }
    set cleanupFailure [expr {$code != 0}]

    set coreFailure 0
    set coreMsg ""
    # check for a core file first - if one was created by the test,
    # then the test failed
    if {[preserveCore]} {
	if {[file exists [file join [workingDirectory] core]]} {
	    # There's only a test failure if there is a core file
	    # and (1) there previously wasn't one or (2) the new
	    # one is different from the old one.
	    if {[info exists coreModTime]} {
		if {$coreModTime != [file mtime \
			[file join [workingDirectory] core]]} {
		    set coreFailure 1
		}
	    } else {
		set coreFailure 1
	    }
	
	    if {([preserveCore] > 1) && ($coreFailure)} {
		append coreMsg "\nMoving file to:\
		    [file join [temporaryDirectory] core-$name]"
		catch {file rename -force -- \
		    [file join [workingDirectory] core] \
		    [file join [temporaryDirectory] core-$name]
		} msg
		if {$msg ne {}} {
		    append coreMsg "\nError:\
			Problem renaming core file: $msg"
		}
	    }
	}
    }

    # check if the return code matched the expected return code
    set codeFailure 0
    if {!$setupFailure && ($returnCode ni $returnCodes)} {
	set codeFailure 1
    }

    # If expected output/error strings exist, we have to compare







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







1987
1988
1989
1990
1991
1992
1993









































1994
1995
1996
1997
1998
1999
2000
	lassign $testResult actualAnswer returnCode
	if {$returnCode == 1} {
	    set errorInfo(body) $::errorInfo
	    set errorCode(body) $::errorCode
	}
    }










































    # check if the return code matched the expected return code
    set codeFailure 0
    if {!$setupFailure && ($returnCode ni $returnCodes)} {
	set codeFailure 1
    }

    # If expected output/error strings exist, we have to compare
2071
2072
2073
2074
2075
2076
2077









































2078
2079
2080
2081
2082
2083
2084
    } elseif {[set scriptCompare [catch {
	CompareStrings $actualAnswer $result $match
    } scriptMatch]] == 0} {
	set scriptFailure [expr {!$scriptMatch}]
    } else {
	set scriptFailure 1
    }










































    # if we didn't experience any failures, then we passed
    variable numTests
    if {!($setupFailure || $cleanupFailure || $coreFailure
	    || $outputFailure || $errorFailure || $codeFailure
	    || $scriptFailure)} {
	if {$testLevel == 1} {







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
    } elseif {[set scriptCompare [catch {
	CompareStrings $actualAnswer $result $match
    } scriptMatch]] == 0} {
	set scriptFailure [expr {!$scriptMatch}]
    } else {
	set scriptFailure 1
    }

    # Always run the cleanup script
    set code [catch {uplevel 1 $cleanup} cleanupMsg]
    if {$code == 1} {
	set errorInfo(cleanup) $::errorInfo
	set errorCode(cleanup) $::errorCode
    }
    set cleanupFailure [expr {$code != 0}]

    set coreFailure 0
    set coreMsg ""
    # check for a core file first - if one was created by the test,
    # then the test failed
    if {[preserveCore]} {
	if {[file exists [file join [workingDirectory] core]]} {
	    # There's only a test failure if there is a core file
	    # and (1) there previously wasn't one or (2) the new
	    # one is different from the old one.
	    if {[info exists coreModTime]} {
		if {$coreModTime != [file mtime \
			[file join [workingDirectory] core]]} {
		    set coreFailure 1
		}
	    } else {
		set coreFailure 1
	    }
	
	    if {([preserveCore] > 1) && ($coreFailure)} {
		append coreMsg "\nMoving file to:\
		    [file join [temporaryDirectory] core-$name]"
		catch {file rename -force -- \
		    [file join [workingDirectory] core] \
		    [file join [temporaryDirectory] core-$name]
		} msg
		if {$msg ne {}} {
		    append coreMsg "\nError:\
			Problem renaming core file: $msg"
		}
	    }
	}
    }

    # if we didn't experience any failures, then we passed
    variable numTests
    if {!($setupFailure || $cleanupFailure || $coreFailure
	    || $outputFailure || $errorFailure || $codeFailure
	    || $scriptFailure)} {
	if {$testLevel == 1} {
Changes to tests/chanio.test.
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
    testConstraint testfevent       [llength [info commands testfevent]]
    testConstraint testchannelevent [llength [info commands testchannelevent]]
    testConstraint testmainthread   [llength [info commands testmainthread]]
    testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]

    # You need a *very* special environment to do some tests.  In particular,
    # many file systems do not support large-files...
    testConstraint largefileSupport 0

    # some tests can only be run is umask is 2 if "umask" cannot be run, the
    # tests will be skipped.
    set umaskValue 0
    testConstraint umask [expr {![catch {set umaskValue [scan [exec /bin/sh -c umask] %o]}]}]

    testConstraint makeFileInHome [expr {![file exists ~/_test_] && [file writable ~]}]







|







40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
    testConstraint testfevent       [llength [info commands testfevent]]
    testConstraint testchannelevent [llength [info commands testchannelevent]]
    testConstraint testmainthread   [llength [info commands testmainthread]]
    testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]

    # You need a *very* special environment to do some tests.  In particular,
    # many file systems do not support large-files...
    testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]

    # some tests can only be run is umask is 2 if "umask" cannot be run, the
    # tests will be skipped.
    set umaskValue 0
    testConstraint umask [expr {![catch {set umaskValue [scan [exec /bin/sh -c umask] %o]}]}]

    testConstraint makeFileInHome [expr {![file exists ~/_test_] && [file writable ~]}]
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
    lappend l [chan tell $f]
    # 4GB offset!
    chan seek $f 0x100000000
    lappend l [chan tell $f]
    chan puts -nonewline $f abcdef
    lappend l [chan tell $f]
    chan close $f
    lappend l [file size $f]
    # truncate...
    chan close [open $path(test3) w]
    lappend l [file size $f]
} -result {0 6 6 4294967296 4294967302 4294967302 0}

# Test Tcl_Eof

test chan-io-35.1 {Tcl_Eof} -setup {
    file delete $path(test1)
} -body {







|


|







4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
    lappend l [chan tell $f]
    # 4GB offset!
    chan seek $f 0x100000000
    lappend l [chan tell $f]
    chan puts -nonewline $f abcdef
    lappend l [chan tell $f]
    chan close $f
    lappend l [file size $path(test3)]
    # truncate...
    chan close [open $path(test3) w]
    lappend l [file size $path(test3)]
} -result {0 6 6 4294967296 4294967302 4294967302 0}

# Test Tcl_Eof

test chan-io-35.1 {Tcl_Eof} -setup {
    file delete $path(test1)
} -body {
Changes to tests/clock.test.
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
} {}

test clock-1.4 "clock format - bad flag" {*}{
    -body {
    list [catch {clock format 0 -oops badflag} msg] $msg $::errorCode
    } 
    -match glob
    -result {1 {bad switch "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badSwitch -oops}}
}

test clock-1.5 "clock format - bad timezone" {
    list [catch {clock format 0 -format "%s" -timezone :NOWHERE} msg] $msg $::errorCode
} {1 {time zone ":NOWHERE" not found} {CLOCK badTimeZone :NOWHERE}}

test clock-1.6 "clock format - gmt + timezone" {







|







269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
} {}

test clock-1.4 "clock format - bad flag" {*}{
    -body {
    list [catch {clock format 0 -oops badflag} msg] $msg $::errorCode
    } 
    -match glob
    -result {1 {bad option "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badOption -oops}}
}

test clock-1.5 "clock format - bad timezone" {
    list [catch {clock format 0 -format "%s" -timezone :NOWHERE} msg] $msg $::errorCode
} {1 {time zone ":NOWHERE" not found} {CLOCK badTimeZone :NOWHERE}}

test clock-1.6 "clock format - gmt + timezone" {
35446
35447
35448
35449
35450
35451
35452
35453
35454
35455
35456
35457
35458
35459
35460
    set start [clock clicks]
    after 10
    set end [clock clicks]
    expr "$end > $start"
} {1}
test clock-33.3 {clock clicks tests} {
    list [catch {clock clicks foo} msg] $msg
} {1 {bad switch "foo": must be -milliseconds or -microseconds}}
test clock-33.4 {clock clicks tests} {
    expr [clock clicks -milliseconds]+1
    concat {}
} {}
test clock-33.4a {clock milliseconds} {
    expr { [clock milliseconds] + 1 }
    concat {}







|







35446
35447
35448
35449
35450
35451
35452
35453
35454
35455
35456
35457
35458
35459
35460
    set start [clock clicks]
    after 10
    set end [clock clicks]
    expr "$end > $start"
} {1}
test clock-33.3 {clock clicks tests} {
    list [catch {clock clicks foo} msg] $msg
} {1 {bad option "foo": must be -milliseconds or -microseconds}}
test clock-33.4 {clock clicks tests} {
    expr [clock clicks -milliseconds]+1
    concat {}
} {}
test clock-33.4a {clock milliseconds} {
    expr { [clock milliseconds] + 1 }
    concat {}
35481
35482
35483
35484
35485
35486
35487
35488
35489
35490
35491
35492
35493
35494
35495
35496
35497
35498
    expr {
	  ($end > $start) && (($end - $start) <= 60) ?
	  "ok" : 
	  "test should have taken 0-60 ms, actually took [expr $end - $start]"}
} {ok}
test clock-33.6 {clock clicks, milli with too much abbreviation} {
    list [catch { clock clicks ? } msg] $msg
} {1 {bad switch "?": must be -milliseconds or -microseconds}}
test clock-33.7 {clock clicks, milli with too much abbreviation} {
    list [catch { clock clicks - } msg] $msg
} {1 {ambiguous switch "-": must be -milliseconds or -microseconds}}

test clock-33.8 {clock clicks test, microsecond timing test} {
    # This test can fail on a system that is so heavily loaded that
    # the test takes >60 ms to run.
    set start [clock clicks -micro]
    after 10
    set end [clock clicks -micro]







|


|







35481
35482
35483
35484
35485
35486
35487
35488
35489
35490
35491
35492
35493
35494
35495
35496
35497
35498
    expr {
	  ($end > $start) && (($end - $start) <= 60) ?
	  "ok" : 
	  "test should have taken 0-60 ms, actually took [expr $end - $start]"}
} {ok}
test clock-33.6 {clock clicks, milli with too much abbreviation} {
    list [catch { clock clicks ? } msg] $msg
} {1 {bad option "?": must be -milliseconds or -microseconds}}
test clock-33.7 {clock clicks, milli with too much abbreviation} {
    list [catch { clock clicks - } msg] $msg
} {1 {ambiguous option "-": must be -milliseconds or -microseconds}}

test clock-33.8 {clock clicks test, microsecond timing test} {
    # This test can fail on a system that is so heavily loaded that
    # the test takes >60 ms to run.
    set start [clock clicks -micro]
    after 10
    set end [clock clicks -micro]
35603
35604
35605
35606
35607
35608
35609
35610
35611
35612
35613
35614
35615
35616
35617
} {Oct 23,1992 15:00 GMT}
test clock-34.8 {clock scan tests} {
    set time [clock scan "Oct 23,1992 15:00" -gmt true]
    clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Oct 23,1992 15:00 GMT}
test clock-34.9 {clock scan tests} {
    list [catch {clock scan "Jan 12" -bad arg} msg] $msg
} {1 {bad switch "-bad", must be -base, -format, -gmt, -locale or -timezone}}
# The following two two tests test the two year date policy
test clock-34.10 {clock scan tests} {
    set time [clock scan "1/1/71" -gmt true]
    clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Jan 01,1971 00:00 GMT}
test clock-34.11 {clock scan tests} {
    set time [clock scan "1/1/37" -gmt true]







|







35603
35604
35605
35606
35607
35608
35609
35610
35611
35612
35613
35614
35615
35616
35617
} {Oct 23,1992 15:00 GMT}
test clock-34.8 {clock scan tests} {
    set time [clock scan "Oct 23,1992 15:00" -gmt true]
    clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Oct 23,1992 15:00 GMT}
test clock-34.9 {clock scan tests} {
    list [catch {clock scan "Jan 12" -bad arg} msg] $msg
} {1 {bad option "-bad", must be -base, -format, -gmt, -locale or -timezone}}
# The following two two tests test the two year date policy
test clock-34.10 {clock scan tests} {
    set time [clock scan "1/1/71" -gmt true]
    clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Jan 01,1971 00:00 GMT}
test clock-34.11 {clock scan tests} {
    set time [clock scan "1/1/37" -gmt true]
36903
36904
36905
36906
36907
36908
36909
36910
36911
36912
36913
36914
36915
36916
36917
36918
36919
36920
36921
36922
36923
36924
36925
36926
36927
36928
36929









36930
36931
36932
36933
36934
36935
36936
36937
36938
36939

test clock-65.1 {clock add, bad option [Bug 2481670]} {*}{
    -body {
	clock add 0 1 year -foo bar
    }
    -match glob
    -returnCodes error
    -result {bad switch "-foo"*}
}

test clock-66.1 {clock scan, no date, never-before-seen timezone} {*}{
    -setup {
	::tcl::clock::ClearCaches
    }
    -body {
	clock scan 1200 \
	    -timezone {<EST>+05:00:00<EDT>+04:00:00,M3.2.0/02:00:00,M11.1.0/02:00:00} \
	    -base 1256529600 \
	    -format %H%M
    }
    -result 1256572800
}

test clock-67.1 {clock format, %% with a letter following [Bug 2819334]} {
    clock format [clock seconds] -format %%r
} %r










# cleanup

namespace delete ::testClock
::tcl::clock::ClearCaches
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:







|



















>
>
>
>
>
>
>
>
>










36903
36904
36905
36906
36907
36908
36909
36910
36911
36912
36913
36914
36915
36916
36917
36918
36919
36920
36921
36922
36923
36924
36925
36926
36927
36928
36929
36930
36931
36932
36933
36934
36935
36936
36937
36938
36939
36940
36941
36942
36943
36944
36945
36946
36947
36948

test clock-65.1 {clock add, bad option [Bug 2481670]} {*}{
    -body {
	clock add 0 1 year -foo bar
    }
    -match glob
    -returnCodes error
    -result {bad option "-foo"*}
}

test clock-66.1 {clock scan, no date, never-before-seen timezone} {*}{
    -setup {
	::tcl::clock::ClearCaches
    }
    -body {
	clock scan 1200 \
	    -timezone {<EST>+05:00:00<EDT>+04:00:00,M3.2.0/02:00:00,M11.1.0/02:00:00} \
	    -base 1256529600 \
	    -format %H%M
    }
    -result 1256572800
}

test clock-67.1 {clock format, %% with a letter following [Bug 2819334]} {
    clock format [clock seconds] -format %%r
} %r

test clock-67.2 {Bug d19a30db57} -body {
    # error, not segfault
    tcl::clock::GetJulianDayFromEraYearMonthDay {} 2361222
} -returnCodes error -match glob -result *
test clock-67.3 {Bug d19a30db57} -body {
    # error, not segfault
    tcl::clock::GetJulianDayFromEraYearWeekDay {} 2361222
} -returnCodes error -match glob -result *

# cleanup

namespace delete ::testClock
::tcl::clock::ClearCaches
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:
Changes to tests/cmdAH.test.
137
138
139
140
141
142
143



144
145
146
147
148
149
150
    set dir [pwd]
} -body {
    cd /
    pwd
} -cleanup {
    cd $dir
} -result {/}



test cmdAH-2.7 {Tcl_ConcatObjCmd} {
    concat
} {}
test cmdAH-2.8 {Tcl_ConcatObjCmd} {
    concat a
} a
test cmdAH-2.9 {Tcl_ConcatObjCmd} {







>
>
>







137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
    set dir [pwd]
} -body {
    cd /
    pwd
} -cleanup {
    cd $dir
} -result {/}
test cmdAH-2.6.3 {Tcl_CdObjCmd, bug #3118489} -returnCodes error -body {
    cd .\0
} -result "couldn't change working directory to \".\0\": no such file or directory"
test cmdAH-2.7 {Tcl_ConcatObjCmd} {
    concat
} {}
test cmdAH-2.8 {Tcl_ConcatObjCmd} {
    concat a
} a
test cmdAH-2.9 {Tcl_ConcatObjCmd} {
Changes to tests/dict.test.
163
164
165
166
167
168
169













































170
171
172
173
174
175
176
177
178
179
180
181



















182
183
184
185
186
187
188
    dict replace {a a a} a b
} -result {missing value to go with key}
test dict-4.8 {dict replace command} -returnCodes error -body {
    dict replace [list a a a] a b
} -result {missing value to go with key}
test dict-4.9 {dict replace command} {dict replace [list a a] a b} {a b}
test dict-4.10 {dict replace command} {dict replace [list a a] a b a c} {a c}














































test dict-5.1 {dict remove command} {dict remove {a b c d} a} {c d}
test dict-5.2 {dict remove command} {dict remove {a b c d} c} {a b}
test dict-5.3 {dict remove command} {dict remove {a b c d} a c} {}
test dict-5.4 {dict remove command} {dict remove {a b c d} c a} {}
test dict-5.5 {dict remove command} {
    dict remove {a b c d}
} {a b c d}
test dict-5.6 {dict remove command} {dict remove {a b} c} {a b}
test dict-5.7 {dict remove command} -returnCodes error -body {
    dict remove
} -result {wrong # args: should be "dict remove dictionary ?key ...?"}




















test dict-6.1 {dict keys command} {dict keys {a b}} a
test dict-6.2 {dict keys command} {dict keys {c d}} c
test dict-6.3 {dict keys command} {lsort [dict keys {a b c d}]} {a c}
test dict-6.4 {dict keys command} {dict keys {a b c d} a} a
test dict-6.5 {dict keys command} {dict keys {a b c d} c} c
test dict-6.6 {dict keys command} {dict keys {a b c d} e} {}







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>












>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
    dict replace {a a a} a b
} -result {missing value to go with key}
test dict-4.8 {dict replace command} -returnCodes error -body {
    dict replace [list a a a] a b
} -result {missing value to go with key}
test dict-4.9 {dict replace command} {dict replace [list a a] a b} {a b}
test dict-4.10 {dict replace command} {dict replace [list a a] a b a c} {a c}
test dict-4.11 {dict replace command: canonicality is forced} {
    dict replace { a b  c d }
} {a b c d}
test dict-4.12 {dict replace command: canonicality is forced} {
    dict replace {a b c d a e}
} {a e c d}
test dict-4.13 {dict replace command: type check is mandatory} -body {
    dict replace { a b c d e }
} -returnCodes error -result {missing value to go with key}
test dict-4.13a {dict replace command: type check is mandatory} {
    catch {dict replace { a b c d e }} -> opt
    dict get $opt -errorcode
} {TCL VALUE DICTIONARY}
test dict-4.14 {dict replace command: type check is mandatory} -body {
    dict replace { a b {}c d }
} -returnCodes error -result {dict element in braces followed by "c" instead of space}
test dict-4.14a {dict replace command: type check is mandatory} {
    catch {dict replace { a b {}c d }} -> opt
    dict get $opt -errorcode
} {TCL VALUE DICTIONARY JUNK}
test dict-4.15 {dict replace command: type check is mandatory} -body {
    dict replace { a b ""c d }
} -returnCodes error -result {dict element in quotes followed by "c" instead of space}
test dict-4.15a {dict replace command: type check is mandatory} {
    catch {dict replace { a b ""c d }} -> opt
    dict get $opt -errorcode
} {TCL VALUE DICTIONARY JUNK}
test dict-4.16 {dict replace command: type check is mandatory} -body {
    dict replace " a b \"c d "
} -returnCodes error -result {unmatched open quote in dict}
test dict-4.16a {dict replace command: type check is mandatory} {
    catch {dict replace " a b \"c d "} -> opt
    dict get $opt -errorcode
} {TCL VALUE DICTIONARY QUOTE}
test dict-4.17 {dict replace command: type check is mandatory} -body {
    dict replace " a b \{c d "
} -returnCodes error -result {unmatched open brace in dict}
test dict-4.17a {dict replace command: type check is mandatory} {
    catch {dict replace " a b \{c d "} -> opt
    dict get $opt -errorcode
} {TCL VALUE DICTIONARY BRACE}
test dict-4.18 {dict replace command: canonicality forcing doesn't leak} {
    set example { a b  c d }
    list $example [dict replace $example]
} {{ a b  c d } {a b c d}}

test dict-5.1 {dict remove command} {dict remove {a b c d} a} {c d}
test dict-5.2 {dict remove command} {dict remove {a b c d} c} {a b}
test dict-5.3 {dict remove command} {dict remove {a b c d} a c} {}
test dict-5.4 {dict remove command} {dict remove {a b c d} c a} {}
test dict-5.5 {dict remove command} {
    dict remove {a b c d}
} {a b c d}
test dict-5.6 {dict remove command} {dict remove {a b} c} {a b}
test dict-5.7 {dict remove command} -returnCodes error -body {
    dict remove
} -result {wrong # args: should be "dict remove dictionary ?key ...?"}
test dict-5.8 {dict remove command: canonicality is forced} {
    dict remove { a b  c d }
} {a b c d}
test dict-5.9 {dict remove command: canonicality is forced} {
    dict remove {a b c d a e}
} {a e c d}
test dict-5.10 {dict remove command: canonicality forced by update} {
    dict remove { a b c d } c
} {a b}
test dict-5.11 {dict remove command: type check is mandatory} -body {
    dict remove { a b c d e }
} -returnCodes error -result {missing value to go with key}
test dict-5.12 {dict remove command: type check is mandatory} -body {
    dict remove { a b {}c d }
} -returnCodes error -result {dict element in braces followed by "c" instead of space}
test dict-5.13 {dict remove command: canonicality forcing doesn't leak} {
    set example { a b  c d }
    list $example [dict remove $example]
} {{ a b  c d } {a b c d}}

test dict-6.1 {dict keys command} {dict keys {a b}} a
test dict-6.2 {dict keys command} {dict keys {c d}} c
test dict-6.3 {dict keys command} {lsort [dict keys {a b c d}]} {a c}
test dict-6.4 {dict keys command} {dict keys {a b c d} a} a
test dict-6.5 {dict keys command} {dict keys {a b c d} c} c
test dict-6.6 {dict keys command} {dict keys {a b c d} e} {}
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
    unset dictv
} -result {missing value to go with key}
test dict-11.13 {dict incr command} -returnCodes error -body {
    set dictv a
    dict incr dictv a a a
} -cleanup {
    unset dictv
} -result {wrong # args: should be "dict incr varName key ?increment?"}
test dict-11.14 {dict incr command} -returnCodes error -body {
    set dictv a
    dict incr dictv
} -cleanup {
    unset dictv
} -result {wrong # args: should be "dict incr varName key ?increment?"}
test dict-11.15 {dict incr command: write failure} -setup {
    unset -nocomplain dictVar
} -body {
    set dictVar(block) {}
    dict incr dictVar a
} -returnCodes error -cleanup {
    unset dictVar







|





|







405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
    unset dictv
} -result {missing value to go with key}
test dict-11.13 {dict incr command} -returnCodes error -body {
    set dictv a
    dict incr dictv a a a
} -cleanup {
    unset dictv
} -result {wrong # args: should be "dict incr dictVarName key ?increment?"}
test dict-11.14 {dict incr command} -returnCodes error -body {
    set dictv a
    dict incr dictv
} -cleanup {
    unset dictv
} -result {wrong # args: should be "dict incr dictVarName key ?increment?"}
test dict-11.15 {dict incr command: write failure} -setup {
    unset -nocomplain dictVar
} -body {
    set dictVar(block) {}
    dict incr dictVar a
} -returnCodes error -cleanup {
    unset dictVar
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
    set dictv a
    dict lappend dictv a a
} -cleanup {
    unset dictv
} -result {missing value to go with key}
test dict-12.7 {dict lappend command} -returnCodes error -body {
    dict lappend
} -result {wrong # args: should be "dict lappend varName key ?value ...?"}
test dict-12.8 {dict lappend command} -returnCodes error -body {
    dict lappend dictv
} -result {wrong # args: should be "dict lappend varName key ?value ...?"}
test dict-12.9 {dict lappend command} -returnCodes error -body {
    set dictv [dict create a "\{"]
    dict lappend dictv a a
} -cleanup {
    unset dictv
} -result {unmatched open brace in list}
test dict-12.10 {dict lappend command: write failure} -setup {







|


|







482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
    set dictv a
    dict lappend dictv a a
} -cleanup {
    unset dictv
} -result {missing value to go with key}
test dict-12.7 {dict lappend command} -returnCodes error -body {
    dict lappend
} -result {wrong # args: should be "dict lappend dictVarName key ?value ...?"}
test dict-12.8 {dict lappend command} -returnCodes error -body {
    dict lappend dictv
} -result {wrong # args: should be "dict lappend dictVarName key ?value ...?"}
test dict-12.9 {dict lappend command} -returnCodes error -body {
    set dictv [dict create a "\{"]
    dict lappend dictv a a
} -cleanup {
    unset dictv
} -result {unmatched open brace in list}
test dict-12.10 {dict lappend command: write failure} -setup {
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
    set dictv a
    dict append dictv a a
} -cleanup {
    unset dictv
} -result {missing value to go with key}
test dict-13.7 {dict append command} -returnCodes error -body {
    dict append
} -result {wrong # args: should be "dict append varName key ?value ...?"}
test dict-13.8 {dict append command} -returnCodes error -body {
    dict append dictv
} -result {wrong # args: should be "dict append varName key ?value ...?"}
test dict-13.9 {dict append command: write failure} -setup {
    unset -nocomplain dictVar
} -body {
    set dictVar(block) {}
    dict append dictVar a x
} -returnCodes error -cleanup {
    unset dictVar
} -result {can't set "dictVar": variable is array}
test dict-13.10 {compiled dict append: crash case} {
    apply {{} {dict append dictVar a o k}}
} {a ok}
test dict-13.11 {compiled dict append: invalidate string rep - Bug 3079830} {
    apply {{} {set d {a 1 b 2 c 3}; dict append d b 22}}
} {a 1 b 222 c 3}

test dict-14.1 {dict for command: syntax} -returnCodes error -body {
    dict for
} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"}
test dict-14.2 {dict for command: syntax} -returnCodes error -body {
    dict for x
} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"}
test dict-14.3 {dict for command: syntax} -returnCodes error -body {
    dict for x x
} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"}
test dict-14.4 {dict for command: syntax} -returnCodes error -body {
    dict for x x x x
} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"}
test dict-14.5 {dict for command: syntax} -returnCodes error -body {
    dict for x x x
} -result {must have exactly two variable names}
test dict-14.6 {dict for command: syntax} -returnCodes error -body {
    dict for {x x x} x x
} -result {must have exactly two variable names}
test dict-14.7 {dict for command: syntax} -returnCodes error -body {







|


|

















|


|


|


|







549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
    set dictv a
    dict append dictv a a
} -cleanup {
    unset dictv
} -result {missing value to go with key}
test dict-13.7 {dict append command} -returnCodes error -body {
    dict append
} -result {wrong # args: should be "dict append dictVarName key ?value ...?"}
test dict-13.8 {dict append command} -returnCodes error -body {
    dict append dictv
} -result {wrong # args: should be "dict append dictVarName key ?value ...?"}
test dict-13.9 {dict append command: write failure} -setup {
    unset -nocomplain dictVar
} -body {
    set dictVar(block) {}
    dict append dictVar a x
} -returnCodes error -cleanup {
    unset dictVar
} -result {can't set "dictVar": variable is array}
test dict-13.10 {compiled dict append: crash case} {
    apply {{} {dict append dictVar a o k}}
} {a ok}
test dict-13.11 {compiled dict append: invalidate string rep - Bug 3079830} {
    apply {{} {set d {a 1 b 2 c 3}; dict append d b 22}}
} {a 1 b 222 c 3}

test dict-14.1 {dict for command: syntax} -returnCodes error -body {
    dict for
} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"}
test dict-14.2 {dict for command: syntax} -returnCodes error -body {
    dict for x
} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"}
test dict-14.3 {dict for command: syntax} -returnCodes error -body {
    dict for x x
} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"}
test dict-14.4 {dict for command: syntax} -returnCodes error -body {
    dict for x x x x
} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"}
test dict-14.5 {dict for command: syntax} -returnCodes error -body {
    dict for x x x
} -result {must have exactly two variable names}
test dict-14.6 {dict for command: syntax} -returnCodes error -body {
    dict for {x x x} x x
} -result {must have exactly two variable names}
test dict-14.7 {dict for command: syntax} -returnCodes error -body {
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
    set dictVar(block) {}
    dict set dictVar a x
} -returnCodes error -cleanup {
    unset dictVar
} -result {can't set "dictVar": variable is array}
test dict-15.10 {dict set command: syntax} -returnCodes error -body {
    dict set
} -result {wrong # args: should be "dict set varName key ?key ...? value"}
test dict-15.11 {dict set command: syntax} -returnCodes error -body {
    dict set a
} -result {wrong # args: should be "dict set varName key ?key ...? value"}
test dict-15.12 {dict set command: syntax} -returnCodes error -body {
    dict set a a
} -result {wrong # args: should be "dict set varName key ?key ...? value"}
test dict-15.13 {dict set command} -returnCodes error -body {
    set dictVar a
    dict set dictVar b c
} -cleanup {
    unset dictVar
} -result {missing value to go with key}








|


|


|







809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
    set dictVar(block) {}
    dict set dictVar a x
} -returnCodes error -cleanup {
    unset dictVar
} -result {can't set "dictVar": variable is array}
test dict-15.10 {dict set command: syntax} -returnCodes error -body {
    dict set
} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"}
test dict-15.11 {dict set command: syntax} -returnCodes error -body {
    dict set a
} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"}
test dict-15.12 {dict set command: syntax} -returnCodes error -body {
    dict set a a
} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"}
test dict-15.13 {dict set command} -returnCodes error -body {
    set dictVar a
    dict set dictVar b c
} -cleanup {
    unset dictVar
} -result {missing value to go with key}

804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
} -body {
    list [info exists dictVar] [dict unset dictVar a] [info exists dictVar]
} -cleanup {
    unset dictVar
} -result {0 {} 1}
test dict-16.8 {dict unset command} -returnCodes error -body {
    dict unset dictVar
} -result {wrong # args: should be "dict unset varName key ?key ...?"}
test dict-16.9 {dict unset command: write failure} -setup {
    unset -nocomplain dictVar
} -body {
    set dictVar(block) {}
    dict unset dictVar a
} -returnCodes error -cleanup {
    unset dictVar







|







868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
} -body {
    list [info exists dictVar] [dict unset dictVar a] [info exists dictVar]
} -cleanup {
    unset dictVar
} -result {0 {} 1}
test dict-16.8 {dict unset command} -returnCodes error -body {
    dict unset dictVar
} -result {wrong # args: should be "dict unset dictVarName key ?key ...?"}
test dict-16.9 {dict unset command: write failure} -setup {
    unset -nocomplain dictVar
} -body {
    set dictVar(block) {}
    dict unset dictVar a
} -returnCodes error -cleanup {
    unset dictVar
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
    }}
} -result {key "c" not known in dictionary}
test dict-16.16 {dict unset command} -body {
    apply {{} {list [info exists dictVar] [dict unset dictVar a] [info exists dictVar]}}
} -result {0 {} 1}
test dict-16.17 {dict unset command} -returnCodes error -body {
    apply {{} {dict unset dictVar}}
} -result {wrong # args: should be "dict unset varName key ?key ...?"}
test dict-16.18 {dict unset command: write failure} -body {
    apply {{} {
	set dictVar(block) {}
	dict unset dictVar a
    }}
} -returnCodes error -result {can't set "dictVar": variable is array}








|







919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
    }}
} -result {key "c" not known in dictionary}
test dict-16.16 {dict unset command} -body {
    apply {{} {list [info exists dictVar] [dict unset dictVar a] [info exists dictVar]}}
} -result {0 {} 1}
test dict-16.17 {dict unset command} -returnCodes error -body {
    apply {{} {dict unset dictVar}}
} -result {wrong # args: should be "dict unset dictVarName key ?key ...?"}
test dict-16.18 {dict unset command: write failure} -body {
    apply {{} {
	set dictVar(block) {}
	dict unset dictVar a
    }}
} -returnCodes error -result {can't set "dictVar": variable is array}

984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
    dict filter {a b} script {k k} {continue}
    return $k
} -cleanup {
    unset k
} -result b
test dict-17.18 {dict filter command: script} -returnCodes error -body {
    dict filter {a b} script {k k}
} -result {wrong # args: should be "dict filter dictionary script {keyVar valueVar} filterScript"}
test dict-17.19 {dict filter command: script} -returnCodes error -body {
    dict filter {a b} script k {continue}
} -result {must have exactly two variable names}
test dict-17.20 {dict filter command: script} -returnCodes error -body {
    dict filter {a b} script "\{k v" {continue}
} -result {unmatched open brace in list}
test dict-17.21 {dict filter command} -returnCodes error -body {







|







1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
    dict filter {a b} script {k k} {continue}
    return $k
} -cleanup {
    unset k
} -result b
test dict-17.18 {dict filter command: script} -returnCodes error -body {
    dict filter {a b} script {k k}
} -result {wrong # args: should be "dict filter dictionary script {keyVarName valueVarName} filterScript"}
test dict-17.19 {dict filter command: script} -returnCodes error -body {
    dict filter {a b} script k {continue}
} -result {must have exactly two variable names}
test dict-17.20 {dict filter command: script} -returnCodes error -body {
    dict filter {a b} script "\{k v" {continue}
} -result {unmatched open brace in list}
test dict-17.21 {dict filter command} -returnCodes error -body {
1222
1223
1224
1225
1226
1227
1228















1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
} {a x c y}
test dict-20.19 {dict merge command} {
    apply {{} {dict merge {a b c d} {c y a x}}}
} {a x c y}
test dict-20.20 {dict merge command} {
    apply {{} {dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}}}
} {a - c d e f 1 - 3 4}
















test dict-21.1 {dict update command} -returnCodes 1 -body {
    dict update
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
test dict-21.2 {dict update command} -returnCodes 1 -body {
    dict update v
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
test dict-21.3 {dict update command} -returnCodes 1 -body {
    dict update v k
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
test dict-21.4 {dict update command} -returnCodes 1 -body {
    dict update v k v
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
test dict-21.5 {dict update command} -body {
    set a {b c}
    set result {}
    set bb {}
    dict update a b bb {
	lappend result $a $bb
    }







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



|


|


|


|







1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
} {a x c y}
test dict-20.19 {dict merge command} {
    apply {{} {dict merge {a b c d} {c y a x}}}
} {a x c y}
test dict-20.20 {dict merge command} {
    apply {{} {dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}}}
} {a - c d e f 1 - 3 4}
test dict-20.21 {dict merge command: canonicality not forced} {
    dict merge { a b c d }
} { a b c d }
test dict-20.22 {dict merge command: canonicality not forced} {
    dict merge { a b c d } {}
} { a b c d }
test dict-20.23 {dict merge command: canonicality forced by update} {
    dict merge { a b c d } {a b}
} {a b c d}
test dict-20.24 {dict merge command: type check is mandatory} -body {
    dict merge { a b c d e }
} -returnCodes error -result {missing value to go with key}
test dict-20.25 {dict merge command: type check is mandatory} -body {
    dict merge { a b {}c d }
} -returnCodes error -result {dict element in braces followed by "c" instead of space}

test dict-21.1 {dict update command} -returnCodes 1 -body {
    dict update
} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"}
test dict-21.2 {dict update command} -returnCodes 1 -body {
    dict update v
} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"}
test dict-21.3 {dict update command} -returnCodes 1 -body {
    dict update v k
} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"}
test dict-21.4 {dict update command} -returnCodes 1 -body {
    dict update v k v
} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"}
test dict-21.5 {dict update command} -body {
    set a {b c}
    set result {}
    set bb {}
    dict update a b bb {
	lappend result $a $bb
    }
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
	}
	string range [append foo OK] end-1 end
    }}
} OK

test dict-22.1 {dict with command} -body {
    dict with
} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"}
test dict-22.2 {dict with command} -body {
    dict with v
} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"}
test dict-22.3 {dict with command} -body {
    unset -nocomplain v
    dict with v {error "in body"}
} -returnCodes 1 -result {can't read "v": no such variable}
test dict-22.4 {dict with command} -body {
    set a {b c d e}
    unset -nocomplain b d







|


|







1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
	}
	string range [append foo OK] end-1 end
    }}
} OK

test dict-22.1 {dict with command} -body {
    dict with
} -returnCodes 1 -result {wrong # args: should be "dict with dictVarName ?key ...? script"}
test dict-22.2 {dict with command} -body {
    dict with v
} -returnCodes 1 -result {wrong # args: should be "dict with dictVarName ?key ...? script"}
test dict-22.3 {dict with command} -body {
    unset -nocomplain v
    dict with v {error "in body"}
} -returnCodes 1 -result {can't read "v": no such variable}
test dict-22.4 {dict with command} -body {
    set a {b c d e}
    unset -nocomplain b d
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
	}
    }} [linenumber]}}
} 5
rename linenumber {}

test dict-24.1 {dict map command: syntax} -returnCodes error -body {
    dict map
} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
test dict-24.2 {dict map command: syntax} -returnCodes error -body {
    dict map x
} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
test dict-24.3 {dict map command: syntax} -returnCodes error -body {
    dict map x x
} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
test dict-24.4 {dict map command: syntax} -returnCodes error -body {
    dict map x x x x
} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
test dict-24.5 {dict map command: syntax} -returnCodes error -body {
    dict map x x x
} -result {must have exactly two variable names}
test dict-24.6 {dict map command: syntax} -returnCodes error -body {
    dict map {x x x} x x
} -result {must have exactly two variable names}
test dict-24.7 {dict map command: syntax} -returnCodes error -body {







|


|


|


|







1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
	}
    }} [linenumber]}}
} 5
rename linenumber {}

test dict-24.1 {dict map command: syntax} -returnCodes error -body {
    dict map
} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"}
test dict-24.2 {dict map command: syntax} -returnCodes error -body {
    dict map x
} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"}
test dict-24.3 {dict map command: syntax} -returnCodes error -body {
    dict map x x
} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"}
test dict-24.4 {dict map command: syntax} -returnCodes error -body {
    dict map x x x x
} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"}
test dict-24.5 {dict map command: syntax} -returnCodes error -body {
    dict map x x x
} -result {must have exactly two variable names}
test dict-24.6 {dict map command: syntax} -returnCodes error -body {
    dict map {x x x} x x
} -result {must have exactly two variable names}
test dict-24.7 {dict map command: syntax} -returnCodes error -body {
Changes to tests/exec.test.
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
err}

# Errors in executing the Tcl command, as opposed to errors in the processes
# that are invoked.

test exec-10.1 {errors in exec invocation} -constraints {exec} -body {
    exec
} -returnCodes error -result {wrong # args: should be "exec ?-switch ...? arg ?arg ...?"}
test exec-10.2 {errors in exec invocation} -constraints {exec} -body {
    exec | cat
} -returnCodes error -result {illegal use of | or |& in command}
test exec-10.3 {errors in exec invocation} -constraints {exec} -body {
    exec cat |
} -returnCodes error -result {illegal use of | or |& in command}
test exec-10.4 {errors in exec invocation} -constraints {exec} -body {







|







366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
err}

# Errors in executing the Tcl command, as opposed to errors in the processes
# that are invoked.

test exec-10.1 {errors in exec invocation} -constraints {exec} -body {
    exec
} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"}
test exec-10.2 {errors in exec invocation} -constraints {exec} -body {
    exec | cat
} -returnCodes error -result {illegal use of | or |& in command}
test exec-10.3 {errors in exec invocation} -constraints {exec} -body {
    exec cat |
} -returnCodes error -result {illegal use of | or |& in command}
test exec-10.4 {errors in exec invocation} -constraints {exec} -body {
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
# Switches before the first argument

test exec-14.1 {-keepnewline switch} {exec} {
    exec -keepnewline [interpreter] $path(echo) foo
} "foo\n"
test exec-14.2 {-keepnewline switch} -constraints {exec} -body {
    exec -keepnewline
} -returnCodes error -result {wrong # args: should be "exec ?-switch ...? arg ?arg ...?"}
test exec-14.3 {unknown switch} -constraints {exec} -body {
    exec -gorp
} -returnCodes error -result {bad switch "-gorp": must be -ignorestderr, -keepnewline, or --}
test exec-14.4 {-- switch} -constraints {exec} -body {
    exec -- -gorp
} -returnCodes error -result {couldn't execute "-gorp": no such file or directory}
test exec-14.5 {-ignorestderr switch} {exec} {
    # Alas, the use of -ignorestderr is buried here :-(
    exec [interpreter] $path(sh2) -c [list $path(echo2) foo bar] 2>@1
} "foo bar\nbar"







|


|







541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
# Switches before the first argument

test exec-14.1 {-keepnewline switch} {exec} {
    exec -keepnewline [interpreter] $path(echo) foo
} "foo\n"
test exec-14.2 {-keepnewline switch} -constraints {exec} -body {
    exec -keepnewline
} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"}
test exec-14.3 {unknown switch} -constraints {exec} -body {
    exec -gorp
} -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, or --}
test exec-14.4 {-- switch} -constraints {exec} -body {
    exec -- -gorp
} -returnCodes error -result {couldn't execute "-gorp": no such file or directory}
test exec-14.5 {-ignorestderr switch} {exec} {
    # Alas, the use of -ignorestderr is buried here :-(
    exec [interpreter] $path(sh2) -c [list $path(echo2) foo bar] 2>@1
} "foo bar\nbar"
Changes to tests/fCmd.test.
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
    file mkdir td1
    testchmod 000 td1
    createfile tf1
    file rename tf1 td1
} -returnCodes error -cleanup {
    testchmod 755 td1
} -result {error renaming "tf1" to "td1/tf1": permission denied}
test fCmd-6.7 {CopyRenameOneFile: errno != ENOENT} -setup {
    cleanup
} -constraints {win 95} -returnCodes error -body {
    createfile tf1
    file rename tf1 $long
} -result [subst {error renaming "tf1" to "$long": file name too long}]
test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} -setup {
    cleanup
} -constraints {unix notRoot} -body {
    createfile tf1
    file rename tf1 tf2
    glob tf*
} -result {tf2}







<
<
<
<
<
<







507
508
509
510
511
512
513






514
515
516
517
518
519
520
    file mkdir td1
    testchmod 000 td1
    createfile tf1
    file rename tf1 td1
} -returnCodes error -cleanup {
    testchmod 755 td1
} -result {error renaming "tf1" to "td1/tf1": permission denied}






test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} -setup {
    cleanup
} -constraints {unix notRoot} -body {
    createfile tf1
    file rename tf1 tf2
    glob tf*
} -result {tf2}
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
    file link
} -result {wrong # args: should be "file link ?-linktype? linkname ?target?"}
test fCmd-28.2 {file link} -returnCodes error -body {
    file link a b c d
} -result {wrong # args: should be "file link ?-linktype? linkname ?target?"}
test fCmd-28.3 {file link} -returnCodes error -body {
    file link abc b c
} -result {bad switch "abc": must be -symbolic or -hard}
test fCmd-28.4 {file link} -returnCodes error -body {
    file link -abc b c
} -result {bad switch "-abc": must be -symbolic or -hard}
cd [workingDirectory]
makeDirectory abc.dir
makeDirectory abc2.dir
makeFile contents abc.file
makeFile contents abc2.file
cd [temporaryDirectory]
test fCmd-28.5 {file link: source already exists} -setup {







|


|







2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
    file link
} -result {wrong # args: should be "file link ?-linktype? linkname ?target?"}
test fCmd-28.2 {file link} -returnCodes error -body {
    file link a b c d
} -result {wrong # args: should be "file link ?-linktype? linkname ?target?"}
test fCmd-28.3 {file link} -returnCodes error -body {
    file link abc b c
} -result {bad option "abc": must be -symbolic or -hard}
test fCmd-28.4 {file link} -returnCodes error -body {
    file link -abc b c
} -result {bad option "-abc": must be -symbolic or -hard}
cd [workingDirectory]
makeDirectory abc.dir
makeDirectory abc2.dir
makeFile contents abc.file
makeFile contents abc2.file
cd [temporaryDirectory]
test fCmd-28.5 {file link: source already exists} -setup {
Changes to tests/http.test.
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
proc myProgress {token total current} {
    global progress httpLog
    if {[info exists httpLog] && $httpLog} {
	puts "progress $total $current"
    }
    set progress [list $total $current]
}
if 0 {
    # This test hangs on Windows95 because the client never gets EOF
    set httpLog 1
    test http-4.6.1 {http::Event} knownBug {
	set token [http::geturl $url -blocksize 50 -progress myProgress]
	return $progress
    } {111 111}
}
test http-4.7 {http::Event} -body {
    set token [http::geturl $url -keepalive 0 -progress myProgress]
    return $progress
} -cleanup {
    http::cleanup $token
} -result {111 111}
test http-4.8 {http::Event} -body {







<
<
<
|
|
|
|
<







488
489
490
491
492
493
494



495
496
497
498

499
500
501
502
503
504
505
proc myProgress {token total current} {
    global progress httpLog
    if {[info exists httpLog] && $httpLog} {
	puts "progress $total $current"
    }
    set progress [list $total $current]
}



test http-4.6.1 {http::Event} knownBug {
    set token [http::geturl $url -blocksize 50 -progress myProgress]
    return $progress
} {111 111}

test http-4.7 {http::Event} -body {
    set token [http::geturl $url -keepalive 0 -progress myProgress]
    return $progress
} -cleanup {
    http::cleanup $token
} -result {111 111}
test http-4.8 {http::Event} -body {
Changes to tests/io.test.
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
testConstraint testfevent       [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread   [llength [info commands testmainthread]]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]

# You need a *very* special environment to do some tests.  In
# particular, many file systems do not support large-files...
testConstraint largefileSupport 0

# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
set umaskValue 0
testConstraint umask [expr {![catch {set umaskValue [scan [exec /bin/sh -c umask] %o]}]}]

testConstraint makeFileInHome [expr {![file exists ~/_test_] && [file writable ~]}]







|







41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
testConstraint testfevent       [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread   [llength [info commands testmainthread]]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]

# You need a *very* special environment to do some tests.  In
# particular, many file systems do not support large-files...
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]

# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
set umaskValue 0
testConstraint umask [expr {![catch {set umaskValue [scan [exec /bin/sh -c umask] %o]}]}]

testConstraint makeFileInHome [expr {![file exists ~/_test_] && [file writable ~]}]
1445
1446
1447
1448
1449
1450
1451

































1452
1453
1454
1455
1456
1457
1458
    puts $f "go3"
    flush $f
    vwait [namespace which -variable x]
    vwait [namespace which -variable x]
    lappend x [catch {close $f} msg] $msg
    set x
} "{} timeout {} timeout \u7266 {} eof 0 {}"


































test io-13.1 {TranslateInputEOL: cr mode} {} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\rdef\r"
    close $f
    set f [open $path(test1)]







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
    puts $f "go3"
    flush $f
    vwait [namespace which -variable x]
    vwait [namespace which -variable x]
    lappend x [catch {close $f} msg] $msg
    set x
} "{} timeout {} timeout \u7266 {} eof 0 {}"
test io-12.6 {ReadChars: too many chars read} {
    proc driver {cmd args} {
        variable buffer
        variable index
        set chan [lindex $args 0]
        switch -- $cmd {
            initialize {
                set index($chan) 0
                set buffer($chan) [encoding convertto utf-8 \
                        [string repeat \uBEEF 20][string repeat . 20]]
                return {initialize finalize watch read}
            }
            finalize {
                unset index($chan) buffer($chan)
                return
            }
            watch {}
            read {
                set n [lindex $args 1]
                set new [expr {$index($chan) + $n}]
                set result [string range $buffer($chan) $index($chan) $new-1]
                set index($chan) $new
                return $result
            }
        }
    }
    set c [chan create read [namespace which driver]]
    chan configure $c -encoding utf-8
    while {![eof $c]} {
        read $c 15
    }
    close $c
} {}

test io-13.1 {TranslateInputEOL: cr mode} {} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\rdef\r"
    close $f
    set f [open $path(test1)]
1559
1560
1561
1562
1563
1564
1565







































1566
1567
1568
1569
1570
1571
1572
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto
    set x [read $f]
    close $f
    set x
} "abcd\ndef"







































test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\rdef"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto
    set x [read $f]
    close $f
    set x
} "abcd\ndef"
test io-13.8.1 {TranslateInputEOL: auto mode: \r\n} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\r\ndef"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto
    set x {}
    lappend x [read $f 5]
    lappend x [read $f]
    close $f
    set x
} [list "abcd\n" "def"]
test io-13.8.2 {TranslateInputEOL: auto mode: \r\n} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\r\ndef"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto -buffersize 6
    set x {}
    lappend x [read $f 5]
    lappend x [read $f]
    close $f
    set x
} [list "abcd\n" "def"]
test io-13.8.3 {TranslateInputEOL: auto mode: \r\n} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\r\n\r\ndef"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto -buffersize 7
    set x {}
    lappend x [read $f 5]
    lappend x [read $f]
    close $f
    set x
} [list "abcd\n" "\ndef"]
test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\rdef"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
	expr {($t2-$t1)/2000 ? $t2-$t1 : 0}
} 0
test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac fileevent} {
    variable c 0
    variable x running
    set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
    proc writelots {s l} {
	for {set i 0} {$i < 2000} {incr i} {
	    puts $s $l
	}
    }
    proc accept {s a p} {
	variable x
	fileevent $s readable [namespace code [list readit $s]]
	fconfigure $s -blocking off







|







2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
	expr {($t2-$t1)/2000 ? $t2-$t1 : 0}
} 0
test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac fileevent} {
    variable c 0
    variable x running
    set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
    proc writelots {s l} {
	for {set i 0} {$i < 9000} {incr i} {
	    puts $s $l
	}
    }
    proc accept {s a p} {
	variable x
	fileevent $s readable [namespace code [list readit $s]]
	fconfigure $s -blocking off
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
    vwait [namespace which -variable x]
    fconfigure $cs -blocking off
    writelots $cs $l
    close $cs
    close $ss
    vwait [namespace which -variable x]
    set c
} 2000
test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac fileevent} {
    # On Mac, this test screws up sockets such that subsequent tests using port 2828
    # either cause errors or panic().

    catch {interp delete x}
    catch {interp delete y}
    interp create x







|







2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
    vwait [namespace which -variable x]
    fconfigure $cs -blocking off
    writelots $cs $l
    close $cs
    close $ss
    vwait [namespace which -variable x]
    set c
} 9000
test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac fileevent} {
    # On Mac, this test screws up sockets such that subsequent tests using port 2828
    # either cause errors or panic().

    catch {interp delete x}
    catch {interp delete y}
    interp create x
3979
3980
3981
3982
3983
3984
3985








































3986
3987
3988
3989
3990
3991
3992
    puts $f1 hello
    flush $f1
    lappend x [read $f1]
    close $f1
    set x
} {{hello
} {hello








































}}
test io-32.12 {Tcl_Read, -nonewline} {
    file delete $path(test1)
    set f1 [open $path(test1) w]
    puts $f1 hello
    puts $f1 bye
    close $f1







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
    puts $f1 hello
    flush $f1
    lappend x [read $f1]
    close $f1
    set x
} {{hello
} {hello
}}
test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} {
    file delete $path(pipe)
    set f1 [open $path(pipe) w]
    puts $f1 {chan configure stdout -translation crlf}
    puts $f1 {puts [gets stdin]}
    puts $f1 {puts [gets stdin]}
    close $f1
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    puts $f1 hello
    flush $f1
    set x ""
    lappend x [read $f1 6]
    puts $f1 hello
    flush $f1
    lappend x [read $f1]
    close $f1
    set x
} {{hello
} {hello
}}
test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} {
    file delete $path(pipe)
    set f1 [open $path(pipe) w]
    puts $f1 {chan configure stdout -translation crlf}
    puts $f1 {puts [gets stdin]}
    puts $f1 {puts [gets stdin]}
    close $f1
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    puts $f1 hello
    flush $f1
    set x ""
    lappend x [read $f1 6]
    puts $f1 hello
    flush $f1
    lappend x [read $f1]
    close $f1
    set x
} {{hello
} {hello
}}
test io-32.12 {Tcl_Read, -nonewline} {
    file delete $path(test1)
    set f1 [open $path(test1) w]
    puts $f1 hello
    puts $f1 bye
    close $f1
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
    lappend l [tell $f]
    # 4GB offset!
    seek $f 0x100000000
    lappend l [tell $f]
    puts -nonewline $f abcdef
    lappend l [tell $f]
    close $f
    lappend l [file size $f]
    # truncate...
    close [open $path(test3) w]
    lappend l [file size $f]
    set l
} {0 6 6 4294967296 4294967302 4294967302 0}

# Test Tcl_Eof

test io-35.1 {Tcl_Eof} {
    file delete $path(test1)







|


|







4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
    lappend l [tell $f]
    # 4GB offset!
    seek $f 0x100000000
    lappend l [tell $f]
    puts -nonewline $f abcdef
    lappend l [tell $f]
    close $f
    lappend l [file size $path(test3)]
    # truncate...
    close [open $path(test3) w]
    lappend l [file size $path(test3)]
    set l
} {0 6 6 4294967296 4294967302 4294967302 0}

# Test Tcl_Eof

test io-35.1 {Tcl_Eof} {
    file delete $path(test1)
4721
4722
4723
4724
4725
4726
4727






















































































4728
4729
4730
4731
4732
4733
4734
    set f [open $path(test1) r]
    fconfigure $f -translation crlf -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $l $e
} {21 8 1}























































































# Test Tcl_InputBlocked

test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} {
    set f1 [open "|[list [interpreter]]" r+]
    puts $f1 {puts hello_from_pipe}
    flush $f1







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
    set f [open $path(test1) r]
    fconfigure $f -translation crlf -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $l $e
} {21 8 1}
test io-35.18 {Tcl_Eof, eof char, cr write, crlf read} -body {
    file delete $path(test1)
    set f [open $path(test1) w]
    fconfigure $f -translation cr
    puts $f abc\ndef
    close $f
    set s [file size $path(test1)]
    set f [open $path(test1) r]
    fconfigure $f -translation crlf
    set l [string length [set in [read $f]]]
    set e [eof $f]
    close $f
    list $s $l $e [scan [string index $in end] %c]
} -result {8 8 1 13}
test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body {
    file delete $path(test1)
    set f [open $path(test1) w]
    fconfigure $f -translation cr -eofchar \x1a
    puts $f abc\ndef
    close $f
    set s [file size $path(test1)]
    set f [open $path(test1) r]
    fconfigure $f -translation crlf -eofchar \x1a
    set l [string length [set in [read $f]]]
    set e [eof $f]
    close $f
    list $s $l $e [scan [string index $in end] %c]
} -result {9 8 1 13}
test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} -body {
    file delete $path(test1)
    set f [open $path(test1) w]
    fconfigure $f -translation cr -eofchar \x1a
    puts $f {}
    close $f
    set s [file size $path(test1)]
    set f [open $path(test1) r]
    fconfigure $f -translation crlf -eofchar \x1a
    set l [string length [set in [read $f]]]
    set e [eof $f]
    close $f
    list $s $l $e [scan [string index $in end] %c]
} -result {2 1 1 13}
test io-35.18c {Tcl_Eof, eof char, cr write, crlf read} -body {
    file delete $path(test1)
    set f [open $path(test1) w]
    fconfigure $f -translation cr
    puts $f {}
    close $f
    set s [file size $path(test1)]
    set f [open $path(test1) r]
    fconfigure $f -translation crlf
    set l [string length [set in [read $f]]]
    set e [eof $f]
    close $f
    list $s $l $e [scan [string index $in end] %c]
} -result {1 1 1 13}
test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} -body {
    file delete $path(test1)
    set f [open $path(test1) w]
    fconfigure $f -translation cr -eofchar {}
    set i [format abc\ndef\n%cqrs\nuvw 26]
    puts $f $i
    close $f
    set c [file size $path(test1)]
    set f [open $path(test1) r]
    fconfigure $f -translation crlf -eofchar \x1a
    set l [string length [set in [read $f]]]
    set e [eof $f]
    close $f
    list $c $l $e [scan [string index $in end] %c]
} -result {17 8 1 13}
test io-35.20 {Tcl_Eof, eof char in middle, cr write, crlf read} {
    file delete $path(test1)
    set f [open $path(test1) w]
    fconfigure $f -translation cr -eofchar {}
    set i [format \n%cqrsuvw 26]
    puts $f $i
    close $f
    set c [file size $path(test1)]
    set f [open $path(test1) r]
    fconfigure $f -translation crlf -eofchar \x1a
    set l [string length [set in [read $f]]]
    set e [eof $f]
    close $f
    list $c $l $e [scan [string index $in end] %c]
} {9 1 1 13}

# Test Tcl_InputBlocked

test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} {
    set f1 [open "|[list [interpreter]]" r+]
    puts $f1 {puts hello_from_pipe}
    flush $f1
6560
6561
6562
6563
6564
6565
6566
6567












6568
6569
6570
6571
6572
6573
6574
6575
6576
6577
6578
test io-52.4 {TclCopyChannel} {fcopy} {
    file delete $path(test1)
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation cr -blocking 0
    fcopy $f1 $f2 -size 40
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]












    close $f1
    close $f2
    lappend result [file size $path(test1)]
} {0 0 40}
test io-52.5 {TclCopyChannel, all} {fcopy} {
    file delete $path(test1)
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation lf -blocking 0
    fcopy $f1 $f2 -size -1 ;# -1 means 'copy all', same as if no -size specified.







|
>
>
>
>
>
>
>
>
>
>
>
>



|







6758
6759
6760
6761
6762
6763
6764
6765
6766
6767
6768
6769
6770
6771
6772
6773
6774
6775
6776
6777
6778
6779
6780
6781
6782
6783
6784
6785
6786
6787
6788
test io-52.4 {TclCopyChannel} {fcopy} {
    file delete $path(test1)
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation cr -blocking 0
    fcopy $f1 $f2 -size 40
    set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    close $f1
    close $f2
    lappend result [file size $path(test1)]
} {0 0 0 40}
test io-52.4.1 {TclCopyChannel} {fcopy} {
    file delete $path(test1)
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fconfigure $f1 -translation lf -blocking 0 -buffersize 10000000
    fconfigure $f2 -translation cr -blocking 0
    fcopy $f1 $f2 -size 40
    set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    close $f1
    close $f2
    lappend result [file size $path(test1)]
} {0 0 0 40}
test io-52.5 {TclCopyChannel, all} {fcopy} {
    file delete $path(test1)
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation lf -blocking 0
    fcopy $f1 $f2 -size -1 ;# -1 means 'copy all', same as if no -size specified.
6749
6750
6751
6752
6753
6754
6755
















































































































































6756
6757
6758
6759
6760
6761
6762

    fcopy $in $out
    close $in
    close $out

    file size $path(kyrillic.txt)
} 3

















































































































































test io-53.1 {CopyData} {fcopy} {
    file delete $path(test1)
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation cr -blocking 0







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







6959
6960
6961
6962
6963
6964
6965
6966
6967
6968
6969
6970
6971
6972
6973
6974
6975
6976
6977
6978
6979
6980
6981
6982
6983
6984
6985
6986
6987
6988
6989
6990
6991
6992
6993
6994
6995
6996
6997
6998
6999
7000
7001
7002
7003
7004
7005
7006
7007
7008
7009
7010
7011
7012
7013
7014
7015
7016
7017
7018
7019
7020
7021
7022
7023
7024
7025
7026
7027
7028
7029
7030
7031
7032
7033
7034
7035
7036
7037
7038
7039
7040
7041
7042
7043
7044
7045
7046
7047
7048
7049
7050
7051
7052
7053
7054
7055
7056
7057
7058
7059
7060
7061
7062
7063
7064
7065
7066
7067
7068
7069
7070
7071
7072
7073
7074
7075
7076
7077
7078
7079
7080
7081
7082
7083
7084
7085
7086
7087
7088
7089
7090
7091
7092
7093
7094
7095
7096
7097
7098
7099
7100
7101
7102
7103
7104
7105
7106
7107
7108
7109
7110
7111
7112
7113
7114
7115
7116

    fcopy $in $out
    close $in
    close $out

    file size $path(kyrillic.txt)
} 3

test io-52.12 {coverage of -translation auto} {
    file delete $path(test1) $path(test2)
    set out [open $path(test1) wb]
    chan configure $out -translation lf
    puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
    close $out
    set in [open $path(test1)]
    chan configure $in -buffersize 8
    set out [open $path(test2) w]
    chan configure $out -translation lf
    fcopy $in $out
    close $in
    close $out
    file size $path(test2)
} 29
test io-52.13 {coverage of -translation cr} {
    file delete $path(test1) $path(test2)
    set out [open $path(test1) wb]
    chan configure $out -translation lf
    puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
    close $out
    set in [open $path(test1)]
    chan configure $in -buffersize 8 -translation cr
    set out [open $path(test2) w]
    chan configure $out -translation lf
    fcopy $in $out
    close $in
    close $out
    file size $path(test2)
} 30
test io-52.14 {coverage of -translation crlf} {
    file delete $path(test1) $path(test2)
    set out [open $path(test1) wb]
    chan configure $out -translation lf
    puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
    close $out
    set in [open $path(test1)]
    chan configure $in -buffersize 8 -translation crlf
    set out [open $path(test2) w]
    chan configure $out -translation lf
    fcopy $in $out
    close $in
    close $out
    file size $path(test2)
} 29
test io-52.14.1 {coverage of -translation crlf} {
    file delete $path(test1) $path(test2)
    set out [open $path(test1) wb]
    chan configure $out -translation lf
    puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
    close $out
    set in [open $path(test1)]
    chan configure $in -buffersize 8 -translation crlf
    set out [open $path(test2) w]
    fcopy $in $out -size 2
    close $in
    close $out
    file size $path(test2)
} 2
test io-52.14.2 {coverage of -translation crlf} {
    file delete $path(test1) $path(test2)
    set out [open $path(test1) wb]
    chan configure $out -translation lf
    puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
    close $out
    set in [open $path(test1)]
    chan configure $in -translation crlf
    set out [open $path(test2) w]
    fcopy $in $out -size 9
    close $in
    close $out
    file size $path(test2)
} 9
test io-52.15 {coverage of -translation crlf} {
    file delete $path(test1) $path(test2)
    set out [open $path(test1) wb]
    chan configure $out -translation lf
    puts -nonewline $out abcdefg\r
    close $out
    set in [open $path(test1)]
    chan configure $in -buffersize 8 -translation crlf
    set out [open $path(test2) w]
    fcopy $in $out
    close $in
    close $out
    file size $path(test2)
} 8
test io-52.16 {coverage of eofChar handling} {
    file delete $path(test1) $path(test2)
    set out [open $path(test1) wb]
    chan configure $out -translation lf
    puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
    close $out
    set in [open $path(test1)]
    chan configure $in -buffersize 8 -translation lf -eofchar a
    set out [open $path(test2) w]
    fcopy $in $out
    close $in
    close $out
    file size $path(test2)
} 0
test io-52.17 {coverage of eofChar handling} {
    file delete $path(test1) $path(test2)
    set out [open $path(test1) wb]
    chan configure $out -translation lf
    puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
    close $out
    set in [open $path(test1)]
    chan configure $in -buffersize 8 -translation lf -eofchar d
    set out [open $path(test2) w]
    fcopy $in $out
    close $in
    close $out
    file size $path(test2)
} 3
test io-52.18 {coverage of eofChar handling} {
    file delete $path(test1) $path(test2)
    set out [open $path(test1) wb]
    chan configure $out -translation lf
    puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
    close $out
    set in [open $path(test1)]
    chan configure $in -buffersize 8 -translation crlf -eofchar h
    set out [open $path(test2) w]
    fcopy $in $out
    close $in
    close $out
    file size $path(test2)
} 8
test io-52.19 {coverage of eofChar handling} {
    file delete $path(test1) $path(test2)
    set out [open $path(test1) wb]
    chan configure $out -translation lf
    puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
    close $out
    set in [open $path(test1)]
    chan configure $in -buffersize 10 -translation crlf -eofchar h
    set out [open $path(test2) w]
    fcopy $in $out
    close $in
    close $out
    file size $path(test2)
} 8

test io-53.1 {CopyData} {fcopy} {
    file delete $path(test1)
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation cr -blocking 0
6819
6820
6821
6822
6823
6824
6825
6826
6827
6828
6829
6830
6831
6832
6833
6834
6835
6836
6837
6838
6839
6840
6841
6842
6843
6844
6845
6846
6847
6848
6849
6850
6851
} "ready line1 line2 {done\n}"
test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileevent fcopy} {
    set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
    variable x
    for {set x 0} {$x < 12} {incr x} {
	append big $big
    }
    file delete $path(test1)
    file delete $path(pipe)
    set f1 [open $path(pipe) w]
    puts $f1 {
	puts ready
	fcopy stdin stdout -command { set x }
	vwait x
	set f [open $path(test1) w]
	fconfigure $f -translation lf
	puts $f "done"
	close $f
    }
    close $f1
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    set result [gets $f1]
    fconfigure $f1 -blocking 0
    puts $f1 $big
    flush $f1
    after 500
    set result ""
    fileevent $f1 read [namespace code {
	append result [read $f1 1024]
	if {[string length $result] >= [string length $big]} {
	    set x done
	}
    }]







<






<
<
<
<







<







7173
7174
7175
7176
7177
7178
7179

7180
7181
7182
7183
7184
7185




7186
7187
7188
7189
7190
7191
7192

7193
7194
7195
7196
7197
7198
7199
} "ready line1 line2 {done\n}"
test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileevent fcopy} {
    set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
    variable x
    for {set x 0} {$x < 12} {incr x} {
	append big $big
    }

    file delete $path(pipe)
    set f1 [open $path(pipe) w]
    puts $f1 {
	puts ready
	fcopy stdin stdout -command { set x }
	vwait x




    }
    close $f1
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    set result [gets $f1]
    fconfigure $f1 -blocking 0
    puts $f1 $big
    flush $f1

    set result ""
    fileevent $f1 read [namespace code {
	append result [read $f1 1024]
	if {[string length $result] >= [string length $big]} {
	    set x done
	}
    }]
7219
7220
7221
7222
7223
7224
7225



















7226
7227
7228
7229
7230
7231
7232
    set done
} -cleanup {
    close $outChan
    close $inChan
    removeFile out
    removeFile in
} -result {40 bytes copied}




















test io-54.1 {Recursive channel events} {socket fileevent} {
    # This test checks to see if file events are delivered during recursive
    # event loops when there is buffered data on the channel.

    proc accept {s a p} {
	variable as







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







7567
7568
7569
7570
7571
7572
7573
7574
7575
7576
7577
7578
7579
7580
7581
7582
7583
7584
7585
7586
7587
7588
7589
7590
7591
7592
7593
7594
7595
7596
7597
7598
7599
    set done
} -cleanup {
    close $outChan
    close $inChan
    removeFile out
    removeFile in
} -result {40 bytes copied}
test io-53.12 {CopyData: foreground short reads, aka bug 3096275} {stdio unix openpipe fcopy} {
    file delete $path(pipe)
    set f1 [open $path(pipe) w]
    puts -nonewline $f1 {
	fconfigure stdin -translation binary -blocking 0
	fconfigure stdout -buffering none -translation binary
	fcopy stdin stdout
    }
    close $f1
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    fconfigure $f1 -translation binary -buffering none
    puts -nonewline $f1 A
    after 2000 {set ::done timeout}
    fileevent $f1 readable {set ::done ok}
    vwait ::done
    set ch [read $f1 1]
    close $f1
    list $::done $ch
} {ok A}

test io-54.1 {Recursive channel events} {socket fileevent} {
    # This test checks to see if file events are delivered during recursive
    # event loops when there is buffered data on the channel.

    proc accept {s a p} {
	variable as
Changes to tests/ioCmd.test.
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
    list [catch {fcopy $wfile $wfile} msg] $msg
} "1 {channel \"$wfile\" wasn't opened for reading}"
test iocmd-15.9 {Tcl_FcopyObjCmd} {fcopy} {
    list [catch {fcopy $rfile $rfile} msg] $msg
} "1 {channel \"$rfile\" wasn't opened for writing}"
test iocmd-15.10 {Tcl_FcopyObjCmd} {fcopy} {
    list [catch {fcopy $rfile $wfile foo bar} msg] $msg
} {1 {bad switch "foo": must be -size or -command}}
test iocmd-15.11 {Tcl_FcopyObjCmd} {fcopy} {
    list [catch {fcopy $rfile $wfile -size foo} msg] $msg
} {1 {expected integer but got "foo"}}
test iocmd-15.12 {Tcl_FcopyObjCmd} {fcopy} {
    list [catch {fcopy $rfile $wfile -command bar -size foo} msg] $msg
} {1 {expected integer but got "foo"}}








|







635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
    list [catch {fcopy $wfile $wfile} msg] $msg
} "1 {channel \"$wfile\" wasn't opened for reading}"
test iocmd-15.9 {Tcl_FcopyObjCmd} {fcopy} {
    list [catch {fcopy $rfile $rfile} msg] $msg
} "1 {channel \"$rfile\" wasn't opened for writing}"
test iocmd-15.10 {Tcl_FcopyObjCmd} {fcopy} {
    list [catch {fcopy $rfile $wfile foo bar} msg] $msg
} {1 {bad option "foo": must be -size or -command}}
test iocmd-15.11 {Tcl_FcopyObjCmd} {fcopy} {
    list [catch {fcopy $rfile $wfile -size foo} msg] $msg
} {1 {expected integer but got "foo"}}
test iocmd-15.12 {Tcl_FcopyObjCmd} {fcopy} {
    list [catch {fcopy $rfile $wfile -command bar -size foo} msg] $msg
} {1 {expected integer but got "foo"}}

789
790
791
792
793
794
795




















































































796
797
798
799
800
801
802
    lappend res [file channel rc*]
    lappend res [catch {chan create {r w} foo} msg]
    lappend res $msg
    lappend res [file channel rc*]
    rename foo {}
    set res
} -result {{} {initialize rc* {read write}} 1 {*all required methods*} {}}





















































































# --- --- --- --------- --------- ---------
# Helper commands to record the arguments to handler methods.

# Stored in a script so that the threads and interpreters needing this
# code do not need their own copy but can access this variable.








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
    lappend res [file channel rc*]
    lappend res [catch {chan create {r w} foo} msg]
    lappend res $msg
    lappend res [file channel rc*]
    rename foo {}
    set res
} -result {{} {initialize rc* {read write}} 1 {*all required methods*} {}}
test iocmd-21.20 {Bug 88aef05cda} -setup {
    proc foo {method chan args} {
	switch -- $method blocking {
	    chan configure $chan -blocking [lindex $args 0]
	    return
	} initialize {
	    return {initialize finalize watch blocking read write
		    configure cget cgetall}
	} finalize {
	    return
	}
    }
    set ch [chan create {read write} foo]
} -body {
    list [catch {chan configure $ch -blocking 0} m] $m
} -cleanup {
    close $ch
    rename foo {}
} -match glob -result {1 {*nested eval*}}
test iocmd-21.21 {[close] in [read] segfaults} -setup {
    proc foo {method chan args} {
	switch -- $method initialize {
	    return {initialize finalize watch read}
	} finalize {} watch {} read {
	    close $chan
	    return a
	}
    }
    set ch [chan create read foo]
} -body {
    read $ch 0
} -cleanup {
    close $ch
    rename foo {}
} -result {}
test iocmd-21.22 {[close] in [read] segfaults} -setup {
    proc foo {method chan args} {
	switch -- $method initialize {
	    return {initialize finalize watch read}
	} finalize {} watch {} read {
	    catch {close $chan}
	    return a
	}
    }
    set ch [chan create read foo]
} -body {
    read $ch 1
} -returnCodes error -cleanup {
    catch {close $ch}
    rename foo {}
} -match glob -result {*invalid argument*}
test iocmd-21.23 {[close] in [gets] segfaults} -setup {
    proc foo {method chan args} {
	switch -- $method initialize {
	    return {initialize finalize watch read}
	} finalize {} watch {} read {
	    catch {close $chan}
	    return \n
	}
    }
    set ch [chan create read foo]
} -body {
    gets $ch
} -cleanup {
    catch {close $ch}
    rename foo {}
} -result {}
test iocmd-21.24 {[close] in binary [gets] segfaults} -setup {
    proc foo {method chan args} {
	switch -- $method initialize {
	    return {initialize finalize watch read}
	} finalize {} watch {} read {
	    catch {close $chan}
	    return \n
	}
    }
    set ch [chan create read foo]
} -body {
    chan configure $ch -translation binary
    gets $ch
} -cleanup {
    catch {close $ch}
    rename foo {}
} -result {}

# --- --- --- --------- --------- ---------
# Helper commands to record the arguments to handler methods.

# Stored in a script so that the threads and interpreters needing this
# code do not need their own copy but can access this variable.

1047
1048
1049
1050
1051
1052
1053














1054
1055
1056
1057
1058
1059
1060
    note [eof $c]
    set res
} -cleanup {
    close $c
    rename foo {}
    unset res
} -result {{read rc* 4096} {} 0}















# --- === *** ###########################
# method write

test iocmd-24.1 {chan write, regular write} -match glob -body {
    set res {}
    proc foo {args} {







>
>
>
>
>
>
>
>
>
>
>
>
>
>







1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
    note [eof $c]
    set res
} -cleanup {
    close $c
    rename foo {}
    unset res
} -result {{read rc* 4096} {} 0}
test iocmd-23.11 {chan read, close pulls the rug out} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	set args [lassign $args sub id]
	if {$sub ne "read"} {return}
	close $id
	return {}
    }
    set c [chan create {r} foo]
    note [read $c]
    rename foo {}
    set res
} -result {{read rc* 4096} {}}

# --- === *** ###########################
# method write

test iocmd-24.1 {chan write, regular write} -match glob -body {
    set res {}
    proc foo {args} {
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983

1984
1985
1986
1987

1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013

    # Set up channel in thread
    set chan [interp eval $ida $helperscript]
    set chan [interp eval $ida {
	proc foo {args} {
	    oninit; onfinal; track;
	    # destroy interpreter during channel access
	    # Actually not possible for an interp to destroy itself.
	    interp delete {}
	    return}

	set chan [chan create {r w} foo]
	fconfigure $chan -buffering none
	set chan
    }]


    # Move channel to 2nd thread.
    interp eval $ida [list testchannel cut    $chan]
    interp eval $idb [list testchannel splice $chan]

    # Run access from interpreter B, this will give us a synchronous
    # response.

    interp eval $idb [list set chan $chan]
    set res [interp eval $idb {
	# wait a bit, give the main thread the time to start its event
	# loop to wait for the response from B
	after 2000
	catch { puts $chan shoo } res
	set res
    }]
    set res
} -constraints {testchannel impossible} \
    -result {Owner lost}

test iocmd-32.2 {delete interp of reflected chan} {
    # Bug 3034840
    # Run this test in an interp with memory debugging to panic
    # on the double free
    interp create slave
    slave eval {







<
<
|
>




>

















|
<







2072
2073
2074
2075
2076
2077
2078


2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103

2104
2105
2106
2107
2108
2109
2110

    # Set up channel in thread
    set chan [interp eval $ida $helperscript]
    set chan [interp eval $ida {
	proc foo {args} {
	    oninit; onfinal; track;
	    # destroy interpreter during channel access


	    suicide
	}
	set chan [chan create {r w} foo]
	fconfigure $chan -buffering none
	set chan
    }]
    interp alias $ida suicide {} interp delete $ida

    # Move channel to 2nd thread.
    interp eval $ida [list testchannel cut    $chan]
    interp eval $idb [list testchannel splice $chan]

    # Run access from interpreter B, this will give us a synchronous
    # response.

    interp eval $idb [list set chan $chan]
    set res [interp eval $idb {
	# wait a bit, give the main thread the time to start its event
	# loop to wait for the response from B
	after 2000
	catch { puts $chan shoo } res
	set res
    }]
    set res
} -constraints {testchannel} -result {Owner lost}


test iocmd-32.2 {delete interp of reflected chan} {
    # Bug 3034840
    # Run this test in an interp with memory debugging to panic
    # on the double free
    interp create slave
    slave eval {
2722
2723
2724
2725
2726
2727
2728

2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739

    LOG MAIN_WAITING
    vwait forever
    LOG MAIN_DONE

    set res
} -cleanup {

    rename LOG {}
    rename POST {}
    rename HANDLER {}
    unset beat drive data forever res tid ch
} -match glob \
    -result {{initialize rc* read} {watch rc* read} {read rc* 4096} {watch rc* {}} {watch rc* read} {read rc* 4096} {watch rc* {}} {finalize rc*}}

# --- === *** ###########################
# method cgetall

test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body {







>



|







2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837

    LOG MAIN_WAITING
    vwait forever
    LOG MAIN_DONE

    set res
} -cleanup {
    after cancel $::timer
    rename LOG {}
    rename POST {}
    rename HANDLER {}
    unset beat drive data forever res tid ch timer
} -match glob \
    -result {{initialize rc* read} {watch rc* read} {read rc* 4096} {watch rc* {}} {watch rc* read} {read rc* 4096} {watch rc* {}} {finalize rc*}}

# --- === *** ###########################
# method cgetall

test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body {
Changes to tests/ioTrans.test.
535
536
537
538
539
540
541
542







































543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
    set c [chan push [set c [tempchan]] [list foo $c]]
    lappend res [read $c]
    #lappend res [gets $c]
} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* {test data
}} file*}







































test iortrans-4.9 {chan read, gets, bug 2921116} -setup {
    set res {}
} -match glob -body {
    proc foo {fd args} {
	handle.initialize
	handle.finalize
	lappend ::res $args
	# Kill and recreate transform while it is operating
	chan pop $fd
	chan push $fd [list foo $fd]
    }
    set c [chan push [set c [tempchan]] [list foo $c]]
    lappend res [gets $c]
} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* {test data
}} file*}

# --- === *** ###########################
# method write (via puts)

test iortrans-5.1 {chan write, regular write} -setup {
    set res {}
} -match glob -body {







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

















|







535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
    set c [chan push [set c [tempchan]] [list foo $c]]
    lappend res [read $c]
    #lappend res [gets $c]
} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* {test data
}} {}}
test iortrans-4.8.1 {chan read, bug 721ec69271} -setup {
    set res {}
} -match glob -body {
    proc foo {fd args} {
	handle.initialize
	handle.finalize
	lappend ::res $args
	# Kill and recreate transform while it is operating
	chan pop $fd
	chan push $fd [list foo $fd]
    }
    set c [chan push [set c [tempchan]] [list foo $c]]
    chan configure $c -buffersize 2
    lappend res [read $c]
} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* te} {read rt* st} {read rt* { d}} {read rt* at} {read rt* {a
}} {}}
test iortrans-4.8.2 {chan read, bug 721ec69271} -setup {
    set res {}
} -match glob -body {
    proc foo {fd args} {
	handle.initialize
	handle.finalize
	lappend ::res $args
	# Kill and recreate transform while it is operating
	chan pop $fd
	chan push $fd [list foo $fd]
	return x
    }
    set c [chan push [set c [tempchan]] [list foo $c]]
    chan configure $c -buffersize 1
    lappend res [read $c]
} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* t} {read rt* e} {read rt* s} {read rt* t} {read rt* { }} {read rt* d} {read rt* a} {read rt* t} {read rt* a} {read rt* {
}} {}}
test iortrans-4.9 {chan read, gets, bug 2921116} -setup {
    set res {}
} -match glob -body {
    proc foo {fd args} {
	handle.initialize
	handle.finalize
	lappend ::res $args
	# Kill and recreate transform while it is operating
	chan pop $fd
	chan push $fd [list foo $fd]
    }
    set c [chan push [set c [tempchan]] [list foo $c]]
    lappend res [gets $c]
} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* {test data
}} {}}

# --- === *** ###########################
# method write (via puts)

test iortrans-5.1 {chan write, regular write} -setup {
    set res {}
} -match glob -body {
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009

1010
1011
1012
1013

1014
1015
1016
1017
1018
1019
1020
} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup {
    set ida [interp create];	#puts <<$ida>>
    set idb [interp create];	#puts <<$idb>>
    # Magic to get the test* commands in the slaves
    load {} Tcltest $ida
    load {} Tcltest $idb
} -constraints {testchannel impossible} -match glob -body {
    # Set up channel in thread
    set chan [interp eval $ida $helperscript]
    set chan [interp eval $ida {
	proc foo {args} {
	    handle.initialize clear drain flush limit? read write
	    handle.finalize
	    lappend ::res $args
	    # Destroy interpreter during channel access.  Actually not
	    # possible for an interp to destroy itself.
	    interp delete {}
	    return}

	set chan [chan push [tempchan] foo]
	fconfigure $chan -buffering none
	set chan
    }]

    # Move channel to 2nd thread, transform goes with it.
    interp eval $ida [list testchannel cut $chan]
    interp eval $idb [list testchannel splice $chan]
    # Run access from interpreter B, this will give us a synchronous response.
    interp eval $idb [list set chan $chan]
    interp eval $idb [list set mid $tcltest::mainThread]
    set res [interp eval $idb {







|







|
<
<
|
>




>







1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045


1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup {
    set ida [interp create];	#puts <<$ida>>
    set idb [interp create];	#puts <<$idb>>
    # Magic to get the test* commands in the slaves
    load {} Tcltest $ida
    load {} Tcltest $idb
} -constraints {testchannel} -match glob -body {
    # Set up channel in thread
    set chan [interp eval $ida $helperscript]
    set chan [interp eval $ida {
	proc foo {args} {
	    handle.initialize clear drain flush limit? read write
	    handle.finalize
	    lappend ::res $args
	    # Destroy interpreter during channel access.


	    suicide
	}
	set chan [chan push [tempchan] foo]
	fconfigure $chan -buffering none
	set chan
    }]
    interp alias $ida suicide {} interp delete $ida
    # Move channel to 2nd thread, transform goes with it.
    interp eval $ida [list testchannel cut $chan]
    interp eval $idb [list testchannel splice $chan]
    # Run access from interpreter B, this will give us a synchronous response.
    interp eval $idb [list set chan $chan]
    interp eval $idb [list set mid $tcltest::mainThread]
    set res [interp eval $idb {
Changes to tests/iogt.test.
215
216
217
218
219
220
221






























222
223
224
225
226
227
228

    #catch {puts stdout "\t>* $res" ; flush stdout}
    #catch {puts stdout "x$res"} msg

    lappend trail [list $op $data $res]
    return $res
}































proc counter {var op data} {
    namespace upvar [namespace current] $var n

    switch -- $op {
	create/write - create/read - delete/write - delete/read - clear_read {
	    #ignore







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258

    #catch {puts stdout "\t>* $res" ; flush stdout}
    #catch {puts stdout "x$res"} msg

    lappend trail [list $op $data $res]
    return $res
}

proc id_torture {chan op data} {
    switch -- $op {
	create/write -
	create/read  -
	delete/write -
	delete/read  -
	clear_read   {;#ignore}
	flush/write -
	flush/read  {}
	write       {
	    global level
	    if {$level} {
		return
	    }
	    incr level
	    testchannel unstack $chan
	    testchannel transform $chan \
		-command [namespace code [list id_torture $chan]]
	    return $data
	}
	read        {
	    testchannel unstack $chan
	    testchannel transform $chan \
		-command [namespace code [list id_torture $chan]]
	    return $data
	}
	query/maxRead {return -1}
    }
}

proc counter {var op data} {
    namespace upvar [namespace current] $var n

    switch -- $op {
	create/write - create/read - delete/write - delete/read - clear_read {
	    #ignore
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
    }

    lappend trail [list counter:$op $data $res]
    return $res
}

proc rblocks {var vtrail n op data} {
    namespace upvar [namespace current] $var n $vtrail trail

    set res {}

    switch -- $op {
	create/write - create/read - delete/write - delete/read - clear_read {
	    set buf {}
	}







|







306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
    }

    lappend trail [list counter:$op $data $res]
    return $res
}

proc rblocks {var vtrail n op data} {
    namespace upvar [namespace current] $var buf $vtrail trail

    set res {}

    switch -- $op {
	create/write - create/read - delete/write - delete/read - clear_read {
	    set buf {}
	}
322
323
324
325
326
327
328





329
330
331
332
333
334
335
}
proc audit_ops {var -attach channel} {
    testchannel transform $channel -command [namespace code [list id_optrail $var]]
}
proc audit_flow {var -attach channel} {
    testchannel transform $channel -command [namespace code [list id_fulltrail $var]]
}





proc stopafter {var n -attach channel} {
    namespace upvar [namespace current] $var vn
    set vn $n
    testchannel transform $channel -command [namespace code [list counter $var]]
}
proc stopafter_audit {var trail n -attach channel} {
    namespace upvar [namespace current] $var vn







>
>
>
>
>







352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
}
proc audit_ops {var -attach channel} {
    testchannel transform $channel -command [namespace code [list id_optrail $var]]
}
proc audit_flow {var -attach channel} {
    testchannel transform $channel -command [namespace code [list id_fulltrail $var]]
}

proc torture {-attach channel} {
    testchannel transform $channel -command [namespace code [list id_torture $channel]]
}

proc stopafter {var n -attach channel} {
    namespace upvar [namespace current] $var vn
    set vn $n
    testchannel transform $channel -command [namespace code [list counter $var]]
}
proc stopafter_audit {var trail n -attach channel} {
    namespace upvar [namespace current] $var vn
441
442
443
444
445
446
447

448
449
450
451
452
453
454
read
query/maxRead
read
query/maxRead
read
query/maxRead
flush/read

delete/read
--------
create/write
write
write
write
write







>







476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
read
query/maxRead
read
query/maxRead
read
query/maxRead
flush/read
query/maxRead
delete/read
--------
create/write
write
write
write
write
487
488
489
490
491
492
493

494
495
496
497
498
499
500
read %^&*()_+-= %^&*()_+-=
query/maxRead {} -1
read {
} {
}
query/maxRead {} -1
flush/read {} {}

delete/read {} *ignored*
--------
create/write {} *ignored*
write abcdefghij abcdefghij
write klmnopqrst klmnopqrst
write uvwxyz0123 uvwxyz0123
write 456789,./? 456789,./?







>







523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
read %^&*()_+-= %^&*()_+-=
query/maxRead {} -1
read {
} {
}
query/maxRead {} -1
flush/read {} {}
query/maxRead {} -1
delete/read {} *ignored*
--------
create/write {} *ignored*
write abcdefghij abcdefghij
write klmnopqrst klmnopqrst
write uvwxyz0123 uvwxyz0123
write 456789,./? 456789,./?
538
539
540
541
542
543
544

545
546
547



















548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563

564
565
566
567
568
569
570
}
query/maxRead {} -1
flush/read {} {}
write %^&*()_+-= %^&*()_+-=
write {
} {
}

delete/read {} *ignored*
flush/write {} {}
delete/write {} *ignored*}




















test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup {
    proc DoneCopy {n {err {}}} {
	variable copy 1
    }
} -constraints {testchannel hangs} -body {
    # This test to check the validity of aquired Tcl_Channel references is not
    # possible because even a backgrounded fcopy will immediately start to
    # copy data, without waiting for the event loop. This is done only in case
    # of an underflow on the read size!. So stacking transforms after the
    # fcopy will miss information, or are not used at all.
    #
    # I was able to circumvent this by using the echo.tcl server with a big
    # delay, causing the fcopy to underflow immediately.
    set fin [open $path(dummy) r]
    fevent 1000 500 {20 20 20 10 1 1} {

	close $fin
	set fout [open dummyout w]
	flush $sock;	# now, or fcopy will error us out
	# But the 1 second delay should be enough to initialize everything
	# else here.
	fcopy $sock $fout -command [namespace code DoneCopy]
	# Transform after fcopy got its handles!  They should be still valid







>



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





|










>







575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
}
query/maxRead {} -1
flush/read {} {}
write %^&*()_+-= %^&*()_+-=
write {
} {
}
query/maxRead {} -1
delete/read {} *ignored*
flush/write {} {}
delete/write {} *ignored*}

test iogt-2.4 {basic I/O, mixed trail} {testchannel} {
    set fh [open $path(dummy) r]
    torture -attach $fh
    chan configure $fh -buffersize 2
    set x [read $fh]
    testchannel unstack $fh
    close   $fh
    set x
} {}
test iogt-2.5 {basic I/O, mixed trail} {testchannel} {
    set ::level 0
    set fh [open $path(dummyout) w]
    torture -attach $fh
    puts -nonewline $fh abcdef
    flush $fh
    testchannel unstack $fh
    close   $fh
} {}

test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup {
    proc DoneCopy {n {err {}}} {
	variable copy 1
    }
} -constraints {testchannel knownBug} -body {
    # This test to check the validity of aquired Tcl_Channel references is not
    # possible because even a backgrounded fcopy will immediately start to
    # copy data, without waiting for the event loop. This is done only in case
    # of an underflow on the read size!. So stacking transforms after the
    # fcopy will miss information, or are not used at all.
    #
    # I was able to circumvent this by using the echo.tcl server with a big
    # delay, causing the fcopy to underflow immediately.
    set fin [open $path(dummy) r]
    fevent 1000 500 {20 20 20 10 1 1} {
	variable copy
	close $fin
	set fout [open dummyout w]
	flush $sock;	# now, or fcopy will error us out
	# But the 1 second delay should be enough to initialize everything
	# else here.
	fcopy $sock $fout -command [namespace code DoneCopy]
	# Transform after fcopy got its handles!  They should be still valid
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606

607
608
609
610
611
612
613








614
615
616
617
618
619
620
621

622
623
624
625
626
627
628
    set data [read $fin]
    close $fin
    set trail [list]
    set got [list]
    proc Done {args} {
	variable stop 1
    }
} -constraints {testchannel hangs} -body {
    fevent 1000 500 {20 20 20 10 1} {
	audit_flow trail -attach $sock
	rblocks_t rbuf trail 23 -attach $sock
	fileevent $sock readable [namespace code {
	    if {[eof $sock]} {
		Done
		lappend trail "xxxxxxxxxxxxx"
		close $sock
	    } else {

		lappend trail "vvvvvvvvvvvvv"
		lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]"
		lappend trail "============="
		#puts stdout $__; flush stdout
		#read $sock
	    }
	}]








	flush $sock;		# Now, or fcopy will error us out
	# But the 1 second delay should be enough to initialize everything
	# else here.
	vwait [namespace which -variable stop]
    } $data
    join [list [join $got \n] ~~~~~~~~ [join $trail \n]] \n
} -cleanup {
    rename Done {}

} -result {[[]]
[[abcdefghijklmnopqrstuvw]]
[[xyz0123456789,./?><;'\|]]
[[]]
[[]]
[[":[]\}\{`~!@#$%^&*()]]
[[]]







<
<
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>








>







648
649
650
651
652
653
654


655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
    set data [read $fin]
    close $fin
    set trail [list]
    set got [list]
    proc Done {args} {
	variable stop 1
    }


    proc Get {sock} {
        variable trail
        variable got
        if {[eof $sock]} {
            Done
            lappend trail "xxxxxxxxxxxxx"
            close $sock
            return
        }
        lappend trail "vvvvvvvvvvvvv"
        lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]"
        lappend trail "============="
        #puts stdout $__ ; flush stdout
        #read $sock
    }

} -constraints {testchannel knownBug} -body {
    fevent 1000 500 {20 20 20 10 1} {
	variable stop
	audit_flow trail -attach $sock
	rblocks_t rbuf trail 23 -attach $sock

	fileevent $sock readable [namespace code [list Get $sock]]

	flush $sock;		# Now, or fcopy will error us out
	# But the 1 second delay should be enough to initialize everything
	# else here.
	vwait [namespace which -variable stop]
    } $data
    join [list [join $got \n] ~~~~~~~~ [join $trail \n]] \n
} -cleanup {
    rename Done {}
    rename Get {}
} -result {[[]]
[[abcdefghijklmnopqrstuvw]]
[[xyz0123456789,./?><;'\|]]
[[]]
[[]]
[[":[]\}\{`~!@#$%^&*()]]
[[]]
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
delete/write {} *ignored*
delete/read {} *ignored*};	# catch unescaped quote "

test iogt-5.0 {EOF simulation} -setup {
    set fin [open $path(dummy) r]
    set fout [open $path(dummyout) w]
    set trail [list]
} -constraints {testchannel unknownFailure} -result {
    audit_flow trail -attach $fin
    stopafter_audit d trail 20 -attach $fin
    audit_flow trail -attach $fout
    fconfigure $fin -buffersize 20
    fconfigure $fout -buffersize 10
    fcopy $fin $fout
    testchannel unstack $fin







|







768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
delete/write {} *ignored*
delete/read {} *ignored*};	# catch unescaped quote "

test iogt-5.0 {EOF simulation} -setup {
    set fin [open $path(dummy) r]
    set fout [open $path(dummyout) w]
    set trail [list]
} -constraints {testchannel knownBug} -result {
    audit_flow trail -attach $fin
    stopafter_audit d trail 20 -attach $fin
    audit_flow trail -attach $fout
    fconfigure $fin -buffersize 20
    fconfigure $fout -buffersize 10
    fcopy $fin $fout
    testchannel unstack $fin
781
782
783
784
785
786
787









788
789
790
791
792
793
794
    # directly from the buffer without bothering to consult the newly stacked
    # transformation. This is wrong.
    read $f 3
} -cleanup {
    close $f
} -result {xxx}
test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body {









    set f [open $path(dummy) r]
    # contents of dummy = "abcdefghi..."
    read $f 3;		# skip behind "abc"
    constx -attach $f
    set res [read $f 3]
    testchannel unstack $f
    append res [read $f 3]







>
>
>
>
>
>
>
>
>







847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
    # directly from the buffer without bothering to consult the newly stacked
    # transformation. This is wrong.
    read $f 3
} -cleanup {
    close $f
} -result {xxx}
test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body {

    # This test demonstrates the bug/misfeature in the stacked
    # channel implementation that data can be discarded if it is
    # read into the buffers of one channel in the stack, and then
    # that channel is popped before anything above it reads.
    #
    # This bug can be worked around by always setting -buffersize
    # to 1, but who wants to do that?

    set f [open $path(dummy) r]
    # contents of dummy = "abcdefghi..."
    read $f 3;		# skip behind "abc"
    constx -attach $f
    set res [read $f 3]
    testchannel unstack $f
    append res [read $f 3]
Changes to tests/namespace.test.
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
    }
    namespace eval test_ns_import {
        namespace import ::test_ns_export::*
        proc p {} {return [cmd1 123]}
    }
    test_ns_import::p
} {cmd1: 123}
test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} {
    list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg
} {0 {}}
test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} {
    namespace eval test_ns_import {
        namespace import -force ::test_ns_export::*
        cmd1 555
    }







|







299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
    }
    namespace eval test_ns_import {
        namespace import ::test_ns_export::*
        proc p {} {return [cmd1 123]}
    }
    test_ns_import::p
} {cmd1: 123}
test namespace-9.5 {Tcl_Import, RFE 1230597} {
    list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg
} {0 {}}
test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} {
    namespace eval test_ns_import {
        namespace import -force ::test_ns_export::*
        cmd1 555
    }
2945
2946
2947
2948
2949
2950
2951




2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
	set end [getbytes]
    }
    set leakedBytes [expr {$end - $start}]
} -cleanup {
    rename getbytes {}
    unset i ns start end
} -result 0





# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
namespace delete {*}[namespace children :: test_ns_*]
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:







>
>
>
>













2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
	set end [getbytes]
    }
    set leakedBytes [expr {$end - $start}]
} -cleanup {
    rename getbytes {}
    unset i ns start end
} -result 0

test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a01} {
    info class [format %s constructor] oo::object
} ""

# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
namespace delete {*}[namespace children :: test_ns_*]
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:
Changes to tests/obj.test.
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
    set x 0x8000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {1 2147483648}
test obj-33.2 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x 0xffff; append x ffff
    list [string is integer $x] [expr { wide($x) }]
} {1 4294967295}
test obj-33.3 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x 0x10000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {0 4294967296}
test obj-33.4 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x -0x8000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {1 -2147483648}
test obj-33.5 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x -0x8000; append x 0001
    list [string is integer $x] [expr { wide($x) }]
} {1 -2147483649}
test obj-33.6 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x -0xffff; append x ffff
    list [string is integer $x] [expr { wide($x) }]
} {1 -4294967295}
test obj-33.7 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x -0x10000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {0 -4294967296}

if {[testConstraint testobj]} {
    testobj freeallvars
}

# cleanup
::tcltest::cleanupTests
return







|















|











601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
    set x 0x8000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {1 2147483648}
test obj-33.2 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x 0xffff; append x ffff
    list [string is integer $x] [expr { wide($x) }]
} {1 4294967295}
test obj-33.3 {integer overflow on input} {
    set x 0x10000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {0 4294967296}
test obj-33.4 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x -0x8000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {1 -2147483648}
test obj-33.5 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x -0x8000; append x 0001
    list [string is integer $x] [expr { wide($x) }]
} {1 -2147483649}
test obj-33.6 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x -0xffff; append x ffff
    list [string is integer $x] [expr { wide($x) }]
} {1 -4294967295}
test obj-33.7 {integer overflow on input} {
    set x -0x10000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {0 -4294967296}

if {[testConstraint testobj]} {
    testobj freeallvars
}

# cleanup
::tcltest::cleanupTests
return
Changes to tests/regexp.test.
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
    regexp .*d e
    regexp .*e f
    regexp .*e xe
} 1

test regexp-6.1 {regexp errors} {
    list [catch {regexp a} msg] $msg
} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexp-6.2 {regexp errors} {
    list [catch {regexp -nocase a} msg] $msg
} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexp-6.3 {regexp errors} {
    list [catch {regexp -gorp a} msg] $msg
} {1 {bad switch "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexp-6.4 {regexp errors} {
    list [catch {regexp a( b} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexp-6.5 {regexp errors} {
    list [catch {regexp a( b} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexp-6.6 {regexp errors} {







|


|


|







237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
    regexp .*d e
    regexp .*e f
    regexp .*e xe
} 1

test regexp-6.1 {regexp errors} {
    list [catch {regexp a} msg] $msg
} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexp-6.2 {regexp errors} {
    list [catch {regexp -nocase a} msg] $msg
} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexp-6.3 {regexp errors} {
    list [catch {regexp -gorp a} msg] $msg
} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexp-6.4 {regexp errors} {
    list [catch {regexp a( b} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexp-6.5 {regexp errors} {
    list [catch {regexp a( b} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexp-6.6 {regexp errors} {
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
test regexp-10.5 {inverse partial newline sensitivity in regsub} {
    set foo xxx
    list [regsub -linestop {a.*b} "da\nbaxyb\nxb" 123 foo] $foo
} "1 {da\nb123\nxb}"

test regexp-11.1 {regsub errors} {
    list [catch {regsub a b} msg] $msg
} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
test regexp-11.2 {regsub errors} {
    list [catch {regsub -nocase a b} msg] $msg
} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
test regexp-11.3 {regsub errors} {
    list [catch {regsub -nocase -all a b} msg] $msg
} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
test regexp-11.4 {regsub errors} {
    list [catch {regsub a b c d e f} msg] $msg
} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
test regexp-11.5 {regsub errors} {
    list [catch {regsub -gorp a b c} msg] $msg
} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
test regexp-11.6 {regsub errors} {
    list [catch {regsub -nocase a( b c d} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexp-11.7 {regsub errors} -setup {
    unset -nocomplain f1
} -body {
    set f1 44







|


|


|


|


|







437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
test regexp-10.5 {inverse partial newline sensitivity in regsub} {
    set foo xxx
    list [regsub -linestop {a.*b} "da\nbaxyb\nxb" 123 foo] $foo
} "1 {da\nb123\nxb}"

test regexp-11.1 {regsub errors} {
    list [catch {regsub a b} msg] $msg
} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.2 {regsub errors} {
    list [catch {regsub -nocase a b} msg] $msg
} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.3 {regsub errors} {
    list [catch {regsub -nocase -all a b} msg] $msg
} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.4 {regsub errors} {
    list [catch {regsub a b c d e f} msg] $msg
} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.5 {regsub errors} {
    list [catch {regsub -gorp a b c} msg] $msg
} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
test regexp-11.6 {regsub errors} {
    list [catch {regsub -nocase a( b c d} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexp-11.7 {regsub errors} -setup {
    unset -nocomplain f1
} -body {
    set f1 44
Changes to tests/regexpComp.test.
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
    }
} 1

test regexpComp-6.1 {regexp errors} {
    evalInProc {
	list [catch {regexp a} msg] $msg
    }
} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexpComp-6.2 {regexp errors} {
    evalInProc {
	list [catch {regexp -nocase a} msg] $msg
    }
} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexpComp-6.3 {regexp errors} {
    evalInProc {
	list [catch {regexp -gorp a} msg] $msg
    }
} {1 {bad switch "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexpComp-6.4 {regexp errors} {
    evalInProc {
	list [catch {regexp a( b} msg] $msg
    }
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexpComp-6.5 {regexp errors} {
    evalInProc {







|




|




|







312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
    }
} 1

test regexpComp-6.1 {regexp errors} {
    evalInProc {
	list [catch {regexp a} msg] $msg
    }
} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexpComp-6.2 {regexp errors} {
    evalInProc {
	list [catch {regexp -nocase a} msg] $msg
    }
} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexpComp-6.3 {regexp errors} {
    evalInProc {
	list [catch {regexp -gorp a} msg] $msg
    }
} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexpComp-6.4 {regexp errors} {
    evalInProc {
	list [catch {regexp a( b} msg] $msg
    }
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexpComp-6.5 {regexp errors} {
    evalInProc {
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
    }
} "1 {da\nb123\nxb}"

test regexpComp-11.1 {regsub errors} {
    evalInProc {
	list [catch {regsub a b} msg] $msg
    }
} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
test regexpComp-11.2 {regsub errors} {
    evalInProc {
	list [catch {regsub -nocase a b} msg] $msg
    }
} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
test regexpComp-11.3 {regsub errors} {
    evalInProc {
	list [catch {regsub -nocase -all a b} msg] $msg
    }
} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
test regexpComp-11.4 {regsub errors} {
    evalInProc {
	list [catch {regsub a b c d e f} msg] $msg
    }
} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
test regexpComp-11.5 {regsub errors} {
    evalInProc {
	list [catch {regsub -gorp a b c} msg] $msg
    }
} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
test regexpComp-11.6 {regsub errors} {
    evalInProc {
	list [catch {regsub -nocase a( b c d} msg] $msg
    }
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexpComp-11.7 {regsub errors} {
    evalInProc {







|




|




|




|




|







558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
    }
} "1 {da\nb123\nxb}"

test regexpComp-11.1 {regsub errors} {
    evalInProc {
	list [catch {regsub a b} msg] $msg
    }
} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexpComp-11.2 {regsub errors} {
    evalInProc {
	list [catch {regsub -nocase a b} msg] $msg
    }
} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexpComp-11.3 {regsub errors} {
    evalInProc {
	list [catch {regsub -nocase -all a b} msg] $msg
    }
} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexpComp-11.4 {regsub errors} {
    evalInProc {
	list [catch {regsub a b c d e f} msg] $msg
    }
} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexpComp-11.5 {regsub errors} {
    evalInProc {
	list [catch {regsub -gorp a b c} msg] $msg
    }
} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
test regexpComp-11.6 {regsub errors} {
    evalInProc {
	list [catch {regsub -nocase a( b c d} msg] $msg
    }
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexpComp-11.7 {regsub errors} {
    evalInProc {
Changes to tests/socket.test.
82
83
84
85
86
87
88
89













90
91
92
93
94
95
96
97
fconfigure $s1 -buffering line
fconfigure $s2 -buffering line
set t1 [clock milliseconds]
puts $s2 test1; gets $s1
puts $s2 test2; gets $s1
close $s1; close $s2
set t2 [clock milliseconds]
set latency [expr {($t2-$t1)*2}]; # doubled as a safety margin













unset t1 t2 s1 s2 server

# If remoteServerIP or remoteServerPort are not set, check in the environment
# variables for externally set values.
#

if {![info exists remoteServerIP]} {
    if {[info exists env(remoteServerIP)]} {







|
>
>
>
>
>
>
>
>
>
>
>
>
>
|







82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
fconfigure $s1 -buffering line
fconfigure $s2 -buffering line
set t1 [clock milliseconds]
puts $s2 test1; gets $s1
puts $s2 test2; gets $s1
close $s1; close $s2
set t2 [clock milliseconds]
set lat1 [expr {($t2-$t1)*2}]; # doubled as a safety margin

# Test the latency of failed connection attempts over the loopback
# interface. They can take more than a second under Windowos and requres
# additional [after]s in some tests that are not needed on systems that fail
# immediately.
set t1 [clock milliseconds]
catch {socket 127.0.0.1 [randport]}
set t2 [clock milliseconds]
set lat2 [expr {($t2-$t1)*3}]

# Use the maximum of the two latency calculations, but at least 100ms
set latency [expr {$lat1 > $lat2 ? $lat1 : $lat2}]
set latency [expr {$latency > 100 ? $latency : 1000}]
unset t1 t2 s1 s2 lat1 lat2 server

# If remoteServerIP or remoteServerPort are not set, check in the environment
# variables for externally set values.
#

if {![info exists remoteServerIP]} {
    if {[info exists env(remoteServerIP)]} {
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140



141
142
143
144
145
146
147
    inet 127.0.0.1
    inet6 ::1
} {
    # Check if the family is supported and set the constraint accordingly
    testConstraint supported_$af [expr {![catch {socket -server foo -myaddr $localhost 0} sock]}]
    catch {close $sock}
}
testConstraint supported_any [expr {[testConstraint supported_inet] || [testConstraint supported_inet6]}]

set sock [socket -server foo -myaddr localhost 0]
set sockname [fconfigure $sock -sockname]
close $sock
testConstraint localhost_v4 [expr {"127.0.0.1" in $sockname}]
testConstraint localhost_v6 [expr {"::1" in $sockname}]


foreach {af localhost} {
    any 127.0.0.1
    inet 127.0.0.1
    inet6 ::1
} {



    set ::tcl::unsupported::socketAF $af
#
# Check if we're supposed to do tests against the remote server
#

set doTestsWithRemoteServer 1
if {![info exists remoteServerIP]} {







<













>
>
>







133
134
135
136
137
138
139

140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
    inet 127.0.0.1
    inet6 ::1
} {
    # Check if the family is supported and set the constraint accordingly
    testConstraint supported_$af [expr {![catch {socket -server foo -myaddr $localhost 0} sock]}]
    catch {close $sock}
}


set sock [socket -server foo -myaddr localhost 0]
set sockname [fconfigure $sock -sockname]
close $sock
testConstraint localhost_v4 [expr {"127.0.0.1" in $sockname}]
testConstraint localhost_v6 [expr {"::1" in $sockname}]


foreach {af localhost} {
    any 127.0.0.1
    inet 127.0.0.1
    inet6 ::1
} {
    if {![testConstraint supported_$af]} {
        continue
    }
    set ::tcl::unsupported::socketAF $af
#
# Check if we're supposed to do tests against the remote server
#

set doTestsWithRemoteServer 1
if {![info exists remoteServerIP]} {
621
622
623
624
625
626
627
















































































628
629
630
631
632
633
634
    lappend result c:[gets $sock]
} -cleanup {
    fconfigure $sock -blocking 1
    close $s2
    close $s
    close $sock
} -result {a:one b: c:two}

















































































test socket_$af-3.1 {socket conflict} -constraints [list socket supported_$af stdio] -setup {
    file delete $path(script)
    set f [open $path(script) w]
    puts $f [list set localhost $localhost]
    puts $f {
	set f [socket -server accept -myaddr $localhost 0]







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
    lappend result c:[gets $sock]
} -cleanup {
    fconfigure $sock -blocking 1
    close $s2
    close $s
    close $sock
} -result {a:one b: c:two}
test socket_$af-2.12 {} [list socket stdio supported_$af] {
    file delete $path(script)
    set f [open $path(script) w]
    puts $f {
	set server [socket -server accept_client 0]
	puts [lindex [chan configure $server -sockname] 2]
	proc accept_client { client host port } {
	    chan configure $client -blocking  0 -buffering line
	    write_line $client
	}
	proc write_line client {
	    if { [catch { chan puts $client [string repeat . 720000]}] } {
		puts [catch {chan close $client}]
	    } else {
		puts signal1
		after 0 write_line $client
	    }
	}
	chan event stdin readable {set forever now}
	vwait forever
	exit
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r+]
    gets $f port
    set sock [socket $localhost $port]
    chan event $sock readable [list read_lines $sock $f]
    proc read_lines { sock pipe } {
	gets $pipe
	chan close $sock
	chan event $pipe readable [list readpipe $pipe]
    }
    proc readpipe {pipe} {
	while {![string is integer [set ::done [gets $pipe]]]} {}
    }
    vwait ::done
    close $f
    set ::done
} 0
test socket_$af-2.13 {Bug 1758a0b603} {socket stdio} {
    file delete $path(script)
    set f [open $path(script) w]
    puts $f {
	set server [socket -server accept 0]
	puts [lindex [chan configure $server -sockname] 2]
	proc accept { client host port } {
	    chan configure $client -blocking  0 -buffering line -buffersize 1
	    puts $client [string repeat . 720000]
	    puts ready
	    chan event $client writable [list setup $client]
	}
	proc setup client {
	    chan event $client writable {set forever write}
	    after 5 {set forever timeout}
	}
	vwait forever
	puts $forever
    }
    close $f
    set pipe [open |[list [interpreter] $path(script)] r]
    gets $pipe port
    set sock [socket $localhost $port]
    chan configure $sock -blocking  0 -buffering line
    chan event $sock readable [list read_lines $sock $pipe ]
    proc read_lines { sock pipe } {
	gets $pipe
	gets $sock line
	after idle [list stop $sock $pipe]
	chan event $sock readable {}
    }
    proc stop {sock pipe} {
	variable done
	close $sock
	set done [gets $pipe]
    }
    variable done
    vwait [namespace which -variable done]
    close $pipe
    set done
} write

test socket_$af-3.1 {socket conflict} -constraints [list socket supported_$af stdio] -setup {
    file delete $path(script)
    set f [open $path(script) w]
    puts $f [list set localhost $localhost]
    puts $f {
	set f [socket -server accept -myaddr $localhost 0]
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573

1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602


1603
1604
1605
1606
1607
1608
1609
	puts $f testing
	flush $f
        exit
    }
    close $f
    # If the socket doesn't hit end-of-file in 10 seconds, the script1 process
    # must have inherited the client.
    set failed 0
    set after [after 10000 [list set failed 1]]
} -constraints [list socket supported_$af stdio exec] -body {
    # Create the server socket
    set server [socket -server accept -myaddr $localhost 0]
    proc accept { file host port } {
	# When the client connects, establish the read handler
	global server
	close $server
	fileevent $file readable [list getdata $file]
	fconfigure $file -buffering line -blocking 0

    }
    proc getdata { file } {
	# Read handler on the accepted socket.
	global x failed
	set status [catch {read $file} data]
	if {$status != 0} {
	    set x {read failed, error was $data}
	    catch { close $file }
	} elseif {$data ne ""} {
	} elseif {[fblocked $file]} {
	} elseif {[eof $file]} {
	    if {$failed} {
		set x {client socket was inherited}
	    } else {
		set x {client socket was not inherited}
	    }
	    catch { close $file }
	} else {
	    set x {impossible case}
	    catch { close $file }
	}
    }
    # Launch the script2 process
    ### exec [interpreter] script2 &
    set p [open "|[list [interpreter] $path(script2)]" w]
    puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p
    vwait x
    return $x
} -cleanup {


    after cancel $after
    close $p
} -result {client socket was not inherited}
test socket_$af-12.3 {testing inheritance of accepted sockets} -setup {
    file delete $path(script1)
    file delete $path(script2)
    set f [open $path(script1) w]







|
|









>



|


|
<



<
<
<
|
<
<

|
<









>
>







1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676

1677
1678
1679



1680


1681
1682

1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
	puts $f testing
	flush $f
        exit
    }
    close $f
    # If the socket doesn't hit end-of-file in 10 seconds, the script1 process
    # must have inherited the client.
    set timeout 0
    set after [after 10000 {set x "client socket was inherited"}]
} -constraints [list socket supported_$af stdio exec] -body {
    # Create the server socket
    set server [socket -server accept -myaddr $localhost 0]
    proc accept { file host port } {
	# When the client connects, establish the read handler
	global server
	close $server
	fileevent $file readable [list getdata $file]
	fconfigure $file -buffering line -blocking 0
        set ::f $file
    }
    proc getdata { file } {
	# Read handler on the accepted socket.
	global x
	set status [catch {read $file} data]
	if {$status != 0} {
	    set x "read failed, error was $data"

	} elseif {$data ne ""} {
	} elseif {[fblocked $file]} {
	} elseif {[eof $file]} {



            set x "client socket was not inherited"


	} else {
	    set x "impossible case"

	}
    }
    # Launch the script2 process
    ### exec [interpreter] script2 &
    set p [open "|[list [interpreter] $path(script2)]" w]
    puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p
    vwait x
    return $x
} -cleanup {
    fconfigure $f -blocking 1
    close $f
    after cancel $after
    close $p
} -result {client socket was not inherited}
test socket_$af-12.3 {testing inheritance of accepted sockets} -setup {
    file delete $path(script1)
    file delete $path(script2)
    set f [open $path(script1) w]
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670


1671
1672
1673
1674
1675
1676
1677
1678
1679
    gets $p listen
    set f [socket $localhost $listen]
    fconfigure $f -buffering full -blocking 0
    fileevent $f readable [list getdata $f]
    # If the socket is still open after 5 seconds, the script1 process must
    # have inherited the accepted socket.
    set failed 0
    set after [after 5000 [list set failed 1]]
    proc getdata { file } {
	# Read handler on the client socket.
	global x
	global failed
	set status [catch {read $file} data]
	if {$status != 0} {
	    set x {read failed, error was $data}
	    catch { close $file }
	} elseif {[string compare {} $data]} {
	} elseif {[fblocked $file]} {
	} elseif {[eof $file]} {
	    if {$failed} {
		set x {accepted socket was inherited}
	    } else {
		set x {accepted socket was not inherited}
	    }
	    catch { close $file }
	} else {
	    set x {impossible case}
	    catch { close $file }
	}
	return
    }
    vwait x
    return $x
} -cleanup {


    after cancel $after
    catch {close $p}
} -result {accepted socket was not inherited}

test socket_$af-13.1 {Testing use of shared socket between two threads} -body {
    # create a thread
    set serverthread [thread::create -preserved [string map [list @localhost@ $localhost] {
        set f [socket -server accept -myaddr @localhost@ 0]
        set listen [lindex [fconfigure $f -sockname] 2]







|






|
<



<
<
<
|
<
<

|
<




|

>
>

|







1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742

1743
1744
1745



1746


1747
1748

1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
    gets $p listen
    set f [socket $localhost $listen]
    fconfigure $f -buffering full -blocking 0
    fileevent $f readable [list getdata $f]
    # If the socket is still open after 5 seconds, the script1 process must
    # have inherited the accepted socket.
    set failed 0
    set after [after 5000 [list set x "accepted socket was inherited"]]
    proc getdata { file } {
	# Read handler on the client socket.
	global x
	global failed
	set status [catch {read $file} data]
	if {$status != 0} {
	    set x "read failed, error was $data"

	} elseif {[string compare {} $data]} {
	} elseif {[fblocked $file]} {
	} elseif {[eof $file]} {



            set x "accepted socket was not inherited"


	} else {
	    set x "impossible case"

	}
	return
    }
    vwait x
    set x
} -cleanup {
    fconfigure $f -blocking 1
    close $f
    after cancel $after
    close $p
} -result {accepted socket was not inherited}

test socket_$af-13.1 {Testing use of shared socket between two threads} -body {
    # create a thread
    set serverthread [thread::create -preserved [string map [list @localhost@ $localhost] {
        set f [socket -server accept -myaddr @localhost@ 0]
        set listen [lindex [fconfigure $f -sockname] 2]
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739






















1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789

1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845

1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857

1858
1859

1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870



1871




























1872





1873
1874
1875
1876
1877
1878



























































































































































































































































1879






















































































1880
1881
1882
1883
1884
1885
1886
1887
1888
if {$remoteProcChan ne ""} {
    catch {sendCommand exit}
}
catch {close $commandSocket}
catch {close $remoteProcChan}
}
unset ::tcl::unsupported::socketAF
test socket-14.0 {[socket -async] when server only listens on IPv4} \
    -constraints [list socket supported_any localhost_v4] \
    -setup {
        proc accept {s a p} {
            global x
            puts $s bye
            close $s
            set x ok
        }
        set server [socket -server accept -myaddr 127.0.0.1 0]
        set port [lindex [fconfigure $server -sockname] 2]
    } -body {
        set client [socket -async localhost $port]
        set after [after 1000 {set x [fconfigure $client -error]}]






















        vwait x
        set x
    } -cleanup {
        after cancel $after
        close $server
        close $client
        unset x
    } -result ok
test socket-14.1 {[socket -async] fileevent while still connecting} \
    -constraints [list socket supported_any] \
    -setup {
        proc accept {s a p} {
            global x
            puts $s bye
            close $s
	    lappend x ok
        }
        set server [socket -server accept -myaddr localhost 0]
        set port [lindex [fconfigure $server -sockname] 2]
        set x ""
    } -body {
        set client [socket -async localhost $port]
        fileevent $client writable {
            lappend x [fconfigure $client -error]
	    fileevent $client writable {}
        }
        set after [after 1000 {lappend x timeout}]
        while {[llength $x] < 2 && "timeout" ni $x} {
            vwait x
        }
        lsort $x; # we only want to see both events, the order doesn't matter
    } -cleanup {
        after cancel $after
        close $server
        close $client
        unset x
    } -result {{} ok}
test socket-14.2 {[socket -async] fileevent connection refused} \
    -constraints [list socket supported_any] \
    -body {
        if {[catch {socket -async localhost [randport]} client]} {
	    regexp {[^:]*: (.*)} $client -> x
	} else {
            fileevent $client writable {set x [fconfigure $client -error]}
            set after [after 1000 {set x timeout}]
            vwait x
	    after cancel $after
            if {$x eq "timeout"} {
                append x ": [fconfigure $client -error]"
            }

	    close $client
	}
        set x
    } -cleanup {
        unset x
    } -result "connection refused"
test socket-14.3 {[socket -async] when server only listens on IPv6} \
    -constraints [list socket supported_any localhost_v6] \
    -setup {
        proc accept {s a p} {
            global x
            puts $s bye
            close $s
            set x ok
        }
        set server [socket -server accept -myaddr ::1 0]
        set port [lindex [fconfigure $server -sockname] 2]
    } -body {
        set client [socket -async localhost $port]
        set after [after 1000 {set x [fconfigure $client -error]}]
        vwait x
        set x
    } -cleanup {
        after cancel $after
        close $server
        close $client
        unset x
    } -result ok
test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \
    -constraints [list socket supported_any] \
    -setup {
        proc accept {s a p} {
            puts $s bye
            close $s
        }
        set server [socket -server accept -myaddr localhost 0]
        set port [lindex [fconfigure $server -sockname] 2]
        set x ""
    } -body {
        set client [socket -async localhost $port]
        fileevent $client writable {
            lappend x [fconfigure $client -error]
            fileevent $client writable {}
        }
        fileevent $client readable {lappend x [gets $client]}
        set after [after 1000 {lappend x timeout}]
        while {[llength $x] < 2 && "timeout" ni $x} {
            vwait x
        }
        lsort $x
    } -cleanup {
        after cancel $after
        close $client
        close $server
        unset x
    } -result {{} bye}

test socket-14.5 {[socket -async] which fails before any connect() can be made} \
    -constraints [list socket supported_any] \
    -body {
        # address from rfc5737
        socket -async -myaddr 192.0.2.42 127.0.0.1 [randport]
    } \
    -returnCodes 1 \
    -result {couldn't open socket: cannot assign requested address}
test socket-14.6 {[socket -async] with no event loop and [fconfigure -error] before the socket is connected} \
    -constraints [list socket supported_inet supported_inet6] \
    -setup {
        proc accept {s a p} {

            puts $s bye
            close $s

        }
        set server [socket -server accept -myaddr 127.0.0.1 0]
        set port [lindex [fconfigure $server -sockname] 2]
        set x ""
    } \
    -body {
        set client [socket -async localhost $port]
        foreach _ {1 2} {
            lappend x [lindex [fconfigure $client -sockname] 0]
            lappend x [fconfigure $client -error]
            update



        }




























        lappend x [gets $client]





    } \
    -cleanup {
        close $server
        close $client
        unset x
    } \



























































































































































































































































    -result [list ::1 "connection refused" 127.0.0.1 "" bye]























































































::tcltest::cleanupTests
flush stdout
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:







|
|











|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









|
















|











|

|
<
<
|
|
|
|
<
|
|
>
|
<
<
<
|
|

|











|









|















|










>

|






|
|


>


>







|
<
<

>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888


1889
1890
1891
1892

1893
1894
1895
1896



1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973


1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
if {$remoteProcChan ne ""} {
    catch {sendCommand exit}
}
catch {close $commandSocket}
catch {close $remoteProcChan}
}
unset ::tcl::unsupported::socketAF
test socket-14.0.0 {[socket -async] when server only listens on IPv4} \
    -constraints {socket supported_inet localhost_v4} \
    -setup {
        proc accept {s a p} {
            global x
            puts $s bye
            close $s
            set x ok
        }
        set server [socket -server accept -myaddr 127.0.0.1 0]
        set port [lindex [fconfigure $server -sockname] 2]
    } -body {
        set client [socket -async localhost $port]
        set after [after $latency {set x [fconfigure $client -error]}]
        vwait x
        set x
    } -cleanup {
        after cancel $after
        close $server
        close $client
        unset x
    } -result ok
test socket-14.0.1 {[socket -async] when server only listens on IPv6} \
    -constraints {socket supported_inet6 localhost_v6} \
    -setup {
        proc accept {s a p} {
            global x
            puts $s bye
            close $s
            set x ok
        }
        set server [socket -server accept -myaddr ::1 0]
        set port [lindex [fconfigure $server -sockname] 2]
    } -body {
        set client [socket -async localhost $port]
        set after [after $latency {set x [fconfigure $client -error]}]
        vwait x
        set x
    } -cleanup {
        after cancel $after
        close $server
        close $client
        unset x
    } -result ok
test socket-14.1 {[socket -async] fileevent while still connecting} \
    -constraints {socket} \
    -setup {
        proc accept {s a p} {
            global x
            puts $s bye
            close $s
	    lappend x ok
        }
        set server [socket -server accept -myaddr localhost 0]
        set port [lindex [fconfigure $server -sockname] 2]
        set x ""
    } -body {
        set client [socket -async localhost $port]
        fileevent $client writable {
            lappend x [fconfigure $client -error]
	    fileevent $client writable {}
        }
        set after [after $latency {lappend x timeout}]
        while {[llength $x] < 2 && "timeout" ni $x} {
            vwait x
        }
        lsort $x; # we only want to see both events, the order doesn't matter
    } -cleanup {
        after cancel $after
        close $server
        close $client
        unset x
    } -result {{} ok}
test socket-14.2 {[socket -async] fileevent connection refused} \
    -constraints {socket} \
    -body {
        set client [socket -async localhost [randport]]


        fileevent $client writable {set x ok}
        set after [after $latency {set x timeout}]
        vwait x
        after cancel $after

        lappend x [fconfigure $client -error]
    } -cleanup {
        after cancel $after
        close $client



        unset x after client
    } -result {ok {connection refused}}
test socket-14.3 {[socket -async] when server only listens on IPv6} \
    -constraints {socket supported_inet6 localhost_v6} \
    -setup {
        proc accept {s a p} {
            global x
            puts $s bye
            close $s
            set x ok
        }
        set server [socket -server accept -myaddr ::1 0]
        set port [lindex [fconfigure $server -sockname] 2]
    } -body {
        set client [socket -async localhost $port]
        set after [after $latency {set x [fconfigure $client -error]}]
        vwait x
        set x
    } -cleanup {
        after cancel $after
        close $server
        close $client
        unset x
    } -result ok
test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \
    -constraints {socket} \
    -setup {
        proc accept {s a p} {
            puts $s bye
            close $s
        }
        set server [socket -server accept -myaddr localhost 0]
        set port [lindex [fconfigure $server -sockname] 2]
        set x ""
    } -body {
        set client [socket -async localhost $port]
        fileevent $client writable {
            lappend x [fconfigure $client -error]
            fileevent $client writable {}
        }
        fileevent $client readable {lappend x [gets $client]}
        set after [after $latency {lappend x timeout}]
        while {[llength $x] < 2 && "timeout" ni $x} {
            vwait x
        }
        lsort $x
    } -cleanup {
        after cancel $after
        close $client
        close $server
        unset x
    } -result {{} bye}
# FIXME: we should also have an IPv6 counterpart of this
test socket-14.5 {[socket -async] which fails before any connect() can be made} \
    -constraints {socket supported_inet} \
    -body {
        # address from rfc5737
        socket -async -myaddr 192.0.2.42 127.0.0.1 [randport]
    } \
    -returnCodes 1 \
    -result {couldn't open socket: cannot assign requested address}
test socket-14.6.0 {[socket -async] with no event loop and server listening on IPv4} \
    -constraints {socket supported_inet localhost_v4} \
    -setup {
        proc accept {s a p} {
            global x
            puts $s bye
            close $s
            set x ok
        }
        set server [socket -server accept -myaddr 127.0.0.1 0]
        set port [lindex [fconfigure $server -sockname] 2]
        set x ""
    } \
    -body {
        set client [socket -async localhost $port]
        for {set i 0} {$i < 50} {incr i } {


            update
            if {$x ne ""} {
                lappend x [gets $client]
                break
            }
            after 100
        }
        set x
    } \
    -cleanup {
        close $server
        close $client
        unset x
    } \
    -result {ok bye}
test socket-14.6.1 {[socket -async] with no event loop and server listening on IPv6} \
    -constraints {socket supported_inet6 localhost_v6} \
    -setup {
        proc accept {s a p} {
            global x
            puts $s bye
            close $s
            set x ok
        }
        set server [socket -server accept -myaddr ::1 0]
        set port [lindex [fconfigure $server -sockname] 2]
        set x ""
    } \
    -body {
        set client [socket -async localhost $port]
        for {set i 0} {$i < 50} {incr i } {
            update
            if {$x ne ""} {
                lappend x [gets $client]
                break
            }
            after 100
        }
        set x
    } \
    -cleanup {
        close $server
        close $client
        unset x
    } \
    -result {ok bye}
test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} \
    -constraints {socket supported_inet localhost_v4} \
    -setup {
        makeFile {
            fileevent stdin readable exit
            set server [socket -server accept -myaddr 127.0.0.1 0]
            proc accept {s h p} {puts $s ok; close $s; set ::x 1}
            puts [lindex [fconfigure $server -sockname] 2]
            flush stdout
            vwait x
        } script
        set fd [open |[list [interpreter] script] RDWR]
        set port [gets $fd]
    } -body {
        set sock [socket -async localhost $port]
        list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error]
    } -cleanup {
        close $fd
        close $sock
    } -result {{} ok {}}
test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} \
    -constraints {socket supported_inet6 localhost_v6} \
    -setup {
        makeFile {
            fileevent stdin readable exit
            set server [socket -server accept -myaddr ::1 0]
            proc accept {s h p} {puts $s ok; close $s; set ::x 1}
            puts [lindex [fconfigure $server -sockname] 2]
            flush stdout
            vwait x
        } script
        set fd [open |[list [interpreter] script] RDWR]
        set port [gets $fd]
    } -body {
        set sock [socket -async localhost $port]
        list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error]
    } -cleanup {
        close $fd
        close $sock
    } -result {{} ok {}}
test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} \
    -constraints {socket} \
    -body {
        set sock [socket -async localhost [randport]]
        catch {gets $sock} x
        list $x [fconfigure $sock -error] [fconfigure $sock -error]
    } -cleanup {
        close $sock
    } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}}
test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IPv4} \
    -constraints {socket supported_inet localhost_v4} \
    -setup {
        makeFile {
            fileevent stdin readable exit
            set server [socket -server accept -myaddr 127.0.0.1 0]
            proc accept {s h p} {puts $s ok; close $s; set ::x 1}
            puts [lindex [fconfigure $server -sockname] 2]
            flush stdout
            vwait x
        } script
        set fd [open |[list [interpreter] script] RDWR]
        set port [gets $fd]
    } -body {
        set sock [socket -async localhost $port]
        fconfigure $sock -blocking 0
        for {set i 0} {$i < 50} {incr i } {
            if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
            after 200
        }
        set x
    } -cleanup {
        close $fd
        close $sock
    } -result {ok}
test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} \
    -constraints {socket supported_inet6 localhost_v6} \
    -setup {
        makeFile {
            fileevent stdin readable exit
            set server [socket -server accept -myaddr ::1 0]
            proc accept {s h p} {puts $s ok; close $s; set ::x 1}
            puts [lindex [fconfigure $server -sockname] 2]
            flush stdout
            vwait x
        } script
        set fd [open |[list [interpreter] script] RDWR]
        set port [gets $fd]
    } -body {
        set sock [socket -async localhost $port]
        fconfigure $sock -blocking 0
        for {set i 0} {$i < 50} {incr i } {
            if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
            after 200
        }
        set x
    } -cleanup {
        close $fd
        close $sock
    } -result {ok}
test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} \
    -constraints {socket} \
    -body {
        set sock [socket -async localhost [randport]]
        fconfigure $sock -blocking 0
        for {set i 0} {$i < 50} {incr i } {
            if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
            after 200
        }
        list $x [fconfigure $sock -error] [fconfigure $sock -error]
    } -cleanup {
        close $sock
    } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}}
test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} \
    -constraints {socket supported_inet localhost_v4} \
    -setup {
        makeFile {
            fileevent stdin readable exit
            set server [socket -server accept -myaddr 127.0.0.1 0]
            proc accept {s h p} {set ::x $s}
            puts [lindex [fconfigure $server -sockname] 2]
            flush stdout
            vwait x
            puts [gets $x]
        } script
        set fd [open |[list [interpreter] script] RDWR]
        set port [gets $fd]
    } -body {
        set sock [socket -async localhost $port]
        puts $sock ok
        flush $sock
        list [fconfigure $sock -error] [gets $fd]
    } -cleanup {
        close $fd
        close $sock
    } -result {{} ok}
test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} \
    -constraints {socket supported_inet6 localhost_v6} \
    -setup {
        makeFile {
            fileevent stdin readable exit
            set server [socket -server accept -myaddr ::1 0]
            proc accept {s h p} {set ::x $s}
            puts [lindex [fconfigure $server -sockname] 2]
            flush stdout
            vwait x
            puts [gets $x]
        } script
        set fd [open |[list [interpreter] script] RDWR]
        set port [gets $fd]
    } -body {
        set sock [socket -async localhost $port]
        puts $sock ok
        flush $sock
        list [fconfigure $sock -error] [gets $fd]
    } -cleanup {
        close $fd
        close $sock
    } -result {{} ok}
test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} \
    -constraints {socket supported_inet localhost_v4} \
    -setup {
        makeFile {
            fileevent stdin readable exit
            set server [socket -server accept -myaddr 127.0.0.1 0]
            proc accept {s h p} {set ::x $s}
            puts [lindex [fconfigure $server -sockname] 2]
            flush stdout
            vwait x
            puts [gets $x]
        } script
        set fd [open |[list [interpreter] script] RDWR]
        set port [gets $fd]
    } -body {
        set sock [socket -async localhost $port]
        fconfigure $sock -blocking 0
        puts $sock ok
        flush $sock
        fileevent $fd readable {set x 1}
        vwait x
        list [fconfigure $sock -error] [gets $fd]
    } -cleanup {
        close $fd
        close $sock
    } -result {{} ok}
test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} \
    -constraints {socket supported_inet6 localhost_v6} \
    -setup {
        makeFile {
            fileevent stdin readable exit
            set server [socket -server accept -myaddr ::1 0]
            proc accept {s h p} {set ::x $s}
            puts [lindex [fconfigure $server -sockname] 2]
            flush stdout
            vwait x
            puts [gets $x]
        } script
        set fd [open |[list [interpreter] script] RDWR]
        set port [gets $fd]
    } -body {
        set sock [socket -async localhost $port]
        fconfigure $sock -blocking 0
        puts $sock ok
        flush $sock
        fileevent $fd readable {set x 1}
        vwait x
        list [fconfigure $sock -error] [gets $fd]
    } -cleanup {
        close $fd
        close $sock
    } -result {{} ok}
test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} \
    -constraints {socket} \
    -body {
        set sock [socket -async localhost [randport]]
        fconfigure $sock -blocking 0
        puts $sock ok
        fileevent $sock writable {set x 1}
        vwait x
        close $sock
    } -cleanup {
        catch {close $sock}
        unset x
    } -result {socket is not connected} -returnCodes 1
test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \
    -constraints {socket} \
    -body {
        set sock [socket -async localhost [randport]]
        fconfigure $sock -blocking 0
        puts $sock ok
        flush $sock
        fileevent $sock writable {set x 1}
        vwait x
        close $sock
    } -cleanup {
        catch {close $sock}
        catch {unset x}
    } -result {socket is not connected} -returnCodes 1
test socket-14.12 {[socket -async] background progress triggered by [fconfigure -error]} \
    -constraints {socket} \
    -body {
        set s [socket -async localhost [randport]]
        for {set i 0} {$i < 50} {incr i} {
            set x [fconfigure $s -error]
            if {$x != ""} break
            after 200
        }
        set x
    } -cleanup {
        close $s
        unset x s
    } -result {connection refused}

test socket-14.13 {testing writable event when quick failure} \
    -constraints {socket win supported_inet} \
    -body {
    # Test for bug 336441ed59 where a quick background fail was ignored
    
    # Test only for windows as socket -async 255.255.255.255 fails
    # directly on unix
    
    # The following connect should fail very quickly
    set a1 [after 2000 {set x timeout}]
    set s [socket -async 255.255.255.255 43434]
    fileevent $s writable {set x writable}
    vwait x
    set x
} -cleanup {
    catch {close $s}
    after cancel $a1
} -result writable

test socket-14.14 {testing fileevent readable on failed async socket connect} \
    -constraints {socket} -body {
    # Test for bug 581937ab1e
    
    set a1 [after 5000 {set x timeout}]
    # This connect should fail
    set s [socket -async localhost [randport]]
    fileevent $s readable {set x readable}
    vwait x
    set x
} -cleanup {
    catch {close $s}
    after cancel $a1
} -result readable

test socket-14.15 {blocking read on async socket should not trigger event handlers} \
    -constraints socket -body {
        set s [socket -async localhost [randport]]
        set x ok
        fileevent $s writable {set x fail}
        catch {read $s}
        set x
    } -result ok

set num 0

set x {localhost {socket} 127.0.0.1 {supported_inet} ::1 {supported_inet6}}
set resultok {-result "sock*" -match glob}
set resulterr {
    -result {couldn't open socket: connection refused}
    -returnCodes 1
}
foreach {servip sc} $x {
    foreach {cliip cc} $x {
        set constraints socket
        lappend constraints $sc $cc
        set result $resulterr
        switch -- [lsort -unique [list $servip $cliip]] {
            localhost - 127.0.0.1 - ::1 {
                set result $resultok
            }
            {127.0.0.1 localhost} {
                if {[testConstraint localhost_v4]} {
                    set result $resultok
                }
            }
            {::1 localhost} {
                if {[testConstraint localhost_v6]} {
                    set result $resultok
                }
            }
        }
        test socket-15.1.$num "Connect to $servip from $cliip" \
            -constraints $constraints -setup {
                set server [socket -server accept -myaddr $servip 0]
                proc accept {s h p} { close $s }
                set port [lindex [fconfigure $server -sockname] 2]
            } -body {
                set s [socket $cliip $port]
            } -cleanup {
                close $server
                catch {close $s}
            } {*}$result
        incr num
    }
}

::tcltest::cleanupTests
flush stdout
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:
Changes to tests/string.test.
1394
1395
1396
1397
1398
1399
1400



1401
1402
1403
1404
1405
1406
1407
} Abc
test string-15.9 {string tolower} {
    string tolower ABC 0 end-1
} abC
test string-15.10 {string tolower, unicode} {
     string tolower ABCabc\xc7\xe7
} "abcabc\xe7\xe7"




test string-16.1 {string toupper} {
    list [catch {string toupper} msg] $msg
} {1 {wrong # args: should be "string toupper string ?first? ?last?"}}
test string-16.2 {string toupper} {
    list [catch {string toupper a b} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}







>
>
>







1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
} Abc
test string-15.9 {string tolower} {
    string tolower ABC 0 end-1
} abC
test string-15.10 {string tolower, unicode} {
     string tolower ABCabc\xc7\xe7
} "abcabc\xe7\xe7"
test string-15.11 {string tolower, compiled} {
    lindex [string tolower [list A B [list C]]] 1
} b

test string-16.1 {string toupper} {
    list [catch {string toupper} msg] $msg
} {1 {wrong # args: should be "string toupper string ?first? ?last?"}}
test string-16.2 {string toupper} {
    list [catch {string toupper a b} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
1425
1426
1427
1428
1429
1430
1431



1432
1433
1434
1435
1436
1437
1438
} aBC
test string-16.9 {string toupper} {
    string toupper abc 0 end-1
} ABc
test string-16.10 {string toupper, unicode} {
    string toupper ABCabc\xc7\xe7
} "ABCABC\xc7\xc7"




test string-17.1 {string totitle} {
    list [catch {string totitle} msg] $msg
} {1 {wrong # args: should be "string totitle string ?first? ?last?"}}
test string-17.2 {string totitle} {
    list [catch {string totitle a b} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}







>
>
>







1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
} aBC
test string-16.9 {string toupper} {
    string toupper abc 0 end-1
} ABc
test string-16.10 {string toupper, unicode} {
    string toupper ABCabc\xc7\xe7
} "ABCABC\xc7\xc7"
test string-16.11 {string toupper, compiled} {
    lindex [string toupper [list a b [list c]]] 1
} B

test string-17.1 {string totitle} {
    list [catch {string totitle} msg] $msg
} {1 {wrong # args: should be "string totitle string ?first? ?last?"}}
test string-17.2 {string totitle} {
    list [catch {string totitle a b} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
1447
1448
1449
1450
1451
1452
1453



1454
1455
1456
1457
1458
1459
1460
} {123#$&*()}
test string-17.6 {string totitle, unicode} {
    string totitle ABCabc\xc7\xe7
} "Abcabc\xe7\xe7"
test string-17.7 {string totitle, unicode} {
    string totitle \u01f3BCabc\xc7\xe7
} "\u01f2bcabc\xe7\xe7"




test string-18.1 {string trim} {
    list [catch {string trim} msg] $msg
} {1 {wrong # args: should be "string trim string ?chars?"}}
test string-18.2 {string trim} {
    list [catch {string trim a b c} msg] $msg
} {1 {wrong # args: should be "string trim string ?chars?"}}







>
>
>







1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
} {123#$&*()}
test string-17.6 {string totitle, unicode} {
    string totitle ABCabc\xc7\xe7
} "Abcabc\xe7\xe7"
test string-17.7 {string totitle, unicode} {
    string totitle \u01f3BCabc\xc7\xe7
} "\u01f2bcabc\xe7\xe7"
test string-17.8 {string totitle, compiled} {
    lindex [string totitle [list aa bb [list cc]]] 0
} Aa

test string-18.1 {string trim} {
    list [catch {string trim} msg] $msg
} {1 {wrong # args: should be "string trim string ?chars?"}}
test string-18.2 {string trim} {
    list [catch {string trim a b c} msg] $msg
} {1 {wrong # args: should be "string trim string ?chars?"}}
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
test string-26.6 {tcl::prefix} {
    tcl::prefix match {apa bepa cepa depa} be
} bepa
test string-26.7 {tcl::prefix} -body {
    tcl::prefix match -exact {apa bepa cepa depa} be
} -returnCodes 1 -result {bad option "be": must be apa, bepa, cepa, or depa}
test string-26.8 {tcl::prefix} -body {
    tcl::prefix match -message switch {apa bepa bear depa} be
} -returnCodes 1 -result {ambiguous switch "be": must be apa, bepa, bear, or depa}
test string-26.9 {tcl::prefix} -body {
    tcl::prefix match -error {} {apa bepa bear depa} be
} -returnCodes 0 -result {}
test string-26.10 {tcl::prefix} -body {
    tcl::prefix match -error {-level 1} {apa bepa bear depa} be
} -returnCodes 2 -result {ambiguous option "be": must be apa, bepa, bear, or depa}
test string-26.10.1 {tcl::prefix} -setup {







|
|







1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
test string-26.6 {tcl::prefix} {
    tcl::prefix match {apa bepa cepa depa} be
} bepa
test string-26.7 {tcl::prefix} -body {
    tcl::prefix match -exact {apa bepa cepa depa} be
} -returnCodes 1 -result {bad option "be": must be apa, bepa, cepa, or depa}
test string-26.8 {tcl::prefix} -body {
    tcl::prefix match -message wombat {apa bepa bear depa} be
} -returnCodes 1 -result {ambiguous wombat "be": must be apa, bepa, bear, or depa}
test string-26.9 {tcl::prefix} -body {
    tcl::prefix match -error {} {apa bepa bear depa} be
} -returnCodes 0 -result {}
test string-26.10 {tcl::prefix} -body {
    tcl::prefix match -error {-level 1} {apa bepa bear depa} be
} -returnCodes 2 -result {ambiguous option "be": must be apa, bepa, bear, or depa}
test string-26.10.1 {tcl::prefix} -setup {
Changes to tests/stringComp.test.
22
23
24
25
26
27
28
















29
30
31
32
33
34
35

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

# Some tests require the testobj command

testConstraint testobj [expr {[info commands testobj] != {}}]

















test stringComp-1.1 {error conditions} {
    proc foo {} {string gorp a b}
    list [catch {foo} msg] $msg
} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test stringComp-1.2 {error conditions} {
    proc foo {} {string}







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

# Some tests require the testobj command

testConstraint testobj [expr {[info commands testobj] != {}}]
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
    proc getbytes {} {
	set lines [split [memory info] \n]
	return [lindex $lines 3 3]
    }
    proc leaktest {script {iterations 3}} {
	set end [getbytes]
	for {set i 0} {$i < $iterations} {incr i} {
	    uplevel 1 $script
	    set tmp $end
	    set end [getbytes]
	}
	return [expr {$end - $tmp}]
    }
}

test stringComp-1.1 {error conditions} {
    proc foo {} {string gorp a b}
    list [catch {foo} msg] $msg
} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test stringComp-1.2 {error conditions} {
    proc foo {} {string}
683
684
685
686
687
688
689


690














691
692
693
694
695
696
697
    }} 12345
} {}

## string repeat
## not yet bc

## string replace


## not yet bc















## string tolower
## not yet bc

## string toupper
## not yet bc








>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>







699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
    }} 12345
} {}

## string repeat
## not yet bc

## string replace
test stringComp-14.1 {Bug 82e7f67325} {
    apply {x {
	set a [join $x {}]
	lappend b [string length [string replace ___! 0 2 $a]]
	lappend b [string length [string replace ___! 0 2 $a[unset a]]]
    }} {a b}
} {3 3}
test stringComp-14.2 {Bug 82e7f67325} memory {
    # As in stringComp-14.1, but make sure we don't retain too many refs
    leaktest {
	apply {x {
	    set a [join $x {}]
	    lappend b [string length [string replace ___! 0 2 $a]]
	    lappend b [string length [string replace ___! 0 2 $a[unset a]]]
	}} {a b}
    }
} {0}

## string tolower
## not yet bc

## string toupper
## not yet bc

Changes to tests/subst.test.
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
}

test subst-1.1 {basics} -returnCodes error -body {
    subst
} -result {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}
test subst-1.2 {basics} -returnCodes error -body {
    subst a b c
} -result {bad switch "a": must be -nobackslashes, -nocommands, or -novariables}

test subst-2.1 {simple strings} {
    subst {}
} {}
test subst-2.2 {simple strings} {
    subst a
} a







|







17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
}

test subst-1.1 {basics} -returnCodes error -body {
    subst
} -result {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}
test subst-1.2 {basics} -returnCodes error -body {
    subst a b c
} -result {bad option "a": must be -nobackslashes, -nocommands, or -novariables}

test subst-2.1 {simple strings} {
    subst {}
} {}
test subst-2.2 {simple strings} {
    subst a
} a
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
test subst-6.1 {clear the result after command substitution} -body {
    catch {unset a}
    subst {[concat foo] $a}
} -returnCodes error -result {can't read "a": no such variable}

test subst-7.1 {switches} -returnCodes error -body {
    subst foo bar
} -result {bad switch "foo": must be -nobackslashes, -nocommands, or -novariables}
test subst-7.2 {switches} -returnCodes error -body {
    subst -no bar
} -result {ambiguous switch "-no": must be -nobackslashes, -nocommands, or -novariables}
test subst-7.3 {switches} -returnCodes error -body {
    subst -bogus bar
} -result {bad switch "-bogus": must be -nobackslashes, -nocommands, or -novariables}
test subst-7.4 {switches} {
    set x 123
    subst -nobackslashes {abc $x [expr 1+2] \\\x41}
} {abc 123 3 \\\x41}
test subst-7.5 {switches} {
    set x 123
    subst -nocommands {abc $x [expr 1+2] \\\x41}







|


|


|







115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
test subst-6.1 {clear the result after command substitution} -body {
    catch {unset a}
    subst {[concat foo] $a}
} -returnCodes error -result {can't read "a": no such variable}

test subst-7.1 {switches} -returnCodes error -body {
    subst foo bar
} -result {bad option "foo": must be -nobackslashes, -nocommands, or -novariables}
test subst-7.2 {switches} -returnCodes error -body {
    subst -no bar
} -result {ambiguous option "-no": must be -nobackslashes, -nocommands, or -novariables}
test subst-7.3 {switches} -returnCodes error -body {
    subst -bogus bar
} -result {bad option "-bogus": must be -nobackslashes, -nocommands, or -novariables}
test subst-7.4 {switches} {
    set x 123
    subst -nobackslashes {abc $x [expr 1+2] \\\x41}
} {abc 123 3 \\\x41}
test subst-7.5 {switches} {
    set x 123
    subst -nocommands {abc $x [expr 1+2] \\\x41}
Changes to tests/switch.test.
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
    while executing
"error "Just a test""
    ("a" arm line 1)
    invoked from within
"switch a a {error "Just a test"} default {subst 1}"}}
test switch-4.2 {error: not enough args} -returnCodes error -body {
    switch
} -result {wrong # args: should be "switch ?-switch ...? string ?pattern body ...? ?default body?"}
test switch-4.3 {error: pattern with no body} -body {
    switch a b
} -returnCodes error -result {extra switch pattern with no body}
test switch-4.4 {error: pattern with no body} -body {
    switch a b {subst 1} c
} -returnCodes error -result {extra switch pattern with no body}
test switch-4.5 {error in default command} {







|







165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
    while executing
"error "Just a test""
    ("a" arm line 1)
    invoked from within
"switch a a {error "Just a test"} default {subst 1}"}}
test switch-4.2 {error: not enough args} -returnCodes error -body {
    switch
} -result {wrong # args: should be "switch ?-option ...? string ?pattern body ...? ?default body?"}
test switch-4.3 {error: pattern with no body} -body {
    switch a b
} -returnCodes error -result {extra switch pattern with no body}
test switch-4.4 {error: pattern with no body} -body {
    switch a b {subst 1} c
} -returnCodes error -result {extra switch pattern with no body}
test switch-4.5 {error in default command} {
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
    switch Foo {
    	Foo {$cmd}
    }
} {INVOKED}

test switch-9.1 {empty pattern/body list} -returnCodes error -body {
    switch x
} -result {wrong # args: should be "switch ?-switch ...? string ?pattern body ...? ?default body?"}
test switch-9.2 {unpaired pattern} -returnCodes error -body {
    switch -- x
} -result {extra switch pattern with no body}
test switch-9.3 {empty pattern/body list} -body {
    switch x {}
} -returnCodes error -result {wrong # args: should be "switch ?-switch ...? string {?pattern body ...? ?default body?}"}
test switch-9.4 {empty pattern/body list} -body {
    switch -- x {}
} -returnCodes error -result {wrong # args: should be "switch ?-switch ...? string {?pattern body ...? ?default body?}"}
test switch-9.5 {unpaired pattern} -body {
    switch x a {} b
} -returnCodes error -result {extra switch pattern with no body}
test switch-9.6 {unpaired pattern} -body {
    switch x {a {} b}
} -returnCodes error -result {extra switch pattern with no body}
test switch-9.7 {unpaired pattern} -body {







|





|


|







265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
    switch Foo {
    	Foo {$cmd}
    }
} {INVOKED}

test switch-9.1 {empty pattern/body list} -returnCodes error -body {
    switch x
} -result {wrong # args: should be "switch ?-option ...? string ?pattern body ...? ?default body?"}
test switch-9.2 {unpaired pattern} -returnCodes error -body {
    switch -- x
} -result {extra switch pattern with no body}
test switch-9.3 {empty pattern/body list} -body {
    switch x {}
} -returnCodes error -result {wrong # args: should be "switch ?-option ...? string {?pattern body ...? ?default body?}"}
test switch-9.4 {empty pattern/body list} -body {
    switch -- x {}
} -returnCodes error -result {wrong # args: should be "switch ?-option ...? string {?pattern body ...? ?default body?}"}
test switch-9.5 {unpaired pattern} -body {
    switch x a {} b
} -returnCodes error -result {extra switch pattern with no body}
test switch-9.6 {unpaired pattern} -body {
    switch x {a {} b}
} -returnCodes error -result {extra switch pattern with no body}
test switch-9.7 {unpaired pattern} -body {
Changes to tests/winFCmd.test.
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
    catch {close $fd}
} -returnCodes error -result EACCES
test winFCmd-1.13 {TclpRenameFile: errno: EACCES} -setup {
    cleanup
} -constraints {win win2000orXP testfile} -body {
    testfile mv nul tf1
} -returnCodes error -result EINVAL
test winFCmd-1.13.1 {TclpRenameFile: errno: EACCES} -setup {
    cleanup
} -constraints {win nt winOlderThan2000 testfile} -body {
    testfile mv nul tf1
} -returnCodes error -result EACCES
test winFCmd-1.13.2 {TclpRenameFile: errno: ENOENT} -setup {
    cleanup
} -constraints {win 95 testfile} -body {
    testfile mv nul tf1
} -returnCodes error -result ENOENT
test winFCmd-1.14 {TclpRenameFile: errno: EACCES} -setup {
    cleanup
} -constraints {win 95 testfile} -body {
    createfile tf1
    testfile mv tf1 nul
} -returnCodes error -result EACCES
test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} -setup {
    cleanup
} -constraints {win nt testfile} -body {
    createfile tf1
    testfile mv tf1 nul
} -returnCodes error -result EEXIST







|



<
<
<
<
<
<
<
<
<
<
<







204
205
206
207
208
209
210
211
212
213
214











215
216
217
218
219
220
221
    catch {close $fd}
} -returnCodes error -result EACCES
test winFCmd-1.13 {TclpRenameFile: errno: EACCES} -setup {
    cleanup
} -constraints {win win2000orXP testfile} -body {
    testfile mv nul tf1
} -returnCodes error -result EINVAL
test winFCmd-1.14 {TclpRenameFile: errno: EACCES} -setup {
    cleanup
} -constraints {win nt winOlderThan2000 testfile} -body {
    testfile mv nul tf1











} -returnCodes error -result EACCES
test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} -setup {
    cleanup
} -constraints {win nt testfile} -body {
    createfile tf1
    testfile mv tf1 nul
} -returnCodes error -result EEXIST
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
    testfile mv nul tf1
} -returnCodes error -result EINVAL
test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} -setup {
    cleanup
} -constraints {win nt winOlderThan2000 testfile} -body {
    testfile mv nul tf1
} -returnCodes error -result EACCES
test winFCmd-1.19.2 {TclpRenameFile: errno == ENOENT} -setup {
    cleanup
} -constraints {win 95 testfile} -body {
    testfile mv nul tf1
} -returnCodes error -result ENOENT
test winFCmd-1.20 {TclpRenameFile: src is dir} -setup {
    cleanup
} -constraints {win nt testfile} -body {
    # under 95, this would actually succeed and move the current dir out from
    # under the current process!
    file delete /tf1
    testfile mv [pwd] /tf1







<
<
<
<
<







242
243
244
245
246
247
248





249
250
251
252
253
254
255
    testfile mv nul tf1
} -returnCodes error -result EINVAL
test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} -setup {
    cleanup
} -constraints {win nt winOlderThan2000 testfile} -body {
    testfile mv nul tf1
} -returnCodes error -result EACCES





test winFCmd-1.20 {TclpRenameFile: src is dir} -setup {
    cleanup
} -constraints {win nt testfile} -body {
    # under 95, this would actually succeed and move the current dir out from
    # under the current process!
    file delete /tf1
    testfile mv [pwd] /tf1
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
    createfile tf1
    testfile cp tf1 ""
} -cleanup {
    cleanup
} -returnCodes error -result ENOENT
test winFCmd-2.7 {TclpCopyFile: errno: EACCES} -setup {
    cleanup
} -constraints {win 95 testfile} -body {
    createfile tf1
    set fd [open tf2 w]
    testfile cp tf1 tf2
} -cleanup {
    close $fd
    cleanup
} -returnCodes error -result EACCES
test winFCmd-2.8 {TclpCopyFile: errno: EACCES} -setup {
    cleanup
} -constraints {win win2000orXP testfile} -body {
    testfile cp nul tf1
} -returnCodes error -result EINVAL
test winFCmd-2.8.1 {TclpCopyFile: errno: EACCES} -setup {
    cleanup
} -constraints {win nt winOlderThan2000 testfile} -body {
    testfile cp nul tf1
} -returnCodes error -result EACCES
test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} -setup {
    cleanup
} -constraints {win 95 testfile} -body {
    testfile cp nul tf1
} -returnCodes error -result ENOENT
test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} -setup {
    cleanup
} -constraints {win testfile} -body {
    createfile tf1 tf1
    testfile cp tf1 tf2
    list [contents tf1] [contents tf2]
} -cleanup {







<
<
<
<
<
<
<
<
<
<



|




<
<
<
<
<







454
455
456
457
458
459
460










461
462
463
464
465
466
467
468





469
470
471
472
473
474
475
    createfile tf1
    testfile cp tf1 ""
} -cleanup {
    cleanup
} -returnCodes error -result ENOENT
test winFCmd-2.7 {TclpCopyFile: errno: EACCES} -setup {
    cleanup










} -constraints {win win2000orXP testfile} -body {
    testfile cp nul tf1
} -returnCodes error -result EINVAL
test winFCmd-2.8 {TclpCopyFile: errno: EACCES} -setup {
    cleanup
} -constraints {win nt winOlderThan2000 testfile} -body {
    testfile cp nul tf1
} -returnCodes error -result EACCES





test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} -setup {
    cleanup
} -constraints {win testfile} -body {
    createfile tf1 tf1
    testfile cp tf1 tf2
    list [contents tf1] [contents tf2]
} -cleanup {
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
    testchmod 000 tf2
    testfile cp tf1 tf2
    list [file writable tf2] [contents tf2]
} -cleanup {
    catch {testchmod 666 tf2}
    cleanup
} -result {1 tf1}
test winFCmd-2.18 {TclpCopyFile: still can't copy onto dst} -setup {
    cleanup
} -constraints {win 95 testfile testchmod} -body {
    createfile tf1
    createfile tf2
    testchmod 000 tf2
    set fd [open tf2]
    set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
    close $fd
    lappend msg [file writable tf2]
} -result {1 EACCES 0}

test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} -body {
    testfile rm $cdfile $cdrom/dummy~~.fil
} -constraints {win cdrom testfile} -returnCodes error -result EACCES
test winFCmd-3.2 {TclpDeleteFile: errno: EISDIR} -setup {
    cleanup
} -constraints {win testfile} -body {







<
<
<
<
<
<
<
<
<
<
<







538
539
540
541
542
543
544











545
546
547
548
549
550
551
    testchmod 000 tf2
    testfile cp tf1 tf2
    list [file writable tf2] [contents tf2]
} -cleanup {
    catch {testchmod 666 tf2}
    cleanup
} -result {1 tf1}












test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} -body {
    testfile rm $cdfile $cdrom/dummy~~.fil
} -constraints {win cdrom testfile} -returnCodes error -result EACCES
test winFCmd-3.2 {TclpDeleteFile: errno: EISDIR} -setup {
    cleanup
} -constraints {win testfile} -body {
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
    catch {testchmod 666 tf1}
    cleanup
} -returnCodes error -result EACCES

test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} -body {
    testfile mkdir $cdrom/dummy~~.dir
} -constraints {win nt cdrom testfile} -returnCodes error -result EACCES
test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} -body {
    testfile mkdir $cdrom/dummy~~.dir
} -constraints {win 95 cdrom testfile} -returnCodes error -result ENOSPC
test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} -setup {
    cleanup
} -constraints {win testfile} -body {
    file mkdir td1
    testfile mkdir td1
} -cleanup {
    cleanup







<
<
<







620
621
622
623
624
625
626



627
628
629
630
631
632
633
    catch {testchmod 666 tf1}
    cleanup
} -returnCodes error -result EACCES

test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} -body {
    testfile mkdir $cdrom/dummy~~.dir
} -constraints {win nt cdrom testfile} -returnCodes error -result EACCES



test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} -setup {
    cleanup
} -constraints {win testfile} -body {
    file mkdir td1
    testfile mkdir td1
} -cleanup {
    cleanup
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
    testchmod 000 td1
    testfile rmdir td1
    file exists td1
} -returnCodes error -cleanup {
    catch {testchmod 666 td1}
    cleanup
} -result {td1 EACCES}
test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} -setup {
    cleanup
} -constraints {win 95 testfile} -body {
    testfile rmdir nul
} -returnCodes error -result {nul EACCES}
test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup {
    cleanup
} -constraints {win nt testfile} -body {
    testfile rmdir /
    # WinXP returns EEXIST, WinNT seems to return EACCES.  No policy
    # decision has been made as to which is correct.
} -returnCodes error -match regexp -result {^/ E(ACCES|EXIST)$}
# This next test has a very hokey way of matching...
test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} -setup {
    cleanup
} -constraints {win 95 testfile} -body {
    createfile tf1
    set res [catch {testfile rmdir tf1} msg]
    # get rid of path
    set msg [list [file tail [lindex $msg 0]] [lindex $msg 1]]
    list $res $msg
} -result {1 {tf1 ENOTDIR}}
test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup {
    cleanup
} -constraints {winVista testfile testchmod} -body {
    file mkdir td1
    testchmod 000 td1
    testfile rmdir td1
    file exists td1
} -cleanup {
    catch {testchmod 666 td1}
    cleanup
} -returnCodes error -result {td1 EACCES}
# This next test has a very hokey way of matching...
test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} -setup {
    cleanup
} -constraints {win 95 testfile} -body {
    file mkdir td1/td2
    set res [catch {testfile rmdir td1} msg]
    # get rid of path
    set msg [list [file tail [lindex $msg 0]] [lindex $msg 1]]
    list $res $msg
} -result {1 {td1 EEXIST}}
# This next test has a very hokey way of matching...
test winFCmd-6.15 {TclpRemoveDirectory: !recursive} -setup {
    cleanup
} -constraints {win testfile} -body {
    file mkdir td1/td2
    list [catch {testfile rmdir td1} msg] [file tail $msg]
} -result {1 {td1 EEXIST}}







<
<
<
<
<







<
<
<
<
<
<
<
<
<
<











<
<
<
<
<
<
<
<
<
<







715
716
717
718
719
720
721





722
723
724
725
726
727
728










729
730
731
732
733
734
735
736
737
738
739










740
741
742
743
744
745
746
    testchmod 000 td1
    testfile rmdir td1
    file exists td1
} -returnCodes error -cleanup {
    catch {testchmod 666 td1}
    cleanup
} -result {td1 EACCES}





test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup {
    cleanup
} -constraints {win nt testfile} -body {
    testfile rmdir /
    # WinXP returns EEXIST, WinNT seems to return EACCES.  No policy
    # decision has been made as to which is correct.
} -returnCodes error -match regexp -result {^/ E(ACCES|EXIST)$}










test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup {
    cleanup
} -constraints {winVista testfile testchmod} -body {
    file mkdir td1
    testchmod 000 td1
    testfile rmdir td1
    file exists td1
} -cleanup {
    catch {testchmod 666 td1}
    cleanup
} -returnCodes error -result {td1 EACCES}










# This next test has a very hokey way of matching...
test winFCmd-6.15 {TclpRemoveDirectory: !recursive} -setup {
    cleanup
} -constraints {win testfile} -body {
    file mkdir td1/td2
    list [catch {testfile rmdir td1} msg] [file tail $msg]
} -result {1 {td1 EEXIST}}
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
    file mkdir td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    contents td2/tf1
} -cleanup {
    cleanup
} -result {tf1}
test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} -body {
    # cdrom can return either d:\ or D:/, but we only care about the errcode
    testfile rmdir $cdrom/
} -constraints {win 95 cdrom testfile} -returnCodes error -match glob \
    -result {* EACCES} ; # was EEXIST, but changed for win98.
test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} -body {
    testfile rmdir $cdrom/
} -constraints {win nt cdrom testfile} -returnCodes error -match glob \
    -result {* EACCES}
test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} \
	{win emptyTest} {
    # can't make it happen







<
<
<
<
<







813
814
815
816
817
818
819





820
821
822
823
824
825
826
    file mkdir td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    contents td2/tf1
} -cleanup {
    cleanup
} -result {tf1}





test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} -body {
    testfile rmdir $cdrom/
} -constraints {win nt cdrom testfile} -returnCodes error -match glob \
    -result {* EACCES}
test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} \
	{win emptyTest} {
    # can't make it happen
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
    file mkdir td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    contents td2/tf1
} -cleanup {
    cleanup
} -result {tf1}
test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} -setup {
    cleanup
} -constraints {win 95 testfile} -body {
    file mkdir td1
    testfile cpdir td1 /
} -cleanup {
    cleanup
} -returnCodes error -result {/ EEXIST}
test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} -setup {
    cleanup
} -constraints {win nt testfile} -body {
    file mkdir td1
    testfile cpdir td1 /
} -cleanup {
    cleanup







<
<
<
<
<
<
<
<







851
852
853
854
855
856
857








858
859
860
861
862
863
864
    file mkdir td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    contents td2/tf1
} -cleanup {
    cleanup
} -result {tf1}








test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} -setup {
    cleanup
} -constraints {win nt testfile} -body {
    file mkdir td1
    testfile cpdir td1 /
} -cleanup {
    cleanup
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
test winFCmd-9.1 {TraversalDelete: DOTREE_F} -setup {
    cleanup
} -constraints {win testfile} -body {
    file mkdir td1
    createfile td1/tf1
    testfile rmdir -force td1
} -result {}
test winFCmd-9.2 {TraversalDelete: DOTREE_F} -setup {
    cleanup
} -constraints {win 95 testfile} -body {
    file mkdir td1
    set fd [open td1/tf1 w]
    testfile rmdir -force td1
} -cleanup {
    close $fd
} -returnCodes error -result {td1\tf1 EACCES}
test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup {
    cleanup
} -constraints {winVista testfile testchmod} -body {
    file mkdir td1/td2
    testchmod 000 td1
    testfile rmdir -force td1
    file exists td1







<
<
<
<
<
<
<
<
<







951
952
953
954
955
956
957









958
959
960
961
962
963
964
test winFCmd-9.1 {TraversalDelete: DOTREE_F} -setup {
    cleanup
} -constraints {win testfile} -body {
    file mkdir td1
    createfile td1/tf1
    testfile rmdir -force td1
} -result {}









test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup {
    cleanup
} -constraints {winVista testfile testchmod} -body {
    file mkdir td1/td2
    testchmod 000 td1
    testfile rmdir -force td1
    file exists td1
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
test winFCmd-19.5 {Windows extended path names} -constraints nt -setup {
    set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp]
    set tmpfile [file normalize $tmpfile]
} -body {
    list [catch {
        set f [open $tmpfile [list WRONLY CREAT]]
        close $f
    } res] errormsg ;#$res
} -cleanup {
    catch {file delete $tmpfile}
} -result [list 1 errormsg]
test winFCmd-19.6 {Windows extended path names} -constraints nt -setup {
    set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp]
    set tmpfile //?/[file normalize $tmpfile]
} -body {
    list [catch {
        set f [open $tmpfile [list WRONLY CREAT]]
        close $f







|


|







1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
test winFCmd-19.5 {Windows extended path names} -constraints nt -setup {
    set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp]
    set tmpfile [file normalize $tmpfile]
} -body {
    list [catch {
        set f [open $tmpfile [list WRONLY CREAT]]
        close $f
    } res] $res
} -cleanup {
    catch {file delete $tmpfile}
} -result [list 0 {}]
test winFCmd-19.6 {Windows extended path names} -constraints nt -setup {
    set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp]
    set tmpfile //?/[file normalize $tmpfile]
} -body {
    list [catch {
        set f [open $tmpfile [list WRONLY CREAT]]
        close $f
Changes to tests/winFile.test.
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
test winFile-1.1 {TclpGetUserHome} -constraints {win} -body {
    glob ~nosuchuser
} -returnCodes error -result {user "nosuchuser" doesn't exist}
test winFile-1.2 {TclpGetUserHome} -constraints {win nt nonPortable} -body {
    # The administrator account should always exist.
    glob ~administrator
} -match glob -result *
test winFile-1.3 {TclpGetUserHome} -constraints {win 95} -body {
    # Find some user in system.ini and then see if they have a home.

    set f [open $::env(windir)/system.ini]
    while {[gets $f line] >= 0} {
	if {$line ne {[Password Lists]}} {
	    continue
	}
	gets $f
	set name [lindex [split [gets $f] =] 0]
	if {$name ne ""} {
	    return [catch {glob ~$name}]
	}
    }
    return 0 ;# didn't find anything...
} -cleanup {
    catch {close $f}
} -result {0}
test winFile-1.4 {TclpGetUserHome} {win nt nonPortable} {
    catch {glob ~stanton@workgroup}
} {0}

test winFile-2.1 {TclpMatchFiles: case sensitivity} -constraints {win} -body {
    makeFile {} GlobCapS
    list [glob -nocomplain GlobC*] [glob -nocomplain globc*]







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







33
34
35
36
37
38
39


















40
41
42
43
44
45
46
test winFile-1.1 {TclpGetUserHome} -constraints {win} -body {
    glob ~nosuchuser
} -returnCodes error -result {user "nosuchuser" doesn't exist}
test winFile-1.2 {TclpGetUserHome} -constraints {win nt nonPortable} -body {
    # The administrator account should always exist.
    glob ~administrator
} -match glob -result *


















test winFile-1.4 {TclpGetUserHome} {win nt nonPortable} {
    catch {glob ~stanton@workgroup}
} {0}

test winFile-2.1 {TclpMatchFiles: case sensitivity} -constraints {win} -body {
    makeFile {} GlobCapS
    list [glob -nocomplain GlobC*] [glob -nocomplain globc*]
Changes to tests/winPipe.test.
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
    exec [interpreter] $path(more) < $path(little) | $cat32 > $path(stdout) 2> $path(stderr)
    list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win nt exec cat32} {
    exec [interpreter] $path(more) < $path(big) | $cat32 > $path(stdout) 2> $path(stderr)
    list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {win 95 exec cat32} {
    exec command /c type $path(big) |& $cat32 > $path(stdout) 2> $path(stderr)
    list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.6 {32 bit comprehensive tests: from console} \
	{win cat32 AllocConsole} {
    # would block waiting for human input
} {}
test winpipe-1.7 {32 bit comprehensive tests: from NUL} {win exec cat32} {
    exec $cat32 < nul > $path(stdout) 2> $path(stderr)
    list [contents $path(stdout)] [contents $path(stderr)]







<
<
<
<







78
79
80
81
82
83
84




85
86
87
88
89
90
91
    exec [interpreter] $path(more) < $path(little) | $cat32 > $path(stdout) 2> $path(stderr)
    list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win nt exec cat32} {
    exec [interpreter] $path(more) < $path(big) | $cat32 > $path(stdout) 2> $path(stderr)
    list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"




test winpipe-1.6 {32 bit comprehensive tests: from console} \
	{win cat32 AllocConsole} {
    # would block waiting for human input
} {}
test winpipe-1.7 {32 bit comprehensive tests: from NUL} {win exec cat32} {
    exec $cat32 < nul > $path(stdout) 2> $path(stderr)
    list [contents $path(stdout)] [contents $path(stderr)]
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
    puts $f $big
    puts $f \032
    flush $f
    set r [read $f 64]
    catch {close $f}
    set r
} "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
test winpipe-1.22 {Checking command.com for Win95/98 hanging} {win 95 exec} {
    exec command.com /c dir /b
    set result 1
} 1

test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} {
    proc readResults {f} {
	global x result
	if { [eof $f] } {
	    close $f
	    set x 1







<
<
<
<







166
167
168
169
170
171
172




173
174
175
176
177
178
179
    puts $f $big
    puts $f \032
    flush $f
    set r [read $f 64]
    catch {close $f}
    set r
} "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"





test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} {
    proc readResults {f} {
	global x result
	if { [eof $f] } {
	    close $f
	    set x 1
Changes to tests/zlib.test.
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
    zlib push decompress $r
    fileevent $r readable {set msg [read $r];lappend ::res $msg;if {[eof $r]} {set ::done 1}}
    after 250 {lappend ::res MIDDLE}
    vwait ::done
    set ::res
} -cleanup {
    catch {close $r}
} -result {qwertyuiop MIDDLE asdfghjkl}
test zlib-8.6 {transformation and fconfigure} -setup {
    set file [makeFile {} test.z]
    set fd [open $file wb]
} -constraints zlib -body {
    list [fconfigure $fd] [zlib push compress $fd; fconfigure $fd] \
	[chan pop $fd; fconfigure $fd]
} -cleanup {







|







211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
    zlib push decompress $r
    fileevent $r readable {set msg [read $r];lappend ::res $msg;if {[eof $r]} {set ::done 1}}
    after 250 {lappend ::res MIDDLE}
    vwait ::done
    set ::res
} -cleanup {
    catch {close $r}
} -result {qwertyuiop MIDDLE asdfghjkl {}}
test zlib-8.6 {transformation and fconfigure} -setup {
    set file [makeFile {} test.z]
    set fd [open $file wb]
} -constraints zlib -body {
    list [fconfigure $fd] [zlib push compress $fd; fconfigure $fd] \
	[chan pop $fd; fconfigure $fd]
} -cleanup {
Changes to tools/genStubs.tcl.
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
# Results:
#	Returns the original text inside an appropriate #ifdef.

proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} {
    set text ""
    switch $plat {
	win {
	    append text "#if defined(__WIN32__)"
	    if {$withCygwin} {
		append text " || defined(__CYGWIN__)"
	    }
	    append text " /* WIN */\n${iftxt}"
	    if {$eltxt ne ""} {
		append text "#else /* WIN */\n${eltxt}"
	    }
	    append text "#endif /* WIN */\n"
	}
	unix {
	    append text "#if !defined(__WIN32__)"
	    if {$withCygwin} {
		append text " && !defined(__CYGWIN__)"
	    }
	    append text " && !defined(MAC_OSX_TCL)\
		    /* UNIX */\n${iftxt}"
	    if {$eltxt ne ""} {
		append text "#else /* UNIX */\n${eltxt}"







|










|







279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
# Results:
#	Returns the original text inside an appropriate #ifdef.

proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} {
    set text ""
    switch $plat {
	win {
	    append text "#if defined(_WIN32)"
	    if {$withCygwin} {
		append text " || defined(__CYGWIN__)"
	    }
	    append text " /* WIN */\n${iftxt}"
	    if {$eltxt ne ""} {
		append text "#else /* WIN */\n${eltxt}"
	    }
	    append text "#endif /* WIN */\n"
	}
	unix {
	    append text "#if !defined(_WIN32)"
	    if {$withCygwin} {
		append text " && !defined(__CYGWIN__)"
	    }
	    append text " && !defined(MAC_OSX_TCL)\
		    /* UNIX */\n${iftxt}"
	    if {$eltxt ne ""} {
		append text "#else /* UNIX */\n${eltxt}"
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
	    append text "#ifdef MAC_OSX_TK /* AQUA */\n${iftxt}"
	    if {$eltxt ne ""} {
		append text "#else /* AQUA */\n${eltxt}"
	    }
	    append text "#endif /* AQUA */\n"
	}
	x11 {
	    append text "#if !(defined(__WIN32__)"
	    if {$withCygwin} {
		append text " || defined(__CYGWIN__)"
	    }
	    append text " || defined(MAC_OSX_TK))\
		    /* X11 */\n${iftxt}"
	    if {$eltxt ne ""} {
		append text "#else /* X11 */\n${eltxt}"







|







316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
	    append text "#ifdef MAC_OSX_TK /* AQUA */\n${iftxt}"
	    if {$eltxt ne ""} {
		append text "#else /* AQUA */\n${eltxt}"
	    }
	    append text "#endif /* AQUA */\n"
	}
	x11 {
	    append text "#if !(defined(_WIN32)"
	    if {$withCygwin} {
		append text " || defined(__CYGWIN__)"
	    }
	    append text " || defined(MAC_OSX_TK))\
		    /* X11 */\n${iftxt}"
	    if {$eltxt ne ""} {
		append text "#else /* X11 */\n${eltxt}"
Changes to unix/Makefile.in.
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
	@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/";
	@for i in $(TOP_DIR)/library/opt/*.tcl ; \
	    do \
	    $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \
	    done;
	@echo "Installing package msgcat 1.5.2 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.2.tm;
	@echo "Installing package tcltest 2.3.7 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.7.tm;

	@echo "Installing package platform 1.0.12 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.12.tm;
	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm;

	@echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/";







|
|







849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
	@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/";
	@for i in $(TOP_DIR)/library/opt/*.tcl ; \
	    do \
	    $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \
	    done;
	@echo "Installing package msgcat 1.5.2 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.2.tm;
	@echo "Installing package tcltest 2.3.8 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.8.tm;

	@echo "Installing package platform 1.0.12 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.12.tm;
	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm;

	@echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/";
2088
2089
2090
2091
2092
2093
2094

2095
2096
2097

2098
2099
2100
2101
2102
2103
2104
# Also note that the 8.6 tool build requires an installed 8.6 native Tcl
# interpreter in order to be able to run.
#--------------------------------------------------------------------------

html: ${NATIVE_TCLSH}
	$(BUILD_HTML)
	@EXTRA_BUILD_HTML@

html-tcl: ${NATIVE_TCLSH}
	$(BUILD_HTML) --tcl
	@EXTRA_BUILD_HTML@

html-tk: ${NATIVE_TCLSH}
	$(BUILD_HTML) --tk
	@EXTRA_BUILD_HTML@

# You'd better have these programs or you will have problems creating Makefile
# from Makefile.in in the first place...
HTML_VERSION = `basename $(TOP_DIR) | sed s/tcl//`







>



>







2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
# Also note that the 8.6 tool build requires an installed 8.6 native Tcl
# interpreter in order to be able to run.
#--------------------------------------------------------------------------

html: ${NATIVE_TCLSH}
	$(BUILD_HTML)
	@EXTRA_BUILD_HTML@

html-tcl: ${NATIVE_TCLSH}
	$(BUILD_HTML) --tcl
	@EXTRA_BUILD_HTML@

html-tk: ${NATIVE_TCLSH}
	$(BUILD_HTML) --tk
	@EXTRA_BUILD_HTML@

# You'd better have these programs or you will have problems creating Makefile
# from Makefile.in in the first place...
HTML_VERSION = `basename $(TOP_DIR) | sed s/tcl//`
Changes to unix/configure.
1333
1334
1335
1336
1337
1338
1339



1340
1341
1342
1343
1344
1345
1346


TCL_VERSION=8.6
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=6
TCL_PATCH_LEVEL=".1"
VERSION=${TCL_VERSION}




#------------------------------------------------------------------------
# Setup configure arguments for bundled packages
#------------------------------------------------------------------------

PKG_CFG_ARGS="$ac_configure_args ${PKG_CFG_ARGS}"








>
>
>







1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349


TCL_VERSION=8.6
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=6
TCL_PATCH_LEVEL=".1"
VERSION=${TCL_VERSION}

EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"}
EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"}

#------------------------------------------------------------------------
# Setup configure arguments for bundled packages
#------------------------------------------------------------------------

PKG_CFG_ARGS="$ac_configure_args ${PKG_CFG_ARGS}"

7075
7076
7077
7078
7079
7080
7081
7082
7083
7084
7085
7086
7087
7088
7089
7090
7091
	    if test "x${TCL_THREADS}" = "x0"; then
		{ { echo "$as_me:$LINENO: error: CYGWIN compile is only supported with --enable-threads" >&5
echo "$as_me: error: CYGWIN compile is only supported with --enable-threads" >&2;}
   { (exit 1); exit 1; }; }
	    fi
	    do64bit_ok=yes
	    if test "x${SHARED_BUILD}" = "x1"; then
		echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args"
		# The eval makes quoting arguments work.
		if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix
		then :
		else
		    { echo "configure: error: configure failed for ../win" 1>&2; exit 1; }
		fi
	    fi
	    ;;
	dgux*)







|

|







7078
7079
7080
7081
7082
7083
7084
7085
7086
7087
7088
7089
7090
7091
7092
7093
7094
	    if test "x${TCL_THREADS}" = "x0"; then
		{ { echo "$as_me:$LINENO: error: CYGWIN compile is only supported with --enable-threads" >&5
echo "$as_me: error: CYGWIN compile is only supported with --enable-threads" >&2;}
   { (exit 1); exit 1; }; }
	    fi
	    do64bit_ok=yes
	    if test "x${SHARED_BUILD}" = "x1"; then
		echo "running cd ${TCL_SRC_DIR}/win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args"
		# The eval makes quoting arguments work.
		if cd ${TCL_SRC_DIR}/win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix
		then :
		else
		    { echo "configure: error: configure failed for ../win" 1>&2; exit 1; }
		fi
	    fi
	    ;;
	dgux*)
7757
7758
7759
7760
7761
7762
7763


7764
7765
7766
7767
7768


7769
7770
7771
7772
7773
7774
7775

		# The -pthread needs to go in the LDFLAGS, not LIBS
		LIBS=`echo $LIBS | sed s/-pthread//`
		CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
		LDFLAGS="$LDFLAGS $PTHREAD_LIBS"
fi



	    # Version numbers are dot-stripped by system policy.
	    TCL_TRIM_DOTS=`echo ${VERSION} | tr -d .`
	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
	    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1'
	    TCL_LIB_VERSIONS_OK=nodots


	    ;;
	Darwin-*)
	    CFLAGS_OPTIMIZE="-Os"
	    SHLIB_CFLAGS="-fno-common"
	    # To avoid discrepancies between what headers configure sees during
	    # preprocessing tests and compiling tests, move any -isysroot and
	    # -mmacosx-version-min flags from CFLAGS to CPPFLAGS:







>
>
|
|
|
|
|
>
>







7760
7761
7762
7763
7764
7765
7766
7767
7768
7769
7770
7771
7772
7773
7774
7775
7776
7777
7778
7779
7780
7781
7782

		# The -pthread needs to go in the LDFLAGS, not LIBS
		LIBS=`echo $LIBS | sed s/-pthread//`
		CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
		LDFLAGS="$LDFLAGS $PTHREAD_LIBS"
fi

	    case $system in
	    FreeBSD-3.*)
		# Version numbers are dot-stripped by system policy.
		TCL_TRIM_DOTS=`echo ${VERSION} | tr -d .`
		UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so'
		TCL_LIB_VERSIONS_OK=nodots
		;;
	    esac
	    ;;
	Darwin-*)
	    CFLAGS_OPTIMIZE="-Os"
	    SHLIB_CFLAGS="-fno-common"
	    # To avoid discrepancies between what headers configure sees during
	    # preprocessing tests and compiling tests, move any -isysroot and
	    # -mmacosx-version-min flags from CFLAGS to CPPFLAGS:
Changes to unix/configure.in.
23
24
25
26
27
28
29



30
31
32
33
34
35
36
])

TCL_VERSION=8.6
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=6
TCL_PATCH_LEVEL=".1"
VERSION=${TCL_VERSION}




#------------------------------------------------------------------------
# Setup configure arguments for bundled packages
#------------------------------------------------------------------------

PKG_CFG_ARGS="$ac_configure_args ${PKG_CFG_ARGS}"








>
>
>







23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
])

TCL_VERSION=8.6
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=6
TCL_PATCH_LEVEL=".1"
VERSION=${TCL_VERSION}

EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"}
EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"}

#------------------------------------------------------------------------
# Setup configure arguments for bundled packages
#------------------------------------------------------------------------

PKG_CFG_ARGS="$ac_configure_args ${PKG_CFG_ARGS}"

Changes to unix/tcl.m4.
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
		AC_MSG_ERROR([${CC} is not a cygwin compiler.])
	    fi
	    if test "x${TCL_THREADS}" = "x0"; then
		AC_MSG_ERROR([CYGWIN compile is only supported with --enable-threads])
	    fi
	    do64bit_ok=yes
	    if test "x${SHARED_BUILD}" = "x1"; then
		echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args"
		# The eval makes quoting arguments work.
		if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix
		then :
		else
		    { echo "configure: error: configure failed for ../win" 1>&2; exit 1; }
		fi
	    fi
	    ;;
	dgux*)







|

|







1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
		AC_MSG_ERROR([${CC} is not a cygwin compiler.])
	    fi
	    if test "x${TCL_THREADS}" = "x0"; then
		AC_MSG_ERROR([CYGWIN compile is only supported with --enable-threads])
	    fi
	    do64bit_ok=yes
	    if test "x${SHARED_BUILD}" = "x1"; then
		echo "running cd ${TCL_SRC_DIR}/win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args"
		# The eval makes quoting arguments work.
		if cd ${TCL_SRC_DIR}/win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix
		then :
		else
		    { echo "configure: error: configure failed for ../win" 1>&2; exit 1; }
		fi
	    fi
	    ;;
	dgux*)
1541
1542
1543
1544
1545
1546
1547


1548
1549
1550
1551
1552


1553
1554
1555
1556
1557
1558
1559
		CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'])
	    AS_IF([test "${TCL_THREADS}" = "1"], [
		# The -pthread needs to go in the LDFLAGS, not LIBS
		LIBS=`echo $LIBS | sed s/-pthread//`
		CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
		LDFLAGS="$LDFLAGS $PTHREAD_LIBS"])


	    # Version numbers are dot-stripped by system policy.
	    TCL_TRIM_DOTS=`echo ${VERSION} | tr -d .`
	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
	    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1'
	    TCL_LIB_VERSIONS_OK=nodots


	    ;;
	Darwin-*)
	    CFLAGS_OPTIMIZE="-Os"
	    SHLIB_CFLAGS="-fno-common"
	    # To avoid discrepancies between what headers configure sees during
	    # preprocessing tests and compiling tests, move any -isysroot and
	    # -mmacosx-version-min flags from CFLAGS to CPPFLAGS:







>
>
|
|
|
|
|
>
>







1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
		CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'])
	    AS_IF([test "${TCL_THREADS}" = "1"], [
		# The -pthread needs to go in the LDFLAGS, not LIBS
		LIBS=`echo $LIBS | sed s/-pthread//`
		CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
		LDFLAGS="$LDFLAGS $PTHREAD_LIBS"])
	    case $system in
	    FreeBSD-3.*)
		# Version numbers are dot-stripped by system policy.
		TCL_TRIM_DOTS=`echo ${VERSION} | tr -d .`
		UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so'
		TCL_LIB_VERSIONS_OK=nodots
		;;
	    esac
	    ;;
	Darwin-*)
	    CFLAGS_OPTIMIZE="-Os"
	    SHLIB_CFLAGS="-fno-common"
	    # To avoid discrepancies between what headers configure sees during
	    # preprocessing tests and compiling tests, move any -isysroot and
	    # -mmacosx-version-min flags from CFLAGS to CPPFLAGS:
Changes to unix/tcl.pc.in.
1
2
3
4
5
6
7
8
9
10
11
12
13
14

15
# tcl pkg-config source file

prefix=@prefix@
exec_prefix=@exec_prefix@
libdir=@libdir@
includedir=@includedir@

Name: Tool Command Language
Description: Tcl is a powerful, easy-to-learn dynamic programming language, suitable for a wide range of uses.
URL: http://www.tcl.tk/
Version: @TCL_VERSION@
Requires:
Conflicts:
Libs: -L${libdir} @TCL_LIBS@

Cflags: -I${includedir}










|
|
<
|
>

1
2
3
4
5
6
7
8
9
10
11
12

13
14
15
# tcl pkg-config source file

prefix=@prefix@
exec_prefix=@exec_prefix@
libdir=@libdir@
includedir=@includedir@

Name: Tool Command Language
Description: Tcl is a powerful, easy-to-learn dynamic programming language, suitable for a wide range of uses.
URL: http://www.tcl.tk/
Version: @TCL_VERSION@@TCL_PATCH_LEVEL@
Requires.private: zlib >= 1.2.3

Libs: -L${libdir} @TCL_LIB_FLAG@ @TCL_STUB_LIB_FLAG@
Libs.private: @TCL_LIBS@
Cflags: -I${includedir}
Changes to unix/tclConfig.sh.in.
161
162
163
164
165
166
167
168
169

# Path to the Tcl stub library in the build directory.
TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@'

# Path to the Tcl stub library in the install directory.
TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@'

# Flag, 1: we built Tcl with threads enables, 0 we didn't
TCL_THREADS=@TCL_THREADS@







|

161
162
163
164
165
166
167
168
169

# Path to the Tcl stub library in the build directory.
TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@'

# Path to the Tcl stub library in the install directory.
TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@'

# Flag, 1: we built Tcl with threads enabled, 0 we didn't
TCL_THREADS=@TCL_THREADS@
Changes to unix/tclUnixFCmd.c.
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
static int		SetOwnerAttribute(Tcl_Interp *interp, int objIndex,
			    Tcl_Obj *fileName, Tcl_Obj *attributePtr);
static int		SetPermissionsAttribute(Tcl_Interp *interp,
			    int objIndex, Tcl_Obj *fileName,
			    Tcl_Obj *attributePtr);
static int		GetModeFromPermString(Tcl_Interp *interp,
			    const char *modeStringPtr, mode_t *modePtr);
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
static int		GetReadOnlyAttribute(Tcl_Interp *interp, int objIndex,
			    Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr);
static int		SetReadOnlyAttribute(Tcl_Interp *interp, int objIndex,
			    Tcl_Obj *fileName, Tcl_Obj *attributePtr);
#endif

/*
 * Prototype for the TraverseUnixTree callback function.
 */








|
|

|







87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
static int		SetOwnerAttribute(Tcl_Interp *interp, int objIndex,
			    Tcl_Obj *fileName, Tcl_Obj *attributePtr);
static int		SetPermissionsAttribute(Tcl_Interp *interp,
			    int objIndex, Tcl_Obj *fileName,
			    Tcl_Obj *attributePtr);
static int		GetModeFromPermString(Tcl_Interp *interp,
			    const char *modeStringPtr, mode_t *modePtr);
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) || defined(__CYGWIN__)
static int		GetUnixFileAttributes(Tcl_Interp *interp, int objIndex,
			    Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr);
static int		SetUnixFileAttributes(Tcl_Interp *interp, int objIndex,
			    Tcl_Obj *fileName, Tcl_Obj *attributePtr);
#endif

/*
 * Prototype for the TraverseUnixTree callback function.
 */

120
121
122
123
124
125
126







127
128
129
130



131
132
133
134
135
136
137
138
139







140
141
142



143
144
145
146
147
148
149
150
151



152



153
154
155
156



157
158
159
160
161
162
163
 */

extern TclFileAttrProcs tclpFileAttrProcs[];
extern const char *const tclpFileAttrStrings[];

#else /* !DJGPP */
enum {







    UNIX_GROUP_ATTRIBUTE, UNIX_OWNER_ATTRIBUTE, UNIX_PERMISSIONS_ATTRIBUTE,
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
    UNIX_READONLY_ATTRIBUTE,
#endif



#ifdef MAC_OSX_TCL
    MACOSX_CREATOR_ATTRIBUTE, MACOSX_TYPE_ATTRIBUTE, MACOSX_HIDDEN_ATTRIBUTE,
    MACOSX_RSRCLENGTH_ATTRIBUTE,
#endif
    UNIX_INVALID_ATTRIBUTE /* lint - last enum value needs no trailing , */
};

MODULE_SCOPE const char *const tclpFileAttrStrings[];
const char *const tclpFileAttrStrings[] = {







    "-group", "-owner", "-permissions",
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
    "-readonly",



#endif
#ifdef MAC_OSX_TCL
    "-creator", "-type", "-hidden", "-rsrclength",
#endif
    NULL
};

MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[];
const TclFileAttrProcs tclpFileAttrProcs[] = {



    {GetGroupAttribute, SetGroupAttribute},



    {GetOwnerAttribute, SetOwnerAttribute},
    {GetPermissionsAttribute, SetPermissionsAttribute},
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
    {GetReadOnlyAttribute, SetReadOnlyAttribute},



#endif
#ifdef MAC_OSX_TCL
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
#endif







>
>
>
>
>
>
>
|
|


>
>
>









>
>
>
>
>
>
>
|
|

>
>
>









>
>
>

>
>
>


|
|
>
>
>







120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
 */

extern TclFileAttrProcs tclpFileAttrProcs[];
extern const char *const tclpFileAttrStrings[];

#else /* !DJGPP */
enum {
#if defined(__CYGWIN__)
    UNIX_ARCHIVE_ATTRIBUTE,
#endif
    UNIX_GROUP_ATTRIBUTE,
#if defined(__CYGWIN__)
    UNIX_HIDDEN_ATTRIBUTE,
#endif
    UNIX_OWNER_ATTRIBUTE, UNIX_PERMISSIONS_ATTRIBUTE,
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) || defined(__CYGWIN__)
    UNIX_READONLY_ATTRIBUTE,
#endif
#if defined(__CYGWIN__)
    UNIX_SYSTEM_ATTRIBUTE,
#endif
#ifdef MAC_OSX_TCL
    MACOSX_CREATOR_ATTRIBUTE, MACOSX_TYPE_ATTRIBUTE, MACOSX_HIDDEN_ATTRIBUTE,
    MACOSX_RSRCLENGTH_ATTRIBUTE,
#endif
    UNIX_INVALID_ATTRIBUTE /* lint - last enum value needs no trailing , */
};

MODULE_SCOPE const char *const tclpFileAttrStrings[];
const char *const tclpFileAttrStrings[] = {
#if defined(__CYGWIN__)
    "-archive",
#endif
    "-group",
#if defined(__CYGWIN__)
    "-hidden",
#endif
    "-owner", "-permissions",
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) || defined(__CYGWIN__)
    "-readonly",
#endif
#if defined(__CYGWIN__)
    "-system",
#endif
#ifdef MAC_OSX_TCL
    "-creator", "-type", "-hidden", "-rsrclength",
#endif
    NULL
};

MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[];
const TclFileAttrProcs tclpFileAttrProcs[] = {
#if defined(__CYGWIN__)
    {GetUnixFileAttributes, SetUnixFileAttributes},
#endif
    {GetGroupAttribute, SetGroupAttribute},
#if defined(__CYGWIN__)
    {GetUnixFileAttributes, SetUnixFileAttributes},
#endif
    {GetOwnerAttribute, SetOwnerAttribute},
    {GetPermissionsAttribute, SetPermissionsAttribute},
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) || defined(__CYGWIN__)
    {GetUnixFileAttributes, SetUnixFileAttributes},
#endif
#if defined(__CYGWIN__)
    {GetUnixFileAttributes, SetUnixFileAttributes},
#endif
#ifdef MAC_OSX_TCL
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
#endif
2242
2243
2244
2245
2246
2247
2248































































































































2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
     * an existing writable directory; we've no recovery mechanism if it
     * isn't.
     */

    return TCL_TEMPORARY_FILE_DIRECTORY;
}
































































































































#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
/*
 *----------------------------------------------------------------------
 *
 * GetReadOnlyAttribute
 *
 *	Gets the readonly attribute (user immutable flag) of a file.
 *
 * Results:
 *	Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there
 *	is no error. The object will have ref count 0.
 *
 * Side effects:
 *	A new object is allocated.
 *
 *----------------------------------------------------------------------
 */

static int
GetReadOnlyAttribute(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    Tcl_StatBuf statBuf;
    int result;







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|



|














|







2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
     * an existing writable directory; we've no recovery mechanism if it
     * isn't.
     */

    return TCL_TEMPORARY_FILE_DIRECTORY;
}

#if defined(__CYGWIN__)

static void
StatError(
    Tcl_Interp *interp,		/* The interp that has the error */
    Tcl_Obj *fileName)		/* The name of the file which caused the
				 * error. */
{
    TclWinConvertError(GetLastError());
    Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s",
	    TclGetString(fileName), Tcl_PosixError(interp)));
}

static WCHAR *
winPathFromObj(
    Tcl_Obj *fileName)
{
    int size;
    const char *native =  Tcl_FSGetNativePath(fileName);
    WCHAR *winPath;

    size = cygwin_conv_path(1, native, NULL, 0);
    winPath = ckalloc(size);
    cygwin_conv_path(1, native, winPath, size);

    return winPath;
}

static const int attributeArray[] = {
    0x20, 0, 2, 0, 0, 1, 4};

/*
 *----------------------------------------------------------------------
 *
 * GetUnixFileAttributes
 *
 *	Gets the readonly attribute of a file.
 *
 * Results:
 *	Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there
 *	is no error. The object will have ref count 0.
 *
 * Side effects:
 *	A new object is allocated.
 *
 *----------------------------------------------------------------------
 */

static int
GetUnixFileAttributes(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    int fileAttributes;
    WCHAR *winPath = winPathFromObj(fileName);

    fileAttributes = GetFileAttributesW(winPath);
    ckfree(winPath);

    if (fileAttributes == -1) {
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    *attributePtrPtr = Tcl_NewIntObj((fileAttributes&attributeArray[objIndex])!=0);

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetUnixFileAttributes
 *
 *	Sets the readonly attribute of a file.
 *
 * Results:
 *	Standard TCL result.
 *
 * Side effects:
 *	The readonly attribute of the file is changed.
 *
 *---------------------------------------------------------------------------
 */

static int
SetUnixFileAttributes(
    Tcl_Interp *interp,	    /* The interp we are using for errors. */
    int objIndex,           /* The index of the attribute. */
    Tcl_Obj *fileName,      /* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr)  /* The attribute to set. */
{
    int yesNo, fileAttributes, old;
    WCHAR *winPath;

    if (Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo) != TCL_OK) {
	return TCL_ERROR;
    }

    winPath = winPathFromObj(fileName);

    fileAttributes = old = GetFileAttributesW(winPath);

    if (fileAttributes == -1) {
	ckfree(winPath);
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    if (yesNo) {
	fileAttributes |= attributeArray[objIndex];
    } else {
	fileAttributes &= ~attributeArray[objIndex];
    }

    if ((fileAttributes != old)
	    && !SetFileAttributesW(winPath, fileAttributes)) {
	ckfree(winPath);
	StatError(interp, fileName);
	return TCL_ERROR;
    }

	ckfree(winPath);
    return TCL_OK;
}
#elif defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
/*
 *----------------------------------------------------------------------
 *
 * GetUnixFileAttributes
 *
 *	Gets the readonly attribute (user immutable flag) of a file.
 *
 * Results:
 *	Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there
 *	is no error. The object will have ref count 0.
 *
 * Side effects:
 *	A new object is allocated.
 *
 *----------------------------------------------------------------------
 */

static int
GetUnixFileAttributes(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    Tcl_StatBuf statBuf;
    int result;
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetReadOnlyAttribute
 *
 *	Sets the readonly attribute (user immutable flag) of a file.
 *
 * Results:
 *	Standard TCL result.
 *
 * Side effects:
 *	The readonly attribute of the file is changed.
 *
 *---------------------------------------------------------------------------
 */

static int
SetReadOnlyAttribute(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr)	/* The attribute to set. */
{
    Tcl_StatBuf statBuf;
    int result, readonly;







|













|







2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetUnixFileAttributes
 *
 *	Sets the readonly attribute (user immutable flag) of a file.
 *
 * Results:
 *	Standard TCL result.
 *
 * Side effects:
 *	The readonly attribute of the file is changed.
 *
 *---------------------------------------------------------------------------
 */

static int
SetUnixFileAttributes(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr)	/* The attribute to set. */
{
    Tcl_StatBuf statBuf;
    int result, readonly;
Changes to unix/tclUnixFile.c.
1101
1102
1103
1104
1105
1106
1107






1108
1109
1110
1111
1112
1113
1114
	}
	Tcl_IncrRefCount(validPathPtr);
    }

    str = Tcl_GetStringFromObj(validPathPtr, &len);
    Tcl_UtfToExternalDString(NULL, str, len, &ds);
    len = Tcl_DStringLength(&ds) + sizeof(char);






    Tcl_DecrRefCount(validPathPtr);
    nativePathPtr = ckalloc(len);
    memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len);

    Tcl_DStringFree(&ds);
    return nativePathPtr;
}







>
>
>
>
>
>







1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
	}
	Tcl_IncrRefCount(validPathPtr);
    }

    str = Tcl_GetStringFromObj(validPathPtr, &len);
    Tcl_UtfToExternalDString(NULL, str, len, &ds);
    len = Tcl_DStringLength(&ds) + sizeof(char);
    if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) {
	/* See bug [3118489]: NUL in filenames */
	Tcl_DecrRefCount(validPathPtr);
	Tcl_DStringFree(&ds);
	return NULL;
    }
    Tcl_DecrRefCount(validPathPtr);
    nativePathPtr = ckalloc(len);
    memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len);

    Tcl_DStringFree(&ds);
    return nativePathPtr;
}
Changes to unix/tclUnixPipe.c.
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
{
    PipeState *psPtr = instanceData;
    int newmask;

    if (psPtr->inFile) {
	newmask = mask & (TCL_READABLE | TCL_EXCEPTION);
	if (newmask) {
	    Tcl_CreateFileHandler(GetFd(psPtr->inFile), mask,
		    (Tcl_FileProc *) Tcl_NotifyChannel, psPtr->channel);
	} else {
	    Tcl_DeleteFileHandler(GetFd(psPtr->inFile));
	}
    }
    if (psPtr->outFile) {
	newmask = mask & (TCL_WRITABLE | TCL_EXCEPTION);
	if (newmask) {
	    Tcl_CreateFileHandler(GetFd(psPtr->outFile), mask,
		    (Tcl_FileProc *) Tcl_NotifyChannel, psPtr->channel);
	} else {
	    Tcl_DeleteFileHandler(GetFd(psPtr->outFile));
	}
    }
}








|








|







1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
{
    PipeState *psPtr = instanceData;
    int newmask;

    if (psPtr->inFile) {
	newmask = mask & (TCL_READABLE | TCL_EXCEPTION);
	if (newmask) {
	    Tcl_CreateFileHandler(GetFd(psPtr->inFile), newmask,
		    (Tcl_FileProc *) Tcl_NotifyChannel, psPtr->channel);
	} else {
	    Tcl_DeleteFileHandler(GetFd(psPtr->inFile));
	}
    }
    if (psPtr->outFile) {
	newmask = mask & (TCL_WRITABLE | TCL_EXCEPTION);
	if (newmask) {
	    Tcl_CreateFileHandler(GetFd(psPtr->outFile), newmask,
		    (Tcl_FileProc *) Tcl_NotifyChannel, psPtr->channel);
	} else {
	    Tcl_DeleteFileHandler(GetFd(psPtr->outFile));
	}
    }
}

Changes to unix/tclUnixPort.h.
89
90
91
92
93
94
95



96
97
98
99
100
101
102
    __declspec(dllimport) extern __stdcall int GetModuleFileNameW(void *, const char *, int);
    __declspec(dllimport) extern __stdcall int WideCharToMultiByte(int, int, const char *, int,
	    const char *, int, const char *, const char *);
    __declspec(dllimport) extern __stdcall int MultiByteToWideChar(int, int, const char *, int,
	    WCHAR *, int);
    __declspec(dllimport) extern __stdcall void OutputDebugStringW(const WCHAR *);
    __declspec(dllimport) extern __stdcall int IsDebuggerPresent();




    __declspec(dllimport) extern int cygwin_conv_path(int, const void *, void *, int);
    __declspec(dllimport) extern int cygwin_conv_path_list(int, const void *, void *, int);
#   define USE_PUTENV 1
#   define USE_PUTENV_FOR_UNSET 1
/* On Cygwin, the environment is imported from the Cygwin DLL. */
#ifndef __x86_64__







>
>
>







89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
    __declspec(dllimport) extern __stdcall int GetModuleFileNameW(void *, const char *, int);
    __declspec(dllimport) extern __stdcall int WideCharToMultiByte(int, int, const char *, int,
	    const char *, int, const char *, const char *);
    __declspec(dllimport) extern __stdcall int MultiByteToWideChar(int, int, const char *, int,
	    WCHAR *, int);
    __declspec(dllimport) extern __stdcall void OutputDebugStringW(const WCHAR *);
    __declspec(dllimport) extern __stdcall int IsDebuggerPresent();
    __declspec(dllimport) extern __stdcall int GetLastError();
    __declspec(dllimport) extern __stdcall int GetFileAttributesW(const WCHAR *);
    __declspec(dllimport) extern __stdcall int SetFileAttributesW(const WCHAR *, int);

    __declspec(dllimport) extern int cygwin_conv_path(int, const void *, void *, int);
    __declspec(dllimport) extern int cygwin_conv_path_list(int, const void *, void *, int);
#   define USE_PUTENV 1
#   define USE_PUTENV_FOR_UNSET 1
/* On Cygwin, the environment is imported from the Cygwin DLL. */
#ifndef __x86_64__
Changes to unix/tclUnixSock.c.
51
52
53
54
55
56
57


58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86





87
88
89
90
91
92
93
} TcpFdList;

struct TcpState {
    Tcl_Channel channel;	/* Channel associated with this file. */
    TcpFdList fds;		/* The file descriptors of the sockets. */
    int flags;			/* ORed combination of the bitfields defined
				 * below. */


    /*
     * Only needed for server sockets
     */

    Tcl_TcpAcceptProc *acceptProc;
                                /* Proc to call on accept. */
    ClientData acceptProcData;  /* The data for the accept proc. */

    /*
     * Only needed for client sockets
     */

    struct addrinfo *addrlist;	/* Addresses to connect to. */
    struct addrinfo *addr;	/* Iterator over addrlist. */
    struct addrinfo *myaddrlist;/* Local address. */
    struct addrinfo *myaddr;	/* Iterator over myaddrlist. */
    int filehandlers;           /* Caches FileHandlers that get set up while
                                 * an async socket is not yet connected. */
    int status;                 /* Cache status of async socket. */
    int cachedBlocking;         /* Cache blocking mode of async socket. */
};

/*
 * These bits may be ORed together into the "flags" field of a TcpState
 * structure.
 */

#define TCP_ASYNC_SOCKET	(1<<0)	/* Asynchronous socket. */
#define TCP_ASYNC_CONNECT	(1<<1)	/* Async connect in progress. */






/*
 * The following defines the maximum length of the listen queue. This is the
 * number of outstanding yet-to-be-serviced requests for a connection on a
 * server socket, more than this number of outstanding requests and the
 * connection request will fail.
 */







>
>


















|








|

>
>
>
>
>







51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
} TcpFdList;

struct TcpState {
    Tcl_Channel channel;	/* Channel associated with this file. */
    TcpFdList fds;		/* The file descriptors of the sockets. */
    int flags;			/* ORed combination of the bitfields defined
				 * below. */
    int interest;		/* Event types of interest */

    /*
     * Only needed for server sockets
     */

    Tcl_TcpAcceptProc *acceptProc;
                                /* Proc to call on accept. */
    ClientData acceptProcData;  /* The data for the accept proc. */

    /*
     * Only needed for client sockets
     */

    struct addrinfo *addrlist;	/* Addresses to connect to. */
    struct addrinfo *addr;	/* Iterator over addrlist. */
    struct addrinfo *myaddrlist;/* Local address. */
    struct addrinfo *myaddr;	/* Iterator over myaddrlist. */
    int filehandlers;           /* Caches FileHandlers that get set up while
                                 * an async socket is not yet connected. */
    int connectError;           /* Cache SO_ERROR of async socket. */
    int cachedBlocking;         /* Cache blocking mode of async socket. */
};

/*
 * These bits may be ORed together into the "flags" field of a TcpState
 * structure.
 */

#define TCP_NONBLOCKING		(1<<0)	/* Socket with non-blocking I/O */
#define TCP_ASYNC_CONNECT	(1<<1)	/* Async connect in progress. */
#define TCP_ASYNC_PENDING	(1<<4)	/* TcpConnect was called to
					 * process an async connect. This
					 * flag indicates that reentry is
					 * still pending */
#define TCP_ASYNC_FAILED	(1<<5)	/* An async connect finally failed */

/*
 * The following defines the maximum length of the listen queue. This is the
 * number of outstanding yet-to-be-serviced requests for a connection on a
 * server socket, more than this number of outstanding requests and the
 * connection request will fail.
 */
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131

132
133
134
135
136
137
138

#define SOCKET_BUFSIZE	4096

/*
 * Static routines for this file:
 */

static int		CreateClientSocket(Tcl_Interp *interp,
                                           TcpState *state);
static void		TcpAccept(ClientData data, int mask);
static int		TcpBlockModeProc(ClientData data, int mode);
static int		TcpCloseProc(ClientData instanceData,
			    Tcl_Interp *interp);
static int		TcpClose2Proc(ClientData instanceData,
			    Tcl_Interp *interp, int flags);
static int		TcpGetHandleProc(ClientData instanceData,
			    int direction, ClientData *handlePtr);
static int		TcpGetOptionProc(ClientData instanceData,
			    Tcl_Interp *interp, const char *optionName,
			    Tcl_DString *dsPtr);
static int		TcpInputProc(ClientData instanceData, char *buf,
			    int toRead, int *errorCode);
static int		TcpOutputProc(ClientData instanceData,
			    const char *buf, int toWrite, int *errorCode);
static void		TcpWatchProc(ClientData instanceData, int mask);
static int		WaitForConnect(TcpState *statePtr, int *errorCodePtr);


/*
 * This structure describes the channel type structure for TCP socket
 * based IO:
 */

static const Tcl_ChannelType tcpChannelType = {







|


















>







113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146

#define SOCKET_BUFSIZE	4096

/*
 * Static routines for this file:
 */

static int		TcpConnect(Tcl_Interp *interp,
                                           TcpState *state);
static void		TcpAccept(ClientData data, int mask);
static int		TcpBlockModeProc(ClientData data, int mode);
static int		TcpCloseProc(ClientData instanceData,
			    Tcl_Interp *interp);
static int		TcpClose2Proc(ClientData instanceData,
			    Tcl_Interp *interp, int flags);
static int		TcpGetHandleProc(ClientData instanceData,
			    int direction, ClientData *handlePtr);
static int		TcpGetOptionProc(ClientData instanceData,
			    Tcl_Interp *interp, const char *optionName,
			    Tcl_DString *dsPtr);
static int		TcpInputProc(ClientData instanceData, char *buf,
			    int toRead, int *errorCode);
static int		TcpOutputProc(ClientData instanceData,
			    const char *buf, int toWrite, int *errorCode);
static void		TcpWatchProc(ClientData instanceData, int mask);
static int		WaitForConnect(TcpState *statePtr, int *errorCodePtr);
static void		WrapNotify(ClientData clientData, int mask);

/*
 * This structure describes the channel type structure for TCP socket
 * based IO:
 */

static const Tcl_ChannelType tcpChannelType = {
159
160
161
162
163
164
165















166
167
168
169
170
171
172
 * The following variable holds the network name of this host.
 */

static TclInitProcessGlobalValueProc InitializeHostName;
static ProcessGlobalValue hostName =
	{0, 0, NULL, NULL, InitializeHostName, NULL, NULL};
















/*
 *----------------------------------------------------------------------
 *
 * InitializeHostName --
 *
 * 	This routine sets the process global value of the name of the local
 * 	host on which the process is running.







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
 * The following variable holds the network name of this host.
 */

static TclInitProcessGlobalValueProc InitializeHostName;
static ProcessGlobalValue hostName =
	{0, 0, NULL, NULL, InitializeHostName, NULL, NULL};

#if 0
/* printf debugging */
void printaddrinfo(struct addrinfo *addrlist, char *prefix)
{
    char host[NI_MAXHOST], port[NI_MAXSERV];
    struct addrinfo *ai;
    for (ai = addrlist; ai != NULL; ai = ai->ai_next) {
	getnameinfo(ai->ai_addr, ai->ai_addrlen,
		    host, sizeof(host),
		    port, sizeof(port),
		    NI_NUMERICHOST|NI_NUMERICSERV);
	fprintf(stderr,"%s: %s:%s\n", prefix, host, port);
    }
}
#endif
/*
 *----------------------------------------------------------------------
 *
 * InitializeHostName --
 *
 * 	This routine sets the process global value of the name of the local
 * 	host on which the process is running.
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371

372




373







374
375
376
377
378




379
380
381
382
383
384
385
386
387
388
389
390



391




392


393
394
395



396
397
398
399
400
401
402
403
404
405
406



407

408


409
410
411
412
413
414
415
416
417
418
419
    int mode)			/* The mode to set. Can be one of
				 * TCL_MODE_BLOCKING or
				 * TCL_MODE_NONBLOCKING. */
{
    TcpState *statePtr = instanceData;

    if (mode == TCL_MODE_BLOCKING) {
	CLEAR_BITS(statePtr->flags, TCP_ASYNC_SOCKET);
    } else {
	SET_BITS(statePtr->flags, TCP_ASYNC_SOCKET);
    }
    if (statePtr->flags & TCP_ASYNC_CONNECT) {
        statePtr->cachedBlocking = mode;
        return 0;
    }
    if (TclUnixSetBlockingMode(statePtr->fds.fd, mode) < 0) {
	return errno;
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * WaitForConnect --
 *
 *	Wait for a connection on an asynchronously opened socket to be

 *	completed.  In nonblocking mode, just test if the connection




 *	has completed without blocking.







 *
 * Results:
 * 	0 if the connection has completed, -1 if still in progress
 * 	or there is an error.
 *




 *----------------------------------------------------------------------
 */

static int
WaitForConnect(
    TcpState *statePtr,		/* State of the socket. */
    int *errorCodePtr)		/* Where to store errors? */
{
    int timeOut;		/* How long to wait. */
    int state;			/* Of calling TclWaitForFile. */

    /*



     * If an asynchronous connect is in progress, attempt to wait for it to




     * complete before reading.


     */

    if (statePtr->flags & TCP_ASYNC_CONNECT) {



	if (statePtr->flags & TCP_ASYNC_SOCKET) {
	    timeOut = 0;
	} else {
	    timeOut = -1;
	}
	errno = 0;
	state = TclUnixWaitForFile(statePtr->fds.fd,
		TCL_WRITABLE | TCL_EXCEPTION, timeOut);
	if (state & TCL_EXCEPTION) {
	    return -1;
	}



	if (state & TCL_WRITABLE) {

	    CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT);


	} else if (timeOut == 0) {
	    *errorCodePtr = errno = EWOULDBLOCK;
	    return -1;
	}
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *







|

|
















|
>
|
>
>
>
>
|
>
>
>
>
>
>
>





>
>
>
>






|

|
<


>
>
>
|
>
>
>
>
|
>
>

|
|
>
>
>
|
|
|
|
|
|
|
|
|
<
|
>
>
>
|
>
|
>
>
|
|
|
|







368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426

427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454

455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
    int mode)			/* The mode to set. Can be one of
				 * TCL_MODE_BLOCKING or
				 * TCL_MODE_NONBLOCKING. */
{
    TcpState *statePtr = instanceData;

    if (mode == TCL_MODE_BLOCKING) {
	CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING);
    } else {
	SET_BITS(statePtr->flags, TCP_NONBLOCKING);
    }
    if (statePtr->flags & TCP_ASYNC_CONNECT) {
        statePtr->cachedBlocking = mode;
        return 0;
    }
    if (TclUnixSetBlockingMode(statePtr->fds.fd, mode) < 0) {
	return errno;
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * WaitForConnect --
 *
 *	Check the state of an async connect process. If a connection
 *	attempt terminated, process it, which may finalize it or may
 *	start the next attempt. If a connect error occures, it is saved
 *	in statePtr->connectError to be reported by 'fconfigure -error'.
 *
 *	There are two modes of operation, defined by errorCodePtr:
 *	 *  non-NULL: Called by explicite read/write command. block if
 *	    socket is blocking.
 *	    May return two error codes:
 *	     *	EWOULDBLOCK: if connect is still in progress
 *	     *	ENOTCONN: if connect failed. This would be the error
 *		message of a rect or sendto syscall so this is
 *		emulated here.
 *	 *  NULL: Called by a backround operation. Do not block and
 *	    don't return any error code.
 *
 * Results:
 * 	0 if the connection has completed, -1 if still in progress
 * 	or there is an error.
 *
 * Side effects:
 *	Processes socket events off the system queue.
 *	May process asynchroneous connect.
 *
 *----------------------------------------------------------------------
 */

static int
WaitForConnect(
    TcpState *statePtr,		/* State of the socket. */
    int *errorCodePtr)
{
    int timeout;


    /*
     * Check if an async connect failed already and error reporting is demanded,
     * return the error ENOTCONN
     */

    if (errorCodePtr != NULL && (statePtr->flags & TCP_ASYNC_FAILED)) {
	*errorCodePtr = ENOTCONN;
	return -1;
    }

    /*
     * Check if an async connect is running. If not return ok
     */
     
    if (!(statePtr->flags & TCP_ASYNC_PENDING)) {
	return 0;
    }
    
    if (errorCodePtr == NULL || (statePtr->flags & TCP_NONBLOCKING)) {
        timeout = 0;
    } else {
        timeout = -1;
    }
    do {
        if (TclUnixWaitForFile(statePtr->fds.fd,
                                TCL_WRITABLE | TCL_EXCEPTION, timeout) != 0) {
            TcpConnect(NULL, statePtr);

        }
        /* Do this only once in the nonblocking case and repeat it until the
         * socket is final when blocking */
    } while (timeout == -1 && statePtr->flags & TCP_ASYNC_CONNECT);

    if (errorCodePtr != NULL) {
        if (statePtr->flags & TCP_ASYNC_PENDING) {
            *errorCodePtr = EAGAIN;
            return -1;
        } else if (statePtr->connectError != 0) {
            *errorCodePtr = ENOTCONN;
            return -1;
        }
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
499
500
501
502
503
504
505

506
507
508
509
510
511
512
    int written;

    *errorCodePtr = 0;
    if (WaitForConnect(statePtr, errorCodePtr) != 0) {
	return -1;
    }
    written = send(statePtr->fds.fd, buf, (size_t) toWrite, 0);

    if (written > -1) {
	return written;
    }
    *errorCodePtr = errno;
    return -1;
}








>







554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
    int written;

    *errorCodePtr = 0;
    if (WaitForConnect(statePtr, errorCodePtr) != 0) {
	return -1;
    }
    written = send(statePtr->fds.fd, buf, (size_t) toWrite, 0);

    if (written > -1) {
	return written;
    }
    *errorCodePtr = errno;
    return -1;
}

722
723
724
725
726
727
728


729
730
731
732
733
734
735
736
737



738




739
740
741
742
743
744
745
746
747
748
749
750
751
752


753


754
755
756
757
758
759
760
761
762
				 * values. */
    Tcl_DString *dsPtr)		/* Where to store the computed value;
				 * initialized by caller. */
{
    TcpState *statePtr = instanceData;
    size_t len = 0;



    if (optionName != NULL) {
	len = strlen(optionName);
    }

    if ((len > 1) && (optionName[1] == 'e') &&
	    (strncmp(optionName, "-error", len) == 0)) {
	socklen_t optlen = sizeof(int);
	int err, ret;




        if (statePtr->status == 0) {




            ret = getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR,
                            (char *) &err, &optlen);
            if (statePtr->flags & TCP_ASYNC_CONNECT) {
                statePtr->status = err;
            }
            if (ret < 0) {
                err = errno;
            }
        } else {
            err = statePtr->status;
            statePtr->status = 0;
        }
	if (err != 0) {
	    Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(err), -1);


	}


	return TCL_OK;
    }

    if ((len == 0) || ((len > 1) && (optionName[1] == 'p') &&
	    (strncmp(optionName, "-peername", len) == 0))) {
        address peername;
        socklen_t size = sizeof(peername);

	if (getpeername(statePtr->fds.fd, &peername.sa, &size) >= 0) {







>
>







<

>
>
>
|
>
>
>
>
|
|
<
|
|
|
|
|
<
<
|
|
|
<
>
>
|
>
>
|








778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793

794
795
796
797
798
799
800
801
802
803
804

805
806
807
808
809


810
811
812

813
814
815
816
817
818
819
820
821
822
823
824
825
826
				 * values. */
    Tcl_DString *dsPtr)		/* Where to store the computed value;
				 * initialized by caller. */
{
    TcpState *statePtr = instanceData;
    size_t len = 0;

    WaitForConnect(statePtr, NULL);

    if (optionName != NULL) {
	len = strlen(optionName);
    }

    if ((len > 1) && (optionName[1] == 'e') &&
	    (strncmp(optionName, "-error", len) == 0)) {
	socklen_t optlen = sizeof(int);


        if (statePtr->flags & TCP_ASYNC_CONNECT) {
            /* Suppress errors as long as we are not done */
            errno = 0;
        } else if (statePtr->connectError != 0) {
            errno = statePtr->connectError;
            statePtr->connectError = 0;
        } else {
            int err;
            getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR,
                    (char *) &err, &optlen);

            errno = err;
        }
        if (errno != 0) {
	    Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(errno), -1);
        }


	return TCL_OK;
    }


    if ((len > 1) && (optionName[1] == 'c') &&
	    (strncmp(optionName, "-connecting", len) == 0)) {

        Tcl_DStringAppend(dsPtr,
                        (statePtr->flags & TCP_ASYNC_CONNECT) ? "1" : "0", -1);
        return TCL_OK;
    }

    if ((len == 0) || ((len > 1) && (optionName[1] == 'p') &&
	    (strncmp(optionName, "-peername", len) == 0))) {
        address peername;
        socklen_t size = sizeof(peername);

	if (getpeername(statePtr->fds.fd, &peername.sa, &size) >= 0) {
839
840
841
842
843
844
845





























846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869






















870
871
872
873
874
875
876
877
878
 *
 * Side effects:
 *	Sets up the notifier so that a future event on the channel will be
 *	seen by Tcl.
 *
 *----------------------------------------------------------------------
 */






























static void
TcpWatchProc(
    ClientData instanceData,	/* The socket state. */
    int mask)			/* Events of interest; an OR-ed combination of
				 * TCL_READABLE, TCL_WRITABLE and
				 * TCL_EXCEPTION. */
{
    TcpState *statePtr = instanceData;

    if (statePtr->acceptProc != NULL) {
        /*
         * Make sure we don't mess with server sockets since they will never
         * be readable or writable at the Tcl level. This keeps Tcl scripts
         * from interfering with the -accept behavior (bug #3394732).
         */
    	return;
    }
     
    if (statePtr->flags & TCP_ASYNC_CONNECT) {
        /* Async sockets use a FileHandler internally while connecting, so we
         * need to cache this request until the connection has succeeded. */
        statePtr->filehandlers = mask;
    } else if (mask) {






















        Tcl_CreateFileHandler(statePtr->fds.fd, mask,
                (Tcl_FileProc *) Tcl_NotifyChannel, statePtr->channel);
    } else {
        Tcl_DeleteFileHandler(statePtr->fds.fd);
    }
}

/*
 *----------------------------------------------------------------------







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



















|




>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|







903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
 *
 * Side effects:
 *	Sets up the notifier so that a future event on the channel will be
 *	seen by Tcl.
 *
 *----------------------------------------------------------------------
 */

static void
WrapNotify(
    ClientData clientData,
    int mask)
{
    TcpState *statePtr = (TcpState *) clientData;
    int newmask = mask & statePtr->interest;

    if (newmask == 0) {
	/*
	 * There was no overlap between the states the channel is
	 * interested in notifications for, and the states that are
	 * reported present on the file descriptor by select().  The
	 * only way that can happen is when the channel is interested
	 * in a writable condition, and only a readable state is reported
	 * present (see TcpWatchProc() below).  In that case, signal back
	 * to the caller the writable state, which is really an error
	 * condition.  As an extra check on that assumption, check for
	 * a non-zero value of errno before reporting an artificial
	 * writable state.
	 */
	if (errno == 0) {
	    return;
	}
	newmask = TCL_WRITABLE;
    }
    Tcl_NotifyChannel(statePtr->channel, newmask);
}

static void
TcpWatchProc(
    ClientData instanceData,	/* The socket state. */
    int mask)			/* Events of interest; an OR-ed combination of
				 * TCL_READABLE, TCL_WRITABLE and
				 * TCL_EXCEPTION. */
{
    TcpState *statePtr = instanceData;

    if (statePtr->acceptProc != NULL) {
        /*
         * Make sure we don't mess with server sockets since they will never
         * be readable or writable at the Tcl level. This keeps Tcl scripts
         * from interfering with the -accept behavior (bug #3394732).
         */
    	return;
    }
     
    if (statePtr->flags & TCP_ASYNC_PENDING) {
        /* Async sockets use a FileHandler internally while connecting, so we
         * need to cache this request until the connection has succeeded. */
        statePtr->filehandlers = mask;
    } else if (mask) {

	/*
	 * Whether it is a bug or feature or otherwise, it is a fact
	 * of life that on at least some Linux kernels select() fails
	 * to report that a socket file descriptor is writable when
	 * the other end of the socket is closed.  This is in contrast
	 * to the guarantees Tcl makes that its channels become
	 * writable and fire writable events on an error conditon.
	 * This has caused a leak of file descriptors in a state of
	 * background flushing.  See Tcl ticket 1758a0b603.
	 *
	 * As a workaround, when our caller indicates an interest in
	 * writable notifications, we must tell the notifier built
	 * around select() that we are interested in the readable state
	 * of the file descriptor as well, as that is the only reliable
	 * means to get notified of error conditions.  Then it is the
	 * task of WrapNotify() above to untangle the meaning of these
	 * channel states and report the chan events as best it can.
	 * We save a copy of the mask passed in to assist with that.
	 */

	statePtr->interest = mask;
        Tcl_CreateFileHandler(statePtr->fds.fd, mask|TCL_READABLE,
                (Tcl_FileProc *) WrapNotify, statePtr);
    } else {
        Tcl_DeleteFileHandler(statePtr->fds.fd);
    }
}

/*
 *----------------------------------------------------------------------
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
}

/*
 *----------------------------------------------------------------------
 *
 * TcpAsyncCallback --
 *
 *	Called by the event handler that CreateClientSocket sets up
 *	internally for [socket -async] to get notified when the
 *	asyncronous connection attempt has succeeded or failed.
 *
 *----------------------------------------------------------------------
 */
static void
TcpAsyncCallback(
    ClientData clientData,	/* The socket state. */
    int mask)			/* Events of interest; an OR-ed combination of
				 * TCL_READABLE, TCL_WRITABLE and
				 * TCL_EXCEPTION. */
{
    CreateClientSocket(NULL, clientData);
}

/*
 *----------------------------------------------------------------------
 *
 * CreateClientSocket --
 *
 *	This function opens a new socket in client mode.
 *
 * Results:
 *      TCL_OK, if the socket was successfully connected or an asynchronous
 *      connection is in progress. If an error occurs, TCL_ERROR is returned
 *      and an error message is left in interp.







|












|





|







1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
}

/*
 *----------------------------------------------------------------------
 *
 * TcpAsyncCallback --
 *
 *	Called by the event handler that TcpConnect sets up
 *	internally for [socket -async] to get notified when the
 *	asyncronous connection attempt has succeeded or failed.
 *
 *----------------------------------------------------------------------
 */
static void
TcpAsyncCallback(
    ClientData clientData,	/* The socket state. */
    int mask)			/* Events of interest; an OR-ed combination of
				 * TCL_READABLE, TCL_WRITABLE and
				 * TCL_EXCEPTION. */
{
    TcpConnect(NULL, clientData);
}

/*
 *----------------------------------------------------------------------
 *
 * TcpConnect --
 *
 *	This function opens a new socket in client mode.
 *
 * Results:
 *      TCL_OK, if the socket was successfully connected or an asynchronous
 *      connection is in progress. If an error occurs, TCL_ERROR is returned
 *      and an error message is left in interp.
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997

998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025


1026

1027
1028
1029
1030
1031

1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043

1044
1045
1046


1047
1048
1049

1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085




1086
1087
1088
1089
1090
1091
1092
1093
1094
1095

1096


1097
1098
1099
1100
1101
1102
1103
1104

1105
1106
1107
1108
1109
1110
1111
 *	return and the loops resume as if they had never been interrupted.
 *	For syncronously connecting sockets, the loops work the usual way.
 *
 *----------------------------------------------------------------------
 */

static int
CreateClientSocket(
    Tcl_Interp *interp,		/* For error reporting; can be NULL. */
    TcpState *state)
{
    socklen_t optlen;
    int async_callback = (state->addr != NULL);
    int status;
    int async = state->flags & TCP_ASYNC_CONNECT;

    if (async_callback) {
        goto reenter;
    }

    for (state->addr = state->addrlist; state->addr != NULL;
            state->addr = state->addr->ai_next) {
	status = -1;

        for (state->myaddr = state->myaddrlist; state->myaddr != NULL;
                state->myaddr = state->myaddr->ai_next) {
            int reuseaddr;
            
	    /*
	     * No need to try combinations of local and remote addresses of
	     * different families.
	     */

	    if (state->myaddr->ai_family != state->addr->ai_family) {
		continue;
	    }

            /*
             * Close the socket if it is still open from the last unsuccessful
             * iteration.
             */

            if (state->fds.fd >= 0) {
		close(state->fds.fd);
		state->fds.fd = -1;

	    }

	    state->fds.fd = socket(state->addr->ai_family, SOCK_STREAM, 0);
	    if (state->fds.fd < 0) {
		continue;
	    }

	    /*
	     * Set the close-on-exec flag so that the socket will not get
	     * inherited by child processes.
	     */
	    
	    fcntl(state->fds.fd, F_SETFD, FD_CLOEXEC);
	    
	    /*
	     * Set kernel space buffering
	     */
	    
	    TclSockMinimumBuffers(INT2PTR(state->fds.fd), SOCKET_BUFSIZE);
    
	    if (async) {
		status = TclUnixSetBlockingMode(state->fds.fd,
                        TCL_MODE_NONBLOCKING);
		if (status < 0) {
                    continue;
		}
	    }



            reuseaddr = 1;

            (void) setsockopt(state->fds.fd, SOL_SOCKET, SO_REUSEADDR,
                    (char *) &reuseaddr, sizeof(reuseaddr));
            status = bind(state->fds.fd, state->myaddr->ai_addr,
                    state->myaddr->ai_addrlen);
            if (status < 0) {

                continue;
            }

	    /*
	     * Attempt to connect. The connect may fail at present with an
	     * EINPROGRESS but at a later time it will complete. The caller
	     * will set up a file handler on the socket if she is interested
	     * in being informed when the connect completes.
	     */
	    
	    status = connect(state->fds.fd, state->addr->ai_addr,
                    state->addr->ai_addrlen);

	    if (status < 0 && errno == EINPROGRESS) {
                Tcl_CreateFileHandler(state->fds.fd,
                        TCL_WRITABLE|TCL_EXCEPTION, TcpAsyncCallback, state);


                return TCL_OK;

            reenter:

                Tcl_DeleteFileHandler(state->fds.fd);

                /*
                 * Read the error state from the socket to see if the async
                 * connection has succeeded or failed. As this clears the
                 * error condition, we cache the status in the socket state
                 * struct for later retrieval by [fconfigure -error].
                 */

                optlen = sizeof(int);

                if (state->status == 0) {
                    getsockopt(state->fds.fd, SOL_SOCKET, SO_ERROR,
                            (char *) &status, &optlen);
                    state->status = status;
                } else {
                    status = state->status;
                    state->status = 0;
                }
            }
	    if (status == 0) {
		goto out;
	    }
	}
    }

out:

    CLEAR_BITS(state->flags, TCP_ASYNC_CONNECT);
    if (async_callback) {
        /*
         * An asynchonous connection has finally succeeded or failed.
         */

        TcpWatchProc(state, state->filehandlers);
        TclUnixSetBlockingMode(state->fds.fd, state->cachedBlocking);





        /*
         * We need to forward the writable event that brought us here, bcasue
         * upon reading of getsockopt(SO_ERROR), at least some OSes clear the
         * writable state from the socket, and so a subsequent select() on
         * behalf of a script level [fileevent] would not fire. It doesn't
         * hurt that this is also called in the successful case and will save
         * the event mechanism one roundtrip through select().
         */


        Tcl_NotifyChannel(state->channel, TCL_WRITABLE);


    } else if (status != 0) {
        /*
         * Failure for either a synchronous connection, or an async one that
         * failed before it could enter background mode, e.g. because an
         * invalid -myaddr was given.
         */

        if (interp != NULL) {

            Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "couldn't open socket: %s", Tcl_PosixError(interp)));
        }
        return TCL_ERROR;
    }
    return TCL_OK;
}







|

|


|
|
|





|
|
<

|
|
|






|








|
|
|
>


|
|








|





|


|
<
|

|
|

>
>
|
>
|

|
|
|
>










|
|
>
|
|
|
>
>



>
|










<
|
|
<
|
<
<
|
<
|






|
|





|
|
>
>
>
>










>
|
>
>
|







>







1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089

1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134

1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182

1183
1184

1185


1186

1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
 *	return and the loops resume as if they had never been interrupted.
 *	For syncronously connecting sockets, the loops work the usual way.
 *
 *----------------------------------------------------------------------
 */

static int
TcpConnect(
    Tcl_Interp *interp,		/* For error reporting; can be NULL. */
    TcpState *statePtr)
{
    socklen_t optlen;
    int async_callback = statePtr->flags & TCP_ASYNC_PENDING;
    int ret = -1, error = errno;
    int async = statePtr->flags & TCP_ASYNC_CONNECT;

    if (async_callback) {
        goto reenter;
    }

    for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL;
            statePtr->addr = statePtr->addr->ai_next) {


        for (statePtr->myaddr = statePtr->myaddrlist; statePtr->myaddr != NULL;
                statePtr->myaddr = statePtr->myaddr->ai_next) {
            int reuseaddr = 1;
            
	    /*
	     * No need to try combinations of local and remote addresses of
	     * different families.
	     */

	    if (statePtr->myaddr->ai_family != statePtr->addr->ai_family) {
		continue;
	    }

            /*
             * Close the socket if it is still open from the last unsuccessful
             * iteration.
             */

            if (statePtr->fds.fd >= 0) {
		close(statePtr->fds.fd);
		statePtr->fds.fd = -1;
                errno = 0;
	    }

	    statePtr->fds.fd = socket(statePtr->addr->ai_family, SOCK_STREAM, 0);
	    if (statePtr->fds.fd < 0) {
		continue;
	    }

	    /*
	     * Set the close-on-exec flag so that the socket will not get
	     * inherited by child processes.
	     */
	    
	    fcntl(statePtr->fds.fd, F_SETFD, FD_CLOEXEC);
	    
	    /*
	     * Set kernel space buffering
	     */
	    
	    TclSockMinimumBuffers(INT2PTR(statePtr->fds.fd), SOCKET_BUFSIZE);
    
	    if (async) {
                ret = TclUnixSetBlockingMode(statePtr->fds.fd,TCL_MODE_NONBLOCKING);

                if (ret < 0) {
                    continue;
                }
            }

            /* Gotta reset the error variable here, before we use it for the
             * first time in this iteration. */
            error = 0;
            
            (void) setsockopt(statePtr->fds.fd, SOL_SOCKET, SO_REUSEADDR,
                    (char *) &reuseaddr, sizeof(reuseaddr));
            ret = bind(statePtr->fds.fd, statePtr->myaddr->ai_addr,
                    statePtr->myaddr->ai_addrlen);
            if (ret < 0) {
                error = errno;
                continue;
            }

	    /*
	     * Attempt to connect. The connect may fail at present with an
	     * EINPROGRESS but at a later time it will complete. The caller
	     * will set up a file handler on the socket if she is interested
	     * in being informed when the connect completes.
	     */
	    
	    ret = connect(statePtr->fds.fd, statePtr->addr->ai_addr,
                        statePtr->addr->ai_addrlen);
            if (ret < 0) error = errno;
	    if (ret < 0 && errno == EINPROGRESS) {
                Tcl_CreateFileHandler(statePtr->fds.fd,
                        TCL_WRITABLE|TCL_EXCEPTION, TcpAsyncCallback, statePtr);
                errno = EWOULDBLOCK;
                SET_BITS(statePtr->flags, TCP_ASYNC_PENDING);
                return TCL_OK;

            reenter:
                CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING);
                Tcl_DeleteFileHandler(statePtr->fds.fd);

                /*
                 * Read the error state from the socket to see if the async
                 * connection has succeeded or failed. As this clears the
                 * error condition, we cache the status in the socket state
                 * struct for later retrieval by [fconfigure -error].
                 */

                optlen = sizeof(int);


                getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR,
                        (char *) &error, &optlen);

                errno = error;


            }

	    if (error == 0) {
		goto out;
	    }
	}
    }

out:
    statePtr->connectError = error;
    CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
    if (async_callback) {
        /*
         * An asynchonous connection has finally succeeded or failed.
         */

        TcpWatchProc(statePtr, statePtr->filehandlers);
        TclUnixSetBlockingMode(statePtr->fds.fd, statePtr->cachedBlocking);

        if (error != 0) {
            SET_BITS(statePtr->flags, TCP_ASYNC_FAILED);
        }

        /*
         * We need to forward the writable event that brought us here, bcasue
         * upon reading of getsockopt(SO_ERROR), at least some OSes clear the
         * writable state from the socket, and so a subsequent select() on
         * behalf of a script level [fileevent] would not fire. It doesn't
         * hurt that this is also called in the successful case and will save
         * the event mechanism one roundtrip through select().
         */

	if (statePtr->cachedBlocking == TCL_MODE_NONBLOCKING) {
	    Tcl_NotifyChannel(statePtr->channel, TCL_WRITABLE);
	}
    }
    if (error != 0) {
        /*
         * Failure for either a synchronous connection, or an async one that
         * failed before it could enter background mode, e.g. because an
         * invalid -myaddr was given.
         */

        if (interp != NULL) {
            errno = error;
            Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "couldn't open socket: %s", Tcl_PosixError(interp)));
        }
        return TCL_ERROR;
    }
    return TCL_OK;
}
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
    const char *host,		/* Host on which to open port. */
    const char *myaddr,		/* Client-side address */
    int myport,			/* Client-side port */
    int async)			/* If nonzero, attempt to do an asynchronous
				 * connect. Otherwise we do a blocking
				 * connect. */
{
    TcpState *state;
    const char *errorMsg = NULL;
    struct addrinfo *addrlist = NULL, *myaddrlist = NULL;
    char channelName[SOCK_CHAN_LENGTH];

    /*
     * Do the name lookups for the local and remote addresses.
     */







|







1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
    const char *host,		/* Host on which to open port. */
    const char *myaddr,		/* Client-side address */
    int myport,			/* Client-side port */
    int async)			/* If nonzero, attempt to do an asynchronous
				 * connect. Otherwise we do a blocking
				 * connect. */
{
    TcpState *statePtr;
    const char *errorMsg = NULL;
    struct addrinfo *addrlist = NULL, *myaddrlist = NULL;
    char channelName[SOCK_CHAN_LENGTH];

    /*
     * Do the name lookups for the local and remote addresses.
     */
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
        }
        return NULL;
    }

    /*
     * Allocate a new TcpState for this socket.
     */
    state = ckalloc(sizeof(TcpState));
    memset(state, 0, sizeof(TcpState));
    state->flags = async ? TCP_ASYNC_CONNECT : 0;
    state->cachedBlocking = TCL_MODE_BLOCKING;
    state->addrlist = addrlist;
    state->myaddrlist = myaddrlist;
    state->fds.fd = -1;

    /*
     * Create a new client socket and wrap it in a channel.
     */
    if (CreateClientSocket(interp, state) != TCL_OK) {
        TcpCloseProc(state, NULL);
        return NULL;
    }

    sprintf(channelName, SOCK_TEMPLATE, (long) state);

    state->channel = Tcl_CreateChannel(&tcpChannelType, channelName, state,
            (TCL_READABLE | TCL_WRITABLE));
    if (Tcl_SetChannelOption(interp, state->channel, "-translation",
	    "auto crlf") == TCL_ERROR) {
	Tcl_Close(NULL, state->channel);
	return NULL;
    }
    return state->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MakeTcpClientChannel --
 *







|
|
|
|
|
|
|




|
|



|

|

|

|


|







1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
        }
        return NULL;
    }

    /*
     * Allocate a new TcpState for this socket.
     */
    statePtr = ckalloc(sizeof(TcpState));
    memset(statePtr, 0, sizeof(TcpState));
    statePtr->flags = async ? TCP_ASYNC_CONNECT : 0;
    statePtr->cachedBlocking = TCL_MODE_BLOCKING;
    statePtr->addrlist = addrlist;
    statePtr->myaddrlist = myaddrlist;
    statePtr->fds.fd = -1;

    /*
     * Create a new client socket and wrap it in a channel.
     */
    if (TcpConnect(interp, statePtr) != TCL_OK) {
        TcpCloseProc(statePtr, NULL);
        return NULL;
    }

    sprintf(channelName, SOCK_TEMPLATE, (long) statePtr);

    statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, statePtr,
            (TCL_READABLE | TCL_WRITABLE));
    if (Tcl_SetChannelOption(interp, statePtr->channel, "-translation",
	    "auto crlf") == TCL_ERROR) {
	Tcl_Close(NULL, statePtr->channel);
	return NULL;
    }
    return statePtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MakeTcpClientChannel --
 *
Changes to unix/tclUnixThrd.c.
723
724
725
726
727
728
729

730
731
732
733
734
735
736
{
    if (ptr != NULL) {
	/*
	 * Called by the pthread lib when a thread exits
	 */

	TclFreeAllocCache(ptr);


    } else if (initialized) {
	/*
	 * Called by us in TclFinalizeThreadAlloc() during the library
	 * finalization initiated from Tcl_Finalize()
	 */








>







723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
{
    if (ptr != NULL) {
	/*
	 * Called by the pthread lib when a thread exits
	 */

	TclFreeAllocCache(ptr);
	pthread_setspecific(key, NULL);

    } else if (initialized) {
	/*
	 * Called by us in TclFinalizeThreadAlloc() during the library
	 * finalization initiated from Tcl_Finalize()
	 */

Changes to win/Makefile.in.
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
	@echo "Installing library opt0.4 directory";
	@for j in $(ROOT_DIR)/library/opt/*.tcl; \
	    do \
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
	    done;
	@echo "Installing package msgcat 1.5.2 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm;
	@echo "Installing package tcltest 2.3.7 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.7.tm;
	@echo "Installing package platform 1.0.12 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.12.tm;
	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm;
	@echo "Installing encodings";
	@for i in $(ROOT_DIR)/library/encoding/*.enc ; do \
		$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \







|
|







647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
	@echo "Installing library opt0.4 directory";
	@for j in $(ROOT_DIR)/library/opt/*.tcl; \
	    do \
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
	    done;
	@echo "Installing package msgcat 1.5.2 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm;
	@echo "Installing package tcltest 2.3.8 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.8.tm;
	@echo "Installing package platform 1.0.12 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.12.tm;
	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm;
	@echo "Installing encodings";
	@for i in $(ROOT_DIR)/library/encoding/*.enc ; do \
		$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \
847
848
849
850
851
852
853

854
855

856
857
858
859
860
861
862
# tk8.* up two directories from the TOOL_DIR.
#

TOOL_DIR=$(ROOT_DIR)/tools
HTML_INSTALL_DIR=$(ROOT_DIR)/html
html:
	$(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS)"

html-tcl: $(TCLSH)
	$(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS) --tcl"

html-tk: $(TCLSH)
	$(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS) --tk"

#
# The list of all the targets that do not correspond to real files. This stops
# 'make' from getting confused when someone makes an error in a rule.
#







>


>







847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
# tk8.* up two directories from the TOOL_DIR.
#

TOOL_DIR=$(ROOT_DIR)/tools
HTML_INSTALL_DIR=$(ROOT_DIR)/html
html:
	$(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS)"

html-tcl: $(TCLSH)
	$(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS) --tcl"

html-tk: $(TCLSH)
	$(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS) --tk"

#
# The list of all the targets that do not correspond to real files. This stops
# 'make' from getting confused when someone makes an error in a rule.
#
Changes to win/configure.
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
  cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

	    #ifndef __WIN32__
		#error cross-compiler
	    #endif

int
main ()
{








|







3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
  cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

	    #ifndef _WIN32
		#error cross-compiler
	    #endif

int
main ()
{

3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
  cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

		#ifdef __WIN32__
		    #error win32
		#endif

int
main ()
{








|







3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
  cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

		#ifdef _WIN32
		    #error win32
		#endif

int
main ()
{

Changes to win/tcl.m4.
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
    MACHINE="X86"

    if test "$GCC" = "yes"; then

      AC_CACHE_CHECK(for cross-compile version of gcc,
	ac_cv_cross,
	AC_TRY_COMPILE([
	    #ifndef __WIN32__
		#error cross-compiler
	    #endif
	], [],
	ac_cv_cross=no,
	ac_cv_cross=yes)
      )








|







568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
    MACHINE="X86"

    if test "$GCC" = "yes"; then

      AC_CACHE_CHECK(for cross-compile version of gcc,
	ac_cv_cross,
	AC_TRY_COMPILE([
	    #ifndef _WIN32
		#error cross-compiler
	    #endif
	], [],
	ac_cv_cross=no,
	ac_cv_cross=yes)
      )

635
636
637
638
639
640
641
642
643
644
645
646
647
648
649

    if test "${GCC}" = "yes" ; then
	extra_cflags="-pipe"
	extra_ldflags="-pipe -static-libgcc"
	AC_CACHE_CHECK(for mingw32 version of gcc,
	    ac_cv_win32,
	    AC_TRY_COMPILE([
		#ifdef __WIN32__
		    #error win32
		#endif
	    ], [],
	    ac_cv_win32=no,
	    ac_cv_win32=yes)
	)
	if test "$ac_cv_win32" != "yes"; then







|







635
636
637
638
639
640
641
642
643
644
645
646
647
648
649

    if test "${GCC}" = "yes" ; then
	extra_cflags="-pipe"
	extra_ldflags="-pipe -static-libgcc"
	AC_CACHE_CHECK(for mingw32 version of gcc,
	    ac_cv_win32,
	    AC_TRY_COMPILE([
		#ifdef _WIN32
		    #error win32
		#endif
	    ], [],
	    ac_cv_win32=no,
	    ac_cv_win32=yes)
	)
	if test "$ac_cv_win32" != "yes"; then
Changes to win/tclConfig.sh.in.
171
172
173
174
175
176
177
178
179
180

# Path to the Tcl stub library in the build directory.
TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@'

# Path to the Tcl stub library in the install directory.
TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@'

# Flag, 1: we built Tcl with threads enables, 0 we didn't
TCL_THREADS=@TCL_THREADS@








|


171
172
173
174
175
176
177
178
179
180

# Path to the Tcl stub library in the build directory.
TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@'

# Path to the Tcl stub library in the install directory.
TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@'

# Flag, 1: we built Tcl with threads enabled, 0 we didn't
TCL_THREADS=@TCL_THREADS@

Changes to win/tclWin32Dll.c.
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
MountPointMap *driveLetterLookup = NULL;
TCL_DECLARE_MUTEX(mountPointMap)

/*
 * We will need this below.
 */

#ifdef __WIN32__
#ifndef STATIC_BUILD

/*
 *----------------------------------------------------------------------
 *
 * DllEntryPoint --
 *







|







65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
MountPointMap *driveLetterLookup = NULL;
TCL_DECLARE_MUTEX(mountPointMap)

/*
 * We will need this below.
 */

#ifdef _WIN32
#ifndef STATIC_BUILD

/*
 *----------------------------------------------------------------------
 *
 * DllEntryPoint --
 *
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
	 * Tcl_Finalize explicitly before unloading Tcl.
	 */
    }

    return TRUE;
}
#endif /* !STATIC_BUILD */
#endif /* __WIN32__ */

/*
 *----------------------------------------------------------------------
 *
 * TclWinGetTclInstance --
 *
 *	Retrieves the global library instance handle.







|







133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
	 * Tcl_Finalize explicitly before unloading Tcl.
	 */
    }

    return TRUE;
}
#endif /* !STATIC_BUILD */
#endif /* _WIN32 */

/*
 *----------------------------------------------------------------------
 *
 * TclWinGetTclInstance --
 *
 *	Retrieves the global library instance handle.
Changes to win/tclWinChan.c.
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
static void		FileSetupProc(ClientData clientData, int flags);
static void		FileWatchProc(ClientData instanceData, int mask);
static void		FileThreadActionProc(ClientData instanceData,
			    int action);
static int		FileTruncateProc(ClientData instanceData,
			    Tcl_WideInt length);
static DWORD		FileGetType(HANDLE handle);

/*
 * This structure describes the channel type structure for file based IO.
 */

static const Tcl_ChannelType fileChannelType = {
    "file",			/* Type name. */
    TCL_CHANNEL_VERSION_5,	/* v5 channel */







|







91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
static void		FileSetupProc(ClientData clientData, int flags);
static void		FileWatchProc(ClientData instanceData, int mask);
static void		FileThreadActionProc(ClientData instanceData,
			    int action);
static int		FileTruncateProc(ClientData instanceData,
			    Tcl_WideInt length);
static DWORD		FileGetType(HANDLE handle);
static int		NativeIsComPort(CONST TCHAR *nativeName);
/*
 * This structure describes the channel type structure for file based IO.
 */

static const Tcl_ChannelType fileChannelType = {
    "file",			/* Type name. */
    TCL_CHANNEL_VERSION_5,	/* v5 channel */
658
659
660
661
662
663
664




665
666
667
668
669
670
671
{
    FileInfo *infoPtr = instanceData;
    DWORD bytesRead;

    *errorCode = 0;

    /*




     * Note that we will block on reads from a console buffer until a full
     * line has been entered. The only way I know of to get around this is to
     * write a console driver. We should probably do this at some point, but
     * for now, we just block. The same problem exists for files being read
     * over the network.
     */








>
>
>
>







658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
{
    FileInfo *infoPtr = instanceData;
    DWORD bytesRead;

    *errorCode = 0;

    /*
     * TODO: This comment appears to be out of date.  We *do* have a
     * console driver, over in tclWinConsole.c.  After some Windows
     * developer confirms, this comment should be revised.
     *
     * Note that we will block on reads from a console buffer until a full
     * line has been entered. The only way I know of to get around this is to
     * write a console driver. We should probably do this at some point, but
     * for now, we just block. The same problem exists for files being read
     * over the network.
     */

880
881
882
883
884
885
886



























887
888
889
890
891
892
893
	createMode = TRUNCATE_EXISTING;
	break;
    default:
	createMode = OPEN_EXISTING;
	break;
    }




























    /*
     * If the file is being created, get the file attributes from the
     * permissions argument, else use the existing file attributes.
     */

    if (mode & O_CREAT) {
	if (permissions & S_IWRITE) {







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
	createMode = TRUNCATE_EXISTING;
	break;
    default:
	createMode = OPEN_EXISTING;
	break;
    }

    /*
     * [2413550] Avoid double-open of serial ports on Windows
     * Special handling for Windows serial ports by a "name-hint"
     * to directly open it with the OVERLAPPED flag set.
     */

    if( NativeIsComPort(nativeName) ) {

	handle = TclWinSerialOpen(INVALID_HANDLE_VALUE, nativeName, accessMode);
	if (handle == INVALID_HANDLE_VALUE) {
	    TclWinConvertError(GetLastError());
	    if (interp != (Tcl_Interp *) NULL) {
		Tcl_AppendResult(interp, "couldn't open serial \"",
			TclGetString(pathPtr), "\": ",
			Tcl_PosixError(interp), NULL);
	    }
	    return NULL;
	}

	/*
	* For natively named Windows serial ports we are done.
	*/
	channel = TclWinOpenSerialChannel(handle, channelName,
		channelPermissions);

	return channel;
    }
    /*
     * If the file is being created, get the file attributes from the
     * permissions argument, else use the existing file attributes.
     */

    if (mode & O_CREAT) {
	if (permissions & S_IWRITE) {
931
932
933
934
935
936
937




938
939
940
941
942
943
944
945
946
947
948
949
    }

    channel = NULL;

    switch (FileGetType(handle)) {
    case FILE_TYPE_SERIAL:
	/*




	 * Reopen channel for OVERLAPPED operation. Normally this shouldn't
	 * fail, because the channel exists.
	 */

	handle = TclWinSerialReopen(handle, nativeName, accessMode);
	if (handle == INVALID_HANDLE_VALUE) {
	    TclWinConvertError(GetLastError());
	    if (interp != (Tcl_Interp *) NULL) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"couldn't reopen serial \"%s\": %s",
			TclGetString(pathPtr), Tcl_PosixError(interp)));
	    }







>
>
>
>




|







962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
    }

    channel = NULL;

    switch (FileGetType(handle)) {
    case FILE_TYPE_SERIAL:
	/*
	 * Natively named serial ports "com1-9", "\\\\.\\comXX" are 
	 * already done with the code above.
	 * Here we handle all other serial port names.
	 *
	 * Reopen channel for OVERLAPPED operation. Normally this shouldn't
	 * fail, because the channel exists.
	 */

	handle = TclWinSerialOpen(handle, nativeName, accessMode);
	if (handle == INVALID_HANDLE_VALUE) {
	    TclWinConvertError(GetLastError());
	    if (interp != (Tcl_Interp *) NULL) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"couldn't reopen serial \"%s\": %s",
			TclGetString(pathPtr), Tcl_PosixError(interp)));
	    }
1474
1475
1476
1477
1478
1479
1480
1481
1482




































































1483
1484
1485
1486
1487
1488
		type = FILE_TYPE_SERIAL;
	    }
	}
    }

    return type;
}

/*




































































 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */








|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
		type = FILE_TYPE_SERIAL;
	    }
	}
    }

    return type;
}

 /*
 *----------------------------------------------------------------------
 *
 * NativeIsComPort --
 *
 *	Determines if a path refers to a Windows serial port.
 *	A simple and efficient solution is to use a "name hint" to detect 
 *      COM ports by their filename instead of resorting to a syscall 
 *	to detect serialness after the fact.
 *	The following patterns cover common serial port names:
 *	    COM[1-9]:?
 *	    //./COM[0-9]+
 *	    \\.\COM[0-9]+
 *
 * Results:
 *	1 = serial port, 0 = not.
 *
 *----------------------------------------------------------------------
 */

static int
NativeIsComPort(
    const TCHAR *nativePath)	/* Path of file to access, native encoding. */
{
    const WCHAR *p = (const WCHAR *) nativePath;
    int i, len = wcslen(p);

    /*
     * 1. Look for com[1-9]:?
     */

    if ( (len >= 4) && (len <= 5) 
	    && (_wcsnicmp(p, L"com", 3) == 0) ) {
	/*
	* The 4th character must be a digit 1..9 optionally followed by a ":"
	*/
	
	if ( (p[3] < L'1') || (p[3] > L'9') ) {
	    return 0;
	}
	if ( (len == 5) && (p[4] != L':') ) {
	    return 0;
	}
	return 1;
    }
    
    /*
     * 2. Look for //./com[0-9]+ or \\.\com[0-9]+
     */
    
    if ( (len >= 8) && ( 
	       (_wcsnicmp(p, L"//./com", 7) == 0)
	    || (_wcsnicmp(p, L"\\\\.\\com", 7) == 0) ) )
    {
	/*
	* Charaters 8..end must be a digits 0..9
	*/
    
	for ( i=7; i<len; i++ ) {
	    if ( (p[i] < '0') || (p[i] > '9') ) {
		return 0;
	    }
	}
	return 1;
    }
    return 0;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */
Changes to win/tclWinConsole.c.
752
753
754
755
756
757
758







759
760
761
762
763
764
765
     * Attempt to read bufSize bytes. The read will return immediately if
     * there is any data available. Otherwise it will block until at least one
     * byte is available or an EOF occurs.
     */

    if (ReadConsoleBytes(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize,
	    &count) == TRUE) {







	buf[count] = '\0';
	return count;
    }

    return -1;
}








>
>
>
>
>
>
>







752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
     * Attempt to read bufSize bytes. The read will return immediately if
     * there is any data available. Otherwise it will block until at least one
     * byte is available or an EOF occurs.
     */

    if (ReadConsoleBytes(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize,
	    &count) == TRUE) {
	/*
	 * TODO: This potentially writes beyond the limits specified
	 * by the caller.  In practice this is harmless, since all writes
	 * are into ChannelBuffers, and those have padding, but still
	 * ought to remove this, unless some Windows wizard can give
	 * a reason not to.  
	 */
	buf[count] = '\0';
	return count;
    }

    return -1;
}

Changes to win/tclWinFCmd.c.
1104
1105
1106
1107
1108
1109
1110

1111




1112
1113
1114
1115
1116
1117
1118
	 * don't want to initialise the errorPtr yet.
	 */
	return TCL_ERROR;
    }

  end:
    if (errorPtr != NULL) {

	Tcl_WinTCharToUtf(nativePath, -1, errorPtr);




    }
    return TCL_ERROR;

}

static int
DoRemoveDirectory(







>

>
>
>
>







1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
	 * don't want to initialise the errorPtr yet.
	 */
	return TCL_ERROR;
    }

  end:
    if (errorPtr != NULL) {
	char *p;
	Tcl_WinTCharToUtf(nativePath, -1, errorPtr);
	p = Tcl_DStringValue(errorPtr);
	for (; *p; ++p) {
	    if (*p == '\\') *p = '/';
	}
    }
    return TCL_ERROR;

}

static int
DoRemoveDirectory(
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850

1851
1852
1853
1854
1855
1856
1857
1858
static int
SetWinFileAttributes(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file. */
    Tcl_Obj *attributePtr)	/* The new value of the attribute. */
{
    DWORD fileAttributes;
    int yesNo, result;
    const TCHAR *nativeName;

    nativeName = Tcl_FSGetNativePath(fileName);
    fileAttributes = GetFileAttributes(nativeName);

    if (fileAttributes == 0xffffffff) {
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo);
    if (result != TCL_OK) {
	return result;
    }

    if (yesNo) {
	fileAttributes |= (attributeArray[objIndex]);
    } else {
	fileAttributes &= ~(attributeArray[objIndex]);
    }


    if (!SetFileAttributes(nativeName, fileAttributes)) {
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    return result;
}








|




|

















>
|







1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
static int
SetWinFileAttributes(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file. */
    Tcl_Obj *attributePtr)	/* The new value of the attribute. */
{
    DWORD fileAttributes, old;
    int yesNo, result;
    const TCHAR *nativeName;

    nativeName = Tcl_FSGetNativePath(fileName);
    fileAttributes = old = GetFileAttributes(nativeName);

    if (fileAttributes == 0xffffffff) {
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo);
    if (result != TCL_OK) {
	return result;
    }

    if (yesNo) {
	fileAttributes |= (attributeArray[objIndex]);
    } else {
	fileAttributes &= ~(attributeArray[objIndex]);
    }

    if ((fileAttributes != old)
	    && !SetFileAttributes(nativeName, fileAttributes)) {
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    return result;
}

Changes to win/tclWinFile.c.
1812
1813
1814
1815
1816
1817
1818



1819
1820
1821
1822
1823
1824
1825
    Tcl_Obj *pathPtr)	/* Path to new working directory. */
{
    int result;
    const TCHAR *nativePath;

    nativePath = Tcl_FSGetNativePath(pathPtr);




    result = SetCurrentDirectory(nativePath);

    if (result == 0) {
	TclWinConvertError(GetLastError());
	return -1;
    }
    return 0;







>
>
>







1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
    Tcl_Obj *pathPtr)	/* Path to new working directory. */
{
    int result;
    const TCHAR *nativePath;

    nativePath = Tcl_FSGetNativePath(pathPtr);

    if (!nativePath) {
	return -1;
    }
    result = SetCurrentDirectory(nativePath);

    if (result == 0) {
	TclWinConvertError(GetLastError());
	return -1;
    }
    return 0;
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900

2901
2902
2903
2904
2905
2906
2907
 *---------------------------------------------------------------------------
 */

ClientData
TclNativeCreateNativeRep(
    Tcl_Obj *pathPtr)
{
    char *nativePathPtr, *str;
    Tcl_DString ds;
    Tcl_Obj *validPathPtr;
    int len;


    if (TclFSCwdIsNative()) {
	/*
	 * The cwd is native, which means we can use the translated path
	 * without worrying about normalization (this will also usually be
	 * shorter so the utf-to-external conversion will be somewhat faster).
	 */







|
|


>







2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
 *---------------------------------------------------------------------------
 */

ClientData
TclNativeCreateNativeRep(
    Tcl_Obj *pathPtr)
{
    WCHAR *nativePathPtr;
    const char *str;
    Tcl_Obj *validPathPtr;
    int len;
    WCHAR *wp;

    if (TclFSCwdIsNative()) {
	/*
	 * The cwd is native, which means we can use the translated path
	 * without worrying about normalization (this will also usually be
	 * shorter so the utf-to-external conversion will be somewhat faster).
	 */
2919
2920
2921
2922
2923
2924
2925
2926


2927
2928
2929



2930
2931
2932




2933










2934










2935
2936
2937







2938



2939

2940
2941












2942
2943
2944
2945
2946
2947
2948
	if (validPathPtr == NULL) {
	    return NULL;
	}
	Tcl_IncrRefCount(validPathPtr);
    }

    str = Tcl_GetStringFromObj(validPathPtr, &len);
    if (str[0] == '/' && str[1] == '/' && str[2] == '?' && str[3] == '/') {


	char *p;

	for (p = str; p && *p; ++p) {



	    if (*p == '/') {
		*p = '\\';
	    }




	}










    }










    Tcl_WinUtfToTChar(str, len, &ds);
    len = Tcl_DStringLength(&ds) + sizeof(WCHAR);
    Tcl_DecrRefCount(validPathPtr);







    nativePathPtr = ckalloc(len);



    memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len);


    Tcl_DStringFree(&ds);












    return nativePathPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclNativeDupInternalRep --







|
>
>
|
|
<
>
>
>
|
|
|
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>

>
>
>
>
>
>
>
>
>
>
|
|
<
>
>
>
>
>
>
>
|
>
>
>
|
>
|
<
>
>
>
>
>
>
>
>
>
>
>
>







2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934

2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968

2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982

2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
	if (validPathPtr == NULL) {
	    return NULL;
	}
	Tcl_IncrRefCount(validPathPtr);
    }

    str = Tcl_GetStringFromObj(validPathPtr, &len);

    if (strlen(str)!=len) {
	/* String contains NUL-bytes. This is invalid. */
	return 0;
    }

    /* Let MultiByteToWideChar check for other invalid sequences, like
     * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames */
    len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0);
    if (len==0) {
	return 0;
    }
    /* Overallocate 6 chars, making some room for extended paths */
    wp = nativePathPtr = ckalloc( (len+6) * sizeof(WCHAR) );
    if (nativePathPtr==0) {
      return 0;
    }
    MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, len);
    /*
    ** If path starts with "//?/" or "\\?\" (extended path), translate
    ** any slashes to backslashes but leave the '?' intact
    */
    if ((str[0]=='\\' || str[0]=='/') && (str[1]=='\\' || str[1]=='/')
	    && str[2]=='?' && (str[3]=='\\' || str[3]=='/')) {
	wp[0] = wp[1] = wp[3] = '\\';
	str += 4;
	wp += 4;
    }
    /*
    ** If there is no "\\?\" prefix but there is a drive or UNC
    ** path prefix and the path is larger than MAX_PATH chars,
    ** no Win32 API function can handle that unless it is
    ** prefixed with the extended path prefix. See:
    ** <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath>
    **/
    if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z'))
	    && str[1]==':') {
	if (wp==nativePathPtr && len>MAX_PATH && (str[2]=='\\' || str[2]=='/')) {
	    memmove(wp+4, wp, len*sizeof(WCHAR));
	    memcpy(wp, L"\\\\?\\", 4*sizeof(WCHAR));

	    wp += 4;
	}
	/*
	 ** If (remainder of) path starts with "<drive>:",
	 ** leave the ':' intact.
	 */
	wp += 2;
    } else if (wp==nativePathPtr && len>MAX_PATH
	    && (str[0]=='\\' || str[0]=='/')
	    && (str[1]=='\\' || str[1]=='/') && str[2]!='?') {
	memmove(wp+6, wp, len*sizeof(WCHAR));
	memcpy(wp, L"\\\\?\\UNC", 7*sizeof(WCHAR));
	wp += 7;
    }

    /*
    ** In the remainder of the path, translate invalid characters to
    ** characters in the Unicode private use area.
    */
    while (*wp != '\0') {
	if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) {
	    *wp |= 0xF000;
	} else if (*wp == '/') {
	    *wp = '\\';
	}
	++wp;
    }
    return nativePathPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclNativeDupInternalRep --
Changes to win/tclWinInit.c.
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132



133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
static int		ToUtf(const WCHAR *wSrc, char *dst);

/*
 *---------------------------------------------------------------------------
 *
 * TclpInitPlatform --
 *
 *	Initialize all the platform-dependant things like signals and
 *	floating-point error handling.
 *
 *	Called at process initialization time.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

void
TclpInitPlatform(void)
{



    tclPlatform = TCL_PLATFORM_WINDOWS;

    /*
     * The following code stops Windows 3.X and Windows NT 3.51 from
     * automatically putting up Sharing Violation dialogs, e.g, when someone
     * tries to access a file that is locked or a drive with no disk in it.
     * Tcl already returns the appropriate error to the caller, and they can
     * decide to put up their own dialog in response to that failure.
     *
     * Under 95 and NT 4.0, this is a NOOP because the system doesn't
     * automatically put up dialogs when the above operations fail.
     */

    SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS);

#ifdef STATIC_BUILD
    /*
     * If we are in a statically linked executable, then we need to explicitly
     * initialize the Windows function tables here since DllMain() will not be
     * invoked.
     */







|
|















>
>
>



|
<
<
<
<
<
<
|

|
<







109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139






140
141
142

143
144
145
146
147
148
149
static int		ToUtf(const WCHAR *wSrc, char *dst);

/*
 *---------------------------------------------------------------------------
 *
 * TclpInitPlatform --
 *
 *	Initialize all the platform-dependant things like signals,
 *	floating-point error handling and sockets.
 *
 *	Called at process initialization time.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

void
TclpInitPlatform(void)
{
    WSADATA wsaData;
    WORD wVersionRequested = MAKEWORD(2, 2);

    tclPlatform = TCL_PLATFORM_WINDOWS;

    /*
     * Initialize the winsock library. On Windows XP and higher this






     * can never fail.
     */
    WSAStartup(wVersionRequested, &wsaData);


#ifdef STATIC_BUILD
    /*
     * If we are in a statically linked executable, then we need to explicitly
     * initialize the Windows function tables here since DllMain() will not be
     * invoked.
     */
Changes to win/tclWinInt.h.
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
MODULE_SCOPE TclFile	TclWinMakeFile(HANDLE handle);
MODULE_SCOPE Tcl_Channel TclWinOpenConsoleChannel(HANDLE handle,
			    char *channelName, int permissions);
MODULE_SCOPE Tcl_Channel TclWinOpenFileChannel(HANDLE handle, char *channelName,
			    int permissions, int appendMode);
MODULE_SCOPE Tcl_Channel TclWinOpenSerialChannel(HANDLE handle,
			    char *channelName, int permissions);
MODULE_SCOPE HANDLE	TclWinSerialReopen(HANDLE handle, const TCHAR *name,
			    DWORD access);
MODULE_SCOPE int	TclWinSymLinkCopyDirectory(const TCHAR *LinkOriginal,
			    const TCHAR *LinkCopy);
MODULE_SCOPE int	TclWinSymLinkDelete(const TCHAR *LinkOriginal,
			    int linkOnly);
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
MODULE_SCOPE void	TclWinFreeAllocCache(void);







|







62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
MODULE_SCOPE TclFile	TclWinMakeFile(HANDLE handle);
MODULE_SCOPE Tcl_Channel TclWinOpenConsoleChannel(HANDLE handle,
			    char *channelName, int permissions);
MODULE_SCOPE Tcl_Channel TclWinOpenFileChannel(HANDLE handle, char *channelName,
			    int permissions, int appendMode);
MODULE_SCOPE Tcl_Channel TclWinOpenSerialChannel(HANDLE handle,
			    char *channelName, int permissions);
MODULE_SCOPE HANDLE	TclWinSerialOpen(HANDLE handle, const TCHAR *name,
			    DWORD access);
MODULE_SCOPE int	TclWinSymLinkCopyDirectory(const TCHAR *LinkOriginal,
			    const TCHAR *LinkCopy);
MODULE_SCOPE int	TclWinSymLinkDelete(const TCHAR *LinkOriginal,
			    int linkOnly);
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
MODULE_SCOPE void	TclWinFreeAllocCache(void);
Changes to win/tclWinPipe.c.
77
78
79
80
81
82
83






84
85
86
87
88
89
90
/*
 * Bit masks used in the sharedFlags field of the PipeInfo structure below.
 */

#define PIPE_EOF	(1<<2)	/* Pipe has reached EOF. */
#define PIPE_EXTRABYTE	(1<<3)	/* The reader thread has consumed one byte. */







/*
 * This structure describes per-instance data for a pipe based channel.
 */

typedef struct PipeInfo {
    struct PipeInfo *nextPtr;	/* Pointer to next registered pipe. */
    Tcl_Channel channel;	/* Pointer to channel structure. */







>
>
>
>
>
>







77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
/*
 * Bit masks used in the sharedFlags field of the PipeInfo structure below.
 */

#define PIPE_EOF	(1<<2)	/* Pipe has reached EOF. */
#define PIPE_EXTRABYTE	(1<<3)	/* The reader thread has consumed one byte. */

/*
 * TODO: It appears the whole EXTRABYTE machinery is in place to support
 * outdated Win 95 systems.  If this can be confirmed, much code can be
 * deleted.
 */

/*
 * This structure describes per-instance data for a pipe based channel.
 */

typedef struct PipeInfo {
    struct PipeInfo *nextPtr;	/* Pointer to next registered pipe. */
    Tcl_Channel channel;	/* Pointer to channel structure. */
Changes to win/tclWinPort.h.
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
#define TclpSysAlloc(size, isBin)	((void*)HeapAlloc(GetProcessHeap(), \
					    (DWORD)0, (DWORD)size))
#define TclpSysFree(ptr)		(HeapFree(GetProcessHeap(), \
					    (DWORD)0, (HGLOBAL)ptr))
#define TclpSysRealloc(ptr, size)	((void*)HeapReAlloc(GetProcessHeap(), \
					    (DWORD)0, (LPVOID)ptr, (DWORD)size))

/*
 * The following defines map from standard socket names to our internal
 * wrappers that redirect through the winSock function table (see the
 * file tclWinSock.c).
 */

#define getservbyname	TclWinGetServByName
#define getsockopt	TclWinGetSockOpt
#define setsockopt	TclWinSetSockOpt
/* This type is not defined in the Windows headers */
#define socklen_t       int


/*
 * The following macros have trivial definitions, allowing generic code to
 * address platform-specific issues.







<
<
<
<
<
<
<
<
<







524
525
526
527
528
529
530









531
532
533
534
535
536
537
#define TclpSysAlloc(size, isBin)	((void*)HeapAlloc(GetProcessHeap(), \
					    (DWORD)0, (DWORD)size))
#define TclpSysFree(ptr)		(HeapFree(GetProcessHeap(), \
					    (DWORD)0, (HGLOBAL)ptr))
#define TclpSysRealloc(ptr, size)	((void*)HeapReAlloc(GetProcessHeap(), \
					    (DWORD)0, (LPVOID)ptr, (DWORD)size))










/* This type is not defined in the Windows headers */
#define socklen_t       int


/*
 * The following macros have trivial definitions, allowing generic code to
 * address platform-specific issues.
Changes to win/tclWinSerial.c.
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434








1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446

1447
1448
1449
1450
1451
1452
1453

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinSerialReopen --
 *
 *	Reopens the serial port with the OVERLAPPED FLAG set
 *
 * Results:
 *	Returns the new handle, or INVALID_HANDLE_VALUE. Normally there
 *	shouldn't be any error, because the same channel has previously been
 *	succeesfully opened.
 *
 * Side effects:
 *	May close the original handle
 *
 *----------------------------------------------------------------------
 */

HANDLE
TclWinSerialReopen(
    HANDLE handle,
    const TCHAR *name,
    DWORD access)
{
    SerialInit();









    /*
     * Multithreaded I/O needs the overlapped flag set otherwise
     * ClearCommError blocks under Windows NT/2000 until serial output is
     * finished
     */

    if (CloseHandle(handle) == FALSE) {
	return INVALID_HANDLE_VALUE;
    }
    handle = CreateFile(name, access, 0, 0, OPEN_EXISTING,
	    FILE_FLAG_OVERLAPPED, 0);

    return handle;
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinOpenSerialChannel --







|

|


|
<
|


|





|





>
>
>
>
>
>
>
>







<
<
<


>







1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418

1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448



1449
1450
1451
1452
1453
1454
1455
1456
1457
1458

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinSerialOpen --
 *
 *	Opens or Reopens the serial port with the OVERLAPPED FLAG set
 *
 * Results:
 *	Returns the new handle, or INVALID_HANDLE_VALUE. 

 *	If an existing channel is specified it is closed and reopened.
 *
 * Side effects:
 *	May close/reopen the original handle
 *
 *----------------------------------------------------------------------
 */

HANDLE
TclWinSerialOpen(
    HANDLE handle,
    const TCHAR *name,
    DWORD access)
{
    SerialInit();

    /*
     * If an open channel is specified, close it
     */

    if ( handle != INVALID_HANDLE_VALUE && CloseHandle(handle) == FALSE) {
	return INVALID_HANDLE_VALUE;
    }

    /*
     * Multithreaded I/O needs the overlapped flag set otherwise
     * ClearCommError blocks under Windows NT/2000 until serial output is
     * finished
     */




    handle = CreateFile(name, access, 0, 0, OPEN_EXISTING,
	    FILE_FLAG_OVERLAPPED, 0);

    return handle;
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinOpenSerialChannel --
Changes to win/tclWinSock.c.
1
2
3
4
5
6
7
8
9
10
11



12
13
14
15
16
17
18
/*
 * tclWinSock.c --
 *
 *	This file contains Windows-specific socket related code.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * -----------------------------------------------------------------------



 *
 * General information on how this module works.
 *
 * - Each Tcl-thread with its sockets maintains an internal window to receive
 *   socket messages from the OS.
 *
 * - To ensure that message reception is always running this window is











>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/*
 * tclWinSock.c --
 *
 *	This file contains Windows-specific socket related code.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * -----------------------------------------------------------------------
 * The order and naming of functions in this file should minimize
 * the file diff to tclUnixSock.c.
 * -----------------------------------------------------------------------
 *
 * General information on how this module works.
 *
 * - Each Tcl-thread with its sockets maintains an internal window to receive
 *   socket messages from the OS.
 *
 * - To ensure that message reception is always running this window is
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76













77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
 *
 *   (Ad 2) The main functions for this are SocketSetupProc() and
 *          SocketCheckProc().
 */

#include "tclWinInt.h"

/*
 * Which version of the winsock API do we want?
 */

#define WSA_VERSION_MAJOR	1
#define WSA_VERSION_MINOR	1

#ifdef _MSC_VER
#   pragma comment (lib, "ws2_32")
#endif

/*
 * Support for control over sockets' KEEPALIVE and NODELAY behavior is
 * currently disabled.
 */

#undef TCL_FEATURE_KEEPALIVE_NAGLE

/*
 * Make sure to remove the redirection defines set in tclWinPort.h that is in
 * use in other sections of the core, except for us.
 */

#undef getservbyname
#undef getsockopt
#undef setsockopt














/*
 * The following variable is used to tell whether this module has been
 * initialized.  If 1, initialization of sockets was successful, if -1 then
 * socket initialization failed (WSAStartup failed).
 */

static int initialized = 0;
static const TCHAR classname[] = TEXT("TclSocket");
TCL_DECLARE_MUTEX(socketMutex)

/*
 * The following variable holds the network name of this host.
 */

static TclInitProcessGlobalValueProc InitializeHostName;
static ProcessGlobalValue hostName = {
    0, 0, NULL, NULL, InitializeHostName, NULL, NULL
};

/*
 * The following defines declare the messages used on socket windows.
 */

#define SOCKET_MESSAGE		WM_USER+1
#define SOCKET_SELECT		WM_USER+2
#define SOCKET_TERMINATE	WM_USER+3







<
<
<
<
<
<
<




















>
>
>
>
>
>
>
>
>
>
>
>
>










<
<
<
<
<
<
<
<
<







46
47
48
49
50
51
52







53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95









96
97
98
99
100
101
102
 *
 *   (Ad 2) The main functions for this are SocketSetupProc() and
 *          SocketCheckProc().
 */

#include "tclWinInt.h"








#ifdef _MSC_VER
#   pragma comment (lib, "ws2_32")
#endif

/*
 * Support for control over sockets' KEEPALIVE and NODELAY behavior is
 * currently disabled.
 */

#undef TCL_FEATURE_KEEPALIVE_NAGLE

/*
 * Make sure to remove the redirection defines set in tclWinPort.h that is in
 * use in other sections of the core, except for us.
 */

#undef getservbyname
#undef getsockopt
#undef setsockopt

/*
 * Helper macros to make parts of this file clearer. The macros do exactly
 * what they say on the tin. :-) They also only ever refer to their arguments
 * once, and so can be used without regard to side effects.
 */

#define SET_BITS(var, bits)	((var) |= (bits))
#define CLEAR_BITS(var, bits)	((var) &= ~(bits))

/* "sock" + a pointer in hex + \0 */
#define SOCK_CHAN_LENGTH        (4 + sizeof(void *) * 2 + 1)
#define SOCK_TEMPLATE           "sock%p"

/*
 * The following variable is used to tell whether this module has been
 * initialized.  If 1, initialization of sockets was successful, if -1 then
 * socket initialization failed (WSAStartup failed).
 */

static int initialized = 0;
static const TCHAR classname[] = TEXT("TclSocket");
TCL_DECLARE_MUTEX(socketMutex)










/*
 * The following defines declare the messages used on socket windows.
 */

#define SOCKET_MESSAGE		WM_USER+1
#define SOCKET_SELECT		WM_USER+2
#define SOCKET_TERMINATE	WM_USER+3
115
116
117
118
119
120
121




122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145


146
147
148
149

150
151


152
153
154
155














156
157
158
159

















160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201




202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222

223
224


225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272

273
274
275
276

277
278
279
280
281
282
283
284
285

286


287



288
289


290
291
292
293

294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316




317
318
319
320

321
322
323
324



325

326
327
328
329


330
331
332
333
334
335
336
337
338




339
340
341
342
343
344
345
346
347
348
349


350
351
352
353






354

355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371



372
373
374
375
376
377
378


379
380

381


382
383


384
385
386
387


388
389
390


391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407


408
409
410


411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450


451
452
453


454
455
456
457
458
459
460
461
462
463
464


465
466
467
468
469
470
471
    struct sockaddr_storage sas;
} address;

#ifndef IN6_ARE_ADDR_EQUAL
#define IN6_ARE_ADDR_EQUAL IN6_ADDR_EQUAL
#endif





typedef struct SocketInfo SocketInfo;

typedef struct TcpFdList {
    SocketInfo *infoPtr;
    SOCKET fd;
    struct TcpFdList *next;
} TcpFdList;

/*
 * The following structure is used to store the data associated with each
 * socket.
 */

struct SocketInfo {
    Tcl_Channel channel;	/* Channel associated with this socket. */
    struct TcpFdList *sockets;	/* Windows SOCKET handle. */
    int flags;			/* Bit field comprised of the flags described
				 * below. */
    int watchEvents;		/* OR'ed combination of FD_READ, FD_WRITE,
				 * FD_CLOSE, FD_ACCEPT and FD_CONNECT that
				 * indicate which events are interesting. */
    int readyEvents;		/* OR'ed combination of FD_READ, FD_WRITE,
				 * FD_CLOSE, FD_ACCEPT and FD_CONNECT that
				 * indicate which events have occurred. */


    int selectEvents;		/* OR'ed combination of FD_READ, FD_WRITE,
				 * FD_CLOSE, FD_ACCEPT and FD_CONNECT that
				 * indicate which events are currently being
				 * selected. */

    int acceptEventCount;	/* Count of the current number of FD_ACCEPTs
				 * that have arrived and not yet processed. */


    Tcl_TcpAcceptProc *acceptProc;
				/* Proc to call on accept. */
    ClientData acceptProcData;	/* The data for the accept proc. */
    int lastError;		/* Error code from last message. */














    struct SocketInfo *nextPtr;	/* The next socket on the per-thread socket
				 * list. */
};


















/*
 * The following structure is what is added to the Tcl event queue when a
 * socket event occurs.
 */

typedef struct {
    Tcl_Event header;		/* Information that is standard for all
				 * events. */
    SOCKET socket;		/* Socket descriptor that is ready. Used to
				 * find the SocketInfo structure for the file
				 * (can't point directly to the SocketInfo
				 * structure because it could go away while
				 * the event is queued). */
} SocketEvent;

/*
 * This defines the minimum buffersize maintained by the kernel.
 */

#define TCP_BUFFER_SIZE 4096

/*
 * The following macros may be used to set the flags field of a SocketInfo
 * structure.
 */

#define SOCKET_ASYNC		(1<<0)	/* The socket is in blocking mode. */
#define SOCKET_EOF		(1<<1)	/* A zero read happened on the
					 * socket. */
#define SOCKET_ASYNC_CONNECT	(1<<2)	/* This socket uses async connect. */
#define SOCKET_PENDING		(1<<3)	/* A message has been sent for this
					 * socket */

typedef struct {
    HWND hwnd;			/* Handle to window for socket messages. */
    HANDLE socketThread;	/* Thread handling the window */
    Tcl_ThreadId threadId;	/* Parent thread. */
    HANDLE readyEvent;		/* Event indicating that a socket event is
				 * ready. Also used to indicate that the
				 * socketThread has been initialized and has
				 * started. */
    HANDLE socketListLock;	/* Win32 Event to lock the socketList */




    SocketInfo *socketList;	/* Every open socket in this thread has an
				 * entry on this list. */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;
static WNDCLASS windowClass;

/*
 * Static functions defined in this file.
 */

static SocketInfo *	CreateSocket(Tcl_Interp *interp, int port,
			    const char *host, int server, const char *myaddr,
			    int myport, int async);
static void		InitSockets(void);
static SocketInfo *	NewSocketInfo(SOCKET socket);
static void		SocketExitHandler(ClientData clientData);
static LRESULT CALLBACK	SocketProc(HWND hwnd, UINT message, WPARAM wParam,
			    LPARAM lParam);
static int		SocketsEnabled(void);
static void		TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr);

static int		WaitForSocketEvent(SocketInfo *infoPtr, int events,
			    int *errorCodePtr);


static DWORD WINAPI	SocketThread(LPVOID arg);
static void		TcpThreadActionProc(ClientData instanceData,
			    int action);

static Tcl_EventCheckProc	SocketCheckProc;
static Tcl_EventProc		SocketEventProc;
static Tcl_EventSetupProc	SocketSetupProc;
static Tcl_DriverBlockModeProc	TcpBlockProc;
static Tcl_DriverCloseProc	TcpCloseProc;
static Tcl_DriverClose2Proc	TcpClose2Proc;
static Tcl_DriverSetOptionProc	TcpSetOptionProc;
static Tcl_DriverGetOptionProc	TcpGetOptionProc;
static Tcl_DriverInputProc	TcpInputProc;
static Tcl_DriverOutputProc	TcpOutputProc;
static Tcl_DriverWatchProc	TcpWatchProc;
static Tcl_DriverGetHandleProc	TcpGetHandleProc;

/*
 * This structure describes the channel type structure for TCP socket
 * based IO.
 */

static const Tcl_ChannelType tcpChannelType = {
    "tcp",		    /* Type name. */
    TCL_CHANNEL_VERSION_5,  /* v5 channel */
    TcpCloseProc,	    /* Close proc. */
    TcpInputProc,	    /* Input proc. */
    TcpOutputProc,	    /* Output proc. */
    NULL,		    /* Seek proc. */
    TcpSetOptionProc,	    /* Set option proc. */
    TcpGetOptionProc,	    /* Get option proc. */
    TcpWatchProc,	    /* Set up notifier to watch this channel. */
    TcpGetHandleProc,	    /* Get an OS handle from channel. */
    TcpClose2Proc,	    /* Close2proc. */
    TcpBlockProc,	    /* Set socket into (non-)blocking mode. */
    NULL,		    /* flush proc. */
    NULL,		    /* handler proc. */
    NULL,		    /* wide seek proc */
    TcpThreadActionProc,    /* thread action proc */
    NULL		    /* truncate */
};

/*
 *----------------------------------------------------------------------
 *
 * InitSockets --
 *
 *	Initialize the socket module.  If winsock startup is successful,

 *	registers the event window for the socket notifier code.
 *
 *	Assumes socketMutex is held.
 *

 * Results:
 *	None.
 *
 * Side effects:
 *	Initializes winsock, registers a new window class and creates a
 *	window for use in asynchronous socket notification.
 *
 *----------------------------------------------------------------------
 */




static void



InitSockets(void)
{


    DWORD id, err;
    WSADATA wsaData;
    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);


    if (!initialized) {
	initialized = 1;
	TclCreateLateExitHandler(SocketExitHandler, NULL);

	/*
	 * Create the async notification window with a new class. We must
	 * create a new class to avoid a Windows 95 bug that causes us to get
	 * the wrong message number for socket events if the message window is
	 * a subclass of a static control.
	 */

	windowClass.style = 0;
	windowClass.cbClsExtra = 0;
	windowClass.cbWndExtra = 0;
	windowClass.hInstance = TclWinGetTclInstance();
	windowClass.hbrBackground = NULL;
	windowClass.lpszMenuName = NULL;
	windowClass.lpszClassName = classname;
	windowClass.lpfnWndProc = SocketProc;
	windowClass.hIcon = NULL;
	windowClass.hCursor = NULL;

	if (!RegisterClass(&windowClass)) {




	    TclWinConvertError(GetLastError());
	    goto initFailure;
	}


	/*
	 * Initialize the winsock library and check the interface version
	 * actually loaded. We only ask for the 1.1 interface and do require
	 * that it not be less than 1.1.



	 */


	err = WSAStartup((WORD) MAKEWORD(WSA_VERSION_MAJOR,WSA_VERSION_MINOR),
		&wsaData);
	if (err != 0) {


	    TclWinConvertError(err);
	    goto initFailure;
	}

	/*
	 * Note the byte positions ae swapped for the comparison, so that
	 * 0x0002 (2.0, MAKEWORD(2,0)) doesn't look less than 0x0101 (1.1). We
	 * want the comparison to be 0x0200 < 0x0101.
	 */





	if (MAKEWORD(HIBYTE(wsaData.wVersion), LOBYTE(wsaData.wVersion))
		< MAKEWORD(WSA_VERSION_MINOR, WSA_VERSION_MAJOR)) {
	    TclWinConvertError(WSAVERNOTSUPPORTED);
	    WSACleanup();
	    goto initFailure;
	}
    }

    /*
     * Check for per-thread initialization.


     */

    if (tsdPtr != NULL) {
	return;






    }


    /*
     * OK, this thread has never done anything with sockets before.  Construct
     * a worker thread to handle asynchronous events related to sockets
     * assigned to _this_ thread.
     */

    tsdPtr = TCL_TSD_INIT(&dataKey);
    tsdPtr->socketList = NULL;
    tsdPtr->hwnd       = NULL;
    tsdPtr->threadId   = Tcl_GetCurrentThread();
    tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
    if (tsdPtr->readyEvent == NULL) {
	goto initFailure;
    }
    tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL);
    if (tsdPtr->socketListLock == NULL) {



	goto initFailure;
    }
    tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, 0,
	    &id);
    if (tsdPtr->socketThread == NULL) {
	goto initFailure;
    }



    SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST);




    /*
     * Wait for the thread to signal when the window has been created and if


     * it is ready to go.
     */

    WaitForSingleObject(tsdPtr->readyEvent, INFINITE);



    if (tsdPtr->hwnd == NULL) {
	goto initFailure;	/* Trouble creating the window. */


    }

    Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
    return;

  initFailure:
    TclpFinalizeSockets();
    initialized = -1;
    return;
}

/*
 *----------------------------------------------------------------------
 *
 * SocketsEnabled --
 *
 *	Check that the WinSock was successfully initialized.


 *
 * Results:
 *	1 if it is.


 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

    /* ARGSUSED */
static int
SocketsEnabled(void)
{
    int enabled;

    Tcl_MutexLock(&socketMutex);
    enabled = (initialized == 1);
    Tcl_MutexUnlock(&socketMutex);
    return enabled;
}


/*
 *----------------------------------------------------------------------
 *
 * SocketExitHandler --
 *
 *	Callback invoked during exit clean up to delete the socket
 *	communication window and to release the WinSock DLL.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

    /* ARGSUSED */
static void
SocketExitHandler(


    ClientData clientData)		/* Not used. */
{
    Tcl_MutexLock(&socketMutex);



    /*
     * Make sure the socket event handling window is cleaned-up for, at
     * most, this thread.
     */

    TclpFinalizeSockets();
    UnregisterClass(classname, TclWinGetTclInstance());
    WSACleanup();
    initialized = 0;
    Tcl_MutexUnlock(&socketMutex);


}

/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeSockets --
 *







>
>
>
>
|


|




<
<
<
<
<
|







|

|
>
>




>
|
|
>
>



|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









|
|










<
<
<
<
<
<
<
<
<
<
<










>
>
>
>
|







|


|
|
<

|





>
|

>
>







|











|



|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|

|
|
<
|
|
>
|
|
<
<
>
|
<
|
|
<
<
<
<
<
>
|
>
>
|
>
>
>
|

>
>
|
<
<
|
>
|
<
<
|
|
<
<
<
<
|
|
<
<
<
<
<
|
<
<
<
<
|
<
>
>
>
>
|
<
<
|
>
|
<
<
|
>
>
>
|
>
|
<
<
<
>
>
|
<
|
|

<
<
|

>
>
>
>
|
<
<
<
<
<
<
<
|
|
<
>
>
|

|
|
>
>
>
>
>
>
|
>
|
<
<
<
<
<
|
<
<
<
<
<
<
<
|
|
<
>
>
>
|
|
<
<
<
<
|
>
>
|
<
>
|
>
>
|
<
>
>
|
<
|
<
>
>
|
<
<
>
>
|
|
<
|
|
<
<
<
|





|

|
>
>


<
>
>


<
<
<
<
|
<
<
<
<
<
|
<
<
<
<
<
|
|
<

|
<
|
<
<
<
<
<
<
<
<
<
<
<
|
<
<
|
>
>
|


>
>

<
|
|
<
|
|
|
<
<
|
>
>







115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133





134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215











216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242

243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299

300
301
302
303
304


305
306

307
308





309
310
311
312
313
314
315
316
317
318
319
320
321


322
323
324


325
326




327
328





329




330

331
332
333
334
335


336
337
338


339
340
341
342
343
344
345



346
347
348

349
350
351


352
353
354
355
356
357
358







359
360

361
362
363
364
365
366
367
368
369
370
371
372
373
374
375





376







377
378

379
380
381
382
383




384
385
386
387

388
389
390
391
392

393
394
395

396

397
398
399


400
401
402
403

404
405



406
407
408
409
410
411
412
413
414
415
416
417
418

419
420
421
422




423





424





425
426

427
428

429











430


431
432
433
434
435
436
437
438
439

440
441

442
443
444


445
446
447
448
449
450
451
452
453
454
    struct sockaddr_storage sas;
} address;

#ifndef IN6_ARE_ADDR_EQUAL
#define IN6_ARE_ADDR_EQUAL IN6_ADDR_EQUAL
#endif

/*
 * This structure describes per-instance state of a tcp based channel.
 */

typedef struct TcpState TcpState;

typedef struct TcpFdList {
    TcpState *statePtr;
    SOCKET fd;
    struct TcpFdList *next;
} TcpFdList;






struct TcpState {
    Tcl_Channel channel;	/* Channel associated with this socket. */
    struct TcpFdList *sockets;	/* Windows SOCKET handle. */
    int flags;			/* Bit field comprised of the flags described
				 * below. */
    int watchEvents;		/* OR'ed combination of FD_READ, FD_WRITE,
				 * FD_CLOSE, FD_ACCEPT and FD_CONNECT that
				 * indicate which events are interesting. */
    volatile int readyEvents;	/* OR'ed combination of FD_READ, FD_WRITE,
				 * FD_CLOSE, FD_ACCEPT and FD_CONNECT that
				 * indicate which events have occurred.
				 * Set by notifier thread, access must be
				 * protected by semaphore */
    int selectEvents;		/* OR'ed combination of FD_READ, FD_WRITE,
				 * FD_CLOSE, FD_ACCEPT and FD_CONNECT that
				 * indicate which events are currently being
				 * selected. */
    volatile int acceptEventCount;
				/* Count of the current number of FD_ACCEPTs
				 * that have arrived and not yet processed.
				 * Set by notifier thread, access must be
				 * protected by semaphore */
    Tcl_TcpAcceptProc *acceptProc;
				/* Proc to call on accept. */
    ClientData acceptProcData;	/* The data for the accept proc. */

    /*
     * Only needed for client sockets
     */

    struct addrinfo *addrlist;	/* Addresses to connect to. */
    struct addrinfo *addr;	/* Iterator over addrlist. */
    struct addrinfo *myaddrlist;/* Local address. */
    struct addrinfo *myaddr;	/* Iterator over myaddrlist. */
    int connectError;		/* Cache status of async socket. */
    int cachedBlocking;         /* Cache blocking mode of async socket. */
    volatile int notifierConnectError;
				/* Async connect error set by notifier thread.
				 * This error is still a windows error code.
				 * Access must be protected by semaphore */
    struct TcpState *nextPtr;	/* The next socket on the per-thread socket
				 * list. */
};

/*
 * These bits may be ORed together into the "flags" field of a TcpState
 * structure.
 */

#define TCP_NONBLOCKING		(1<<0)	/* Socket with non-blocking I/O */
#define TCP_ASYNC_CONNECT	(1<<1)	/* Async connect in progress. */
#define SOCKET_EOF		(1<<2)	/* A zero read happened on the
					 * socket. */
#define SOCKET_PENDING		(1<<3)	/* A message has been sent for this
					 * socket */
#define TCP_ASYNC_PENDING	(1<<4)	/* TcpConnect was called to
					 * process an async connect. This
					 * flag indicates that reentry is
					 * still pending */
#define TCP_ASYNC_FAILED	(1<<5)	/* An async connect finally failed */

/*
 * The following structure is what is added to the Tcl event queue when a
 * socket event occurs.
 */

typedef struct {
    Tcl_Event header;		/* Information that is standard for all
				 * events. */
    SOCKET socket;		/* Socket descriptor that is ready. Used to
				 * find the TcpState structure for the file
				 * (can't point directly to the TcpState
				 * structure because it could go away while
				 * the event is queued). */
} SocketEvent;

/*
 * This defines the minimum buffersize maintained by the kernel.
 */

#define TCP_BUFFER_SIZE 4096













typedef struct {
    HWND hwnd;			/* Handle to window for socket messages. */
    HANDLE socketThread;	/* Thread handling the window */
    Tcl_ThreadId threadId;	/* Parent thread. */
    HANDLE readyEvent;		/* Event indicating that a socket event is
				 * ready. Also used to indicate that the
				 * socketThread has been initialized and has
				 * started. */
    HANDLE socketListLock;	/* Win32 Event to lock the socketList */
    TcpState *pendingTcpState;
				/* This socket is opened but not jet in the
				 * list. This value is also checked by
				 * the event structure. */
    TcpState *socketList;	/* Every open socket in this thread has an
				 * entry on this list. */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;
static WNDCLASS windowClass;

/*
 * Static routines for this file:
 */

static int		TcpConnect(Tcl_Interp *interp,
			    TcpState *state);

static void		InitSockets(void);
static TcpState *	NewSocketInfo(SOCKET socket);
static void		SocketExitHandler(ClientData clientData);
static LRESULT CALLBACK	SocketProc(HWND hwnd, UINT message, WPARAM wParam,
			    LPARAM lParam);
static int		SocketsEnabled(void);
static void		TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr);
static int		WaitForConnect(TcpState *statePtr, int *errorCodePtr);
static int		WaitForSocketEvent(TcpState *statePtr, int events,
			    int *errorCodePtr);
static void		AddSocketInfoFd(TcpState *statePtr,  SOCKET socket);
static int		FindFDInList(TcpState *statePtr, SOCKET socket);
static DWORD WINAPI	SocketThread(LPVOID arg);
static void		TcpThreadActionProc(ClientData instanceData,
			    int action);

static Tcl_EventCheckProc	SocketCheckProc;
static Tcl_EventProc		SocketEventProc;
static Tcl_EventSetupProc	SocketSetupProc;
static Tcl_DriverBlockModeProc	TcpBlockModeProc;
static Tcl_DriverCloseProc	TcpCloseProc;
static Tcl_DriverClose2Proc	TcpClose2Proc;
static Tcl_DriverSetOptionProc	TcpSetOptionProc;
static Tcl_DriverGetOptionProc	TcpGetOptionProc;
static Tcl_DriverInputProc	TcpInputProc;
static Tcl_DriverOutputProc	TcpOutputProc;
static Tcl_DriverWatchProc	TcpWatchProc;
static Tcl_DriverGetHandleProc	TcpGetHandleProc;

/*
 * This structure describes the channel type structure for TCP socket
 * based IO:
 */

static const Tcl_ChannelType tcpChannelType = {
    "tcp",			/* Type name. */
    TCL_CHANNEL_VERSION_5,	/* v5 channel */
    TcpCloseProc,		/* Close proc. */
    TcpInputProc,		/* Input proc. */
    TcpOutputProc,		/* Output proc. */
    NULL,			/* Seek proc. */
    TcpSetOptionProc,		/* Set option proc. */
    TcpGetOptionProc,		/* Get option proc. */
    TcpWatchProc,		/* Initialize notifier. */
    TcpGetHandleProc,		/* Get OS handles out of channel. */
    TcpClose2Proc,		/* Close2 proc. */
    TcpBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    NULL,			/* wide seek proc. */
    TcpThreadActionProc,	/* thread action proc. */
    NULL			/* truncate proc. */
};

/*
 * The following variable holds the network name of this host.
 */


static TclInitProcessGlobalValueProc InitializeHostName;
static ProcessGlobalValue hostName =
	{0, 0, NULL, NULL, InitializeHostName, NULL, NULL};



/*
 * Address print debug functions

 */
#if 0





void printaddrinfo(struct addrinfo *ai, char *prefix)
{
    char host[NI_MAXHOST], port[NI_MAXSERV];
    getnameinfo(ai->ai_addr, ai->ai_addrlen,
		host, sizeof(host),
		port, sizeof(port),
		NI_NUMERICHOST|NI_NUMERICSERV);
}
void printaddrinfolist(struct addrinfo *addrlist, char *prefix)
{
    struct addrinfo *ai;
    for (ai = addrlist; ai != NULL; ai = ai->ai_next) {
	printaddrinfo(ai, prefix);


    }
}
#endif



/*




 *----------------------------------------------------------------------
 *





 * InitializeHostName --




 *

 *	This routine sets the process global value of the name of the local
 *	host on which the process is running.
 *
 * Results:
 *	None.


 *
 *----------------------------------------------------------------------
 */



void
InitializeHostName(
    char **valuePtr,
    int *lengthPtr,
    Tcl_Encoding *encodingPtr)
{



    TCHAR tbuf[MAX_COMPUTERNAME_LENGTH + 1];
    DWORD length = MAX_COMPUTERNAME_LENGTH + 1;
    Tcl_DString ds;


    if (GetComputerName(tbuf, &length) != 0) {
	/*


	 * Convert string from native to UTF then change to lowercase.
	 */

	Tcl_UtfToLower(Tcl_WinTCharToUtf(tbuf, -1, &ds));

    } else {
	Tcl_DStringInit(&ds);







	if (TclpHasSockets(NULL) == TCL_OK) {
	    /*

	     * The buffer size of 256 is recommended by the MSDN page that
	     * documents gethostname() as being always adequate.
	     */

	    Tcl_DString inDs;

	    Tcl_DStringInit(&inDs);
	    Tcl_DStringSetLength(&inDs, 256);
	    if (gethostname(Tcl_DStringValue(&inDs),
		    Tcl_DStringLength(&inDs)) == 0) {
		Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), -1,
			&ds);
	    }
	    Tcl_DStringFree(&inDs);
	}





    }








    *encodingPtr = Tcl_GetEncoding(NULL, "utf-8");

    *lengthPtr = Tcl_DStringLength(&ds);
    *valuePtr = ckalloc((*lengthPtr) + 1);
    memcpy(*valuePtr, Tcl_DStringValue(&ds), (size_t)(*lengthPtr)+1);
    Tcl_DStringFree(&ds);
}





/*
 *----------------------------------------------------------------------
 *

 * Tcl_GetHostName --
 *
 *	Returns the name of the local host.
 *
 * Results:

 *	A string containing the network name for this machine, or an empty
 *	string if we can't figure out the name. The caller must not modify or
 *	free this string.

 *

 * Side effects:
 *	Caches the name to return for future calls.
 *


 *----------------------------------------------------------------------
 */

const char *

Tcl_GetHostName(void)
{



    return Tcl_GetString(TclGetProcessGlobalValue(&hostName));
}

/*
 *----------------------------------------------------------------------
 *
 * TclpHasSockets --
 *
 *	This function determines whether sockets are available on the current
 *	system and returns an error in interp if they are not. Note that
 *	interp may be NULL.
 *
 * Results:

 *	Returns TCL_OK if the system supports sockets, or TCL_ERROR with an
 *	error in interp (if non-NULL).
 *
 * Side effects:




 *	If not already prepared, initializes the TSD structure and socket





 *	message handling thread associated to the calling thread for the





 *	subsystem of the driver.
 *

 *----------------------------------------------------------------------
 */













int


TclpHasSockets(
    Tcl_Interp *interp)		/* Where to write an error message if sockets
				 * are not present, or NULL if no such message
				 * is to be written. */
{
    Tcl_MutexLock(&socketMutex);
    InitSockets();
    Tcl_MutexUnlock(&socketMutex);


    if (SocketsEnabled()) {
	return TCL_OK;

    }
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(


		"sockets are not available on this system", -1));
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeSockets --
 *
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536

537
538
539
540
541
542
543
544
545

546

547
548
549


550
551
552
553
554

555
556
557
558
559
560
561

562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578

579
580
581
582
583
584
585
586
587
588
589
590
591
592

593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678


679
680
681
682
683









684




685




686



687














































































688
689

690
691
692
693
694
695
696
697
698
699
700
701
702
703

704









705
706
707
708
709
710
711
712
713
714
715
716

717
718
719
720
721

722
723


724
725
726


727
728
729
730


731
732
733
734
735
736



737
738
739
740
741
742
743
744
745
746

747
748
749
750


751

752
753
754
755
756

757
758
759
760
761

762
763
764
765
766
767

768
769
770
771
772

773
774


775
776
777
778
779
780
781
782
783
784

785
786
787
788
789
790

791
792



793





794
795
796
797
798
799
800
801
802
803
804
805

806
807
808


809



810




811
812
813
814


815



816
817
818
819
820
821


822
823

824
825


826
827



828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844

845
846
847


848
849
850
851
852

853
854
855
856
857
858
859
860
861

862
863
864
865

866
867
868
869
870
871
872
873
874
875








876

877





878




879





880



881



882































883





884




885








886
887
888
889
890
891
892
893
    }
    Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpHasSockets --
 *
 *	This function determines whether sockets are available on the current
 *	system and returns an error in interp if they are not. Note that
 *	interp may be NULL.
 *
 * Results:
 *	Returns TCL_OK if the system supports sockets, or TCL_ERROR with an
 *	error in interp (if non-NULL).

 *
 * Side effects:
 *	If not already prepared, initializes the TSD structure and socket
 *	message handling thread associated to the calling thread for the
 *	subsystem of the driver.
 *
 *----------------------------------------------------------------------
 */


int

TclpHasSockets(
    Tcl_Interp *interp)		/* Where to write an error message if sockets
				 * are not present, or NULL if no such message


				 * is to be written. */
{
    Tcl_MutexLock(&socketMutex);
    InitSockets();
    Tcl_MutexUnlock(&socketMutex);


    if (SocketsEnabled()) {
	return TCL_OK;
    }
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"sockets are not available on this system", -1));

    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * SocketSetupProc --
 *
 *	This function is invoked before Tcl_DoOneEvent blocks waiting for an
 *	event.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Adjusts the block time if needed.

 *
 *----------------------------------------------------------------------
 */

void
SocketSetupProc(
    ClientData data,		/* Not used. */
    int flags)			/* Event flags as passed to Tcl_DoOneEvent. */
{
    SocketInfo *infoPtr;
    Tcl_Time blockTime = { 0, 0 };
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {

	return;
    }

    /*
     * Check to see if there is a ready socket.	 If so, poll.
     */

    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
    for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->readyEvents & infoPtr->watchEvents) {
	    Tcl_SetMaxBlockTime(&blockTime);
	    break;
	}
    }
    SetEvent(tsdPtr->socketListLock);
}

/*
 *----------------------------------------------------------------------
 *
 * SocketCheckProc --
 *
 *	This function is called by Tcl_DoOneEvent to check the socket event
 *	source for events.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May queue an event.
 *
 *----------------------------------------------------------------------
 */

static void
SocketCheckProc(
    ClientData data,		/* Not used. */
    int flags)			/* Event flags as passed to Tcl_DoOneEvent. */
{
    SocketInfo *infoPtr;
    SocketEvent *evPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Queue events for any ready sockets that don't already have events
     * queued (caused by persistent states that won't generate WinSock
     * events).
     */

    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
    for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if ((infoPtr->readyEvents & infoPtr->watchEvents)
		&& !(infoPtr->flags & SOCKET_PENDING)) {
	    infoPtr->flags |= SOCKET_PENDING;
	    evPtr = ckalloc(sizeof(SocketEvent));
	    evPtr->header.proc = SocketEventProc;
	    evPtr->socket = infoPtr->sockets->fd;
	    Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
	}
    }
    SetEvent(tsdPtr->socketListLock);
}

/*
 *----------------------------------------------------------------------
 *
 * SocketEventProc --
 *
 *	This function is called by Tcl_ServiceEvent when a socket event
 *	reaches the front of the event queue. This function is responsible for
 *	notifying the generic channel code.
 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be removed from
 *	the queue. Returns 0 if the event was not handled, meaning it should
 *	stay on the queue. The only time the event isn't handled is if the
 *	TCL_FILE_EVENTS flag bit isn't set.
 *
 * Side effects:
 *	Whatever the channel callback functions do.


 *
 *----------------------------------------------------------------------
 */

static int









SocketEventProc(




    Tcl_Event *evPtr,		/* Event to service. */




    int flags)			/* Flags that indicate what events to handle,



				 * such as TCL_FILE_EVENTS. */














































































{
    SocketInfo *infoPtr;

    SocketEvent *eventPtr = (SocketEvent *) evPtr;
    int mask = 0, events;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    TcpFdList *fds;
    SOCKET newSocket;
    address addr;
    int len;

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Find the specified socket on the socket list.

     */










    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
    for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->sockets->fd == eventPtr->socket) {
	    break;
	}
    }

    /*
     * Discard events that have gone stale.
     */


    if (!infoPtr) {
        SetEvent(tsdPtr->socketListLock);
	return 1;
    }


    infoPtr->flags &= ~SOCKET_PENDING;



    /*
     * Handle connection requests directly.


     */

    if (infoPtr->readyEvents & FD_ACCEPT) {
	for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) {



	    /*
	    * Accept the incoming connection request.
	    */
	    len = sizeof(address);




	    newSocket = accept(fds->fd, &(addr.sa), &len);

	    /* On Tcl server sockets with multiple OS fds we loop over the fds trying
	     * an accept() on each, so we expect INVALID_SOCKET.  There are also other
	     * network stack conditions that can result in FD_ACCEPT but a subsequent
	     * failure on accept() by the time we get around to it.
	     * Access to sockets (acceptEventCount, readyEvents) in socketList
	     * is still protected by the lock (prevents reintroduction of 
	     * SF Tcl Bug 3056775.
	     */


	    if (newSocket == INVALID_SOCKET) {
		/* int err = WSAGetLastError(); */
		continue;


	    }


	    /*
	     * It is possible that more than one FD_ACCEPT has been sent, so an extra
	     * count must be kept. Decrement the count, and reset the readyEvent bit
	     * if the count is no longer > 0.

	     */
	    infoPtr->acceptEventCount--;

	    if (infoPtr->acceptEventCount <= 0) {
		infoPtr->readyEvents &= ~(FD_ACCEPT);

	    }

	    SetEvent(tsdPtr->socketListLock);

	    /* Caution: TcpAccept() has the side-effect of evaluating the server
	     * accept script (via AcceptCallbackProc() in tclIOCmd.c), which can

	     * close the server socket and invalidate infoPtr and fds.
	     * If TcpAccept() accepts a socket we must return immediately and let
	     * SocketCheckProc queue additional FD_ACCEPT events.
	     */
	    TcpAccept(fds, newSocket, addr);

	    return 1;
	}



	/* Loop terminated with no sockets accepted; clear the ready mask so 
	 * we can detect the next connection request. Note that connection 
	 * requests are level triggered, so if there is a request already 
	 * pending, a new event will be generated.
	 */
	infoPtr->acceptEventCount = 0;
	infoPtr->readyEvents &= ~(FD_ACCEPT);

	SetEvent(tsdPtr->socketListLock);

	return 1;
    }

    SetEvent(tsdPtr->socketListLock);

    /*

     * Mask off unwanted events and compute the read/write mask so we can
     * notify the channel.



     */






    events = infoPtr->readyEvents & infoPtr->watchEvents;

    if (events & FD_CLOSE) {
	/*
	 * If the socket was closed and the channel is still interested in
	 * read events, then we need to ensure that we keep polling for this
	 * event until someone does something with the channel. Note that we
	 * do this before calling Tcl_NotifyChannel so we don't have to watch
	 * out for the channel being deleted out from under us. This may cause
	 * a redundant trip through the event loop, but it's simpler than
	 * trying to do unwind protection.

	 */

	Tcl_Time blockTime = { 0, 0 };






	Tcl_SetMaxBlockTime(&blockTime);




	mask |= TCL_READABLE|TCL_WRITABLE;
    } else if (events & FD_READ) {
	fd_set readFds;
	struct timeval timeout;






	/*
	 * We must check to see if data is really available, since someone
	 * could have consumed the data in the meantime. Turn off async
	 * notification so select will work correctly. If the socket is still
	 * readable, notify the channel driver, otherwise reset the async
	 * select handler and keep waiting.


	 */


	SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
		(WPARAM) UNSELECT, (LPARAM) infoPtr);



	FD_ZERO(&readFds);



	FD_SET(infoPtr->sockets->fd, &readFds);
	timeout.tv_usec = 0;
	timeout.tv_sec = 0;

	if (select(0, &readFds, NULL, NULL, &timeout) != 0) {
	    mask |= TCL_READABLE;
	} else {
	    infoPtr->readyEvents &= ~(FD_READ);
	    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
		    (WPARAM) SELECT, (LPARAM) infoPtr);
	}
    }
    if (events & (FD_WRITE | FD_CONNECT)) {
	mask |= TCL_WRITABLE;
	if (events & FD_CONNECT && infoPtr->lastError != NO_ERROR) {
	    /*
	     * Connect errors should also fire the readable handler.

	     */

	    mask |= TCL_READABLE;


	}
    }

    if (mask) {
	Tcl_NotifyChannel(infoPtr->channel, mask);

    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpBlockProc --
 *

 *	Sets a socket into blocking or non-blocking mode.
 *
 * Results:
 *	0 if successful, errno if there was an error.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TcpBlockProc(
    ClientData instanceData,	/* The socket to block/un-block. */








    int mode)			/* TCL_MODE_BLOCKING or

				 * TCL_MODE_NONBLOCKING. */





{




    SocketInfo *infoPtr = instanceData;









    if (mode == TCL_MODE_NONBLOCKING) {



	infoPtr->flags |= SOCKET_ASYNC;































    } else {





	infoPtr->flags &= ~(SOCKET_ASYNC);




    }








    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpCloseProc --
 *







|

|
|
<


<
<
>


<
<
|




>
|
>
|
<
<
>
>
|

<
<
<
>

|
|
|
<
<
<
>

|





|

|
|
<
<
<
<
<
|
>

<
<
|
<
<
<
<
<
<
<
<
|
<
>
|
<
|
<
<
<
|
<
<
<
<
<
<
<
<
<
<
|
|
<
<
<
<
|
<
<
<
|
<
<
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

<
|
<
|


<
>
>





>
>
>
>
>
>
>
>
>
|
>
>
>
>
|
>
>
>
>
|
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
>
|
|
<
|
<
<
<

|
|
|

|
|
>
|
>
>
>
>
>
>
>
>
>

|
<
<
<
<
|
|
|
|
<
<
>
|
<
<
<
<
>
|
<
>
>
|
|
<
>
>
|
|
<
<
>
>
|
|
<
|
<

>
>
>
|
|
<
|
<
<
<
<
<
|
>
|
<
|
|
>
>
|
>

|
|
<
|
>
|
<

|
|
>
|

<
|
<
<
>
|
<
<
|
|
>
|
|
>
>
|
|
|
<
<
|
<
<

<
>
|


<
<

>
|
<
>
>
>

>
>
>
>
>
|
|

<

<
<
<
<
<
<
<
>


<
>
>
|
>
>
>
|
>
>
>
>
|
|
<
|
>
>
|
>
>
>

<
<
<
<
<
>
>


>
|
<
>
>
|
|
>
>
>
|
<
<
|
|
|
|
|
<
<

|
<
<
<
|
|
>
|

|
>
>



<
<
>
|
|





|

>
|


<
>


|





|
|
>
>
>
>
>
>
>
>
|
>
|
>
>
>
>
>
|
>
>
>
>
|
>
>
>
>
>

>
>
>
|
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
|
>
>
>
>
|
>
>
>
>
>
>
>
>
|







504
505
506
507
508
509
510
511
512
513
514

515
516


517
518
519


520
521
522
523
524
525
526
527
528


529
530
531
532



533
534
535
536
537



538
539
540
541
542
543
544
545
546
547
548
549





550
551
552


553








554

555
556

557



558










559
560




561



562



563














































564

565

566
567
568

569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678

679
680
681

682



683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702




703
704
705
706


707
708




709
710

711
712
713
714

715
716
717
718


719
720
721
722

723

724
725
726
727
728
729

730





731
732
733

734
735
736
737
738
739
740
741
742

743
744
745

746
747
748
749
750
751

752


753
754


755
756
757
758
759
760
761
762
763
764


765


766

767
768
769
770


771
772
773

774
775
776
777
778
779
780
781
782
783
784
785

786







787
788
789

790
791
792
793
794
795
796
797
798
799
800
801
802

803
804
805
806
807
808
809
810





811
812
813
814
815
816

817
818
819
820
821
822
823
824


825
826
827
828
829


830
831



832
833
834
835
836
837
838
839
840
841
842


843
844
845
846
847
848
849
850
851
852
853
854
855
856

857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
    }
    Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TcpBlockModeProc --
 *
 *	This function is invoked by the generic IO level to set blocking and
 *	nonblocking mode on a TCP socket based channel.

 *
 * Results:


 *	0 if successful, errno when failed.
 *
 * Side effects:


 *	Sets the device into blocking or nonblocking mode.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
TcpBlockModeProc(
    ClientData instanceData,	/* Socket state. */


    int mode)			/* The mode to set. Can be one of
				 * TCL_MODE_BLOCKING or
				 * TCL_MODE_NONBLOCKING. */
{



    TcpState *statePtr = instanceData;

    if (mode == TCL_MODE_NONBLOCKING) {
	statePtr->flags |= TCP_NONBLOCKING;
    } else {



	statePtr->flags &= ~(TCP_NONBLOCKING);
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * WaitForConnect --
 *
 *	Check the state of an async connect process. If a connection
 *	attempt terminated, process it, which may finalize it or may





 *	start the next attempt. If a connect error occures, it is saved
 *	in statePtr->connectError to be reported by 'fconfigure -error'.
 *


 *	There are two modes of operation, defined by errorCodePtr:








 *	 *  non-NULL: Called by explicite read/write command. block if

 *	    socket is blocking.
 *	    May return two error codes:

 *	     *	EWOULDBLOCK: if connect is still in progress



 *	     *	ENOTCONN: if connect failed. This would be the error










 *		message of a rect or sendto syscall so this is
 *		emulated here.




 *	 *  Null: Called by a backround operation. Do not block and



 *	    don't return any error code.



 *














































 * Results:

 * 	0 if the connection has completed, -1 if still in progress

 * 	or there is an error.
 *
 * Side effects:

 *	Processes socket events off the system queue.
 *	May process asynchroneous connect.
 *
 *----------------------------------------------------------------------
 */

static int
WaitForConnect(
    TcpState *statePtr,		/* State of the socket. */
    int *errorCodePtr)		/* Where to store errors?
				 * A passed null-pointer activates background mode.
				 */
{
    int result;
    int oldMode;
    ThreadSpecificData *tsdPtr;

    /*
     * Check if an async connect failed already and error reporting is demanded,
     * return the error ENOTCONN
     */

    if (errorCodePtr != NULL && (statePtr->flags & TCP_ASYNC_FAILED)) {
	*errorCodePtr = ENOTCONN;
	return -1;
    }

    /*
     * Check if an async connect is running. If not return ok
     */
     
    if (!(statePtr->flags & TCP_ASYNC_CONNECT)) {
	return 0;
    }

    /*
     * Be sure to disable event servicing so we are truly modal.
     */

    oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE);

    /*
     * Loop in the blocking case until the connect signal is present
     */

    while (1) {

	/* get statePtr lock */
        tsdPtr = TclThreadDataKeyGet(&dataKey);
	WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
	
	/* Check for connect event */
	if (statePtr->readyEvents & FD_CONNECT) {

	    /* Consume the connect event */
	    statePtr->readyEvents &= ~(FD_CONNECT);

	    /*
	     * For blocking sockets and foreground processing
	     * disable async connect as we continue now synchoneously
	     */
	    if ( errorCodePtr != NULL &&
		    ! (statePtr->flags & TCP_NONBLOCKING) ) {
		CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
	    }

	    /* Free list lock */
	    SetEvent(tsdPtr->socketListLock);

	    /*
	     * Continue connect.
	     * If switched to synchroneous connect, the connect is terminated.
	     */
	    result = TcpConnect(NULL, statePtr);

	    /* Restore event service mode */
	    (void) Tcl_SetServiceMode(oldMode);

	    /*
	     * Check for Succesfull connect or async connect restart
	     */

	    if (result == TCL_OK) {
		/*
		 * Check for async connect restart
		 * (not possible for foreground blocking operation)
		 */
		if ( statePtr->flags & TCP_ASYNC_PENDING ) {
		    if (errorCodePtr != NULL) {
			*errorCodePtr = EWOULDBLOCK;
		    }
		    return -1;
		}
		return 0;
	    }

	    /*
	     * Connect finally failed.
	     * For foreground operation return ENOTCONN.
	     */

	    if (errorCodePtr != NULL) {
		*errorCodePtr = ENOTCONN;
	    }
	    return -1;
	}

        /* Free list lock */
        SetEvent(tsdPtr->socketListLock);


	/*
	 * Background operation returns with no action as there was no connect
	 * event

	 */




	if ( errorCodePtr == NULL ) {
	    return -1;
	}

	/*
	 * A non blocking socket waiting for an asyncronous connect
	 * returns directly the error EWOULDBLOCK
	 */

	if (statePtr->flags & TCP_NONBLOCKING) {
	    *errorCodePtr = EWOULDBLOCK;
	    return -1;
	}

	/*
	 * Wait until something happens.
	 */

	WaitForSingleObject(tsdPtr->readyEvent, INFINITE);




    }
}

/*


 *----------------------------------------------------------------------
 *




 * TcpInputProc --
 *

 *	This function is invoked by the generic IO level to read input from a
 *	TCP socket based channel.
 *
 * Results:

 *	The number of bytes read is returned or -1 on error. An output
 *	argument contains the POSIX error code on error, or zero if no error
 *	occurred.
 *


 * Side effects:
 *	Reads input from the input device of the channel.
 *
 *----------------------------------------------------------------------

 */


	/* ARGSUSED */
static int
TcpInputProc(
    ClientData instanceData,	/* Socket state. */
    char *buf,			/* Where to store data read. */

    int bufSize,		/* How much space is available in the





				 * buffer? */
    int *errorCodePtr)		/* Where to store error code. */
{

    TcpState *statePtr = instanceData;
    int bytesRead;
    DWORD error;
    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);

    *errorCodePtr = 0;

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent

     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.
     */


    if (!SocketsEnabled()) {
	*errorCodePtr = EFAULT;
	return -1;
    }


    /*


     * First check to see if EOF was already detected, to prevent calling the
     * socket stack after the first time EOF is detected.


     */

    if (statePtr->flags & SOCKET_EOF) {
	return 0;
    }

    /*
     * Check if there is an async connect running.
     * For blocking sockets terminate connect, otherwise do one step.
     * For a non blocking socket return EWOULDBLOCK if connect not terminated


     */




    if (WaitForConnect(statePtr, errorCodePtr) != 0) {
	return -1;
    }



    /*
     * No EOF, and it is connected, so try to read more from the socket. Note
     * that we clear the FD_READ bit because read events are level triggered

     * so a new event will be generated if there is still data available to be
     * read. We have to simulate blocking behavior here since we are always
     * using non-blocking sockets.
     */

    while (1) {
	SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
		(WPARAM) UNSELECT, (LPARAM) statePtr);
	/* single fd operation: this proc is only called for a connected socket. */
	bytesRead = recv(statePtr->sockets->fd, buf, bufSize, 0);
	statePtr->readyEvents &= ~(FD_READ);


	/*







	 * Check for end-of-file condition or successful read.
	 */


	if (bytesRead == 0) {
	    statePtr->flags |= SOCKET_EOF;
	}
	if (bytesRead != SOCKET_ERROR) {
	    break;
	}

	/*
	 * If an error occurs after the FD_CLOSE has arrived, then ignore the
	 * error and report an EOF.
	 */

	if (statePtr->readyEvents & FD_CLOSE) {

	    statePtr->flags |= SOCKET_EOF;
	    bytesRead = 0;
	    break;
	}

	error = WSAGetLastError();

	/*





	 * If an RST comes, then ignore the error and report an EOF just like
	 * on unix.
	 */

	if (error == WSAECONNRESET) {
	    statePtr->flags |= SOCKET_EOF;

	    bytesRead = 0;
	    break;
	}

	/*
	 * Check for error condition or underflow in non-blocking case.
	 */



	if ((statePtr->flags & TCP_NONBLOCKING) || (error != WSAEWOULDBLOCK)) {
	    TclWinConvertError(error);
	    *errorCodePtr = Tcl_GetErrno();
	    bytesRead = -1;
	    break;


	}




	/*
	 * In the blocking case, wait until the file becomes readable or
	 * closed and try again.
	 */

	if (!WaitForSocketEvent(statePtr, FD_READ|FD_CLOSE, errorCodePtr)) {
	    bytesRead = -1;
	    break;
	}
    }



    SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr);

    return bytesRead;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpOutputProc --
 *
 *	This function is called by the generic IO level to write data to a
 *	socket based channel.
 *
 * Results:

 *	The number of bytes written or -1 on failure.
 *
 * Side effects:
 *	Produces output on the socket.
 *
 *----------------------------------------------------------------------
 */

static int
TcpOutputProc(
    ClientData instanceData,	/* Socket state. */
    const char *buf,		/* The data buffer. */
    int toWrite,		/* How many bytes to write? */
    int *errorCodePtr)		/* Where to store error code. */
{
    TcpState *statePtr = instanceData;
    int written;
    DWORD error;
    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);

    *errorCodePtr = 0;

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.
     */

    if (!SocketsEnabled()) {
	*errorCodePtr = EFAULT;
	return -1;
    }

    /*
     * Check if there is an async connect running.
     * For blocking sockets terminate connect, otherwise do one step.
     * For a non blocking socket return EWOULDBLOCK if connect not terminated
     */

    if (WaitForConnect(statePtr, errorCodePtr) != 0) {
	return -1;
    }

    while (1) {
	SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
		(WPARAM) UNSELECT, (LPARAM) statePtr);

	/* single fd operation: this proc is only called for a connected socket. */
	written = send(statePtr->sockets->fd, buf, toWrite, 0);
	if (written != SOCKET_ERROR) {
	    /*
	     * Since Windows won't generate a new write event until we hit an
	     * overflow condition, we need to force the event loop to poll
	     * until the condition changes.
	     */

	    if (statePtr->watchEvents & FD_WRITE) {
		Tcl_Time blockTime = { 0, 0 };
		Tcl_SetMaxBlockTime(&blockTime);
	    }
	    break;
	}

	/*
	 * Check for error condition or overflow. In the event of overflow, we
	 * need to clear the FD_WRITE flag so we can detect the next writable
	 * event. Note that Windows only sends a new writable event after a
	 * send fails with WSAEWOULDBLOCK.
	 */

	error = WSAGetLastError();
	if (error == WSAEWOULDBLOCK) {
	    statePtr->readyEvents &= ~(FD_WRITE);
	    if (statePtr->flags & TCP_NONBLOCKING) {
		*errorCodePtr = EWOULDBLOCK;
		written = -1;
		break;
	    }
	} else {
	    TclWinConvertError(error);
	    *errorCodePtr = Tcl_GetErrno();
	    written = -1;
	    break;
	}

	/*
	 * In the blocking case, wait until the file becomes writable or
	 * closed and try again.
	 */

	if (!WaitForSocketEvent(statePtr, FD_WRITE|FD_CLOSE, errorCodePtr)) {
	    written = -1;
	    break;
	}
    }

    SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr);

    return written;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpCloseProc --
 *
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
























942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957

    /* ARGSUSED */
static int
TcpCloseProc(
    ClientData instanceData,	/* The socket to close. */
    Tcl_Interp *interp)		/* Unused. */
{
    SocketInfo *infoPtr = instanceData;
    /* TIP #218 */
    int errorCode = 0;
    /* ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); */

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.
     */

    if (SocketsEnabled()) {
	/*
	 * Clean up the OS socket handle. The default Windows setting for a
	 * socket is SO_DONTLINGER, which does a graceful shutdown in the
	 * background.
	 */

	while ( infoPtr->sockets != NULL ) {
	    TcpFdList *thisfd = infoPtr->sockets;
	    infoPtr->sockets = thisfd->next;

	    if (closesocket(thisfd->fd) == SOCKET_ERROR) {
		TclWinConvertError((DWORD) WSAGetLastError());
		errorCode = Tcl_GetErrno();
	    }
	    ckfree(thisfd);
	}
    }

























    /*
     * TIP #218. Removed the code removing the structure from the global
     * socket list. This is now done by the thread action callbacks, and only
     * there. This happens before this code is called. We can free without
     * fear of damaging the list.
     */

    ckfree(infoPtr);
    return errorCode;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpClose2Proc --







|


|














|
|
|








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








|







975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050

    /* ARGSUSED */
static int
TcpCloseProc(
    ClientData instanceData,	/* The socket to close. */
    Tcl_Interp *interp)		/* Unused. */
{
    TcpState *statePtr = instanceData;
    /* TIP #218 */
    int errorCode = 0;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.
     */

    if (SocketsEnabled()) {
	/*
	 * Clean up the OS socket handle. The default Windows setting for a
	 * socket is SO_DONTLINGER, which does a graceful shutdown in the
	 * background.
	 */

	while ( statePtr->sockets != NULL ) {
	    TcpFdList *thisfd = statePtr->sockets;
	    statePtr->sockets = thisfd->next;

	    if (closesocket(thisfd->fd) == SOCKET_ERROR) {
		TclWinConvertError((DWORD) WSAGetLastError());
		errorCode = Tcl_GetErrno();
	    }
	    ckfree(thisfd);
	}
    }

    if (statePtr->addrlist != NULL) {
        freeaddrinfo(statePtr->addrlist);
    }
    if (statePtr->myaddrlist != NULL) {
        freeaddrinfo(statePtr->myaddrlist);
    }

    /*
     * Clear an eventual tsd info list pointer.
     * This may be called, if an async socket connect fails or is closed
     * between connect and thread action callback.
     */
    if (tsdPtr->pendingTcpState != NULL
	    && tsdPtr->pendingTcpState == statePtr) {

	/* get infoPtr lock, because this concerns the notifier thread */
	WaitForSingleObject(tsdPtr->socketListLock, INFINITE);

	tsdPtr->pendingTcpState = NULL;

	/* Free list lock */
	SetEvent(tsdPtr->socketListLock);
    }

    /*
     * TIP #218. Removed the code removing the structure from the global
     * socket list. This is now done by the thread action callbacks, and only
     * there. This happens before this code is called. We can free without
     * fear of damaging the list.
     */

    ckfree(statePtr);
    return errorCode;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpClose2Proc --
970
971
972
973
974
975
976
977
978

979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961

static int
TcpClose2Proc(
    ClientData instanceData,	/* The socket to close. */
    Tcl_Interp *interp,		/* For error reporting. */
    int flags)			/* Flags that indicate which side to close. */
{
    SocketInfo *infoPtr = instanceData;
    int errorCode = 0, sd;


    /*
     * Shutdown the OS socket handle.
     */

    switch (flags) {
    case TCL_CLOSE_READ:
	sd = SD_RECEIVE;
	break;
    case TCL_CLOSE_WRITE:
	sd = SD_SEND;
	break;
    default:
	if (interp) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "Socket close2proc called bidirectionally", -1));
	}
	return TCL_ERROR;
    }

    /* single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or
     * TCL_WRITABLE so this should never be called for a server socket. */
    if (shutdown(infoPtr->sockets->fd, sd) == SOCKET_ERROR) {
	TclWinConvertError((DWORD) WSAGetLastError());
	errorCode = Tcl_GetErrno();
    }

    return errorCode;
}

/*
 *----------------------------------------------------------------------
 *
 * AddSocketInfoFd --
 *
 *	This function adds a SOCKET file descriptor to the 'sockets' linked 
 *	list of a SocketInfo structure.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None, except for allocation of memory.
 *
 *----------------------------------------------------------------------
 */

static void
AddSocketInfoFd(
    SocketInfo *infoPtr, 
    SOCKET socket)
{
    TcpFdList *fds = infoPtr->sockets;

    if ( fds == NULL ) {
	/* Add the first FD */
	infoPtr->sockets = ckalloc(sizeof(TcpFdList));
	fds = infoPtr->sockets;
    } else {
	/* Find end of list and append FD */
	while ( fds->next != NULL ) {
	    fds = fds->next;
	}
    
	fds->next = ckalloc(sizeof(TcpFdList));
	fds = fds->next;
    }

    /* Populate new FD */
    fds->fd = socket;
    fds->infoPtr = infoPtr;
    fds->next = NULL;
}

    
/*
 *----------------------------------------------------------------------
 *
 * NewSocketInfo --
 *
 *	This function allocates and initializes a new SocketInfo structure.
 *
 * Results:
 *	Returns a newly allocated SocketInfo.
 *
 * Side effects:
 *	None, except for allocation of memory.
 *
 *----------------------------------------------------------------------
 */

static SocketInfo *
NewSocketInfo(
    SOCKET socket)
{
    SocketInfo *infoPtr = ckalloc(sizeof(SocketInfo));

    /* ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); */
    infoPtr->channel = 0;
    infoPtr->sockets = NULL;
    infoPtr->flags = 0;
    infoPtr->watchEvents = 0;
    infoPtr->readyEvents = 0;
    infoPtr->selectEvents = 0;
    infoPtr->acceptEventCount = 0;
    infoPtr->acceptProc = NULL;
    infoPtr->acceptProcData = NULL;
    infoPtr->lastError = 0;

    /*
     * TIP #218. Removed the code inserting the new structure into the global
     * list. This is now handled in the thread action callbacks, and only
     * there.
     */

    infoPtr->nextPtr = NULL;

    AddSocketInfoFd(infoPtr, socket);

    return infoPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * CreateSocket --
 *
 *	This function opens a new socket and initializes the SocketInfo
 *	structure.
 *
 * Results:
 *	Returns a new SocketInfo, or NULL with an error in interp.
 *
 * Side effects:
 *	None, except for allocation of memory.
 *
 *----------------------------------------------------------------------
 */

static SocketInfo *
CreateSocket(
    Tcl_Interp *interp,		/* For error reporting; can be NULL. */
    int port,			/* Port number to open. */
    const char *host,		/* Name of host on which to open port. */
    int server,			/* 1 if socket should be a server socket, else
				 * 0 for a client socket. */
    const char *myaddr,		/* Optional client-side address */
    int myport,			/* Optional client-side port */
    int async)			/* If nonzero, connect client socket
				 * asynchronously. */
{
    u_long flag = 1;		/* Indicates nonblocking mode. */
    int asyncConnect = 0;	/* Will be 1 if async connect is in
				 * progress. */
    unsigned short chosenport = 0;
    struct addrinfo *addrlist = NULL, *addrPtr;
				/* Socket address to connect to. */
    struct addrinfo *myaddrlist = NULL, *myaddrPtr;
				/* Socket address for our side. */
    const char *errorMsg = NULL;
    SOCKET sock = INVALID_SOCKET;
    SocketInfo *infoPtr = NULL;	/* The returned value. */
    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.
     */

    if (!SocketsEnabled()) {
	return NULL;
    }

    /*
     * Construct the addresses for each end of the socket.
     */

    if (!TclCreateSocketAddress(interp, &addrlist, host, port, server,
	    &errorMsg)) {
	goto error;
    }
    if (!TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1,
	    &errorMsg)) {
	goto error;
    }

    if (server) {

	for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) {
	    sock = socket(addrPtr->ai_family, SOCK_STREAM, 0);
	    if (sock == INVALID_SOCKET) {
		TclWinConvertError((DWORD) WSAGetLastError());
		continue;
	    }

	    /*
	     * Win-NT has a misfeature that sockets are inherited in child
	     * processes by default. Turn off the inherit bit.
	     */

	    SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0);

	    /*
	     * Set kernel space buffering
	     */

	    TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE);

	    /*
	     * Make sure we use the same port when opening two server sockets
	     * for IPv4 and IPv6.
	     *
	     * As sockaddr_in6 uses the same offset and size for the port
	     * member as sockaddr_in, we can handle both through the IPv4 API.
	     */

	    if (port == 0 && chosenport != 0) {
		((struct sockaddr_in *) addrPtr->ai_addr)->sin_port =
			htons(chosenport);
	    }

	    /*
	     * Bind to the specified port. Note that we must not call
	     * setsockopt with SO_REUSEADDR because Microsoft allows addresses
	     * to be reused even if they are still in use.
	     *
	     * Bind should not be affected by the socket having already been
	     * set into nonblocking mode. If there is trouble, this is one
	     * place to look for bugs.
	     */

	    if (bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen)
		    == SOCKET_ERROR) {
		TclWinConvertError((DWORD) WSAGetLastError());
		closesocket(sock);
		continue;
	    }
	    if (port == 0 && chosenport == 0) {
		address sockname;
		socklen_t namelen = sizeof(sockname);

		/*
		 * Synchronize port numbers when binding to port 0 of multiple
		 * addresses.
		 */

		if (getsockname(sock, &sockname.sa, &namelen) >= 0) {
		    chosenport = ntohs(sockname.sa4.sin_port);
		}
	    }

	    /*
	     * Set the maximum number of pending connect requests to the max
	     * value allowed on each platform (Win32 and Win32s may be
	     * different, and there may be differences between TCP/IP stacks).
	     */

	    if (listen(sock, SOMAXCONN) == SOCKET_ERROR) {
		TclWinConvertError((DWORD) WSAGetLastError());
		closesocket(sock);
		continue;
	    }

	    if (infoPtr == NULL) {
		/*
		 * Add this socket to the global list of sockets.
		 */

		infoPtr = NewSocketInfo(sock);

		/*
		 * Set up the select mask for connection request events.
		 */

		infoPtr->selectEvents = FD_ACCEPT;
		infoPtr->watchEvents |= FD_ACCEPT;

	    } else {
		AddSocketInfoFd( infoPtr, sock );
	    }
	}
    } else {
	for (addrPtr = addrlist; addrPtr != NULL;
		addrPtr = addrPtr->ai_next) {
	    for (myaddrPtr = myaddrlist; myaddrPtr != NULL;
		    myaddrPtr = myaddrPtr->ai_next) {
		/*
		 * No need to try combinations of local and remote addresses
		 * of different families.
		 */

		if (myaddrPtr->ai_family != addrPtr->ai_family) {
		    continue;
		}

		sock = socket(myaddrPtr->ai_family, SOCK_STREAM, 0);
		if (sock == INVALID_SOCKET) {
		    TclWinConvertError((DWORD) WSAGetLastError());
		    continue;
		}

		/*
		 * Win-NT has a misfeature that sockets are inherited in child
		 * processes by default. Turn off the inherit bit.
		 */

		SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0);

		/*
		 * Set kernel space buffering
		 */

		TclSockMinimumBuffers((void *) sock, TCP_BUFFER_SIZE);

		/*
		 * Try to bind to a local port.
		 */

		if (bind(sock, myaddrPtr->ai_addr, myaddrPtr->ai_addrlen)
			== SOCKET_ERROR) {
		    TclWinConvertError((DWORD) WSAGetLastError());
		    goto looperror;
		}
		/*
		 * Set the socket into nonblocking mode if the connect should
		 * be done in the background.
		 */
		if (async && ioctlsocket(sock, (long) FIONBIO, &flag)
			== SOCKET_ERROR) {
		    TclWinConvertError((DWORD) WSAGetLastError());
		    goto looperror;
		}

		/*
		 * Attempt to connect to the remote socket.
		 */

		if (connect(sock, addrPtr->ai_addr, addrPtr->ai_addrlen)
			== SOCKET_ERROR) {
		    DWORD error = (DWORD) WSAGetLastError();
		    if (error != WSAEWOULDBLOCK) {
			TclWinConvertError(error);
			goto looperror;
		    }

		    /*
		     * The connection is progressing in the background.
		     */

		    asyncConnect = 1;
		}
		goto connected;

	    looperror:
		if (sock != INVALID_SOCKET) {
		    closesocket(sock);
		    sock = INVALID_SOCKET;
		}
	    }
	}
	goto error;

    connected:
	/*
	 * Add this socket to the global list of sockets.
	 */

	infoPtr = NewSocketInfo(sock);

	/*
	 * Set up the select mask for read/write events. If the connect
	 * attempt has not completed, include connect events.
	 */

	infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE;
	if (asyncConnect) {
	    infoPtr->flags |= SOCKET_ASYNC_CONNECT;
	    infoPtr->selectEvents |= FD_CONNECT;
	}
    }

  error:
    if (addrlist != NULL) {
	freeaddrinfo(addrlist);
    }
    if (myaddrlist != NULL) {
	freeaddrinfo(myaddrlist);
    }

    /*
     * Register for interest in events in the select mask. Note that this
     * automatically places the socket into non-blocking mode.
     */

    if (infoPtr != NULL) {
	ioctlsocket(sock, (long) FIONBIO, &flag);
	SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
		(LPARAM) infoPtr);

	return infoPtr;
    }

    if (interp != NULL) {
        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"couldn't open socket: %s",
		(errorMsg ? errorMsg : Tcl_PosixError(interp))));
    }

    if (sock != INVALID_SOCKET) {
	closesocket(sock);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * WaitForSocketEvent --
 *
 *	Waits until one of the specified events occurs on a socket.
 *
 * Results:
 *	Returns 1 on success or 0 on failure, with an error code in
 *	errorCodePtr.
 *
 * Side effects:
 *	Processes socket events off the system queue.
 *
 *----------------------------------------------------------------------
 */

static int
WaitForSocketEvent(
    SocketInfo *infoPtr,	/* Information about this socket. */
    int events,			/* Events to look for. */
    int *errorCodePtr)		/* Where to store errors? */
{
    int result = 1;
    int oldMode;
    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);

    /*
     * Be sure to disable event servicing so we are truly modal.
     */

    oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE);

    /*
     * Reset WSAAsyncSelect so we have a fresh set of events pending.
     */

    SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT,
	    (LPARAM) infoPtr);
    SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
	    (LPARAM) infoPtr);

    while (1) {
	if (infoPtr->lastError) {
	    *errorCodePtr = infoPtr->lastError;
	    result = 0;
	    break;
	} else if (infoPtr->readyEvents & events) {
	    break;
	} else if (infoPtr->flags & SOCKET_ASYNC) {
	    *errorCodePtr = EWOULDBLOCK;
	    result = 0;
	    break;
	}

	/*
	 * Wait until something happens.
	 */

	WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
    }

    (void) Tcl_SetServiceMode(oldMode);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_OpenTcpClient --
 *
 *	Opens a TCP client socket and creates a channel around it.
 *
 * Results:
 *	The channel or NULL if failed. An error message is returned in the
 *	interpreter on failure.
 *
 * Side effects:
 *	Opens a client socket and creates a new channel.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_OpenTcpClient(
    Tcl_Interp *interp,		/* For error reporting; can be NULL. */
    int port,			/* Port number to open. */
    const char *host,		/* Host on which to open port. */
    const char *myaddr,		/* Client-side address */
    int myport,			/* Client-side port */
    int async)			/* If nonzero, should connect client socket
				 * asynchronously. */
{
    SocketInfo *infoPtr;
    char channelName[16 + TCL_INTEGER_SPACE];

    if (TclpHasSockets(interp) != TCL_OK) {
	return NULL;
    }

    /*
     * Create a new client socket and wrap it in a channel.
     */

    infoPtr = CreateSocket(interp, port, host, 0, myaddr, myport, async);
    if (infoPtr == NULL) {
	return NULL;
    }

    sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd);

    infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
	    infoPtr, (TCL_READABLE | TCL_WRITABLE));
    if (TCL_ERROR == Tcl_SetChannelOption(NULL, infoPtr->channel,
	    "-translation", "auto crlf")) {
	Tcl_Close(NULL, infoPtr->channel);
	return NULL;
    } else if (TCL_ERROR == Tcl_SetChannelOption(NULL, infoPtr->channel,
	    "-eofchar", "")) {
	Tcl_Close(NULL, infoPtr->channel);
	return NULL;
    }
    return infoPtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MakeTcpClientChannel --
 *
 *	Creates a Tcl_Channel from an existing client TCP socket.
 *
 * Results:
 *	The Tcl_Channel wrapped around the preexisting TCP socket.
 *
 * Side effects:
 *	None.
 *
 * NOTE: Code contributed by Mark Diekhans (markd@grizzly.com)
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_MakeTcpClientChannel(
    ClientData sock)		/* The socket to wrap up into a channel. */
{
    SocketInfo *infoPtr;
    char channelName[16 + TCL_INTEGER_SPACE];
    ThreadSpecificData *tsdPtr;

    if (TclpHasSockets(NULL) != TCL_OK) {
	return NULL;
    }

    tsdPtr = TclThreadDataKeyGet(&dataKey);

    /*
     * Set kernel space buffering and non-blocking.
     */

    TclSockMinimumBuffers(sock, TCP_BUFFER_SIZE);

    infoPtr = NewSocketInfo((SOCKET) sock);

    /*
     * Start watching for read/write events on the socket.
     */

    infoPtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE;
    SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr);

    sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd);
    infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
	    infoPtr, (TCL_READABLE | TCL_WRITABLE));
    Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto crlf");
    return infoPtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_OpenTcpServer --
 *
 *	Opens a TCP server socket and creates a channel around it.
 *
 * Results:
 *	The channel or NULL if failed. An error message is returned in the
 *	interpreter on failure.
 *
 * Side effects:
 *	Opens a server socket and creates a new channel.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_OpenTcpServer(
    Tcl_Interp *interp,		/* For error reporting - may be NULL. */
    int port,			/* Port number to open. */
    const char *host,		/* Name of local host. */
    Tcl_TcpAcceptProc *acceptProc,
				/* Callback for accepting connections from new
				 * clients. */
    ClientData acceptProcData)	/* Data for the callback. */
{
    SocketInfo *infoPtr;
    char channelName[16 + TCL_INTEGER_SPACE];

    if (TclpHasSockets(interp) != TCL_OK) {
	return NULL;
    }

    /*
     * Create a new client socket and wrap it in a channel.
     */

    infoPtr = CreateSocket(interp, port, host, 1, NULL, 0, 0);
    if (infoPtr == NULL) {
	return NULL;
    }

    infoPtr->acceptProc = acceptProc;
    infoPtr->acceptProcData = acceptProcData;

    sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd);

    infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
	    infoPtr, 0);
    if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "")
	    == TCL_ERROR) {
	Tcl_Close(NULL, infoPtr->channel);
	return NULL;
    }

    return infoPtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpAccept --
 *
 *	Creates a channel for a newly accepted socket connection. This is 
 *	called by SocketEventProc and it in turns calls the registered 
 *	accept function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Invokes the accept proc which may invoke arbitrary Tcl code.
 *
 *----------------------------------------------------------------------
 */

static void
TcpAccept(
    TcpFdList *fds,	/* Server socket that accepted newSocket. */
    SOCKET newSocket,   /* Newly accepted socket. */
    address addr)       /* Address of new socket. */
{
    SocketInfo *newInfoPtr;
    SocketInfo *infoPtr = fds->infoPtr;
    int len = sizeof(addr);
    char channelName[16 + TCL_INTEGER_SPACE];
    char host[NI_MAXHOST], port[NI_MAXSERV];
    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);

    /*
     * Win-NT has a misfeature that sockets are inherited in child processes
     * by default. Turn off the inherit bit.
     */

    SetHandleInformation((HANDLE) newSocket, HANDLE_FLAG_INHERIT, 0);

    /*
     * Add this socket to the global list of sockets.
     */

    newInfoPtr = NewSocketInfo(newSocket);

    /*
     * Select on read/write events and create the channel.
     */

    newInfoPtr->selectEvents = (FD_READ | FD_WRITE | FD_CLOSE);
    SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
	    (LPARAM) newInfoPtr);

    sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) newInfoPtr->sockets->fd);
    newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
	    newInfoPtr, (TCL_READABLE | TCL_WRITABLE));
    if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation",
	    "auto crlf") == TCL_ERROR) {
	Tcl_Close(NULL, newInfoPtr->channel);
	return;
    }
    if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-eofchar", "")
	    == TCL_ERROR) {
	Tcl_Close(NULL, newInfoPtr->channel);
	return;
    }

    /*
     * Invoke the accept callback function.
     */

    if (infoPtr->acceptProc != NULL) {
	getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port),
                    NI_NUMERICHOST|NI_NUMERICSERV);
	infoPtr->acceptProc(infoPtr->acceptProcData, newInfoPtr->channel,
			    host, atoi(port));
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TcpInputProc --
 *
 *	This function is called by the generic IO level to read data from a
 *	socket based channel.
 *
 * Results:
 *	The number of bytes read or -1 on error.
 *
 * Side effects:
 *	Consumes input from the socket.
 *
 *----------------------------------------------------------------------
 */

static int
TcpInputProc(
    ClientData instanceData,	/* The socket state. */
    char *buf,			/* Where to store data. */
    int toRead,			/* Maximum number of bytes to read. */
    int *errorCodePtr)		/* Where to store error codes. */
{
    SocketInfo *infoPtr = instanceData;
    int bytesRead;
    DWORD error;
    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);

    *errorCodePtr = 0;

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.
     */

    if (!SocketsEnabled()) {
	*errorCodePtr = EFAULT;
	return -1;
    }

    /*
     * First check to see if EOF was already detected, to prevent calling the
     * socket stack after the first time EOF is detected.
     */

    if (infoPtr->flags & SOCKET_EOF) {
	return 0;
    }

    /*
     * Check to see if the socket is connected before trying to read.
     */

    if ((infoPtr->flags & SOCKET_ASYNC_CONNECT)
	    && !WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) {
	return -1;
    }

    /*
     * No EOF, and it is connected, so try to read more from the socket. Note
     * that we clear the FD_READ bit because read events are level triggered
     * so a new event will be generated if there is still data available to be
     * read. We have to simulate blocking behavior here since we are always
     * using non-blocking sockets.
     */

    while (1) {
	SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
		(WPARAM) UNSELECT, (LPARAM) infoPtr);
	/* single fd operation: this proc is only called for a connected socket. */
	bytesRead = recv(infoPtr->sockets->fd, buf, toRead, 0);
	infoPtr->readyEvents &= ~(FD_READ);

	/*
	 * Check for end-of-file condition or successful read.
	 */

	if (bytesRead == 0) {
	    infoPtr->flags |= SOCKET_EOF;
	}
	if (bytesRead != SOCKET_ERROR) {
	    break;
	}

	/*
	 * If an error occurs after the FD_CLOSE has arrived, then ignore the
	 * error and report an EOF.
	 */

	if (infoPtr->readyEvents & FD_CLOSE) {
	    infoPtr->flags |= SOCKET_EOF;
	    bytesRead = 0;
	    break;
	}

	error = WSAGetLastError();

	/*
	 * If an RST comes, then ignore the error and report an EOF just like
	 * on unix.
	 */

	if (error == WSAECONNRESET) {
	    infoPtr->flags |= SOCKET_EOF;
	    bytesRead = 0;
	    break;
	}

	/*
	 * Check for error condition or underflow in non-blocking case.
	 */

	if ((infoPtr->flags & SOCKET_ASYNC) || (error != WSAEWOULDBLOCK)) {
	    TclWinConvertError(error);
	    *errorCodePtr = Tcl_GetErrno();
	    bytesRead = -1;
	    break;
	}

	/*
	 * In the blocking case, wait until the file becomes readable or
	 * closed and try again.
	 */

	if (!WaitForSocketEvent(infoPtr, FD_READ|FD_CLOSE, errorCodePtr)) {
	    bytesRead = -1;
	    break;
	}
    }

    SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr);

    return bytesRead;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpOutputProc --
 *
 *	This function is called by the generic IO level to write data to a
 *	socket based channel.
 *
 * Results:
 *	The number of bytes written or -1 on failure.
 *
 * Side effects:
 *	Produces output on the socket.
 *
 *----------------------------------------------------------------------
 */

static int
TcpOutputProc(
    ClientData instanceData,	/* The socket state. */
    const char *buf,		/* Where to get data. */
    int toWrite,		/* Maximum number of bytes to write. */
    int *errorCodePtr)		/* Where to store error codes. */
{
    SocketInfo *infoPtr = instanceData;
    int bytesWritten;
    DWORD error;
    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);

    *errorCodePtr = 0;

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.
     */

    if (!SocketsEnabled()) {
	*errorCodePtr = EFAULT;
	return -1;
    }

    /*
     * Check to see if the socket is connected before trying to write.
     */

    if ((infoPtr->flags & SOCKET_ASYNC_CONNECT)
	    && !WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) {
	return -1;
    }

    while (1) {
	SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
		(WPARAM) UNSELECT, (LPARAM) infoPtr);

	/* single fd operation: this proc is only called for a connected socket. */
	bytesWritten = send(infoPtr->sockets->fd, buf, toWrite, 0);
	if (bytesWritten != SOCKET_ERROR) {
	    /*
	     * Since Windows won't generate a new write event until we hit an
	     * overflow condition, we need to force the event loop to poll
	     * until the condition changes.
	     */

	    if (infoPtr->watchEvents & FD_WRITE) {
		Tcl_Time blockTime = { 0, 0 };
		Tcl_SetMaxBlockTime(&blockTime);
	    }
	    break;
	}

	/*
	 * Check for error condition or overflow. In the event of overflow, we
	 * need to clear the FD_WRITE flag so we can detect the next writable
	 * event. Note that Windows only sends a new writable event after a
	 * send fails with WSAEWOULDBLOCK.
	 */

	error = WSAGetLastError();
	if (error == WSAEWOULDBLOCK) {
	    infoPtr->readyEvents &= ~(FD_WRITE);
	    if (infoPtr->flags & SOCKET_ASYNC) {
		*errorCodePtr = EWOULDBLOCK;
		bytesWritten = -1;
		break;
	    }
	} else {
	    TclWinConvertError(error);
	    *errorCodePtr = Tcl_GetErrno();
	    bytesWritten = -1;
	    break;
	}

	/*
	 * In the blocking case, wait until the file becomes writable or
	 * closed and try again.
	 */

	if (!WaitForSocketEvent(infoPtr, FD_WRITE|FD_CLOSE, errorCodePtr)) {
	    bytesWritten = -1;
	    break;
	}
    }

    SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr);

    return bytesWritten;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpSetOptionProc --
 *
 *	Sets Tcp channel specific options.







|
|
>





|









|






|






<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101



















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































1102
1103
1104
1105
1106
1107
1108

static int
TcpClose2Proc(
    ClientData instanceData,	/* The socket to close. */
    Tcl_Interp *interp,		/* For error reporting. */
    int flags)			/* Flags that indicate which side to close. */
{
    TcpState *statePtr = instanceData;
    int errorCode = 0;
    int sd;

    /*
     * Shutdown the OS socket handle.
     */

    switch(flags) {
    case TCL_CLOSE_READ:
	sd = SD_RECEIVE;
	break;
    case TCL_CLOSE_WRITE:
	sd = SD_SEND;
	break;
    default:
	if (interp) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "socket close2proc called bidirectionally", -1));
	}
	return TCL_ERROR;
    }

    /* single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or
     * TCL_WRITABLE so this should never be called for a server socket. */
    if (shutdown(statePtr->sockets->fd, sd) == SOCKET_ERROR) {
	TclWinConvertError((DWORD) WSAGetLastError());
	errorCode = Tcl_GetErrno();
    }

    return errorCode;
}




















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































/*
 *----------------------------------------------------------------------
 *
 * TcpSetOptionProc --
 *
 *	Sets Tcp channel specific options.
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
TcpSetOptionProc(
    ClientData instanceData,	/* Socket state. */
    Tcl_Interp *interp,		/* For error reporting - can be NULL. */
    const char *optionName,	/* Name of the option to set. */
    const char *value)		/* New value for option. */
{
#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
    SocketInfo *infoPtr = instanceData;
    SOCKET sock;
#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.
     */

    if (!SocketsEnabled()) {
	if (interp) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "winsock is not initialized", -1));
	}
	return TCL_ERROR;
    }

#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
    #error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat infoPtr->sockets as single fd or list"
    sock = infoPtr->sockets->fd;

    if (!strcasecmp(optionName, "-keepalive")) {
	BOOL val = FALSE;
	int boolVar, rtn;

	if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) {
	    return TCL_ERROR;







|


















|
|







1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
TcpSetOptionProc(
    ClientData instanceData,	/* Socket state. */
    Tcl_Interp *interp,		/* For error reporting - can be NULL. */
    const char *optionName,	/* Name of the option to set. */
    const char *value)		/* New value for option. */
{
#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
    TcpState *statePtr = instanceData;
    SOCKET sock;
#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.
     */

    if (!SocketsEnabled()) {
	if (interp) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "winsock is not initialized", -1));
	}
	return TCL_ERROR;
    }

#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
    #error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat statePtr->sockets as single fd or list"
    sock = statePtr->sockets->fd;

    if (!strcasecmp(optionName, "-keepalive")) {
	BOOL val = FALSE;
	int boolVar, rtn;

	if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) {
	    return TCL_ERROR;
2059
2060
2061
2062
2063
2064
2065
2066

2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104






2105
2106
2107
2108
2109
2110
2111



























2112
2113
2114

2115



2116
2117
2118




2119
2120
2121



2122
2123
2124
2125


2126
2127









2128
2129
2130
2131
2132
2133
2134
 *	Computes an option value for a TCP socket based channel, or a list of
 *	all options and their values.
 *
 *	Note: This code is based on code contributed by John Haxby.
 *
 * Results:
 *	A standard Tcl result. The value of the specified option or a list of
 *	all options and their values is returned in the supplied DString.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TcpGetOptionProc(
    ClientData instanceData,	/* Socket state. */
    Tcl_Interp *interp,		/* For error reporting - can be NULL */
    const char *optionName,	/* Name of the option to retrieve the value
				 * for, or NULL to get all options and their
				 * values. */
    Tcl_DString *dsPtr)		/* Where to store the computed value;
				 * initialized by caller. */
{
    SocketInfo *infoPtr = instanceData;
    char host[NI_MAXHOST], port[NI_MAXSERV];
    SOCKET sock;
    size_t len = 0;
    int reverseDNS = 0;
#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS"

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.
     */

    if (!SocketsEnabled()) {
	if (interp) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "winsock is not initialized", -1));
	}
	return TCL_ERROR;
    }







    sock = infoPtr->sockets->fd;
    if (optionName != NULL) {
	len = strlen(optionName);
    }

    if ((len > 1) && (optionName[1] == 'e') &&
	    (strncmp(optionName, "-error", len) == 0)) {



























	int optlen;
	DWORD err;
	int ret;





	optlen = sizeof(int);
	ret = TclWinGetSockOpt(sock, SOL_SOCKET, SO_ERROR,
		(char *)&err, &optlen);




	if (ret == SOCKET_ERROR) {
	    err = WSAGetLastError();
	}



	if (err) {
	    TclWinConvertError(err);
	    Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1);
	}


	return TCL_OK;
    }










    if (interp != NULL && Tcl_GetVar(interp, SUPPRESS_RDNS_VAR, 0) != NULL) {
	reverseDNS = NI_NUMERICHOST;
    }

    if ((len == 0) || ((len > 1) && (optionName[1] == 'p') &&
	    (strncmp(optionName, "-peername", len) == 0))) {







|
>










|






|




















>
>
>
>
>
>
|






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
|
>

>
>
>
|
|
|
>
>
>
>
|
|
|
>
>
>
|
|
|
|
>
>


>
>
>
>
>
>
>
>
>







1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293

1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
 *	Computes an option value for a TCP socket based channel, or a list of
 *	all options and their values.
 *
 *	Note: This code is based on code contributed by John Haxby.
 *
 * Results:
 *	A standard Tcl result. The value of the specified option or a list of
 *	all options and their values is returned in the supplied DString. Sets
 *	Error message if needed.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TcpGetOptionProc(
    ClientData instanceData,	/* Socket state. */
    Tcl_Interp *interp,		/* For error reporting - can be NULL. */
    const char *optionName,	/* Name of the option to retrieve the value
				 * for, or NULL to get all options and their
				 * values. */
    Tcl_DString *dsPtr)		/* Where to store the computed value;
				 * initialized by caller. */
{
    TcpState *statePtr = instanceData;
    char host[NI_MAXHOST], port[NI_MAXSERV];
    SOCKET sock;
    size_t len = 0;
    int reverseDNS = 0;
#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS"

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.
     */

    if (!SocketsEnabled()) {
	if (interp) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "winsock is not initialized", -1));
	}
	return TCL_ERROR;
    }

    /* 
     * Go one step in async connect
     * If any error is thrown save it as backround error to report eventually below
     */
    WaitForConnect(statePtr, NULL);

    sock = statePtr->sockets->fd;
    if (optionName != NULL) {
	len = strlen(optionName);
    }

    if ((len > 1) && (optionName[1] == 'e') &&
	    (strncmp(optionName, "-error", len) == 0)) {

	/*
	* Do not return any errors if async connect is running
	*/
	if ( ! (statePtr->flags & TCP_ASYNC_PENDING) ) {


	    if ( statePtr->flags & TCP_ASYNC_FAILED ) {

		/*
		 * In case of a failed async connect, eventually report the
		 * connect error only once.
		 * Do not report the system error, as this comes again and again.
		 */

		if ( statePtr->connectError != 0 ) {
		    Tcl_DStringAppend(dsPtr,
			    Tcl_ErrnoMsg(statePtr->connectError), -1);
		    statePtr->connectError = 0;
		}

	    } else {

		/*
		 * Report an eventual last error of the socket system
		 */

		int optlen;

		int ret;
		DWORD err;

		/*
		 * Populater the err Variable with a possix error
		 */
		optlen = sizeof(int);
		ret = getsockopt(sock, SOL_SOCKET, SO_ERROR,
			(char *)&err, &optlen);
		/*
		 * The error was not returned directly but should be
		 * taken from WSA
		 */
		if (ret == SOCKET_ERROR) {
		    err = WSAGetLastError();
		}
		/*
		 * Return error message
		 */
		if (err) {
		    TclWinConvertError(err);
		    Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1);
		}
	    }
	}
	return TCL_OK;
    }

    if ((len > 1) && (optionName[1] == 'c') &&
	    (strncmp(optionName, "-connecting", len) == 0)) {

	Tcl_DStringAppend(dsPtr,
		(statePtr->flags & TCP_ASYNC_PENDING)
		? "1" : "0", -1);
        return TCL_OK;
    }

    if (interp != NULL && Tcl_GetVar(interp, SUPPRESS_RDNS_VAR, 0) != NULL) {
	reverseDNS = NI_NUMERICHOST;
    }

    if ((len == 0) || ((len > 1) && (optionName[1] == 'p') &&
	    (strncmp(optionName, "-peername", len) == 0))) {
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
	socklen_t size;
	int found = 0;

	if (len == 0) {
	    Tcl_DStringAppendElement(dsPtr, "-sockname");
	    Tcl_DStringStartSublist(dsPtr);
	}
	for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) {
	    sock = fds->fd;
	    size = sizeof(sockname);
	    if (getsockname(sock, &(sockname.sa), &size) >= 0) {
		int flags = reverseDNS;

		found = 1;
		getnameinfo(&sockname.sa, size, host, sizeof(host),







|







1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
	socklen_t size;
	int found = 0;

	if (len == 0) {
	    Tcl_DStringAppendElement(dsPtr, "-sockname");
	    Tcl_DStringStartSublist(dsPtr);
	}
	for (fds = statePtr->sockets; fds != NULL; fds = fds->next) {
	    sock = fds->fd;
	    size = sizeof(sockname);
	    if (getsockname(sock, &(sockname.sa), &size) >= 0) {
		int flags = reverseDNS;

		found = 1;
		getnameinfo(&sockname.sa, size, host, sizeof(host),
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355

2356
2357
2358
2359
2360
2361
2362

2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373


























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































2374
2375
2376
2377
2378
2379
2380
static void
TcpWatchProc(
    ClientData instanceData,	/* The socket state. */
    int mask)			/* Events of interest; an OR-ed combination of
				 * TCL_READABLE, TCL_WRITABLE and
				 * TCL_EXCEPTION. */
{
    SocketInfo *infoPtr = instanceData;

    /*
     * Update the watch events mask. Only if the socket is not a server
     * socket. [Bug 557878]
     */

    if (!infoPtr->acceptProc) {
	infoPtr->watchEvents = 0;
	if (mask & TCL_READABLE) {
	    infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT);
	}
	if (mask & TCL_WRITABLE) {
	    infoPtr->watchEvents |= (FD_WRITE|FD_CLOSE|FD_CONNECT);
	}

	/*
	 * If there are any conditions already set, then tell the notifier to
	 * poll rather than block.
	 */

	if (infoPtr->readyEvents & infoPtr->watchEvents) {
	    Tcl_Time blockTime = { 0, 0 };

	    Tcl_SetMaxBlockTime(&blockTime);
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TcpGetProc --
 *
 *	Called from Tcl_GetChannelHandle to retrieve an OS handle from inside
 *	a TCP socket based channel.
 *
 * Results:
 *	Returns TCL_OK with the socket in handlePtr.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */


static int
TcpGetHandleProc(
    ClientData instanceData,	/* The socket state. */
    int direction,		/* Not used. */
    ClientData *handlePtr)	/* Where to store the handle. */
{
    SocketInfo *statePtr = instanceData;

    *handlePtr = INT2PTR(statePtr->sockets->fd);
    return TCL_OK;
}



























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































/*
 *----------------------------------------------------------------------
 *
 * SocketThread --
 *
 *	Helper thread used to manage the socket event handling window.







|






|
|

|


|







|










|

|
|


|
>







>






|




>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
static void
TcpWatchProc(
    ClientData instanceData,	/* The socket state. */
    int mask)			/* Events of interest; an OR-ed combination of
				 * TCL_READABLE, TCL_WRITABLE and
				 * TCL_EXCEPTION. */
{
    TcpState *statePtr = instanceData;

    /*
     * Update the watch events mask. Only if the socket is not a server
     * socket. [Bug 557878]
     */

    if (!statePtr->acceptProc) {
	statePtr->watchEvents = 0;
	if (mask & TCL_READABLE) {
	    statePtr->watchEvents |= (FD_READ|FD_CLOSE);
	}
	if (mask & TCL_WRITABLE) {
	    statePtr->watchEvents |= (FD_WRITE|FD_CLOSE);
	}

	/*
	 * If there are any conditions already set, then tell the notifier to
	 * poll rather than block.
	 */

	if (statePtr->readyEvents & statePtr->watchEvents) {
	    Tcl_Time blockTime = { 0, 0 };

	    Tcl_SetMaxBlockTime(&blockTime);
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TcpGetHandleProc --
 *
 *	Called from Tcl_GetChannelHandle to retrieve OS handles from inside a
 *	TCP socket based channel.
 *
 * Results:
 *	Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no
 *	handle for the specified direction.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
TcpGetHandleProc(
    ClientData instanceData,	/* The socket state. */
    int direction,		/* Not used. */
    ClientData *handlePtr)	/* Where to store the handle. */
{
    TcpState *statePtr = instanceData;

    *handlePtr = INT2PTR(statePtr->sockets->fd);
    return TCL_OK;
}



/*
 *----------------------------------------------------------------------
 *
 * TcpConnect --
 *
 *	This function opens a new socket in client mode.
 *
 *	This might be called in 3 circumstances:
 *	-   By a regular socket command
 *	-   By the event handler to continue an asynchroneous connect
 *	-   By a blocking socket function (gets/puts) to terminate the
 *	    connect synchroneously
 *
 * Results:
 *      TCL_OK, if the socket was successfully connected or an asynchronous
 *      connection is in progress. If an error occurs, TCL_ERROR is returned
 *      and an error message is left in interp.
 *
 * Side effects:
 *	Opens a socket.
 *
 * Remarks:
 *	A single host name may resolve to more than one IP address, e.g. for
 *	an IPv4/IPv6 dual stack host. For handling asyncronously connecting
 *	sockets in the background for such hosts, this function can act as a
 *	coroutine. On the first call, it sets up the control variables for the
 *	two nested loops over the local and remote addresses. Once the first
 *	connection attempt is in progress, it sets up itself as a writable
 *	event handler for that socket, and returns. When the callback occurs,
 *	control is transferred to the "reenter" label, right after the initial
 *	return and the loops resume as if they had never been interrupted.
 *	For syncronously connecting sockets, the loops work the usual way.
 *
 *----------------------------------------------------------------------
 */

static int
TcpConnect(
    Tcl_Interp *interp,		/* For error reporting; can be NULL. */
    TcpState *statePtr)
{
    DWORD error;
    /*
     * We are started with async connect and the connect notification
     * was not jet received
     */
    int async_connect = statePtr->flags & TCP_ASYNC_CONNECT;
    /* We were called by the event procedure and continue our loop */
    int async_callback = statePtr->flags & TCP_ASYNC_PENDING;
    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
    
    if (async_callback) {
        goto reenter;
    }
    
    for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL;
	 statePtr->addr = statePtr->addr->ai_next) {
	
        for (statePtr->myaddr = statePtr->myaddrlist; statePtr->myaddr != NULL;
	     statePtr->myaddr = statePtr->myaddr->ai_next) {

	    /*
	     * No need to try combinations of local and remote addresses
	     * of different families.
	     */

	    if (statePtr->myaddr->ai_family != statePtr->addr->ai_family) {
		continue;
	    }

            /*
             * Close the socket if it is still open from the last unsuccessful
             * iteration.
             */	    
	    if (statePtr->sockets->fd != INVALID_SOCKET) {
		closesocket(statePtr->sockets->fd);
	    }

	    /* get statePtr lock */
	    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);

	    /*
	     * Reset last error from last try
	     */
	    statePtr->notifierConnectError = 0;
	    Tcl_SetErrno(0);
	    
	    statePtr->sockets->fd = socket(statePtr->myaddr->ai_family, SOCK_STREAM, 0);
	    
	    /* Free list lock */
	    SetEvent(tsdPtr->socketListLock);

	    /* continue on socket creation error */
	    if (statePtr->sockets->fd == INVALID_SOCKET) {
		TclWinConvertError((DWORD) WSAGetLastError());
		continue;
	    }

	    /*
	     * Win-NT has a misfeature that sockets are inherited in child
	     * processes by default. Turn off the inherit bit.
	     */

	    SetHandleInformation((HANDLE) statePtr->sockets->fd, HANDLE_FLAG_INHERIT, 0);

	    /*
	     * Set kernel space buffering
	     */

	    TclSockMinimumBuffers((void *) statePtr->sockets->fd, TCP_BUFFER_SIZE);

	    /*
	     * Try to bind to a local port.
	     */

	    if (bind(statePtr->sockets->fd, statePtr->myaddr->ai_addr,
			statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) {
		TclWinConvertError((DWORD) WSAGetLastError());
		continue;
	    }
	    /*
	     * For asyncroneous connect set the socket in nonblocking mode
	     * and activate connect notification
	     */
	    if (async_connect) {
		TcpState *statePtr2;
		int in_socket_list = 0;
		/* get statePtr lock */
		WaitForSingleObject(tsdPtr->socketListLock, INFINITE);

		/*
		 * Bugfig for 336441ed59 to not ignore notifications until the
		 * infoPtr is in the list.
		 * Check if my statePtr is already in the tsdPtr->socketList
		 * It is set after this call by TcpThreadActionProc and is set
		 * on a second round.
		 *
		 * If not, we buffer my statePtr in the tsd memory so it is not
		 * lost by the event procedure
		 */

		for (statePtr2 = tsdPtr->socketList; statePtr2 != NULL;
			statePtr2 = statePtr->nextPtr) {
		    if (statePtr2 == statePtr) {
			in_socket_list = 1;
			break;
		    }
		}
		if (!in_socket_list) {
		    tsdPtr->pendingTcpState = statePtr;
		}
		/*
		 * Set connect mask to connect events
		 * This is activated by a SOCKET_SELECT message to the notifier
		 * thread.
		 */
		statePtr->selectEvents |= FD_CONNECT;
		
		/*
		 * Free list lock
		 */
		SetEvent(tsdPtr->socketListLock);

    		/* activate accept notification */
		SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
			(LPARAM) statePtr);
	    }

	    /*
	     * Attempt to connect to the remote socket.
	     */
	    
	    connect(statePtr->sockets->fd, statePtr->addr->ai_addr,
		    statePtr->addr->ai_addrlen);

	    error = WSAGetLastError();
	    TclWinConvertError(error);

	    if (async_connect && error == WSAEWOULDBLOCK) {
		/*
		 * Asynchroneous connect
		 */

		/*
		 * Remember that we jump back behind this next round
		 */
		statePtr->flags |= TCP_ASYNC_PENDING;
		return TCL_OK;

	    reenter:
		/*
		 * Re-entry point for async connect after connect event or
		 * blocking operation
		 *
		 * Clear the reenter flag
		 */
		statePtr->flags &= ~(TCP_ASYNC_PENDING);
		/* get statePtr lock */
		WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
		/* Get signaled connect error */
		TclWinConvertError((DWORD) statePtr->notifierConnectError);
		/* Clear eventual connect flag */
		statePtr->selectEvents &= ~(FD_CONNECT);
		/* Free list lock */
		SetEvent(tsdPtr->socketListLock);
	    }

	    /*
	     * Clear the tsd socket list pointer if we did not wait for
	     * the FD_CONNECT asyncroneously
	     */
	    tsdPtr->pendingTcpState = NULL;
	    
	    if (Tcl_GetErrno() == 0) {
		goto out;
	    }
	}
    }

out:
    /*
     * Socket connected or connection failed
     */

    /*
     * Async connect terminated
     */

    CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT);

    if ( Tcl_GetErrno() == 0 ) {
	/*
	 * Succesfully connected
	 */
	/*
	 * Set up the select mask for read/write events.
	 */
	statePtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE;
        
	/*
	 * Register for interest in events in the select mask. Note that this
	 * automatically places the socket into non-blocking mode.
	 */
        
	SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
		    (LPARAM) statePtr);
    } else {
	/*
	 * Connect failed
	 */

	/*
	 * For async connect schedule a writable event to report the fail.
	 */
	if (async_callback) {
	    /*
	     * Set up the select mask for read/write events.
	     */
	    statePtr->selectEvents = FD_WRITE|FD_READ;
	    /* get statePtr lock */
	    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
	    /* Signal ready readable and writable events */
	    statePtr->readyEvents |= FD_WRITE | FD_READ;
	    /* Flag error to event routine */
	    statePtr->flags |= TCP_ASYNC_FAILED;
	    /* Save connect error to be reported by 'fconfigure -error' */
	    statePtr->connectError = Tcl_GetErrno();
	    /* Free list lock */
	    SetEvent(tsdPtr->socketListLock);
	}
	/*
	 * Error message on syncroneous connect
	 */
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "couldn't open socket: %s", Tcl_PosixError(interp)));
	}
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_OpenTcpClient --
 *
 *	Opens a TCP client socket and creates a channel around it.
 *
 * Results:
 *	The channel or NULL if failed. An error message is returned in the
 *	interpreter on failure.
 *
 * Side effects:
 *	Opens a client socket and creates a new channel.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_OpenTcpClient(
    Tcl_Interp *interp,		/* For error reporting; can be NULL. */
    int port,			/* Port number to open. */
    const char *host,		/* Host on which to open port. */
    const char *myaddr,		/* Client-side address */
    int myport,			/* Client-side port */
    int async)			/* If nonzero, attempt to do an asynchronous
				 * connect. Otherwise we do a blocking
				 * connect. */
{
    TcpState *statePtr;
    const char *errorMsg = NULL;
    struct addrinfo *addrlist = NULL, *myaddrlist = NULL;
    char channelName[SOCK_CHAN_LENGTH];

    if (TclpHasSockets(interp) != TCL_OK) {
	return NULL;
    }

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.
     */

    if (!SocketsEnabled()) {
	return NULL;
    }

    /*
     * Do the name lookups for the local and remote addresses.
     */

    if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg)
            || !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1,
                    &errorMsg)) {
        if (addrlist != NULL) {
            freeaddrinfo(addrlist);
        }
        if (interp != NULL) {
            Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "couldn't open socket: %s", errorMsg));
        }
        return NULL;
    }

    statePtr = NewSocketInfo(INVALID_SOCKET);
    statePtr->addrlist = addrlist;
    statePtr->myaddrlist = myaddrlist;
    if (async) {
	statePtr->flags |= TCP_ASYNC_CONNECT;
    }

    /*
     * Create a new client socket and wrap it in a channel.
     */
    if (TcpConnect(interp, statePtr) != TCL_OK) {
	TcpCloseProc(statePtr, NULL);
	return NULL;
    }

    sprintf(channelName, SOCK_TEMPLATE, statePtr);

    statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
	    statePtr, (TCL_READABLE | TCL_WRITABLE));
    if (TCL_ERROR == Tcl_SetChannelOption(NULL, statePtr->channel,
	    "-translation", "auto crlf")) {
	Tcl_Close(NULL, statePtr->channel);
	return NULL;
    } else if (TCL_ERROR == Tcl_SetChannelOption(NULL, statePtr->channel,
	    "-eofchar", "")) {
	Tcl_Close(NULL, statePtr->channel);
	return NULL;
    }
    return statePtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MakeTcpClientChannel --
 *
 *	Creates a Tcl_Channel from an existing client TCP socket.
 *
 * Results:
 *	The Tcl_Channel wrapped around the preexisting TCP socket.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_MakeTcpClientChannel(
    ClientData sock)		/* The socket to wrap up into a channel. */
{
    TcpState *statePtr;
    char channelName[SOCK_CHAN_LENGTH];
    ThreadSpecificData *tsdPtr;

    if (TclpHasSockets(NULL) != TCL_OK) {
	return NULL;
    }

    tsdPtr = TclThreadDataKeyGet(&dataKey);

    /*
     * Set kernel space buffering and non-blocking.
     */

    TclSockMinimumBuffers(sock, TCP_BUFFER_SIZE);

    statePtr = NewSocketInfo((SOCKET) sock);

    /*
     * Start watching for read/write events on the socket.
     */

    statePtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE;
    SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr);

    sprintf(channelName, SOCK_TEMPLATE, statePtr);
    statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
	    statePtr, (TCL_READABLE | TCL_WRITABLE));
    Tcl_SetChannelOption(NULL, statePtr->channel, "-translation", "auto crlf");
    return statePtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_OpenTcpServer --
 *
 *	Opens a TCP server socket and creates a channel around it.
 *
 * Results:
 *	The channel or NULL if failed. If an error occurred, an error message
 *	is left in the interp's result if interp is not NULL.
 *
 * Side effects:
 *	Opens a server socket and creates a new channel.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_OpenTcpServer(
    Tcl_Interp *interp,		/* For error reporting - may be NULL. */
    int port,			/* Port number to open. */
    const char *myHost,		/* Name of local host. */
    Tcl_TcpAcceptProc *acceptProc,
				/* Callback for accepting connections from new
				 * clients. */
    ClientData acceptProcData)	/* Data for the callback. */
{
    SOCKET sock = INVALID_SOCKET;
    unsigned short chosenport = 0;
    struct addrinfo *addrlist = NULL;
    struct addrinfo *addrPtr;	/* Socket address to listen on. */
    TcpState *statePtr = NULL;	/* The returned value. */
    char channelName[SOCK_CHAN_LENGTH];
    u_long flag = 1;		/* Indicates nonblocking mode. */
    const char *errorMsg = NULL;
    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);

    if (TclpHasSockets(interp) != TCL_OK) {
	return NULL;
    }

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.
     */

    if (!SocketsEnabled()) {
	return NULL;
    }

    /*
     * Construct the addresses for each end of the socket.
     */

    if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, &errorMsg)) {
	goto error;
    }

    for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) {
	sock = socket(addrPtr->ai_family, addrPtr->ai_socktype,
                addrPtr->ai_protocol);
	if (sock == INVALID_SOCKET) {
	    TclWinConvertError((DWORD) WSAGetLastError());
	    continue;
	}
	
	/*
	 * Win-NT has a misfeature that sockets are inherited in child
	 * processes by default. Turn off the inherit bit.
	 */
	
	SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0);
	
	/*
	 * Set kernel space buffering
	 */
	
	TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE);
	
	/*
	 * Make sure we use the same port when opening two server sockets
	 * for IPv4 and IPv6.
	 *
	 * As sockaddr_in6 uses the same offset and size for the port
	 * member as sockaddr_in, we can handle both through the IPv4 API.
	 */
	
	if (port == 0 && chosenport != 0) {
	    ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port =
		htons(chosenport);
	}
	
	/*
	 * Bind to the specified port. Note that we must not call
	 * setsockopt with SO_REUSEADDR because Microsoft allows addresses
	 * to be reused even if they are still in use.
	 *
	 * Bind should not be affected by the socket having already been
	 * set into nonblocking mode. If there is trouble, this is one
	 * place to look for bugs.
	 */
	
	if (bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen)
	    == SOCKET_ERROR) {
	    TclWinConvertError((DWORD) WSAGetLastError());
	    closesocket(sock);
	    continue;
	}
	if (port == 0 && chosenport == 0) {
	    address sockname;
	    socklen_t namelen = sizeof(sockname);
	    
	    /*
	     * Synchronize port numbers when binding to port 0 of multiple
	     * addresses.
	     */
	    
	    if (getsockname(sock, &sockname.sa, &namelen) >= 0) {
		chosenport = ntohs(sockname.sa4.sin_port);
	    }
	}
	
	/*
	 * Set the maximum number of pending connect requests to the max
	 * value allowed on each platform (Win32 and Win32s may be
	 * different, and there may be differences between TCP/IP stacks).
	 */
	
	if (listen(sock, SOMAXCONN) == SOCKET_ERROR) {
	    TclWinConvertError((DWORD) WSAGetLastError());
	    closesocket(sock);
	    continue;
	}
	
	if (statePtr == NULL) {
	    /*
	     * Add this socket to the global list of sockets.
	     */
	    statePtr = NewSocketInfo(sock);
	} else {
	    AddSocketInfoFd( statePtr, sock );
	}
    }

error:
    if (addrlist != NULL) {
	freeaddrinfo(addrlist);
    }

    if (statePtr != NULL) {

	statePtr->acceptProc = acceptProc;
	statePtr->acceptProcData = acceptProcData;
	sprintf(channelName, SOCK_TEMPLATE, statePtr);
	statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
		statePtr, 0);
	/*
	 * Set up the select mask for connection request events.
	 */
	
	statePtr->selectEvents = FD_ACCEPT;
	
	/*
	 * Register for interest in events in the select mask. Note that this
	 * automatically places the socket into non-blocking mode.
	 */

	ioctlsocket(sock, (long) FIONBIO, &flag);
	SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
		    (LPARAM) statePtr);
	if (Tcl_SetChannelOption(interp, statePtr->channel, "-eofchar", "")
	    == TCL_ERROR) {
	    Tcl_Close(NULL, statePtr->channel);
	    return NULL;
	}
	return statePtr->channel;
    }

    if (interp != NULL) {
        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"couldn't open socket: %s",
		(errorMsg ? errorMsg : Tcl_PosixError(interp))));
    }

    if (sock != INVALID_SOCKET) {
	closesocket(sock);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpAccept --
 *	Accept a TCP socket connection.	 This is called by the event loop.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Creates a new connection socket. Calls the registered callback for the
 *	connection acceptance mechanism.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static void
TcpAccept(
    TcpFdList *fds,	/* Server socket that accepted newSocket. */
    SOCKET newSocket,   /* Newly accepted socket. */
    address addr)       /* Address of new socket. */
{
    TcpState *newInfoPtr;
    TcpState *statePtr = fds->statePtr;
    int len = sizeof(addr);
    char channelName[SOCK_CHAN_LENGTH];
    char host[NI_MAXHOST], port[NI_MAXSERV];
    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);

    /*
     * Win-NT has a misfeature that sockets are inherited in child processes
     * by default. Turn off the inherit bit.
     */

    SetHandleInformation((HANDLE) newSocket, HANDLE_FLAG_INHERIT, 0);

    /*
     * Add this socket to the global list of sockets.
     */

    newInfoPtr = NewSocketInfo(newSocket);

    /*
     * Select on read/write events and create the channel.
     */

    newInfoPtr->selectEvents = (FD_READ | FD_WRITE | FD_CLOSE);
    SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
	    (LPARAM) newInfoPtr);

    sprintf(channelName, SOCK_TEMPLATE, newInfoPtr);
    newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
	    newInfoPtr, (TCL_READABLE | TCL_WRITABLE));
    if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation",
	    "auto crlf") == TCL_ERROR) {
	Tcl_Close(NULL, newInfoPtr->channel);
	return;
    }
    if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-eofchar", "")
	    == TCL_ERROR) {
	Tcl_Close(NULL, newInfoPtr->channel);
	return;
    }

    /*
     * Invoke the accept callback function.
     */

    if (statePtr->acceptProc != NULL) {
	getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port),
                    NI_NUMERICHOST|NI_NUMERICSERV);
	statePtr->acceptProc(statePtr->acceptProcData, newInfoPtr->channel,
			    host, atoi(port));
    }
}

/*
 *----------------------------------------------------------------------
 *
 * InitSockets --
 *
 *	Registers the event window for the socket notifier code.
 *
 *	Assumes socketMutex is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Register a new window class and creates a
 *	window for use in asynchronous socket notification.
 *
 *----------------------------------------------------------------------
 */

static void
InitSockets(void)
{
    DWORD id;
    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);

    if (!initialized) {
	initialized = 1;
	TclCreateLateExitHandler(SocketExitHandler, NULL);

	/*
	 * Create the async notification window with a new class. We must
	 * create a new class to avoid a Windows 95 bug that causes us to get
	 * the wrong message number for socket events if the message window is
	 * a subclass of a static control.
	 */

	windowClass.style = 0;
	windowClass.cbClsExtra = 0;
	windowClass.cbWndExtra = 0;
	windowClass.hInstance = TclWinGetTclInstance();
	windowClass.hbrBackground = NULL;
	windowClass.lpszMenuName = NULL;
	windowClass.lpszClassName = classname;
	windowClass.lpfnWndProc = SocketProc;
	windowClass.hIcon = NULL;
	windowClass.hCursor = NULL;

	if (!RegisterClass(&windowClass)) {
	    TclWinConvertError(GetLastError());
	    goto initFailure;
	}
    }

    /*
     * Check for per-thread initialization.
     */

    if (tsdPtr != NULL) {
	return;
    }

    /*
     * OK, this thread has never done anything with sockets before.  Construct
     * a worker thread to handle asynchronous events related to sockets
     * assigned to _this_ thread.
     */

    tsdPtr = TCL_TSD_INIT(&dataKey);
    tsdPtr->pendingTcpState = NULL;
    tsdPtr->socketList = NULL;
    tsdPtr->hwnd       = NULL;
    tsdPtr->threadId   = Tcl_GetCurrentThread();
    tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
    if (tsdPtr->readyEvent == NULL) {
	goto initFailure;
    }
    tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL);
    if (tsdPtr->socketListLock == NULL) {
	goto initFailure;
    }
    tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, 0,
	    &id);
    if (tsdPtr->socketThread == NULL) {
	goto initFailure;
    }

    SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST);

    /*
     * Wait for the thread to signal when the window has been created and if
     * it is ready to go.
     */

    WaitForSingleObject(tsdPtr->readyEvent, INFINITE);

    if (tsdPtr->hwnd == NULL) {
	goto initFailure;	/* Trouble creating the window. */
    }

    Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
    return;

  initFailure:
    TclpFinalizeSockets();
    initialized = -1;
    return;
}

/*
 *----------------------------------------------------------------------
 *
 * SocketsEnabled --
 *
 *	Check that the WinSock was successfully initialized.
 *
 * Warning:
 *	This check was useful in times of Windows98 where WinSock may
 *	not be available. This is not the case any more.
 *	This function may be removed with TCL 9.0
 *
 * Results:
 *	1 if it is.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

    /* ARGSUSED */
static int
SocketsEnabled(void)
{
    int enabled;

    Tcl_MutexLock(&socketMutex);
    enabled = (initialized == 1);
    Tcl_MutexUnlock(&socketMutex);
    return enabled;
}


/*
 *----------------------------------------------------------------------
 *
 * SocketExitHandler --
 *
 *	Callback invoked during exit clean up to delete the socket
 *	communication window.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

    /* ARGSUSED */
static void
SocketExitHandler(
    ClientData clientData)		/* Not used. */
{
    Tcl_MutexLock(&socketMutex);

    /*
     * Make sure the socket event handling window is cleaned-up for, at
     * most, this thread.
     */

    TclpFinalizeSockets();
    UnregisterClass(classname, TclWinGetTclInstance());
    initialized = 0;
    Tcl_MutexUnlock(&socketMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * SocketSetupProc --
 *
 *	This function is invoked before Tcl_DoOneEvent blocks waiting for an
 *	event.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Adjusts the block time if needed.
 *
 *----------------------------------------------------------------------
 */

void
SocketSetupProc(
    ClientData data,		/* Not used. */
    int flags)			/* Event flags as passed to Tcl_DoOneEvent. */
{
    TcpState *statePtr;
    Tcl_Time blockTime = { 0, 0 };
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Check to see if there is a ready socket.	 If so, poll.
     */
    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
    for (statePtr = tsdPtr->socketList; statePtr != NULL;
	    statePtr = statePtr->nextPtr) {
	if (statePtr->readyEvents &
	    (statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)
	) {
	    Tcl_SetMaxBlockTime(&blockTime);
	    break;
	}
    }
    SetEvent(tsdPtr->socketListLock);
}

/*
 *----------------------------------------------------------------------
 *
 * SocketCheckProc --
 *
 *	This function is called by Tcl_DoOneEvent to check the socket event
 *	source for events.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May queue an event.
 *
 *----------------------------------------------------------------------
 */

static void
SocketCheckProc(
    ClientData data,		/* Not used. */
    int flags)			/* Event flags as passed to Tcl_DoOneEvent. */
{
    TcpState *statePtr;
    SocketEvent *evPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Queue events for any ready sockets that don't already have events
     * queued (caused by persistent states that won't generate WinSock
     * events).
     */

    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
    for (statePtr = tsdPtr->socketList; statePtr != NULL;
	    statePtr = statePtr->nextPtr) {
	if ((statePtr->readyEvents &
		(statePtr->watchEvents | FD_CONNECT | FD_ACCEPT))
	    && !(statePtr->flags & SOCKET_PENDING)
	) {
	    statePtr->flags |= SOCKET_PENDING;
	    evPtr = ckalloc(sizeof(SocketEvent));
	    evPtr->header.proc = SocketEventProc;
	    evPtr->socket = statePtr->sockets->fd;
	    Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
	}
    }
    SetEvent(tsdPtr->socketListLock);
}

/*
 *----------------------------------------------------------------------
 *
 * SocketEventProc --
 *
 *	This function is called by Tcl_ServiceEvent when a socket event
 *	reaches the front of the event queue. This function is responsible for
 *	notifying the generic channel code.
 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be removed from
 *	the queue. Returns 0 if the event was not handled, meaning it should
 *	stay on the queue. The only time the event isn't handled is if the
 *	TCL_FILE_EVENTS flag bit isn't set.
 *
 * Side effects:
 *	Whatever the channel callback functions do.
 *
 *----------------------------------------------------------------------
 */

static int
SocketEventProc(
    Tcl_Event *evPtr,		/* Event to service. */
    int flags)			/* Flags that indicate what events to handle,
				 * such as TCL_FILE_EVENTS. */
{
    TcpState *statePtr;
    SocketEvent *eventPtr = (SocketEvent *) evPtr;
    int mask = 0, events;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    TcpFdList *fds;
    SOCKET newSocket;
    address addr;
    int len;

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Find the specified socket on the socket list.
     */

    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
    for (statePtr = tsdPtr->socketList; statePtr != NULL;
	    statePtr = statePtr->nextPtr) {
	if (statePtr->sockets->fd == eventPtr->socket) {
	    break;
	}
    }

    /*
     * Discard events that have gone stale.
     */

    if (!statePtr) {
        SetEvent(tsdPtr->socketListLock);
	return 1;
    }

    /*
     * Clear flag that (this) event is pending
     */

    statePtr->flags &= ~SOCKET_PENDING;

    /*
     * Continue async connect if pending and ready
     */

    if ( statePtr->readyEvents & FD_CONNECT ) {
	if ( statePtr->flags & TCP_ASYNC_PENDING ) {

	    /*
	     * Do one step and save eventual connect error
	     */

	    SetEvent(tsdPtr->socketListLock);
	    WaitForConnect(statePtr,NULL);

	} else {
	    
	    /*
	     * No async connect reenter pending. Just clear event.
	     */

	    statePtr->readyEvents &= ~(FD_CONNECT);
	    SetEvent(tsdPtr->socketListLock);
	}
	return 1;
    }

    /*
     * Handle connection requests directly.
     */
    if (statePtr->readyEvents & FD_ACCEPT) {
	for (fds = statePtr->sockets; fds != NULL; fds = fds->next) {

	    /*
	    * Accept the incoming connection request.
	    */
	    len = sizeof(address);

	    newSocket = accept(fds->fd, &(addr.sa), &len);

	    /* On Tcl server sockets with multiple OS fds we loop over the fds trying
	     * an accept() on each, so we expect INVALID_SOCKET.  There are also other
	     * network stack conditions that can result in FD_ACCEPT but a subsequent
	     * failure on accept() by the time we get around to it.
	     * Access to sockets (acceptEventCount, readyEvents) in socketList
	     * is still protected by the lock (prevents reintroduction of 
	     * SF Tcl Bug 3056775.
	     */

	    if (newSocket == INVALID_SOCKET) {
		/* int err = WSAGetLastError(); */
		continue;
	    }

	    /*
	     * It is possible that more than one FD_ACCEPT has been sent, so an extra
	     * count must be kept. Decrement the count, and reset the readyEvent bit
	     * if the count is no longer > 0.
	     */
	    statePtr->acceptEventCount--;

	    if (statePtr->acceptEventCount <= 0) {
		statePtr->readyEvents &= ~(FD_ACCEPT);
	    }

	    SetEvent(tsdPtr->socketListLock);

	    /* Caution: TcpAccept() has the side-effect of evaluating the server
	     * accept script (via AcceptCallbackProc() in tclIOCmd.c), which can
	     * close the server socket and invalidate statePtr and fds.
	     * If TcpAccept() accepts a socket we must return immediately and let
	     * SocketCheckProc queue additional FD_ACCEPT events.
	     */
	    TcpAccept(fds, newSocket, addr);
	    return 1;
	}

	/* Loop terminated with no sockets accepted; clear the ready mask so 
	 * we can detect the next connection request. Note that connection 
	 * requests are level triggered, so if there is a request already 
	 * pending, a new event will be generated.
	 */
	statePtr->acceptEventCount = 0;
	statePtr->readyEvents &= ~(FD_ACCEPT);

	SetEvent(tsdPtr->socketListLock);
	return 1;
    }

    SetEvent(tsdPtr->socketListLock);

    /*
     * Mask off unwanted events and compute the read/write mask so we can
     * notify the channel.
     */

    events = statePtr->readyEvents & statePtr->watchEvents;

    if (events & FD_CLOSE) {
	/*
	 * If the socket was closed and the channel is still interested in
	 * read events, then we need to ensure that we keep polling for this
	 * event until someone does something with the channel. Note that we
	 * do this before calling Tcl_NotifyChannel so we don't have to watch
	 * out for the channel being deleted out from under us. This may cause
	 * a redundant trip through the event loop, but it's simpler than
	 * trying to do unwind protection.
	 */

	Tcl_Time blockTime = { 0, 0 };

	Tcl_SetMaxBlockTime(&blockTime);
	mask |= TCL_READABLE|TCL_WRITABLE;
    } else if (events & FD_READ) {

	/*
	 * Throw the readable event if an async connect failed.
	 */

	if ( statePtr->flags & TCP_ASYNC_FAILED ) {

	    mask |= TCL_READABLE;
	    
	} else {
	    fd_set readFds;
	    struct timeval timeout;

	    /*
	     * We must check to see if data is really available, since someone
	     * could have consumed the data in the meantime. Turn off async
	     * notification so select will work correctly. If the socket is
	     * still readable, notify the channel driver, otherwise reset the
	     * async select handler and keep waiting.
	     */

	    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
		    (WPARAM) UNSELECT, (LPARAM) statePtr);

	    FD_ZERO(&readFds);
	    FD_SET(statePtr->sockets->fd, &readFds);
	    timeout.tv_usec = 0;
	    timeout.tv_sec = 0;

	    if (select(0, &readFds, NULL, NULL, &timeout) != 0) {
		mask |= TCL_READABLE;
	    } else {
		statePtr->readyEvents &= ~(FD_READ);
		SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
			(WPARAM) SELECT, (LPARAM) statePtr);
	    }
	}
    }

    /*
     * writable event
     */

    if (events & FD_WRITE) {
	mask |= TCL_WRITABLE;
    }
    
    /*
     * Call registered event procedures
     */
     
    if (mask) {
	Tcl_NotifyChannel(statePtr->channel, mask);
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * AddSocketInfoFd --
 *
 *	This function adds a SOCKET file descriptor to the 'sockets' linked 
 *	list of a TcpState structure.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None, except for allocation of memory.
 *
 *----------------------------------------------------------------------
 */

static void
AddSocketInfoFd(
    TcpState *statePtr, 
    SOCKET socket)
{
    TcpFdList *fds = statePtr->sockets;

    if ( fds == NULL ) {
	/* Add the first FD */
	statePtr->sockets = ckalloc(sizeof(TcpFdList));
	fds = statePtr->sockets;
    } else {
	/* Find end of list and append FD */
	while ( fds->next != NULL ) {
	    fds = fds->next;
	}
    
	fds->next = ckalloc(sizeof(TcpFdList));
	fds = fds->next;
    }

    /* Populate new FD */
    fds->fd = socket;
    fds->statePtr = statePtr;
    fds->next = NULL;
}

    
/*
 *----------------------------------------------------------------------
 *
 * NewSocketInfo --
 *
 *	This function allocates and initializes a new TcpState structure.
 *
 * Results:
 *	Returns a newly allocated TcpState.
 *
 * Side effects:
 *	None, except for allocation of memory.
 *
 *----------------------------------------------------------------------
 */

static TcpState *
NewSocketInfo(SOCKET socket)
{
    TcpState *statePtr = ckalloc(sizeof(TcpState));

    memset(statePtr, 0, sizeof(TcpState));

    /*
     * TIP #218. Removed the code inserting the new structure into the global
     * list. This is now handled in the thread action callbacks, and only
     * there.
     */

    AddSocketInfoFd(statePtr, socket);

    return statePtr;
}

/*
 *----------------------------------------------------------------------
 *
 * WaitForSocketEvent --
 *
 *	Waits until one of the specified events occurs on a socket.
 *	For event FD_CONNECT use WaitForConnect.
 *
 * Results:
 *	Returns 1 on success or 0 on failure, with an error code in
 *	errorCodePtr.
 *
 * Side effects:
 *	Processes socket events off the system queue.
 *
 *----------------------------------------------------------------------
 */

static int
WaitForSocketEvent(
    TcpState *statePtr,	/* Information about this socket. */
    int events,			/* Events to look for. May be one of
				 * FD_READ or FD_WRITE.
				 */
    int *errorCodePtr)		/* Where to store errors? */
{
    int result = 1;
    int oldMode;
    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
    /*
     * Be sure to disable event servicing so we are truly modal.
     */

    oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE);

    /*
     * Reset WSAAsyncSelect so we have a fresh set of events pending.
     */

    SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT,
	    (LPARAM) statePtr);
    SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
	    (LPARAM) statePtr);

    while (1) {
	int event_found;

	/* get statePtr lock */
	WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
	
	/* Check if event occured */
	event_found = (statePtr->readyEvents & events);

	/* Free list lock */
	SetEvent(tsdPtr->socketListLock);

	/* exit loop if event occured */
	if (event_found) {
	    break;
	}
	
	/* Exit loop if event did not occur but this is a non-blocking channel */
	if (statePtr->flags & TCP_NONBLOCKING) {
	    *errorCodePtr = EWOULDBLOCK;
	    result = 0;
	    break;
	}

	/*
	 * Wait until something happens.
	 */

	WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
    }

    (void) Tcl_SetServiceMode(oldMode);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * SocketThread --
 *
 *	Helper thread used to manage the socket event handling window.
2459
2460
2461
2462
2463
2464
2465
2466

2467
2468
2469
2470
2471
2472
2473
    HWND hwnd,
    UINT message,
    WPARAM wParam,
    LPARAM lParam)
{
    int event, error;
    SOCKET socket;
    SocketInfo *infoPtr;

    TcpFdList *fds = NULL;
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
#ifdef _WIN64
	    GetWindowLongPtr(hwnd, GWLP_USERDATA);
#else
	    GetWindowLong(hwnd, GWL_USERDATA);
#endif







|
>







3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
    HWND hwnd,
    UINT message,
    WPARAM wParam,
    LPARAM lParam)
{
    int event, error;
    SOCKET socket;
    TcpState *statePtr;
    int info_found = 0;
    TcpFdList *fds = NULL;
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
#ifdef _WIN64
	    GetWindowLongPtr(hwnd, GWLP_USERDATA);
#else
	    GetWindowLong(hwnd, GWL_USERDATA);
#endif
2497
2498
2499
2500
2501
2502
2503


2504
2505
2506
2507
2508
2509
2510
2511










2512





2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555

2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
	break;

    case SOCKET_MESSAGE:
	event = WSAGETSELECTEVENT(lParam);
	error = WSAGETSELECTERROR(lParam);
	socket = (SOCKET) wParam;



	/*
	 * Find the specified socket on the socket list and update its
	 * eventState flag.
	 */

	WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
	for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
		infoPtr = infoPtr->nextPtr) {










	    for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) {





		if (fds->fd == socket) {
		    /*
		     * Update the socket state.
		     *
		     * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event
		     * happens, then clear the FD_ACCEPT count. Otherwise,
		     * increment the count if the current event is an FD_ACCEPT.
		     */

		    if (event & FD_CLOSE) {
			infoPtr->acceptEventCount = 0;
			infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT);
		    } else if (event & FD_ACCEPT) {
			infoPtr->acceptEventCount++;
		    }

		    if (event & FD_CONNECT) {
			/*
			 * The socket is now connected, clear the async connect
			 * flag.
			 */

			infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);

			/*
			 * Remember any error that occurred so we can report
			 * connection failures.
			 */

			if (error != ERROR_SUCCESS) {
			    TclWinConvertError((DWORD) error);
			    infoPtr->lastError = Tcl_GetErrno();
			}
		    }

		    if (infoPtr->flags & SOCKET_ASYNC_CONNECT) {
			infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);
			if (error != ERROR_SUCCESS) {
			    TclWinConvertError((DWORD) error);
			    infoPtr->lastError = Tcl_GetErrno();
			}
			infoPtr->readyEvents |= FD_WRITE;
		    }

		    infoPtr->readyEvents |= event;

		    /*
		     * Wake up the Main Thread.
		     */

		    SetEvent(tsdPtr->readyEvent);
		    Tcl_ThreadAlert(tsdPtr->threadId);
		    break;
		}
	    }
	}
	SetEvent(tsdPtr->socketListLock);
	break;

    case SOCKET_SELECT:
	infoPtr = (SocketInfo *) lParam;
	for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) {
	    infoPtr = (SocketInfo *) lParam;
	    if (wParam == SELECT) {
		WSAAsyncSelect(fds->fd, hwnd,
			SOCKET_MESSAGE, infoPtr->selectEvents);
	    } else {
		/*
		 * Clear the selection mask
		 */

		WSAAsyncSelect(fds->fd, hwnd, 0, 0);
	    }







>
>





<
|
|
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
|
|
|
|
|
|
|
|

|
|
|
|
|
|

|
|
<
<
<
<
<
<
<
|
|
|
<
|
<
|
|
|
|
<
<
<
<
<
<
|
<
>
|

|
|
|
<
|
|
<
<
<





|
|
<


|







3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085

3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121







3122
3123
3124

3125

3126
3127
3128
3129






3130

3131
3132
3133
3134
3135
3136

3137
3138



3139
3140
3141
3142
3143
3144
3145

3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
	break;

    case SOCKET_MESSAGE:
	event = WSAGETSELECTEVENT(lParam);
	error = WSAGETSELECTERROR(lParam);
	socket = (SOCKET) wParam;

	WaitForSingleObject(tsdPtr->socketListLock, INFINITE);

	/*
	 * Find the specified socket on the socket list and update its
	 * eventState flag.
	 */


	for (statePtr = tsdPtr->socketList; statePtr != NULL;
		statePtr = statePtr->nextPtr) {
	    if ( FindFDInList(statePtr,socket) ) {
		info_found = 1;
		break;
	    }
	}
	/*
	 * Check if there is a pending info structure not jet in the
	 * list
	 */
	if ( !info_found
		&& tsdPtr->pendingTcpState != NULL
		&& FindFDInList(tsdPtr->pendingTcpState,socket) ) {
	    statePtr = tsdPtr->pendingTcpState;
	    info_found = 1;
	}
	if (info_found) {

	    /*
	     * Update the socket state.
	     *
	     * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event
	     * happens, then clear the FD_ACCEPT count. Otherwise,
	     * increment the count if the current event is an FD_ACCEPT.
	     */

	    if (event & FD_CLOSE) {
		statePtr->acceptEventCount = 0;
		statePtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT);
	    } else if (event & FD_ACCEPT) {
		statePtr->acceptEventCount++;
	    }

	    if (event & FD_CONNECT) {
		/*







		 * Remember any error that occurred so we can report
		 * connection failures.
		 */

		if (error != ERROR_SUCCESS) {

		    statePtr->notifierConnectError = error;
		}
	    }
	    /*






	     * Inform main thread about signaled events

	     */
	    statePtr->readyEvents |= event;

	    /*
	     * Wake up the Main Thread.
	     */

	    SetEvent(tsdPtr->readyEvent);
	    Tcl_ThreadAlert(tsdPtr->threadId);



	}
	SetEvent(tsdPtr->socketListLock);
	break;

    case SOCKET_SELECT:
	statePtr = (TcpState *) lParam;
	for (fds = statePtr->sockets; fds != NULL; fds = fds->next) {

	    if (wParam == SELECT) {
		WSAAsyncSelect(fds->fd, hwnd,
			SOCKET_MESSAGE, statePtr->selectEvents);
	    } else {
		/*
		 * Clear the selection mask
		 */

		WSAAsyncSelect(fds->fd, hwnd, 0, 0);
	    }
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601

2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685

2686

2687
2688
2689
2690
2691
2692
2693
2694
2695
2696

2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetHostName --
 *
 *	Returns the name of the local host.

 *
 * Results:
 *	A string containing the network name for this machine. The caller must
 *	not modify or free this string.
 *
 * Side effects:
 *	Caches the name to return for future calls.
 *
 *----------------------------------------------------------------------
 */

const char *
Tcl_GetHostName(void)
{
    return Tcl_GetString(TclGetProcessGlobalValue(&hostName));
}

/*
 *----------------------------------------------------------------------
 *
 * InitializeHostName --
 *
 *	This routine sets the process global value of the name of the local
 *	host on which the process is running.
 *
 * Results:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
InitializeHostName(
    char **valuePtr,
    int *lengthPtr,
    Tcl_Encoding *encodingPtr)
{
    TCHAR tbuf[MAX_COMPUTERNAME_LENGTH + 1];
    DWORD length = MAX_COMPUTERNAME_LENGTH + 1;
    Tcl_DString ds;

    if (GetComputerName(tbuf, &length) != 0) {
	/*
	 * Convert string from native to UTF then change to lowercase.
	 */

	Tcl_UtfToLower(Tcl_WinTCharToUtf(tbuf, -1, &ds));

    } else {
	Tcl_DStringInit(&ds);
	if (TclpHasSockets(NULL) == TCL_OK) {
	    /*
	     * The buffer size of 256 is recommended by the MSDN page that
	     * documents gethostname() as being always adequate.
	     */

	    Tcl_DString inDs;

	    Tcl_DStringInit(&inDs);
	    Tcl_DStringSetLength(&inDs, 256);
	    if (gethostname(Tcl_DStringValue(&inDs),
		    Tcl_DStringLength(&inDs)) == 0) {
		Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), -1,
			&ds);
	    }
	    Tcl_DStringFree(&inDs);
	}
    }

    *encodingPtr = Tcl_GetEncoding(NULL, "utf-8");
    *lengthPtr = Tcl_DStringLength(&ds);
    *valuePtr = ckalloc((*lengthPtr) + 1);
    memcpy(*valuePtr, Tcl_DStringValue(&ds), (size_t)(*lengthPtr)+1);
    Tcl_DStringFree(&ds);
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinGetSockOpt, et al. --
 *
 *	These functions are wrappers that let us bind the WinSock API
 *	dynamically so we can run on systems that don't have the wsock32.dll.
 *	We need wrappers for these interfaces because they are called from the

 *	generic Tcl code.

 *
 * Results:
 *	As defined for each function.
 *
 * Side effects:
 *	As defined for each function.
 *
 *----------------------------------------------------------------------
 */


int
TclWinGetSockOpt(
    SOCKET s,
    int level,
    int optname,
    char *optval,
    int *optlen)
{
    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.
     */

    if (!SocketsEnabled()) {
	return SOCKET_ERROR;
    }

    return getsockopt(s, level, optname, optval, optlen);
}

int
TclWinSetSockOpt(
    SOCKET s,
    int level,
    int optname,
    const char *optval,
    int optlen)
{
    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.
     */

    if (!SocketsEnabled()) {
	return SOCKET_ERROR;
    }

    return setsockopt(s, level, optname, optval, optlen);
}

#undef TclpInetNtoa
char *
TclpInetNtoa(
    struct in_addr addr)
{
    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.
     */

    if (!SocketsEnabled()) {
        return NULL;
    }

    return inet_ntoa(addr);
}

struct servent *
TclWinGetServByName(
    const char *name,
    const char *proto)
{
    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.
     */

    if (!SocketsEnabled()) {
	return NULL;
    }

    return getservbyname(name, proto);
}

/*
 *----------------------------------------------------------------------
 *
 * TcpThreadActionProc --







|

|
>


<
|


<



<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
|
<
<
<
<
|
<
|
<
<
|
<
<
<
<
|
|
|
<
<
<
<
<
|
<
|


|
<
<
<
<
<







|
<
|
>
|
>










>








<
<
<
<
<
<
<
<
<



|








<
<
<
<
<
<
<
<
<
<








<
<
<
<
<
<
<
<
<
<


|





<
<
<
<
<
<
<
<
<
<







3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175

3176
3177
3178

3179
3180
3181


























3182



3183




3184

3185


3186




3187
3188
3189





3190

3191
3192
3193
3194





3195
3196
3197
3198
3199
3200
3201
3202

3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225









3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237










3238
3239
3240
3241
3242
3243
3244
3245










3246
3247
3248
3249
3250
3251
3252
3253










3254
3255
3256
3257
3258
3259
3260

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * FindFDInList --
 *
 *	Return true, if the given file descriptior is contained in the
 *	file descriptor list.
 *
 * Results:

 *	true if found.
 *
 * Side effects:

 *
 *----------------------------------------------------------------------
 */






























static int




FindFDInList(

    TcpState *statePtr,


    SOCKET socket)




{
    TcpFdList *fds;
    for (fds = statePtr->sockets; fds != NULL; fds = fds->next) {





	if (fds->fd == socket) {

	    return 1;
	}
    }
    return 0;





}

/*
 *----------------------------------------------------------------------
 *
 * TclWinGetSockOpt, et al. --
 *
 *	Those functions are historically exported by the stubs table and

 *	just use the original system calls now.
 *
 * Warning:
 *	Those functions are depreciated and will be removed with TCL 9.0.
 *
 * Results:
 *	As defined for each function.
 *
 * Side effects:
 *	As defined for each function.
 *
 *----------------------------------------------------------------------
 */

#undef TclWinGetSockOpt
int
TclWinGetSockOpt(
    SOCKET s,
    int level,
    int optname,
    char *optval,
    int *optlen)
{










    return getsockopt(s, level, optname, optval, optlen);
}
#undef TclWinSetSockOpt
int
TclWinSetSockOpt(
    SOCKET s,
    int level,
    int optname,
    const char *optval,
    int optlen)
{










    return setsockopt(s, level, optname, optval, optlen);
}

#undef TclpInetNtoa
char *
TclpInetNtoa(
    struct in_addr addr)
{










    return inet_ntoa(addr);
}
#undef TclWinGetServByName
struct servent *
TclWinGetServByName(
    const char *name,
    const char *proto)
{










    return getservbyname(name, proto);
}

/*
 *----------------------------------------------------------------------
 *
 * TcpThreadActionProc --
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814





2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840

static void
TcpThreadActionProc(
    ClientData instanceData,
    int action)
{
    ThreadSpecificData *tsdPtr;
    SocketInfo *infoPtr = instanceData;
    int notifyCmd;

    if (action == TCL_CHANNEL_THREAD_INSERT) {
	/*
	 * Ensure that socket subsystem is initialized in this thread, or else
	 * sockets will not work.
	 */

	Tcl_MutexLock(&socketMutex);
	InitSockets();
	Tcl_MutexUnlock(&socketMutex);

	tsdPtr = TCL_TSD_INIT(&dataKey);

	WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
	infoPtr->nextPtr = tsdPtr->socketList;
	tsdPtr->socketList = infoPtr;





	SetEvent(tsdPtr->socketListLock);

	notifyCmd = SELECT;
    } else {
	SocketInfo **nextPtrPtr;
	int removed = 0;

	tsdPtr = TCL_TSD_INIT(&dataKey);

	/*
	 * TIP #218, Bugfix: All access to socketList has to be protected by
	 * the lock.
	 */

	WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
	for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL;
		nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
	    if ((*nextPtrPtr) == infoPtr) {
		(*nextPtrPtr) = infoPtr->nextPtr;
		removed = 1;
		break;
	    }
	}
	SetEvent(tsdPtr->socketListLock);

	/*







|















|
|
>
>
>
>
>




|












|
|







3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327

static void
TcpThreadActionProc(
    ClientData instanceData,
    int action)
{
    ThreadSpecificData *tsdPtr;
    TcpState *statePtr = instanceData;
    int notifyCmd;

    if (action == TCL_CHANNEL_THREAD_INSERT) {
	/*
	 * Ensure that socket subsystem is initialized in this thread, or else
	 * sockets will not work.
	 */

	Tcl_MutexLock(&socketMutex);
	InitSockets();
	Tcl_MutexUnlock(&socketMutex);

	tsdPtr = TCL_TSD_INIT(&dataKey);

	WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
	statePtr->nextPtr = tsdPtr->socketList;
	tsdPtr->socketList = statePtr;
	
	if (statePtr == tsdPtr->pendingTcpState) {
	    tsdPtr->pendingTcpState = NULL;
	}
	
	SetEvent(tsdPtr->socketListLock);

	notifyCmd = SELECT;
    } else {
	TcpState **nextPtrPtr;
	int removed = 0;

	tsdPtr = TCL_TSD_INIT(&dataKey);

	/*
	 * TIP #218, Bugfix: All access to socketList has to be protected by
	 * the lock.
	 */

	WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
	for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL;
		nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
	    if ((*nextPtrPtr) == statePtr) {
		(*nextPtrPtr) = statePtr->nextPtr;
		removed = 1;
		break;
	    }
	}
	SetEvent(tsdPtr->socketListLock);

	/*
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866


2867
2868

    /*
     * Ensure that, or stop, notifications for the socket occur in this
     * thread.
     */

    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
	    (WPARAM) notifyCmd, (LPARAM) infoPtr);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78


 * End:
 */







|







>
>


3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357

    /*
     * Ensure that, or stop, notifications for the socket occur in this
     * thread.
     */

    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
	    (WPARAM) notifyCmd, (LPARAM) statePtr);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * tab-width: 8
 * indent-tabs-mode: nil
 * End:
 */
Changes to win/tclWinTest.c.
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
#   define USE_TCL_STUBS
#endif
#include "tclInt.h"

/*
 * For TestplatformChmod on Windows
 */
#ifdef __WIN32__
#include <aclapi.h>
#endif

/*
 * MinGW 3.4.2 does not define this.
 */
#ifndef INHERITED_ACE







|







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
#   define USE_TCL_STUBS
#endif
#include "tclInt.h"

/*
 * For TestplatformChmod on Windows
 */
#ifdef _WIN32
#include <aclapi.h>
#endif

/*
 * MinGW 3.4.2 does not define this.
 */
#ifndef INHERITED_ACE