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: |
8f0855701a5b81ea2bbcf32695d4727b |
| 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
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 | 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 | > | > | 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 | 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 | | > | | 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 | \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. | | > | | 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 | .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 | | | | | 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 | \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 | | > | 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 | \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 | | > | | | 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 | .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 | | | > | 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 | .SH NAME encoding \- Manipulate encodings .SH SYNOPSIS \fBencoding \fIoption\fR ?\fIarg arg ...\fR? .BE .SH INTRODUCTION .PP | | > > > > > > > > > > | | | > > | | > > > > > | > > > | 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 | 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 | | | > > > | | 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 | 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 | | > > > | | | > > > > > > > > > > > > > > > > > | 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 | '\" '\" 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 | | | 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 | 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. | | | | 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 | /* *---------------------------------------------------------------------------- * The following definitions set up the proper options for Windows compilers. * We use this method because there is no autoconf equivalent. */ | > | < > | | < < < < | | | 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 | * * 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. */ | | | 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 | /* *---------------------------------------------------------------------------- * 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. */ | | | | 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 | * * 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) | | | | | 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 | # 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 */ | | | 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 | /* *---------------------------------------------------------------------------- * 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. */ | | | | 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 | * table. */ #include "tclDecls.h" /* * Include platform specific public function declarations that are accessible | | > > > > > > | 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 | #include "tclInt.h" /* * Windows has mktime. The configurators do not check. */ | | | 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 |
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
| > | | | | | | > > | 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 |
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
| > | | | | | | | | | > > | 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 |
Tcl_Time now;
Tcl_WideInt clicks = 0;
switch (objc) {
case 1:
break;
case 2:
| | | 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 |
* 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) {
| | | | 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 | * 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. */ | | | 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 |
* 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;
| | | 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 |
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;
| | > | 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 |
if (mode == EXACT || mode == SORTED) {
switch ((enum datatypes) dataType) {
case ASCII:
case DICTIONARY:
patternBytes = TclGetStringFromObj(patObj, &length);
break;
case INTEGER:
| | | 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 | match = strCmpFn(patternBytes, bytes); break; case DICTIONARY: bytes = TclGetString(itemPtr); match = DictionaryCompare(patternBytes, bytes); break; case INTEGER: | | | | | 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 | case DICTIONARY: bytes = TclGetString(itemPtr); match = (DictionaryCompare(bytes, patternBytes) == 0); break; case INTEGER: | | | | 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 |
/*
* Determine the "value" of this object for sorting purposes
*/
if (sortMode == SORTMODE_ASCII) {
elementArray[i].collationKey.strValuePtr = TclGetString(indexPtr);
} else if (sortMode == SORTMODE_INTEGER) {
| | | | | 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 |
} 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) {
| | | | | 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 |
const char *name;
int index;
name = TclGetString(objv[i]);
if (name[0] != '-') {
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 |
goto endOfForLoop;
}
}
endOfForLoop:
if ((objc - i) < (2 - about)) {
Tcl_WrongNumArgs(interp, 1, objv,
| | > > | 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 |
const char *name;
int index;
name = TclGetString(objv[idx]);
if (name[0] != '-') {
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 |
goto endOfForLoop;
}
}
endOfForLoop:
if (objc-idx < 3 || objc-idx > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
| | | 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 |
SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS
};
int i, flags = TCL_SUBST_ALL;
for (i = 0; i < numOpts; i++) {
int optionIndex;
| | | 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 |
break;
}
}
finishedOptions:
if (objc - i < 2) {
Tcl_WrongNumArgs(interp, 1, objv,
| | | 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 |
/*
* Ensure that the list is non-empty.
*/
if (objc < 1) {
Tcl_WrongNumArgs(interp, 1, savedObjv,
| | | 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 | 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); | | | | 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 | 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); | | | 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 |
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 */
| | | | | | 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 |
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 */
| | | | 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 | (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 */ | | | | 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 | (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 */ | | | 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 |
*/
static void
DupDictInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
| | | 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 |
newDict->chain = NULL;
newDict->refcount = 1;
/*
* Store in the object.
*/
| | | 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 |
*----------------------------------------------------------------------
*/
static void
FreeDictInternalRep(
Tcl_Obj *dictPtr)
{
| | | 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 |
static void
UpdateStringOfDict(
Tcl_Obj *dictPtr)
{
#define LOCAL_SIZE 20
int localFlags[LOCAL_SIZE], *flagPtr = NULL;
| | | 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 |
static int
SetDictFromAny(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
Tcl_HashEntry *hPtr;
| | | 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 |
const char *limit = (nextElem + length);
while (nextElem < limit) {
Tcl_Obj *keyPtr, *valuePtr;
const char *elemStart;
int elemSize, literal;
| | | < | | | < | | 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 |
* Tcl_GetStringFromObj, to use that old internalRep.
*/
TclFreeIntRep(objPtr);
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
| | < | < < < < | | 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 |
int keyc,
Tcl_Obj *const keyv[],
int flags)
{
Dict *dict, *newDict;
int i;
| | | | | < | | 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 |
hPtr = CreateChainEntry(dict, keyv[i], &isNew);
tmpObj = Tcl_NewDictObj();
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, tmpObj);
} else {
tmpObj = Tcl_GetHashValue(hPtr);
| | | | < | | | 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 |
*----------------------------------------------------------------------
*/
static void
InvalidateDictChain(
Tcl_Obj *dictObj)
{
| | | | 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 |
Tcl_HashEntry *hPtr;
int isNew;
if (Tcl_IsShared(dictPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_DictObjPut");
}
| | | < < | < | | 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 |
Tcl_Obj *dictPtr,
Tcl_Obj *keyPtr,
Tcl_Obj **valuePtrPtr)
{
Dict *dict;
Tcl_HashEntry *hPtr;
| | | < | | | | | < | 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 |
{
Dict *dict;
if (Tcl_IsShared(dictPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove");
}
| | | < | | | | > | | | < < | 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 |
Tcl_DictObjSize(
Tcl_Interp *interp,
Tcl_Obj *dictPtr,
int *sizePtr)
{
Dict *dict;
| | | < | | | | < | 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 |
* written into when there are no further
* values in the dictionary, or a 0
* otherwise. */
{
Dict *dict;
ChainEntry *cPtr;
| | | < < | | | | < | 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 |
}
dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE);
if (dictPtr == NULL) {
return TCL_ERROR;
}
| | > | 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 |
}
dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_UPDATE);
if (dictPtr == NULL) {
return TCL_ERROR;
}
| | | 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 |
TclNewObj(dictPtr);
TclInvalidateStringRep(dictPtr);
dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
| | | 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 |
TclDbNewObj(dictPtr, file, line);
TclInvalidateStringRep(dictPtr);
dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
| | | 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 |
}
dictObj = Tcl_NewDictObj();
for (i=1 ; i<objc ; i+=2) {
/*
* The next command is assumed to never fail...
*/
| | | 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 |
DictReplaceCmd(
ClientData dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr;
| | < > > > > < < < < | | | | < > | 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 |
DictRemoveCmd(
ClientData dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr;
| | < > > > > < < | < < | | | < > | 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 |
}
/*
* Make sure first argument is a dictionary.
*/
targetObj = objv[1];
| | | | < | 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 |
/*
* 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]
*/
| | | < < | < | 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 |
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
return TCL_ERROR;
}
dictPtr = objv[1];
| | | < | | < | | 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 |
int objc,
Tcl_Obj *const *objv)
{
int code = TCL_OK;
Tcl_Obj *dictPtr, *valuePtr = NULL;
if (objc < 3 || objc > 4) {
| | | 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 |
} else {
/*
* Remember to dispose with the bignum as we're not actually
* using it directly. [Bug 2874678]
*/
mp_clear(&increment);
| | | | | | | 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 |
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
int i, allocatedDict = 0, allocatedValue = 0;
if (objc < 3) {
| | | 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 |
}
return TCL_ERROR;
}
}
}
if (allocatedValue) {
| | | 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 |
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
int i, allocatedDict = 0;
if (objc < 3) {
| | | 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 |
TclDecrRefCount(dictPtr);
}
return TCL_ERROR;
}
if (valuePtr == NULL) {
TclNewObj(valuePtr);
| < | | < | | 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 |
Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
Tcl_Obj **varv, *keyObj, *valueObj;
Tcl_DictSearch *searchPtr;
int varc, done;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv,
| | > | 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 |
/*
* Stop the value from getting hit in any way by any traces on the key
* variable.
*/
Tcl_IncrRefCount(valueObj);
| | > | > | 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 |
Interp *iPtr = (Interp *) interp;
Tcl_Obj **varv, *keyObj, *valueObj;
DictMapStorage *storagePtr;
int varc, done;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv,
| | > | 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 |
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *resultPtr;
int result, allocatedDict = 0;
if (objc < 4) {
| | | 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 |
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *resultPtr;
int result, allocatedDict = 0;
if (objc < 3) {
| | | 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 |
* 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) {
| | | | | 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 |
resultObj = Tcl_NewDictObj();
while (!done) {
int i;
for (i=3 ; i<objc ; i++) {
pattern = TclGetString(objv[i]);
if (Tcl_StringMatch(TclGetString(valueObj), pattern)) {
| | | > | 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 |
* key variable.
*/
Tcl_IncrRefCount(keyObj);
Tcl_IncrRefCount(valueObj);
if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
TCL_LEAVE_ERR_MSG) == NULL) {
| | < | < | < | < | 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 |
&satisfied) != TCL_OK) {
TclDecrRefCount(boolObj);
result = TCL_ERROR;
goto abnormalResult;
}
TclDecrRefCount(boolObj);
if (satisfied) {
| | | 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 |
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *dictPtr, *objPtr;
int i, dummy;
if (objc < 5 || !(objc & 1)) {
Tcl_WrongNumArgs(interp, 1, objv,
| | | 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 |
* 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) {
| | < | | | 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 |
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *dictPtr, *keysPtr, *pathPtr;
if (objc < 3) {
| | | 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 |
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);
| < < < < < < < > > > > > > | 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 |
#ifdef USE_PUTENV_FOR_UNSET
/*
* For those platforms that support putenv to unset, Linux indicates
* that no = should be included, and Windows requires it.
*/
| | | | 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 |
#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \
((((objPtr)->typePtr == &tclIntType) \
|| ((objPtr)->typePtr == &tclBooleanType)) \
? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
: Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr)))
| < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
} else if (Tcl_IsShared(value3Ptr)) {
objResultPtr = Tcl_DuplicateObj(value3Ptr);
if (toIdx < length) {
Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
length - toIdx);
}
} else {
| > > > > > > | | > > > > | 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 | /* * 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. */ | | | 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 |
/*
* We have a '-linktype' argument.
*/
static const char *const linkTypes[] = {
"-symbolic", "-hard", NULL
};
| | | 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 | } 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); | > > > > < < < | > | | | | 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 | #define SpaceLeft(bufPtr) ((bufPtr)->bufLength - (bufPtr)->nextAdded) #define IsBufferReady(bufPtr) ((bufPtr)->nextAdded > (bufPtr)->nextRemoved) #define IsBufferEmpty(bufPtr) ((bufPtr)->nextAdded == (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 |
Channel *chanPtr,
Tcl_Interp *interp,
int flags)
{
return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, flags);
}
| > > > > > > > > > > > > > > > > > > > > > > > | | > > | > > > > > | > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
CheckForStdChannelsBeingClosed(chan);
/*
* If the refCount reached zero, close the actual channel.
*/
if (statePtr->refCount <= 0) {
| < < < < < < < < < | 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 |
* 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)) {
/*
| > < | > | | | | < | 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 | chanPtr->typePtr = NULL; /* * AK: Tcl_NotifyChannel may hold a reference to this block of memory */ Tcl_EventuallyFree(chanPtr, TCL_DYNAMIC); | | | 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 |
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?
*/
| > > | > | | | | | | 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 |
}
}
/*
* If we reached this code we return the buffer to the OS.
*/
| | | 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 |
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. */
| < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < | < < < | | < > | 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 | /* * When we get an error we throw away all the output currently * queued. */ DiscardOutputQueued(statePtr); | > | > > < | < > | > > > > > > > > > > > > > | 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 |
DiscardInputQueued(statePtr, 1);
/*
* Discard a leftover buffer in the current output buffer field.
*/
if (statePtr->curOutPtr != NULL) {
| | | 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 |
/*
* When the channel has an escape sequence driven encoding such as
* iso2022, the terminated escape sequence must write to the buffer.
*/
stickyError = 0;
| | > > | > > | | > > > > | 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 |
statePtr->closeCbPtr = cbPtr->nextPtr;
cbPtr->proc(cbPtr->clientData);
ckfree(cbPtr);
}
ResetFlag(statePtr, CHANNEL_INCLOSE);
| < < < < < < < < | 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 |
if (stickyError != 0) {
Tcl_SetErrno(stickyError);
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj(Tcl_PosixError(interp), -1));
}
| > > > > > > > > | > > | 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 |
/*
* 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) {
| < < < < | 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 |
/* 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;
| < < < < < < < < | 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 |
}
}
static int
WillRead(
Channel *chanPtr)
{
if ((chanPtr->typePtr->seekProc != NULL)
&& (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 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 | } result |= Tcl_UtfToExternal(NULL, encoding, nl, nlLen, statePtr->outputEncodingFlags, &statePtr->outputEncodingState, dst, dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); | | < < | 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 |
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)))) {
| > > < | 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 |
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) {
| | < > | 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 |
gotEOL:
/*
* Regenerate the top channel, in case it was changed due to
* self-modifying reflected transforms.
*/
| > > | > > | 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 |
*/
restore:
/*
* Regenerate the top channel, in case it was changed due to
* self-modifying reflected transforms.
*/
| | > | > | | > | < | | 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 |
*/
done:
/*
* Regenerate the top channel, in case it was changed due to
* self-modifying reflected transforms.
*/
| | > | > | > | 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 |
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.
*/
| | | | < < > > > | 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 |
* 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;
| | > | < | | 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 |
FilterInputBytes(
Channel *chanPtr, /* Channel to read. */
GetsState *gsPtr) /* Current state of gets operation. */
{
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
ChannelBuffer *bufPtr;
| | | 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 |
/*
* 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:
| < < < < < < < < > > > > > | < | 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 |
* 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
| | > > > > > > | 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 |
*
*----------------------------------------------------------------------
*/
int
Tcl_ReadRaw(
Tcl_Channel chan, /* The channel from which to read. */
| | < | < < < < < < < < < < < < | < < < | | > > | < < < | < < | | < < | < < < < > > | < > | > | > | < < < | < | < < < < < < < < < | < < < | > | < > | < < < < < < < < < | < | | < < < < < < < < < < < < < > > > | < < | > > > | > > > | > | | | | | > > > > | < | | < < < < < < < < < | 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 |
* 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;
| | > > > > > > | > > < < < < < < | | | > | | | < | 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 |
}
}
if (copiedNow < 0) {
if (GotFlag(statePtr, CHANNEL_EOF)) {
break;
}
| | | | | > > > | > < | | < | > > > > > > | > | < > > > > > | > | < < < < < < < < < > | | < < < > | < < < < < | < < < < < < | < | < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < | < | | 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 |
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
| | | | | | | < < | | < | < < | | | | > > > | < | > > | > | > | | > > > > > > > > | | | < > > > > > > > | < > > > > > | > > > | > > > > < < < | | | > | > > > > > > | | > > | > | | < < > > | | < < | > > > > > > | | < | < < > | | | | | > > | | | < < | | > > | | | | | | | < > | < > > | < | | | | > > > > > > | > | < | > > > > > | > > | > > > > > > | > > | < > > | | > | | | > > | < < | | > | | < > | > > > > > > > > > > > > > | | < | > > | > > > | | < < | | > > > > | > > > | | > > > > | > | | | | < > > > > > | > > | | < | > | > | > > > > > > > > > | > | | | | | < < < | > > > > | < < | > > > > > > > > > > > > > > > > > > > | | > | | | | | | | | | | | | | | | | | | | | | > | | < < < < < < < < < < < < < < | < < | | > | < < < < | < | < < < | < | < < < < < < < | < | < < < < < | > | < | | < | < | | < | | | | < < > > | | > > > > > | | < < | | > | | | < | | | > > > > > | > > > > > > | < < | | | < < | | < < | | < > | < > | | | < | | | | < | | > | > > > > | > > > > | | < | < | < | < | | < < > > > > | | > | | | | < < < | | | < < | < > | | < > > | | < < < < | 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 |
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
len = -1;
goto done;
}
statePtr->flags = flags;
/*
| < < | < | < < | | 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 |
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
return -1;
}
| < < < < < < < < | 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 |
/*
* If discardSavedBuffers is nonzero, must also discard any previously
* saved buffer in the saveInBufPtr field.
*/
if (discardSavedBuffers && statePtr->saveInBufPtr != NULL) {
| | > > > | 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 |
* 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.
| > > > > > > > > > > > > < < < < < < | > | | < | | | < < < < < < < < < < < < < < > | | < < < < | < < | | < < < < < < < | < < < < < < | | | < < < < | < | < < < < < < < < < | < < < < < < < < < < < < < < < < < < | < < | 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 |
}
ResetFlag(statePtr, CHANNEL_NONBLOCKING);
if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
}
}
| < < < < < < < < < | 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 |
if (BUSY_STATE(statePtr, flags) && ((flags & CHANNEL_RAW_MODE) == 0)) {
Tcl_SetErrno(EBUSY);
return -1;
}
if (direction == TCL_READABLE) {
| < < < < < < < < | < < | 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 |
} 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.
*/
| > | > > | 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 |
} else if (chanPtr->typePtr->setOptionProc != NULL) {
return chanPtr->typePtr->setOptionProc(chanPtr->instanceData, interp,
optionName, newValue);
} else {
return Tcl_BadChannelOption(interp, optionName, NULL);
}
| < < < < < < < < < < < < < < < < | 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 |
/* State info for channel */
ChannelHandler *chPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
NextChannelHandler nh;
Channel *upChanPtr;
const Tcl_ChannelType *upTypePtr;
| < < < < < < < < < < < < < < < | 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 |
/*
* 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)) {
| | | > | 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 |
/*
* 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);
| < < < < < < < < < < < < < < < < < < < < < | 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 | } /* *---------------------------------------------------------------------- * * DoRead -- * | > > | | > | > > > > > > > > | | | < < < < < > > | < < > | | < > | | < | < < < < < > | < < < < < < < < < > < < | < < | < > | | | | < < | | < | | < < | < < < < < < < < < < < < | < < > | < < > > > | < < < < < < | < < < < < < < | | < < < < < | | | > | < | | < < < < < | | < < < | | | | > | < < < < | < < < | < < < < | > | < < < < | < < < < < < < < < < | < < > | | < < | < | < | < | | < | | < < | < < | < | < < < < < < < < < < < < < | < > > | < > | > > > < < < | < > | | | < < < > | < < | < | | < < < < | < | > | < < > | < < | | < < | < < > > | | < < < < < | < < < < < < | < | < < < < < < < | | | | | | | < < < < < | < < | < < < < < < < < < < < < < < < < | < < < < < < < < < < < < | < < < < < < < | < < < < < < < < | < < < < < | < < < | < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < | | 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 |
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
*/
| > > > | | 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 |
#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);
| < < < < < < | 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 | #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. */ | < < < < < | 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 | #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". */ | < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
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)));
}
| > > | > | > > > | | 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 |
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.
*/
| > > > | > > | 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 |
keepNewline = 0;
ignoreStderr = 0;
for (skip = 1; skip < objc; skip++) {
string = TclGetString(objv[skip]);
if (string[0] != '-') {
break;
}
| | | | 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 |
TclGetString(objv[2])));
return TCL_ERROR;
}
toRead = -1;
cmdPtr = NULL;
for (i = 3; i < objc; i += 2) {
| | | 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 |
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);
| > > > > > > > > < < < | > > > > > | 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 |
* interpreters. */
{
Tcl_Obj *resObj; /* See below, switch (transmit). */
int resLen;
unsigned char *resBuf;
Tcl_InterpState state = NULL;
int res = TCL_OK;
| | > > > | < | < < < < | < < < | | | > > > > | > > > | | | | | | < | < < < < < < < | 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 |
/*
* 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.
*/
| > > | | | | 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 |
int gotBytes, read, copied;
Tcl_Channel downChan;
/*
* Should assert(dataPtr->mode & TCL_READABLE);
*/
| | > | | 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 |
if (dataPtr->maxRead >= 0) {
if (dataPtr->maxRead < toRead) {
toRead = dataPtr->maxRead;
}
} /* else: 'maxRead < 0' == Accept the current value of toRead. */
if (toRead <= 0) {
| | > | < | | > | < < | < < < < < < > > | < < < > > < < | < < | > > | > > > > | | | > > | 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 |
/*
* Catch a no-op.
*/
return 0;
}
if (ExecuteCallback(dataPtr, NULL, A_WRITE, UCHARP(buf), toWrite,
TRANSMIT_DOWN, P_NO_PRESERVE) != TCL_OK) {
*errorCodePtr = EINVAL;
| > | > | 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 |
* 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
| | < < < < < < < < < < | < < < < < < < < | < < < < | 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 | 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); | < | < < < > | 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 |
/*
* Now create the channel.
*/
rcId = NextHandle();
rcPtr = NewReflectedChannel(interp, cmdObj, mode, rcId);
| < < < < | | 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 |
Tcl_ResetResult(interp);
/*
* Everything is fine now.
*/
| > > | > > | 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 |
*/
Tcl_SetObjResult(interp,
Tcl_NewStringObj(chanPtr->state->channelName, -1));
return TCL_OK;
error:
| < < < | | | > | 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 |
*/
Tcl_DeleteEvents(ReflectEventDelete, rcPtr);
if (result != TCL_OK) {
FreeReceivedError(&p);
}
}
#endif
| > | | < | < | < < < < | < | 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 |
/*
* Now squash the pending reflection events for this channel.
*/
Tcl_DeleteEvents(ReflectEventDelete, rcPtr);
| < < | | 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 |
{
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' */
| < < < < < < < < < < < < | 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 |
/* ASSERT: rcPtr->mode & TCL_READABLE */
Tcl_Preserve(rcPtr);
toReadObj = Tcl_NewIntObj(toRead);
Tcl_IncrRefCount(toReadObj);
| | | 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 |
int *errorCodePtr)
{
ReflectedChannel *rcPtr = clientData;
Tcl_Obj *bufObj;
Tcl_Obj *resObj; /* Result data for 'write' */
int written;
| < < < < < < < < < < < < | 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 |
}
#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);
| > | > > > > > > > > | 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 |
offObj = Tcl_NewWideIntObj(offset);
baseObj = Tcl_NewStringObj(
(seekMode == SEEK_SET) ? "start" :
(seekMode == SEEK_CUR) ? "current" : "end", -1);
Tcl_IncrRefCount(offObj);
Tcl_IncrRefCount(baseObj);
| | | 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 |
ReflectWatch(
ClientData clientData,
int mask)
{
ReflectedChannel *rcPtr = clientData;
Tcl_Obj *maskObj;
| < < | 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 |
}
#endif
Tcl_Preserve(rcPtr);
maskObj = DecodeEventMask(mask);
/* assert maskObj.refCount == 1 */
| | | 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 |
#endif
blockObj = Tcl_NewBooleanObj(!nonblocking);
Tcl_IncrRefCount(blockObj);
Tcl_Preserve(rcPtr);
| | | 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 |
optionObj = Tcl_NewStringObj(optionName, -1);
valueObj = Tcl_NewStringObj(newValue, -1);
Tcl_IncrRefCount(optionObj);
Tcl_IncrRefCount(valueObj);
| | | 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 |
*/
ReflectedChannel *rcPtr = clientData;
Tcl_Obj *optionObj;
Tcl_Obj *resObj; /* Result data for 'configure' */
int listc, result = TCL_OK;
Tcl_Obj **listv;
| | | 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 |
#endif
if (optionName == NULL) {
/*
* Retrieve all options.
*/
| | | | 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 |
NewReflectedChannel(
Tcl_Interp *interp,
Tcl_Obj *cmdpfxObj,
int mode,
Tcl_Obj *handleObj)
{
ReflectedChannel *rcPtr;
| | < < < < < < < | < | < < < | < < < < < | < < | < < < | < < | | < < < < < < < < | | < < < < < < < < < | 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 |
Tcl_MutexLock(&rcCounterMutex);
resObj = Tcl_ObjPrintf("rc%lu", rcCounter);
rcCounter++;
Tcl_MutexUnlock(&rcCounterMutex);
return resObj;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | < | | | 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 |
*
*----------------------------------------------------------------------
*/
static int
InvokeTclMethod(
ReflectedChannel *rcPtr,
| | < > | 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 |
* See the contract as well.
*/
return TCL_ERROR;
}
/*
| < < < < < < | > | | | > < | < | < > | | 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 |
* 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) {
| < | > > < < < < < < < < < < | 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 | * Ignore entries for other interpreters. */ continue; } rcPtr->dead = 1; | < | 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 |
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;
| < | 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 |
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.
*/
| | > > | | > > > > > | > | | 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 |
case ForwardedOutput: {
Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *)
paramPtr->output.buf, paramPtr->output.toWrite);
Tcl_IncrRefCount(bufObj);
Tcl_Preserve(rcPtr);
| | | 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 |
(paramPtr->seek.seekMode==SEEK_SET) ? "start" :
(paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1);
Tcl_IncrRefCount(offObj);
Tcl_IncrRefCount(baseObj);
Tcl_Preserve(rcPtr);
| | | 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 |
}
case ForwardedWatch: {
Tcl_Obj *maskObj = DecodeEventMask(paramPtr->watch.mask);
/* assert maskObj.refCount == 1 */
Tcl_Preserve(rcPtr);
| | | | | | | 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 | * 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, | | < | 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 |
} /* else: 'maxRead < 0' == Accept the current value of toRead */
}
if (toRead <= 0) {
goto stop;
}
| > | > < < | < < > > | < > > > > > > > > < < < < < < < < < < | < < | < < < < < | < < | | | 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 | /* * The drain delivered nothing. */ 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 |
return copied;
}
static int
TransformRead(
ReflectedTransform *rtPtr,
int *errorCodePtr,
| | < < | | < < < < < | 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 | * 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" | | > > > > > > | 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 |
filesystemList = NULL;
/*
* Now filesystemList is NULL. This means that any attempt to use the
* filesystem is likely to fail.
*/
| | | 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 |
void
TclResetFilesystem(void)
{
filesystemList = &nativeFilesystemRecord;
theFilesystemEpoch++;
| | | 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 |
*/
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
return TCL_ERROR;
}
| | | 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 |
}
/*
* Try to delete the file immediately - this is possible in some OSes, and
* avoids any worries about leaving the copy laying around on exit.
*/
| > > | | 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 | * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. */ #ifndef _TCLINTPLATDECLS #define _TCLINTPLATDECLS | | | 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 |
extern "C" {
#endif
/*
* Exported function declarations:
*/
| | | 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 | /* 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 */ | | | 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 |
Tcl_Obj *resultingNameObj);
#endif /* MACOSX */
typedef struct TclIntPlatStubs {
int magic;
void *hooks;
| | | 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 |
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 */
| | | 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 | #if defined(USE_TCL_STUBS) /* * Inline function declarations: */ | | | 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 | /* Slot 27 is reserved */ /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* UNIX */ | | | 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 | #undef TclpLocaltime_unix #undef TclpGmtime_unix #undef TclWinConvertWSAError #define TclWinConvertWSAError TclWinConvertError #undef TclpInetNtoa #define TclpInetNtoa inet_ntoa | | > > > > > > | 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 |
code = TCL_OK;
if (pkgPtr->safeInterpRefCount <= 0 && pkgPtr->interpRefCount <= 0
&& !keepLibrary) {
/*
* Unload the shared library from the application memory...
*/
| | | 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 |
* subsystem left alive at this point is the memory allocator.
*/
while (firstPackagePtr != NULL) {
pkgPtr = firstPackagePtr;
firstPackagePtr = pkgPtr->nextPtr;
| | | 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 | /* * 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. */ | | | 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 | /* * This file is (mostly) automatically generated from tclOO.decls. */ #ifndef _TCLOODECLS #define _TCLOODECLS | | | | | > > > > | | | < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | #define Tcl_GetObjectName \ (tclOOStubsPtr->tcl_GetObjectName) /* 28 */ #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ | < < | 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 | /* * This file is (mostly) automatically generated from tclOO.decls. */ #ifndef _TCLOOINTDECLS #define _TCLOOINTDECLS | < < < < < < < < < < < | | | | | | | | | | | | | | | | | 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 | #define TclOOClassSetMixins \ (tclOOIntStubsPtr->tclOOClassSetMixins) /* 15 */ #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ | < < | 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 |
if (fsPathPtr->cwdPtr == NULL) {
return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr,
NULL);
}
if (PATHFLAGS(pathPtr) == 0) {
/* The path is not absolute... */
| | | 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 | Tcl_DecrRefCount(absolutePath); absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath); Tcl_IncrRefCount(absolutePath); /* * We have a refCount on the cwd. */ | | | | 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 |
extern "C" {
#endif
/*
* Exported function declarations:
*/
| | | 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 |
char *libraryPath);
#endif /* MACOSX */
typedef struct TclPlatStubs {
int magic;
void *hooks;
| | | 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 | #if defined(USE_TCL_STUBS) /* * Inline function declarations: */ | | | 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 |
if (length <= limit) {
toCopy = length;
} else {
if (ellipsis == NULL) {
ellipsis = "...";
}
| > | | 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 | /* * Protect against case where unicode points into the existing * stringPtr->unicode array. Force it to follow any relocations due to * the reallocs below. */ | | | 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 |
}
/*
* Copy the new string onto the end of the old string, then add the
* trailing null.
*/
| > | | > | 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 | /* * Protect against case where unicode points into the existing * stringPtr->unicode array. Force it to follow any relocations due to * the reallocs below. */ | | | 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 |
/*
* Invalidate the unicode data.
*/
stringPtr->numChars = -1;
stringPtr->hasUnicode = 0;
| > | > | 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 |
if (needed > stringPtr->maxChars) {
GrowUnicodeBuffer(objPtr, needed);
stringPtr = GET_STRING(objPtr);
}
stringPtr->hasUnicode = 1;
| > | > > > | 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 |
#undef TclWinNToHS
#define TclWinNToHS winNToHS
static unsigned short TclWinNToHS(unsigned short ns) {
return ntohs(ns);
}
#endif
| | > | > | > | > | > | | 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 |
TclSetSlaveCancelFlags, /* 250 */
TclRegisterLiteral, /* 251 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
TCL_STUB_MAGIC,
0,
| | | 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 |
0, /* 25 */
0, /* 26 */
0, /* 27 */
0, /* 28 */
TclWinCPUID, /* 29 */
TclUnixOpenTemporaryFile, /* 30 */
#endif /* UNIX */
| | | 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 |
TclUnixOpenTemporaryFile, /* 30 */
#endif /* MACOSX */
};
static const TclPlatStubs tclPlatStubs = {
TCL_STUB_MAGIC,
0,
| | | 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 |
Tcl_Panic, /* 2 */
Tcl_Alloc, /* 3 */
Tcl_Free, /* 4 */
Tcl_Realloc, /* 5 */
Tcl_DbCkalloc, /* 6 */
Tcl_DbCkfree, /* 7 */
Tcl_DbCkrealloc, /* 8 */
| | | | | | 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 |
Tcl_GetCommandName, /* 160 */
Tcl_GetErrno, /* 161 */
Tcl_GetHostName, /* 162 */
Tcl_GetInterpPath, /* 163 */
Tcl_GetMaster, /* 164 */
Tcl_GetNameOfExecutable, /* 165 */
Tcl_GetObjResult, /* 166 */
| | | | 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 | 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[]); | | | 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 |
#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);
| | | 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 |
}
len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len);
Tcl_SetObjResult(interp, Tcl_NewIntObj(len));
}
return TCL_OK;
}
| | | 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 | } /* *---------------------------------------------------------------------- * * TclFinalizeThreadData -- * | | > | > > > | 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 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#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 |
if (threadPtr->waitedUpon) {
Tcl_ConditionNotify(&threadPtr->cond);
}
Tcl_MutexUnlock(&threadPtr->threadMutex);
}
| | | 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 | 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); | | > > > > | 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 | * * 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 | | | 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 |
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. */
{
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | 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 |
if (interp != NULL) {
p2 = p;
while ((p2 < limit) && (!TclIsSpaceProc(*p2))
&& (p2 < p+20)) {
p2++;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | | 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 |
if (interp != NULL) {
p2 = p;
while ((p2 < limit) && (!TclIsSpaceProc(*p2))
&& (p2 < p+20)) {
p2++;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | | | | | | | | | 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 |
* 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) {
| < < < < < | < < < | < < < < < < < < < < | < < < < < | < < < < < < | < < < < < < | 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 |
set locale [string tolower $value]
}
-t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone {
set timezone $value
}
default {
return -code error \
| | | | 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 |
set locale [string tolower $b]
}
-t - -ti - -tim - -time - -timez - -timezo - -timezon -
-timezone {
set timezone $b
}
default {
| | | | 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 |
dict incr ::tcl::UnknownOptions -level
return -options $::tcl::UnknownOptions $::tcl::UnknownResult
}
if {[llength $cmds]} {
return -code error "ambiguous command name \"$name\": [lsort $cmds]"
}
}
| > | | 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 |
# 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}
| | | 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 |
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.
| | | 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 |
lassign $testResult actualAnswer returnCode
if {$returnCode == 1} {
set errorInfo(body) $::errorInfo
set errorCode(body) $::errorCode
}
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
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...
| | | 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 |
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
| | | | 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 |
} {}
test clock-1.4 "clock format - bad flag" {*}{
-body {
list [catch {clock format 0 -oops badflag} msg] $msg $::errorCode
}
-match glob
| | | 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 |
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
| | | 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 |
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
| | | | 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 |
} {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
| | | 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 |
test clock-65.1 {clock add, bad option [Bug 2481670]} {*}{
-body {
clock add 0 1 year -foo bar
}
-match glob
-returnCodes error
| | > > > > > > > > > | 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 |
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
| | | | 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 |
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
| | | | 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 |
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
| | | | | | | | 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 |
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
| | | | | 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 |
} -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
| | | 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 |
}}
} -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}}
| | | 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 |
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}
| | | 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 |
} {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
| > > > > > > > > > > > > > > > | | | | | 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 |
}
string range [append foo OK] end-1 end
}}
} OK
test dict-22.1 {dict with command} -body {
dict with
| | | | 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 |
}
}} [linenumber]}}
} 5
rename linenumber {}
test dict-24.1 {dict map command: syntax} -returnCodes error -body {
dict map
| | | | | | 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 |
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
| | | 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 |
# 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
| | | | 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 |
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}
| < < < < < < | 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 |
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
| | | | 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 |
proc myProgress {token total current} {
global progress httpLog
if {[info exists httpLog] && $httpLog} {
puts "progress $total $current"
}
set progress [list $total $current]
}
| < < < | | | | < | 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 |
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...
| | | 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 |
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} {
| | | 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 |
vwait [namespace which -variable x]
fconfigure $cs -blocking off
writelots $cs $l
close $cs
close $ss
vwait [namespace which -variable x]
set c
| | | 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 |
lappend l [tell $f]
# 4GB offset!
seek $f 0x100000000
lappend l [tell $f]
puts -nonewline $f abcdef
lappend l [tell $f]
close $f
| | | | 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 |
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
| | > > > > > > > > > > > > | | 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 |
} "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
}
| < < < < < < | 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 |
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
| | | 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 |
# 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
| < < | > > | < | 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 |
LOG MAIN_WAITING
vwait forever
LOG MAIN_DONE
set res
} -cleanup {
rename LOG {}
rename POST {}
rename HANDLER {}
| > | | 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 |
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
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 |
} -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
| | | < < | > > | 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 |
}
lappend trail [list counter:$op $data $res]
return $res
}
proc rblocks {var vtrail n op data} {
| | | 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 |
}
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
}
| > > > > > > > > > > > > > > > > > > > > | > | 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 |
set data [read $fin]
close $fin
set trail [list]
set got [list]
proc Done {args} {
variable stop 1
}
| < < | | | | | | | | > | | | | | | | > > > > > > > > > | 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 |
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]
| | | 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 |
}
namespace eval test_ns_import {
namespace import ::test_ns_export::*
proc p {} {return [cmd1 123]}
}
test_ns_import::p
} {cmd1: 123}
| | | 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 |
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}
| | | | 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 |
regexp .*d e
regexp .*e f
regexp .*e xe
} 1
test regexp-6.1 {regexp errors} {
list [catch {regexp a} msg] $msg
| | | | | 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 |
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
| | | | | | | 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 |
}
} 1
test regexpComp-6.1 {regexp errors} {
evalInProc {
list [catch {regexp a} msg] $msg
}
| | | | | 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 |
}
} "1 {da\nb123\nxb}"
test regexpComp-11.1 {regsub errors} {
evalInProc {
list [catch {regsub a b} msg] $msg
}
| | | | | | | 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 | 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] | | > > > > > > > > > > > > > | | 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 |
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}
}
| < > > > | 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 |
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.
| | | > | | < < < < | < < | < > > | 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 |
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
| | | < < < < | < < | < | > > | | 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 |
if {$remoteProcChan ne ""} {
catch {sendCommand exit}
}
catch {close $commandSocket}
catch {close $remoteProcChan}
}
unset ::tcl::unsupported::socketAF
| | | | > > > > > > > > > > > > > > > > > > > > > > | | | | < < | | | | < | | > | < < < | | | | | | > | | | > > | < < > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
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 {
| | | | 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 |
}} 12345
} {}
## string repeat
## not yet bc
## string replace
| > > | > > > > > > > > > > > > > > | 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 |
}
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
| | | 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 |
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
| | | | | 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 |
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
| | | 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 |
switch Foo {
Foo {$cmd}
}
} {INVOKED}
test switch-9.1 {empty pattern/body list} -returnCodes error -body {
switch x
| | | | | 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 |
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
| | < < < < < < < < < < < | 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 |
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
| < < < < < | 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 |
createfile tf1
testfile cp tf1 ""
} -cleanup {
cleanup
} -returnCodes error -result ENOENT
test winFCmd-2.7 {TclpCopyFile: errno: EACCES} -setup {
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 |
testchmod 000 tf2
testfile cp tf1 tf2
list [file writable tf2] [contents tf2]
} -cleanup {
catch {testchmod 666 tf2}
cleanup
} -result {1 tf1}
| < < < < < < < < < < < | 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 |
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
| < < < | 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 |
testchmod 000 td1
testfile rmdir td1
file exists td1
} -returnCodes error -cleanup {
catch {testchmod 666 td1}
cleanup
} -result {td1 EACCES}
| < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
file mkdir td1
createfile td1/tf1 tf1
testfile cpdir td1 td2
contents td2/tf1
} -cleanup {
cleanup
} -result {tf1}
| < < < < < | 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 |
file mkdir td1
createfile td1/tf1 tf1
testfile cpdir td1 td2
contents td2/tf1
} -cleanup {
cleanup
} -result {tf1}
| < < < < < < < < | 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 |
test winFCmd-9.1 {TraversalDelete: DOTREE_F} -setup {
cleanup
} -constraints {win testfile} -body {
file mkdir td1
createfile td1/tf1
testfile rmdir -force td1
} -result {}
| < < < < < < < < < | 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 |
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
| | | | 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 |
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 *
| < < < < < < < < < < < < < < < < < < | 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 |
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"
| < < < < | 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 |
puts $f $big
puts $f \032
flush $f
set r [read $f 64]
catch {close $f}
set r
} "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
| < < < < | 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 |
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}
| | | 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 |
# Results:
# Returns the original text inside an appropriate #ifdef.
proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} {
set text ""
switch $plat {
win {
| | | | 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 |
append text "#ifdef MAC_OSX_TK /* AQUA */\n${iftxt}"
if {$eltxt ne ""} {
append text "#else /* AQUA */\n${eltxt}"
}
append text "#endif /* AQUA */\n"
}
x11 {
| | | 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 | @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; | | | | 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 |
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
| | | | 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 | # 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 | > > | | | | | > > | 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 |
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
| | | | 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 |
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"])
| > > | | | | | > > | 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 | # 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/ | | | < | > | 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 | # 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@' | | | 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 | 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); | | | | | 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 |
*/
extern TclFileAttrProcs tclpFileAttrProcs[];
extern const char *const tclpFileAttrStrings[];
#else /* !DJGPP */
enum {
| > > > > > > > | | > > > > > > > > > > | | > > > > > > > > > | | > > > | 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 |
* an existing writable directory; we've no recovery mechanism if it
* isn't.
*/
return TCL_TEMPORARY_FILE_DIRECTORY;
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | 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 |
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
| | | | 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 |
{
PipeState *psPtr = instanceData;
int newmask;
if (psPtr->inFile) {
newmask = mask & (TCL_READABLE | TCL_EXCEPTION);
if (newmask) {
| | | | 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 |
} 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. */
| > > | | > > > > > | 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 | #define SOCKET_BUFSIZE 4096 /* * Static routines for this file: */ | | > | 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 |
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) {
| | | | > | > > > > | > > > > > > > > > > > | | < > > > | > > > > | > > | | > > > | | | | | | | | | < | > > > | > | > > | | | | | 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 |
* 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);
| > > < > > > | > > > > | | < | | | | | < < | | | < > > | > > | | 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 |
*
* 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;
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > | | | 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 | } /* *---------------------------------------------------------------------- * * TcpAsyncCallback -- * | | | | | 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 | * return and the loops resume as if they had never been interrupted. * For syncronously connecting sockets, the loops work the usual way. * *---------------------------------------------------------------------- */ static int | | | | | | | | < | | | | | | | > | | | | | < | | | > > | > | | | | > | | > | | | > > > | < | | < | < < | < | | | | | > > > > > | > > | > | 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 |
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. */
{
| | | 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 |
}
return NULL;
}
/*
* Allocate a new TcpState for this socket.
*/
| | | | | | | | | | | | | | | | 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 | @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; | | | | 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 | cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ | | | 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 | cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ | | | 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 |
MACHINE="X86"
if test "$GCC" = "yes"; then
AC_CACHE_CHECK(for cross-compile version of gcc,
ac_cv_cross,
AC_TRY_COMPILE([
| | | 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 |
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([
| | | 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 | # 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@' | | | 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 | MountPointMap *driveLetterLookup = NULL; TCL_DECLARE_MUTEX(mountPointMap) /* * We will need this below. */ | | | 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 |
* Tcl_Finalize explicitly before unloading Tcl.
*/
}
return TRUE;
}
#endif /* !STATIC_BUILD */
| | | 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 | 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); | | | 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 |
}
channel = NULL;
switch (FileGetType(handle)) {
case FILE_TYPE_SERIAL:
/*
* Reopen channel for OVERLAPPED operation. Normally this shouldn't
* fail, because the channel exists.
*/
| > > > > | | 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 |
type = FILE_TYPE_SERIAL;
}
}
}
return type;
}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
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. */
{
| | | > | | 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 |
*---------------------------------------------------------------------------
*/
ClientData
TclNativeCreateNativeRep(
Tcl_Obj *pathPtr)
{
| | | > | 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 |
if (validPathPtr == NULL) {
return NULL;
}
Tcl_IncrRefCount(validPathPtr);
}
str = Tcl_GetStringFromObj(validPathPtr, &len);
| | > > | | < > > > | | | > > > > | > > > > > > > > > > > > > > > > > > > > | | < > > > > > > > | > > > | > | < > > > > > > > > > > > > | 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 | static int ToUtf(const WCHAR *wSrc, char *dst); /* *--------------------------------------------------------------------------- * * TclpInitPlatform -- * | | | > > > | < < < < < < | | < | 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 | 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); | | | 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 | #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)) | < < < < < < < < < | 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 |
return 0;
}
/*
*----------------------------------------------------------------------
*
| | | | < | | | > > > > > > > > < < < > | 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 | * * (Ad 2) The main functions for this are SocketSetupProc() and * SocketCheckProc(). */ #include "tclWinInt.h" | < < < < < < < > > > > > > > > > > > > > < < < < < < < < < | 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 |
struct sockaddr_storage sas;
} address;
#ifndef IN6_ARE_ADDR_EQUAL
#define IN6_ARE_ADDR_EQUAL IN6_ADDR_EQUAL
#endif
| > > > > | | < < < < < | | | > > > | | > > | > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > | | < < < < < < < < < < < > > > > | | | | < | > | > > | | | | | | | | | | | | | | | | | | | | | | < | | > | | < < > | < | | < < < < < > | > > | > > > | > > | < < | > | < < | | < < < < | | < < < < < | < < < < | < > > > > | < < | > | < < | > > > | > | < < < > > | < | | < < | > > > > | < < < < < < < | | < > > | | | > > > > > > | > | < < < < < | < < < < < < < | | < > > > | | < < < < | > > | < > | > > | < > > | < | < > > | < < > > | | < | | < < < | | | > > < > > < < < < | < < < < < | < < < < < | | < | < | < < < < < < < < < < < | < < | > > | > > < | | < | | | < < | > > | 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 |
}
Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL);
}
/*
*----------------------------------------------------------------------
*
| | | | < < < > < < | > | > | < < > > | < < < > | | | < < < > | | | | < < < < < | > < < | < < < < < < < < | < > | < | < < < | < < < < < < < < < < | | < < < < | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | < > > > > > > > > > > > | > > > > | > > > > | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < > | | < | < < < | | | | | > | > > > > > > > > > | < < < < | | | | < < > | < < < < > | < > > | | < > > | | < < > > | | < | < > > > | | < | < < < < < | > | < | | > > | > | | < | > | < | | > | < | < < > | < < | | > | | > > | | | < < | < < < > | < < > | < > > > > > > > > | | < < < < < < < < > < > > | > > > | > > > > | | < | > > | > > > < < < < < > > > | < > > | | > > > | < < | | | | | < < | < < < | | > | | > > < < > | | | > | < > | | | > > > > > > > > | > | > > > > > | > > > > | > > > > > > > > | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > | > > > > | > > > > > > > > | | 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 |
/* ARGSUSED */
static int
TcpCloseProc(
ClientData instanceData, /* The socket to close. */
Tcl_Interp *interp) /* Unused. */
{
| | | | | | > > > > > > > > > > > > > > > > > > > > > > > > | | 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 |
static int
TcpClose2Proc(
ClientData instanceData, /* The socket to close. */
Tcl_Interp *interp, /* For error reporting. */
int flags) /* Flags that indicate which side to close. */
{
| | | > | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
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
| | | | | 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 | * 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 | | > | | > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > | < | > > > > | | | > > > > | | | > > > | | | | > > > > > > > > > > > | 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 |
socklen_t size;
int found = 0;
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-sockname");
Tcl_DStringStartSublist(dsPtr);
}
| | | 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 |
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. */
{
| | | | | | | | | | | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
HWND hwnd,
UINT message,
WPARAM wParam,
LPARAM lParam)
{
int event, error;
SOCKET socket;
| | > | 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 |
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.
*/
| > > < | | > > > > > > > > > > | > > > > > | | | | | | | | | | | | | | | | < < < < < < < | | | < | < | | | | < < < < < < | < > | | | | < | | < < < | | < | | 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 |
return 0;
}
/*
*----------------------------------------------------------------------
*
| | | > < | < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < | < < < < | < | < < | < < < < | | | < < < < < | < | | < < < < < | < | > | > > < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < | 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 |
static void
TcpThreadActionProc(
ClientData instanceData,
int action)
{
ThreadSpecificData *tsdPtr;
| | | | > > > > > | | | | 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 |
/*
* Ensure that, or stop, notifications for the socket occur in this
* thread.
*/
SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
| | > > | 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 | # define USE_TCL_STUBS #endif #include "tclInt.h" /* * For TestplatformChmod on Windows */ | | | 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 |
| ︙ | ︙ |