Tcl Source Code

Check-in [29d29484d0]
Login
EuroTcl/OpenACS 11 - 12 JULY 2024, VIENNA

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

Overview
Comment:Merge 9.0
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | tip-626
Files: files | file ages | folders
SHA3-256: 29d29484d05da0d69e43de4675f1e16074fa484fdf2b2070f74d4000ceb024f3
User & Date: jan.nijtmans 2024-06-20 18:22:43
Original Comment: Merge 8.7
Context
2024-06-20
18:22
Merge 9.0 Leaf check-in: 29d29484d0 user: jan.nijtmans tags: tip-626
2024-06-19
16:39
Fix [7be97a6859]: Reviewing chan.n changes check-in: 9453353b55 user: jan.nijtmans tags: trunk, main
2024-06-11
07:52
Merge 9.0 check-in: 121c2ead8c user: jan.nijtmans tags: tip-626
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to doc/CrtCommand.3.

98
99
100
101
102
103
104
105

106


107
108
109
110
111
112
113
114
point to constant strings or may be shared with other parts of the
interpreter.
Note also that the argument strings are encoded in normalized UTF-8 since
version 8.1 of Tcl.
.PP
\fIProc\fR must return an integer code that is expected to be one of
\fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or
\fBTCL_CONTINUE\fR.  See the Tcl overview man page

for details on what these codes mean.  Most normal commands will only


return \fBTCL_OK\fR or \fBTCL_ERROR\fR.  In addition, \fIproc\fR must set
the interpreter result;
in the case of a \fBTCL_OK\fR return code this gives the result
of the command, and in the case of \fBTCL_ERROR\fR it gives an error message.
The \fBTcl_SetResult\fR procedure provides an easy interface for setting
the return value;  for complete details on how the interpreter result
field is managed, see the \fBTcl_Interp\fR man page.
Before invoking a command procedure,







|
>
|
>
>
|







98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
point to constant strings or may be shared with other parts of the
interpreter.
Note also that the argument strings are encoded in normalized UTF-8 since
version 8.1 of Tcl.
.PP
\fIProc\fR must return an integer code that is expected to be one of
\fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or
\fBTCL_CONTINUE\fR. See the \fBreturn\fR man page for details on
what these codes mean and the use of extended values for an extension's
private use. Most normal commands will only return \fBTCL_OK\fR
or \fBTCL_ERROR\fR.
.PP
In addition, \fIproc\fR must set
the interpreter result;
in the case of a \fBTCL_OK\fR return code this gives the result
of the command, and in the case of \fBTCL_ERROR\fR it gives an error message.
The \fBTcl_SetResult\fR procedure provides an easy interface for setting
the return value;  for complete details on how the interpreter result
field is managed, see the \fBTcl_Interp\fR man page.
Before invoking a command procedure,

Changes to doc/CrtObjCmd.3.

128
129
130
131
132
133
134
135
136

137

138
139
140
141
142
143
144
\fBTcl_GetIntFromObj\fR on \fIobjv\fR[\fB2\fR] to obtain the integer
representation of that value; that call may change the type of the value
that \fIobjv\fR[\fB2\fR] points at, but will not change where
\fIobjv\fR[\fB2\fR] points.
.PP
\fIproc\fR must return an integer code that is either \fBTCL_OK\fR,
\fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR.
See the Tcl overview man page
for details on what these codes mean.  Most normal commands will only

return \fBTCL_OK\fR or \fBTCL_ERROR\fR.

In addition, if \fIproc\fR needs to return a non-empty result,
it can call \fBTcl_SetObjResult\fR to set the interpreter's result.
In the case of a \fBTCL_OK\fR return code this gives the result
of the command,
and in the case of \fBTCL_ERROR\fR this gives an error message.
Before invoking a command procedure,
\fBTcl_EvalObjEx\fR sets interpreter's result to







<
|
>
|
>







128
129
130
131
132
133
134

135
136
137
138
139
140
141
142
143
144
145
\fBTcl_GetIntFromObj\fR on \fIobjv\fR[\fB2\fR] to obtain the integer
representation of that value; that call may change the type of the value
that \fIobjv\fR[\fB2\fR] points at, but will not change where
\fIobjv\fR[\fB2\fR] points.
.PP
\fIproc\fR must return an integer code that is either \fBTCL_OK\fR,
\fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR.

See the \fBreturn\fR man page for details on what these codes mean and the
use of extended values for an extension's private use. Most normal commands
will only return \fBTCL_OK\fR or \fBTCL_ERROR\fR.
.PP
In addition, if \fIproc\fR needs to return a non-empty result,
it can call \fBTcl_SetObjResult\fR to set the interpreter's result.
In the case of a \fBTCL_OK\fR return code this gives the result
of the command,
and in the case of \fBTCL_ERROR\fR this gives an error message.
Before invoking a command procedure,
\fBTcl_EvalObjEx\fR sets interpreter's result to

Changes to doc/ObjectType.3.

150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
.CE
where the contents are exactly the existing contents of the union in the
\fIinternalRep\fR field of the \fITcl_Obj\fR struct.
This definition permits us to pass internal representations and pointers to
them as arguments and results in public routines.
.SH "THE TCL_OBJTYPE STRUCTURE"
.PP
Extension writers can define new value types by defining four to eight
procedures and initializing a Tcl_ObjType structure to describe the
type.  Extension writers may also pass a pointer to their Tcl_ObjType
structure to \fBTcl_RegisterObjType\fR if they wish to permit other
extensions to look up their Tcl_ObjType by name with the
\fBTcl_GetObjType\fR routine.  The \fBTcl_ObjType\fR structure is
defined as follows:
.PP







|







150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
.CE
where the contents are exactly the existing contents of the union in the
\fIinternalRep\fR field of the \fITcl_Obj\fR struct.
This definition permits us to pass internal representations and pointers to
them as arguments and results in public routines.
.SH "THE TCL_OBJTYPE STRUCTURE"
.PP
Extension writers can define new value types by defining four to twelve
procedures and initializing a Tcl_ObjType structure to describe the
type.  Extension writers may also pass a pointer to their Tcl_ObjType
structure to \fBTcl_RegisterObjType\fR if they wish to permit other
extensions to look up their Tcl_ObjType by name with the
\fBTcl_GetObjType\fR routine.  The \fBTcl_ObjType\fR structure is
defined as follows:
.PP

Changes to doc/SaveInterpState.3.

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
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright)
'\" Copyright (c) 2018 Nathan Coulter.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH Tcl_SaveInterpState 3 8.1 Tcl "Tcl Library Procedures"
.so man.macros
.BS
.SH NAME
Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState \- Save and restore the
state of an an interpreter.
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_InterpState
\fBTcl_SaveInterpState\fR(\fIinterp, status\fR)
.sp
int
\fBTcl_RestoreInterpState\fR(\fIinterp, state\fR)
.sp
\fBTcl_DiscardInterpState\fR(\fIstate\fR)
.fi
.SH ARGUMENTS
.AS Tcl_InterpState savedPtr
.AP Tcl_Interp *interp in
The interpreter for the operation.
.AP int status in
The return code for the state.
.AP Tcl_InterpState state in
A token for saved state.
.BE
.SH DESCRIPTION
.PP

These routines save the state of an interpreter before a call to a routine such
as \fBTcl_Eval\fR, and restore the state afterwards.

.PP
\fBTcl_SaveInterpState\fR saves the parts of \fIinterp\fR that comprise the








result of a script, including the resulting value, the return code passed as

\fIstatus\fR, and any options such as \fB\-errorinfo\fR and \fB\-errorcode\fR.
It returns a token for the saved state.  The interpreter result is not reset


and no interpreter state is changed.
.PP
\fBTcl_RestoreInterpState\fR restores the state indicated by \fIstate\fR and

returns the \fIstatus\fR originally passed in the corresponding call to

\fBTcl_SaveInterpState\fR.

.PP
If a saved state is not restored, \fBTcl_DiscardInterpState\fR must be called

to release it.  A token used to discard or restore state must not be used
again.





.SH KEYWORDS
result, state, interp



<








|
<















|

|

|



>
|
|
>

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

|
>
|
>
|
>

|
>
|
|
>
>
>
>
>


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
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\" Contributions from Don Porter, NIST, 2004. (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.
'\"
.TH Tcl_SaveInterpState 3 8.1 Tcl "Tcl Library Procedures"
.so man.macros
.BS
.SH NAME
Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState \- save and restore an interpreter's state

.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_InterpState
\fBTcl_SaveInterpState\fR(\fIinterp, status\fR)
.sp
int
\fBTcl_RestoreInterpState\fR(\fIinterp, state\fR)
.sp
\fBTcl_DiscardInterpState\fR(\fIstate\fR)
.fi
.SH ARGUMENTS
.AS Tcl_InterpState savedPtr
.AP Tcl_Interp *interp in
Interpreter for which state should be saved.
.AP int status in
Return code value to save as part of interpreter state.
.AP Tcl_InterpState state in
Saved state token to be restored or discarded.
.BE
.SH DESCRIPTION
.PP
These routines allows a C procedure to take a snapshot of the current
state of an interpreter so that it can be restored after a call
to \fBTcl_Eval\fR or some other routine that modifies the interpreter
state.
.PP
\fBTcl_SaveInterpState\fR stores a snapshot of the interpreter state in
an opaque token returned by \fBTcl_SaveInterpState\fR.  That token
value may then be passed back to one of \fBTcl_RestoreInterpState\fR
or \fBTcl_DiscardInterpState\fR, depending on whether the interp
state is to be restored.  So long as one of the latter two routines
is called, Tcl will take care of memory management.
.PP
\fBTcl_SaveInterpState\fR takes a snapshot of those portions of
interpreter state that make up the full result of script evaluation.
This include the interpreter result, the return code (passed in
as the \fIstatus\fR argument, and any return options, including
\fB\-errorinfo\fR and \fB\-errorcode\fR when an error is in progress.

This snapshot is returned as an opaque token of type \fBTcl_InterpState\fR.
The call to \fBTcl_SaveInterpState\fR does not itself change the
state of the interpreter.
.PP
\fBTcl_RestoreInterpState\fR accepts a \fBTcl_InterpState\fR token
previously returned by \fBTcl_SaveInterpState\fR and restores the
state of the interp to the state held in that snapshot.  The return
value of \fBTcl_RestoreInterpState\fR is the status value originally
passed to \fBTcl_SaveInterpState\fR when the snapshot token was
created.
.PP
\fBTcl_DiscardInterpState\fR is called to release a \fBTcl_InterpState\fR
token previously returned by \fBTcl_SaveInterpState\fR when that
snapshot is not to be restored to an interp.
.PP
The \fBTcl_InterpState\fR token returned by \fBTcl_SaveInterpState\fR
must eventually be passed to either \fBTcl_RestoreInterpState\fR
or \fBTcl_DiscardInterpState\fR to avoid a memory leak.  Once
the \fBTcl_InterpState\fR token is passed to one of them, the
token is no longer valid and should not be used anymore.
.SH KEYWORDS
result, state, interp

Changes to doc/SetResult.3.

230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
.PP
\fBTcl_GetStringResult\fR does not manipulate reference counts, but the string
it returns is owned by (and has a lifetime controlled by) the current
interpreter result value; it should be copied instead of being relied upon to
persist after the next Tcl API call, as most Tcl operations can modify the
interpreter result.
.PP
\fBTcl_SetResult\fR, \fBTcl_AppendResult\fR, \fBTcl_AppendResultVA\fR,
\fBTcl_AppendElement\fR, and \fBTcl_ResetResult\fR all modify the interpreter
result. They may cause the old interpreter result to have its reference count
decremented and a new interpreter result to be allocated. After they have been
called, the reference count of the interpreter result is guaranteed to be 1.
.SH "SEE ALSO"
Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp,
Tcl_GetReturnOptions







|







230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
.PP
\fBTcl_GetStringResult\fR does not manipulate reference counts, but the string
it returns is owned by (and has a lifetime controlled by) the current
interpreter result value; it should be copied instead of being relied upon to
persist after the next Tcl API call, as most Tcl operations can modify the
interpreter result.
.PP
\fBTcl_SetResult\fR, \fBTcl_AppendResult\fR,
\fBTcl_AppendElement\fR, and \fBTcl_ResetResult\fR all modify the interpreter
result. They may cause the old interpreter result to have its reference count
decremented and a new interpreter result to be allocated. After they have been
called, the reference count of the interpreter result is guaranteed to be 1.
.SH "SEE ALSO"
Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp,
Tcl_GetReturnOptions

Changes to doc/StringObj.3.

15
16
17
18
19
20
21

22
23

24
25
26
27
28
29
30
.sp
Tcl_Obj *
\fBTcl_NewStringObj\fR(\fIbytes, length\fR)
.sp
Tcl_Obj *
\fBTcl_NewUnicodeObj\fR(\fIunicode, numChars\fR)
.sp

\fBTcl_SetStringObj\fR(\fIobjPtr, bytes, length\fR)
.sp

\fBTcl_SetUnicodeObj\fR(\fIobjPtr, unicode, numChars\fR)
.sp
char *
\fBTcl_GetStringFromObj\fR(\fIobjPtr, lengthPtr\fR)
.sp
char *
\fBTcl_GetString\fR(\fIobjPtr\fR)







>


>







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
.sp
Tcl_Obj *
\fBTcl_NewStringObj\fR(\fIbytes, length\fR)
.sp
Tcl_Obj *
\fBTcl_NewUnicodeObj\fR(\fIunicode, numChars\fR)
.sp
void
\fBTcl_SetStringObj\fR(\fIobjPtr, bytes, length\fR)
.sp
void
\fBTcl_SetUnicodeObj\fR(\fIobjPtr, unicode, numChars\fR)
.sp
char *
\fBTcl_GetStringFromObj\fR(\fIobjPtr, lengthPtr\fR)
.sp
char *
\fBTcl_GetString\fR(\fIobjPtr\fR)
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
.sp
Tcl_Size
\fBTcl_GetCharLength\fR(\fIobjPtr\fR)
.sp
Tcl_Obj *
\fBTcl_GetRange\fR(\fIobjPtr, first, last\fR)
.sp

\fBTcl_AppendToObj\fR(\fIobjPtr, bytes, length\fR)
.sp

\fBTcl_AppendUnicodeToObj\fR(\fIobjPtr, unicode, numChars\fR)
.sp

\fBTcl_AppendObjToObj\fR(\fIobjPtr, appendObjPtr\fR)
.sp

\fBTcl_AppendStringsToObj\fR(\fIobjPtr, string, string, ... \fB(char *)NULL\fR)
.sp

\fBTcl_AppendLimitedToObj\fR(\fIobjPtr, bytes, length, limit, ellipsis\fR)
.sp
Tcl_Obj *
\fBTcl_Format\fR(\fIinterp, format, objc, objv\fR)
.sp
int
\fBTcl_AppendFormatToObj\fR(\fIinterp, objPtr, format, objc, objv\fR)
.sp
Tcl_Obj *
\fBTcl_ObjPrintf\fR(\fIformat, ...\fR)
.sp

\fBTcl_AppendPrintfToObj\fR(\fIobjPtr, format, ...\fR)
.sp

\fBTcl_SetObjLength\fR(\fIobjPtr, newLength\fR)
.sp
int
\fBTcl_AttemptSetObjLength\fR(\fIobjPtr, newLength\fR)
.sp
Tcl_Obj *
\fBTcl_ConcatObj\fR(\fIobjc, objv\fR)







>


>


>


>


>











>


>







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
.sp
Tcl_Size
\fBTcl_GetCharLength\fR(\fIobjPtr\fR)
.sp
Tcl_Obj *
\fBTcl_GetRange\fR(\fIobjPtr, first, last\fR)
.sp
void
\fBTcl_AppendToObj\fR(\fIobjPtr, bytes, length\fR)
.sp
void
\fBTcl_AppendUnicodeToObj\fR(\fIobjPtr, unicode, numChars\fR)
.sp
void
\fBTcl_AppendObjToObj\fR(\fIobjPtr, appendObjPtr\fR)
.sp
void
\fBTcl_AppendStringsToObj\fR(\fIobjPtr, string, string, ... \fB(char *)NULL\fR)
.sp
void
\fBTcl_AppendLimitedToObj\fR(\fIobjPtr, bytes, length, limit, ellipsis\fR)
.sp
Tcl_Obj *
\fBTcl_Format\fR(\fIinterp, format, objc, objv\fR)
.sp
int
\fBTcl_AppendFormatToObj\fR(\fIinterp, objPtr, format, objc, objv\fR)
.sp
Tcl_Obj *
\fBTcl_ObjPrintf\fR(\fIformat, ...\fR)
.sp
void
\fBTcl_AppendPrintfToObj\fR(\fIobjPtr, format, ...\fR)
.sp
void
\fBTcl_SetObjLength\fR(\fIobjPtr, newLength\fR)
.sp
int
\fBTcl_AttemptSetObjLength\fR(\fIobjPtr, newLength\fR)
.sp
Tcl_Obj *
\fBTcl_ConcatObj\fR(\fIobjc, objv\fR)

Changes to doc/Thread.3.

72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
.AP int *result out
The referred storage is used to place the exit code of the thread
waited upon into it.
.BE
.SH INTRODUCTION
Beginning with the 8.1 release, the Tcl core is thread safe, which
allows you to incorporate Tcl into multithreaded applications without
customizing the Tcl core.  Starting with the 8.6 release, Tcl
multithreading support is on by default. To disable Tcl multithreading
support, you must include the \fB\-\|\-disable-threads\fR option to
\fBconfigure\fR when you configure and compile your Tcl core.
.PP
An important constraint of the Tcl threads implementation is that
\fIonly the thread that created a Tcl interpreter can use that
interpreter\fR.  In other words, multiple threads can not access
the same Tcl interpreter.  (However, a single thread can safely create
and use multiple interpreters.)
.SH DESCRIPTION







|
<
<
<







72
73
74
75
76
77
78
79



80
81
82
83
84
85
86
.AP int *result out
The referred storage is used to place the exit code of the thread
waited upon into it.
.BE
.SH INTRODUCTION
Beginning with the 8.1 release, the Tcl core is thread safe, which
allows you to incorporate Tcl into multithreaded applications without
customizing the Tcl core.



.PP
An important constraint of the Tcl threads implementation is that
\fIonly the thread that created a Tcl interpreter can use that
interpreter\fR.  In other words, multiple threads can not access
the same Tcl interpreter.  (However, a single thread can safely create
and use multiple interpreters.)
.SH DESCRIPTION

Changes to doc/catch.n.

26
27
28
29
30
31
32
33
34
35


36
37
38
39
40
41
42
43
value corresponding to the exceptional return code returned by evaluation
of \fIscript\fR.  Tcl defines the normal return code from script
evaluation to be zero (0), or \fBTCL_OK\fR.  Tcl also defines four exceptional
return codes: 1 (\fBTCL_ERROR\fR), 2 (\fBTCL_RETURN\fR), 3 (\fBTCL_BREAK\fR),
and 4 (\fBTCL_CONTINUE\fR).  Errors during evaluation of a script are indicated
by a return code of \fBTCL_ERROR\fR.  The other exceptional return codes are
returned by the \fBreturn\fR, \fBbreak\fR, and \fBcontinue\fR commands
and in other special situations as documented.  Tcl packages can define
new commands that return other integer values as return codes as well,
and scripts that make use of the \fBreturn \-code\fR command can also


have return codes other than the five defined by Tcl.
.PP
If the \fIresultVarName\fR argument is given, then the variable it names is
set to the result of the script evaluation.  When the return code from the
script is 1 (\fBTCL_ERROR\fR), the value stored in \fIresultVarName\fR is an
error message.  When the return code from the script is 0 (\fBTCL_OK\fR), the
value stored in \fIresultVarName\fR is the value returned from \fIscript\fR.
.PP







|
|
|
>
>
|







26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
value corresponding to the exceptional return code returned by evaluation
of \fIscript\fR.  Tcl defines the normal return code from script
evaluation to be zero (0), or \fBTCL_OK\fR.  Tcl also defines four exceptional
return codes: 1 (\fBTCL_ERROR\fR), 2 (\fBTCL_RETURN\fR), 3 (\fBTCL_BREAK\fR),
and 4 (\fBTCL_CONTINUE\fR).  Errors during evaluation of a script are indicated
by a return code of \fBTCL_ERROR\fR.  The other exceptional return codes are
returned by the \fBreturn\fR, \fBbreak\fR, and \fBcontinue\fR commands
and in other special situations as documented.
New commands defined by Tcl packages as well as scripts that make
use of the \fBreturn \-code\fR  command can return other integer
values as the return code. These must however lie outside the range
reserved for Tcl as documented for the \fBreturn\fR command.

.PP
If the \fIresultVarName\fR argument is given, then the variable it names is
set to the result of the script evaluation.  When the return code from the
script is 1 (\fBTCL_ERROR\fR), the value stored in \fIresultVarName\fR is an
error message.  When the return code from the script is 0 (\fBTCL_OK\fR), the
value stored in \fIresultVarName\fR is the value returned from \fIscript\fR.
.PP

Changes to doc/chan.n.

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

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
'\"
'\" Copyright (c) 2005-2006 Donal K. Fellows
'\" Copyright (c) 2021 Nathan Coulter
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
.TH chan n 8.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
chan \- Reads, writes and manipulates channels.
.SH SYNOPSIS
\fBchan \fIoperation\fR ?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
\fBchan\fR provides several operations for reading from, writing to, and
otherwise manipulating channels, e.g. those created by \fBopen\fR and

\fBsocket\fR, or the default channels \fBstdin\fR, \fBstdout\fR or \fBstderr\fR
which correspond respectively to the standard input, output, and error streams

of the process.  Any unique abbreviation for \fIoperation\fR is acceptable.
Available operations are:
.\" METHOD: blocked
.TP
\fBchan blocked \fIchannelName\fR
.
Returns 1 when the channel is in non-blocking mode and the last input operation
on the channel failed because it would have otherwise caused the process to
block, and 0 otherwise.  Each Tcl channel is in blocking mode unless configured
otherwise.


.\" METHOD: close
.TP
\fBchan close \fIchannelName\fR ?\fIdirection\fR?
.
Closes and destroys the named channel deleting any existing event handlers
established for the channel. The command returns the empty string. If
\fIdirection\fR is given, it is \fBread\fR, or \fBwrite\fR, or any unique
abbreviation of those words, and only that side of the channel is closed. I.e. a
read-write channel may become read-only or write-only. Closing a read-only


channel for reading, or closing a write-only channel for writing is the same as

simply closing the channel. It is an error to close a read-only channel for
writing or to close a write-only channel for reading.
.RS
.PP
When a channel is closed for writing, any buffered output on the channel is

flushed. When a channel is closed for reading, any buffered input is discarded.
When a channel is destroyed the underlying resource is closed and the channel
is thereafter unavailable.

.PP
\fBchan close\fR fully flushes any output before closing the write side of a


channel unless it is non-blocking mode, where it returns immediately and the
channel is flushed in the background before finally being closed.

.PP
\fBchan close\fR may return an error if an error occurs while flushing
output.  If a process in a command pipeline created by \fBopen\fR returns an
error (either by returning a non-zero exit code or writing to its standard
error file descriptor), \fBchan close\fR generates an error in the same
manner as \fBexec\fR.
.PP
Closing one side of a socket or command pipeline may lead to the shutdown() or
close() of the underlying system resource, leading to a reaction from whatever

is on the other side of the pipeline or socket.






.PP

If the channel for a command pipeline is in blocking mode, \fBchan close\fR
waits for the connected processes to complete.

.PP
\fBchan close\fR only affects the current interpreter.  If the channel is open
in any other interpreter, its state is unchanged there.  See \fBinterp\fR for a
description of channel sharing.




.PP
When the last interpreter sharing a channel is destroyed, the channel is
switched to blocking mode and fully flushed and then closed.




.PP
Channels are automatically closed when an interpreter is destroyed and
when the process exits.
From 8.6 on (TIP#398), nonblocking channels are no longer switched to
blocking mode when exiting; this guarantees a timely exit even when the
peer or a communication channel is stalled. To ensure proper flushing of
stalled nonblocking channels on exit, one must now either (a) actively
switch them back to blocking or (b) use the environment variable
\fBTCL_FLUSH_NONBLOCKING_ON_EXIT\fR, which when set and not equal to
.QW \fB0\fR
restores the previous behavior.
.RE
.\" METHOD: configure
.TP
\fBchan configure \fIchannelName\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?...
.
Configures or retrieves the configuration of the channel \fIchannelName\fR.

.RS
.PP
If no \fIoptionName\fR or \fIvalue\fR arguments are given,
\fBchan configure\fR returns a dictionary of option names and
values for the channel.  If \fIoptionName\fR is supplied without a \fIvalue\fR,
\fBchan configure\fR returns the current value of the named option.  If one or
more pairs of \fIoptionName\fR and \fIvalue\fR are supplied,
\fBchan configure\fR sets each of the named options to the corresponding
\fIvalue\fR and returns the empty string.
.PP
The options described below are supported for all channels. Each type of


channel may provide additional options. Those options are described in the

relevant documentation. For example, additional options are documented for
\fBsocket\fR, and also for serial devices at \fBopen\fR.

.\" OPTION: -blocking
.TP
\fB\-blocking\fI boolean\fR
.
If \fB\-blocking\fR is set to \fBtrue\fR (default), reading the channel
or writing to it may cause the process to block indefinitely.  Otherwise,


operations such as \fBchan gets\fR, \fBchan read\fR, \fBchan puts\fR, \fBchan
flush\fR, and \fBchan close\fR take care not to block.  Non-blocking mode in

general requires that the event loop is entered, e.g. by calling
\fBTcl_DoOneEvent\fR or \fBvwait\fR or by using Tk, to give Tcl a chance to
process events on the channel.
.\" OPTION: -buffering
.TP
\fB\-buffering\fI newValue\fR
.
If \fInewValue\fR is \fBfull\fR, which is the default, output is buffered
until the internal buffer is full or until \fBchan flush\fR is called. If
\fInewValue\fR is \fBline\fR, output is flushed each time a end-of-line

character is written. If \fInewValue\fR is \fBnone\fR, output is flushed after
every output operation.  For \fBstdin\fR, \fBstdout\fR, and channels that

connect to terminal-like devices, the default value is \fBline\fR.  For


\fBstderr\fR the default value is \fBnone\fR.
.\" OPTION: -buffersize
.TP
\fB\-buffersize\fI newSize\fR
.
\fInewSize\fR, an integer no greater than one million, is the size in bytes of
any input or output buffers subsequently allocated for this channel.


.\" OPTION: -encoding
.TP
\fB\-encoding\fR \fIname\fR
.
Sets the encoding of the channel to \fIname\fR which should be one of the names
returned by \fBencoding names\fR, or
.QW \fBbinary\fR
\&. Input is converted from the encoding into Unicode, and output is converted



from Unicode to the encoding.


.RS
.PP



\fBbinary\fR is an alias for \fBiso8859-1\fR.  This alone is not sufficient for

working with binary data.  Use \fB\-translation binary\fR instead.


.PP
The encoding of a new channel is the value of \fBencoding system\fR,
which returns the platform- and locale-dependent system encoding used to
interface with the operating system,
.RE
.\" OPTION: -eofchar
.TP
\fB\-eofchar\fI char\fR
.


\fIchar\fR signals the end of the data when it is encountered in the input.
If \fIchar\fR is the empty string, there is no special character that marks
the end of the data.
.RS
.PP
The default value is the empty string.  The acceptable range is \ex01 -

\ex7F.  A value outside this range results in an error.
.RE
.VS "TCL8.7 TIP656"
.\" OPTION: -profile
.TP
\fB\-profile\fI profile\fR
.
Specifies the encoding profile to be used on the channel. The encoding
transforms in use for the channel's input and output will then be subject to the
rules of that profile. Any failures will result in a channel error. See
\fBPROFILES\fR in the \fBencoding(n)\fR documentation for details about encoding
profiles.
.VE "TCL8.7 TIP656"
.\" OPTION: -translation
.TP
\fB\-translation\fI translation\fR
.TP
\fB\-translation\fR \fB{\fIinTranslation outTranslation\fB}\fR
.
In Tcl a single line feed (\en) represents the end of a line.  However,

at the destination the end of a line may be represented differently on
different platforms, or even for different devices on the same platform.  For
example, under UNIX line feed is used in files and a
carriage-return-linefeed sequence is normally used in network connections.
Therefore, on input, e.g. with \fBchan gets\fR and \fBchan read\fR, each
external end-of-line character is translated into a line feed.  On
output, e.g. with \fBchan puts\fR, each line feed is translated to the external

end-of-line character.  The default translation, \fBauto\fR, handles all the
common cases, and \fB\-translation\fR provides explicit control over the
end-of-line character.
.RS
.PP
Returns the input translation for a read-only channel, the output translation
for a write-only channel, and both the input translation and the output
translation for a  read-write channel.  When two translations are given, they

are the input and output translation, respectively.  When only one translation

is given for a read-write channel, it is the translation for both input and

output.  The following values are currently supported:
.IP \fBauto\fR
The default.  For input each occurrence of a line feed (\fBlf\fR), carriage

return (\fBcr\fR), or carriage return followed by a line feed (\fBcrlf\fR) is


translated into a line feed.  For output, each line feed is translated into a
platform-specific representation:  For all Unix variants it is \fBlf\fR, and
for all Windows variants it is \fBcrlf\fR, except that for sockets on all


platforms it is \fBcrlf\fR for both input and output.
.IP \fBbinary\fR
Like \fBlf\fR, no end-of-line translation is performed, but in addition, sets
\fB\-eofchar\fR to the empty string to disable it, and sets \fB\-encoding\fR
to \fBiso8859-1\fR.  With this one setting, a channel is fully configured
for binary input and output:  Each byte read from the channel
becomes the Unicode character having the same value as that byte, and each
character written to the channel becomes a single byte in the output.  This
makes it possible to work seamlessly with binary data as long as each character
in the data remains in the range of 0 to 255 so that there is no distinction
between binary data and text.  For example, A JPEG image can be read from a
such a channel, manipulated, and then written back to such a channel.
.IP \fBcr\fR
The end of a line is represented in the external data by a single carriage
return character.  For input, each carriage return is translated to a line

feed, and for output each line feed character is translated to a carriage
return.
.IP \fBcrlf\fR
The end of a line is represented in the external data by a carriage return
character followed by a line feed.  For input, each carriage-return-linefeed
sequence is translated to a line feed.  For output, each line feed is
translated to a carriage-return-linefeed sequence.  This translation is


typically used for network connections, and also on Windows systems.
.IP \fBlf\fR
The end of a line in the external data is represented by a line feed so no

translations occur during either input or output.  This translation is
typically used on UNIX platforms,
.RE
.RE
.\" METHOD: copy
.TP
\fBchan copy \fIinputChan outputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR?
.
Reads characters from \fIinputChan\fR and writes them to \fIoutputChan\fR until
all characters are copied, blocking until the copy is complete and returning


<








|

|



|
|
>
|
|
>
|
<


|

|
|
|
|
>
>


|

|
|
|
|
|
>
>
|
>
|
|


|
>
|
|
|
>

<
>
>
|
|
>

<
|
<
|
<

<
|
>
|
>
>
>
>
>
>

>
|
<
>

<
<
<
>
>
>
>

<
<
>
>
>
>














|

|
>


|
|
|
|
|
|
|

|
>
>
|
>
|
|
>




|
|
>
>
|
|
>
|
|
|




|
|
|
>
|
|
>
|
>
>
|




|
|
>
>




|
|
|
|
>
>
>
|
>
>


>
>
>
|
>
|
>
>

|
|
|





>
>
|
|
<
<
<
|
>
|
<

















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


|
|
|
>
|
>
|
>
|

<
>
|
>
>
|
|
|
>
>
|












|
|
>
|
|

|
|
|
|
>
>
|

|
>
|
|
<







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
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
'\"
'\" Copyright (c) 2005-2006 Donal K. Fellows

'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
.TH chan n 8.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
chan \- Read, write and manipulate channels
.SH SYNOPSIS
\fBchan \fIoption\fR ?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
This command provides several operations for reading from, writing to
and otherwise manipulating open channels (such as have been created
with the \fBopen\fR and \fBsocket\fR commands, or the default named
channels \fBstdin\fR, \fBstdout\fR or \fBstderr\fR which correspond to
the process's standard input, output and error streams respectively).
\fIOption\fR indicates what to do with the channel; any unique
abbreviation for \fIoption\fR is acceptable. Valid options are:

.\" METHOD: blocked
.TP
\fBchan blocked \fIchannel\fR
.
This tests whether the last input operation on the channel called
\fIchannel\fR failed because it would have otherwise caused the
process to block, and returns 1 if that was the case. It returns 0
otherwise. Note that this only ever returns 1 when the channel has
been configured to be non-blocking; all Tcl channels have blocking
turned on by default.
.\" METHOD: close
.TP
\fBchan close \fIchannel\fR ?\fIdirection\fR?
.
Close and destroy the channel called \fIchannel\fR. Note that this
deletes all existing file-events registered on the channel.
If the \fIdirection\fR argument (which must be \fBread\fR or \fBwrite\fR or
any unique abbreviation of them) is present, the channel will only be
half-closed, so that it can go from being read-write to write-only or
read-only respectively. If a read-only channel is closed for reading, it is
the same as if the channel is fully closed, and respectively similar for
write-only channels. Without the \fIdirection\fR argument, the channel is
closed for both reading and writing (but only if those directions are
currently open). It is an error to close a read-only channel for writing, or a
write-only channel for reading.
.RS
.PP
As part of closing the channel, all buffered output is flushed to the
channel's output device (only if the channel is ceasing to be writable), any
buffered input is discarded (only if the channel is ceasing to be readable),
the underlying operating system resource is closed and \fIchannel\fR becomes
unavailable for future use (both only if the channel is being completely
closed).
.PP

If the channel is blocking and the channel is ceasing to be writable, the
command does not return until all output is flushed.  If the channel is
non-blocking and there is unflushed output, the channel remains open and the
command returns immediately; output will be flushed in the background and the
channel will be closed when all the flushing is complete.
.PP

If \fIchannel\fR is a blocking channel for a command pipeline then

\fBchan close\fR waits for the child processes to complete.

.PP

If the channel is shared between interpreters, then \fBchan close\fR
makes \fIchannel\fR unavailable in the invoking interpreter but has
no other effect until all of the sharing interpreters have closed the
channel. When the last interpreter in which the channel is registered
invokes \fBchan close\fR (or \fBclose\fR), the cleanup actions
described above occur. With half-closing, the half-close of the channel only
applies to the current interpreter's view of the channel until all channels
have closed it in that direction (or completely).
See the \fBinterp\fR command for a description of channel sharing.
.PP
Channels are automatically fully closed when an interpreter is destroyed and
when the process exits.  Channels are switched to blocking mode, to

ensure that all output is correctly flushed before the process exits.
.PP



The command returns an empty string, and may generate an error if
an error occurs while flushing output.  If a command in a command
pipeline created with \fBopen\fR returns an error, \fBchan close\fR
generates an error (similar to the \fBexec\fR command.)
.PP


Note that half-closes of sockets and command pipelines can have important side
effects because they result in a shutdown() or close() of the underlying
system resource, which can change how other processes or systems respond to
the Tcl program.
.PP
Channels are automatically closed when an interpreter is destroyed and
when the process exits.
From 8.6 on (TIP#398), nonblocking channels are no longer switched to
blocking mode when exiting; this guarantees a timely exit even when the
peer or a communication channel is stalled. To ensure proper flushing of
stalled nonblocking channels on exit, one must now either (a) actively
switch them back to blocking or (b) use the environment variable
\fBTCL_FLUSH_NONBLOCKING_ON_EXIT\fR, which when set and not equal to
.QW \fB0\fR
restores the previous behavior.
.RE
.\" METHOD: configure
.TP
\fBchan configure \fIchannel\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?...
.
Query or set the configuration options of the channel named
\fIchannel\fR.
.RS
.PP
If no \fIoptionName\fR or \fIvalue\fR arguments are supplied, the
command returns a list containing alternating option names and values
for the channel.  If \fIoptionName\fR is supplied but no \fIvalue\fR
then the command returns the current value of the given option.  If
one or more pairs of \fIoptionName\fR and \fIvalue\fR are supplied,
the command sets each of the named options to the corresponding
\fIvalue\fR; in this case the return value is an empty string.
.PP
The options described below are supported for all channels. In
addition, each channel type may add options that only it supports. See
the manual entry for the command that creates each type of channel
for the options supported by that specific type of channel. For
example, see the manual entry for the \fBsocket\fR command for additional
options for sockets, and the \fBopen\fR command for additional options for
serial devices.
.RE
.\" OPTION: -blocking
.TP
\fB\-blocking\fI boolean\fR
.
The \fB\-blocking\fR option determines whether I/O operations on the
channel can cause the process to block indefinitely.  The value of the
option must be a proper boolean value.  Channels are normally in
blocking mode; if a channel is placed into non-blocking mode it will
affect the operation of the \fBchan gets\fR, \fBchan read\fR, \fBchan
puts\fR, \fBchan flush\fR, and \fBchan close\fR commands; see the
documentation for those commands for details.  For non-blocking mode to
work correctly, the application must be using the Tcl event loop
(e.g. by calling \fBTcl_DoOneEvent\fR or invoking the \fBvwait\fR
command).
.\" OPTION: -buffering
.TP
\fB\-buffering\fI newValue\fR
.
If \fInewValue\fR is \fBfull\fR then the I/O system will buffer output
until its internal buffer is full or until the \fBchan flush\fR
command is invoked. If \fInewValue\fR is \fBline\fR, then the I/O
system will automatically flush output for the channel whenever a
newline character is output. If \fInewValue\fR is \fBnone\fR, the I/O
system will flush automatically after every output operation.  The
default is for \fB\-buffering\fR to be set to \fBfull\fR except for
channels that connect to terminal-like devices; for these channels the
initial setting is \fBline\fR.  Additionally, \fBstdin\fR and
\fBstdout\fR are initially set to \fBline\fR, and \fBstderr\fR is set
to \fBnone\fR.
.\" OPTION: -buffersize
.TP
\fB\-buffersize\fI newSize\fR
.
\fInewSize\fR must be an integer; its value is used to set the size
of buffers, in bytes, subsequently allocated for this channel to store
input or output. \fInewSize\fR must be a number of no more than one
million, allowing buffers of up to one million bytes in size.
.\" OPTION: -encoding
.TP
\fB\-encoding\fR \fIname\fR
.
This option is used to specify the encoding of the channel as one of
the named encodings returned by \fBencoding names\fR or the special
value \fBbinary\fR, so that the data can be converted to and from
Unicode for use in Tcl.  For instance, in order for Tcl to read
characters from a Japanese file in \fBshiftjis\fR and properly process
and display the contents, the encoding would be set to \fBshiftjis\fR.
Thereafter, when reading from the channel, the bytes in the Japanese
file would be converted to Unicode as they are read.  Writing is also
supported \- as Tcl strings are written to the channel they will
automatically be converted to the specified encoding on output.
.RS
.PP
If a file contains pure binary data (for instance, a JPEG image), the
encoding for the channel should be configured to be \fBbinary\fR.  Tcl
will then assign no interpretation to the data in the file and simply
read or write raw bytes.  The Tcl \fBbinary\fR command can be used to
manipulate this byte-oriented data.  It is usually better to set the
\fB\-translation\fR option to \fBbinary\fR when you want to transfer
binary data, as this turns off the other automatic interpretations of
the bytes in the stream as well.
.PP
The default encoding for newly opened channels is the same platform-
and locale-dependent system encoding used for interfacing with the
operating system, as returned by \fBencoding system\fR.
.RE
.\" OPTION: -eofchar
.TP
\fB\-eofchar\fI char\fR
.
This option supports DOS file systems that use Control-z (\ex1A) as an
end of file marker.  If \fIchar\fR is not an empty string, then this
character signals end-of-file when it is encountered during input.
Otherwise (the default) there is no special end of file character marker.



The acceptable range for \fB\-eofchar\fR values is \ex01 - \ex7f;
attempting to set \fB\-eofchar\fR to a value outside of this range will
generate an error.

.VS "TCL8.7 TIP656"
.\" OPTION: -profile
.TP
\fB\-profile\fI profile\fR
.
Specifies the encoding profile to be used on the channel. The encoding
transforms in use for the channel's input and output will then be subject to the
rules of that profile. Any failures will result in a channel error. See
\fBPROFILES\fR in the \fBencoding(n)\fR documentation for details about encoding
profiles.
.VE "TCL8.7 TIP656"
.\" OPTION: -translation
.TP
\fB\-translation\fI translation\fR
.TP
\fB\-translation\fR \fB{\fIinTranslation outTranslation\fB}\fR
.
In Tcl scripts the end of a line is always represented using a single
newline character (\en).  However, in actual files and devices the end
of a line may be represented differently on different platforms, or
even for different devices on the same platform.  For example, under
UNIX newlines are used in files, whereas carriage-return-linefeed
sequences are normally used in network connections.  On input (i.e.,
with \fBchan gets\fR and \fBchan read\fR) the Tcl I/O system
automatically translates the external end-of-line representation into
newline characters.  Upon output (i.e., with \fBchan puts\fR), the I/O
system translates newlines to the external end-of-line representation.
The default translation mode, \fBauto\fR, handles all the common cases
automatically, but the \fB\-translation\fR option provides explicit
control over the end of line translations.
.RS
.PP
The value associated with \fB\-translation\fR is a single item for
read-only and write-only channels.  The value is a two-element list for
read-write channels; the read translation mode is the first element of
the list, and the write translation mode is the second element.  As a
convenience, when setting the translation mode for a read-write channel
you can specify a single value that will apply to both reading and
writing.  When querying the translation mode of a read-write channel, a
two-element list will always be returned.  The following values are
currently supported:
.IP \fBauto\fR

As the input translation mode, \fBauto\fR treats any of newline
(\fBlf\fR), carriage return (\fBcr\fR), or carriage return followed by
a newline (\fBcrlf\fR) as the end of line representation.  The end of
line representation can even change from line-to-line, and all cases
are translated to a newline.  As the output translation mode,
\fBauto\fR chooses a platform specific representation; for sockets on
all platforms Tcl chooses \fBcrlf\fR, for all Unix flavors, it chooses
\fBlf\fR, and for the various flavors of Windows it chooses
\fBcrlf\fR.  The default setting for \fB\-translation\fR is \fBauto\fR
for both input and output.
.IP \fBbinary\fR
Like \fBlf\fR, no end-of-line translation is performed, but in addition, sets
\fB\-eofchar\fR to the empty string to disable it, and sets \fB\-encoding\fR
to \fBiso8859-1\fR.  With this one setting, a channel is fully configured
for binary input and output:  Each byte read from the channel
becomes the Unicode character having the same value as that byte, and each
character written to the channel becomes a single byte in the output.  This
makes it possible to work seamlessly with binary data as long as each character
in the data remains in the range of 0 to 255 so that there is no distinction
between binary data and text.  For example, A JPEG image can be read from a
such a channel, manipulated, and then written back to such a channel.
.IP \fBcr\fR
The end of a line in the underlying file or device is represented by a
single carriage return character.  As the input translation mode,
\fBcr\fR mode converts carriage returns to newline characters.  As the
output translation mode, \fBcr\fR mode translates newline characters
to carriage returns.
.IP \fBcrlf\fR
The end of a line in the underlying file or device is represented by a
carriage return character followed by a linefeed character.  As the
input translation mode, \fBcrlf\fR mode converts
carriage-return-linefeed sequences to newline characters.  As the
output translation mode, \fBcrlf\fR mode translates newline characters
to carriage-return-linefeed sequences.  This mode is typically used on
Windows platforms and for network connections.
.IP \fBlf\fR
The end of a line in the underlying file or device is represented by a
single newline (linefeed) character.  In this mode no translations
occur during either input or output.  This mode is typically used on
UNIX platforms.

.RE
.\" METHOD: copy
.TP
\fBchan copy \fIinputChan outputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR?
.
Reads characters from \fIinputChan\fR and writes them to \fIoutputChan\fR until
all characters are copied, blocking until the copy is complete and returning
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
.QW "channel busy"
error.
.RE
.\" METHOD: create
.TP
\fBchan create \fImode cmdPrefix\fR
.
Creates a new channel, called a \fBreflected\fR channel, with \fIcmdPrefix\fR
as its handler, and returns the name of the channel.  \fBcmdPrefix\fR is the


first words of a command that provides the interface for a \fBrefchan\fR.



.RS
.PP


\fBImode\fR is a list of one or more of the strings
.QW \fBread\fR
or
.QW \fBwrite\fR ,

indicating whether the channel is a read channel, a write channel, or both.
It is an error if the handler does not support the chosen mode.

.PP
The handler is called as needed from the global namespace at the top level, and

command resolution happens there at the time of the call.  If the handler is
renamed or deleted any subsequent attempt to call it is an error, which may



not be able to describe the failure.

.PP

The handler is always called in the interpreter and thread it was created in,
even if the channel was shared with or moved into a different interpreter in a


different thread.  This is achieved through event dispatch, so if the event
loop is not entered, e.g. by calling \fBTcl_DoOneEvent\fR or \fBvwait\fR or


using Tk, the thread performing the channel operation \fIblocks


indefinitely\fR, resulting in deadlock.
.PP
One side of a channel may be in one thread while the other side is in a
different thread, providing a stream-oriented bridge between the threads. This

provides a method for regular stream communication between threads as an
alternative to sending commands.
.PP
When the interpreter the handler is in is deleted each channel associated with

the handler is deleted as well, regardless of which interpreter or thread it




is currently in or shared with.
.PP
\fBchan create\fR is \fBsafe\fR and is accessible to safe interpreters.  The


handler is always called in the safe interpreter it was created in.
.RE
.\" METHOD: eof
.TP
\fBchan eof \fIchannelName\fR
.

Returns 1 if the last read on the channel failed because the end of the data
was already reached, and 0 otherwise.
.\" METHOD: event
.TP
\fBchan event \fIchannelName event\fR ?\fIscript\fR?
.
Arranges for the given script, called a \fBchannel event handler\fR, to be
called whenever the given event, one of

.QW \fBreadable\fR
or
.QW \fBwritable\fR
occurs on the given channel, replacing any script that was previously set.  If
\fIscript\fR is the empty string the current handler is deleted.  It is also
deleted when the channel is closed.  If \fIscript\fR is omitted, either the

existing script or the empty string is returned.  The event loop must be
entered, e.g. via \fBvwait\fR or \fBupdate\fR, or by using Tk, for handlers to
be evaluated.
.RS
.PP
\fIscript\fR is evaluated at the global level in the interpreter it was
established in.  Any resulting error is handled in the background, i.e. via
\fBinterp bgerror\fR.  In order to prevent an endless loop due to a buggy
handler, the handler is deleted if \fIscript\fR returns an error so that it is
not evaluated again.
.PP




Without an event handler, \fBchan gets\fR or \fBchan read\fR on a channel in
blocking mode may block until data becomes available, during which the
thread is unable to perform other work or respond to events on other channels.

This could cause the application to appear to
.QW "freeze up"
\&.
Channel event handlers allow events on the channel to direct channel handling
so that the reader or writer can continue to perform other processing while
waiting for a channel to become available and then handle channel operations
when the channel is ready for the operation.
.PP
A channel is considered to be readable if there is unread data
available on the underlying device.  A channel is also considered to
be readable if there is unread data in an input buffer, except in the
special case where the most recent attempt to read from the channel
was a \fBchan gets\fR call that could not find a complete line in the
input buffer.  This feature allows a file to be read a line at a time
in non-blocking mode using events.  A channel is also considered to be
readable if an end of file or error condition is present on the
underlying file or device.  It is important for \fIscript\fR to check
for these conditions and handle them appropriately; for example, if
there is no special check for end of file, an infinite loop may occur
where \fIscript\fR reads no data, returns, and is immediately invoked
again.
.PP
A channel is considered to be writable if at least one byte of data can be
written to the underlying file or device without blocking, or if an error

condition is present. Note that client sockets opened in asynchronous mode
become writable when they become connected or if the connection fails.
.PP
Event-driven channel handling works best for channels in non-blocking mode.  A

channel in blocking mode blocks when \fBchan puts\fR writes more data than the

channel can accept at the moment, and when \fBchan gets\fR or \fBchan read\fR
requests more data than is currently available.  When a channel blocks, the
thread can not do any other processing or service any other events.  A channel
in non-blocking mode allows a thread to carry on with other work and get back





to the channel at the right time.



.RE
.\" METHOD: flush
.TP
\fBchan flush \fIchannelName\fR
.





For a channel in blocking mode, flushes all buffered output to the destination,
and then returns.  For a channel in non-blocking mode, returns immediately
while all buffered output is flushed in the background as soon as possible.



.\" METHOD: gets
.TP
\fBchan gets \fIchannelName\fR ?\fIvarName\fR?
.
Reads a line from the channel consisting of all characters up to the next
end-of-line sequence or until end of file is seen. The line feed character
corresponding to end-of-line sequence is not included as part of the line.
If the \fIvarName\fR argument is specified, the line is stored in the variable
of that name and the command returns the length of the line. If \fIvarName\fR
is not specified, the command returns the line itself as the result of the command.







|
|
>
>
|
>
>
>


>
>
|



>
|
|
>

|
>
|
<
>
>
>
|
>

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

|
|
>
|
|

|
>
|
>
>
>
>
|

|
>
>
|



|

>
|
|


|

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


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


|
|
<
|















|
|
>
|
|

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



|

>
>
>
>
>
|
|
|
>
>
>


|







322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352

353
354
355
356
357
358
359
360
361
362
363
364

365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406


407
408
409
410
411
412
413
414
415



416
417

418
419
420
421
422
423

424
425
426
427
428
429

430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457

458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
.QW "channel busy"
error.
.RE
.\" METHOD: create
.TP
\fBchan create \fImode cmdPrefix\fR
.
This subcommand creates a new script level channel using the command
prefix \fIcmdPrefix\fR as its handler. Any such channel is called a
\fBreflected\fR channel. The specified command prefix, \fBcmdPrefix\fR,
must be a non-empty list, and should provide the API described in the
\fBrefchan\fR manual page. The handle of the new channel is
returned as the result of the \fBchan create\fR command, and the
channel is open. Use either \fBclose\fR or \fBchan close\fR to remove
the channel.
.RS
.PP
The argument \fImode\fR specifies if the new channel is opened for
reading, writing, or both. It has to be a list containing any of the
strings
.QW \fBread\fR
or
.QW \fBwrite\fR ,
The list must have at least one
element, as a channel you can neither write to nor read from makes no
sense. The handler command for the new channel must support the chosen
mode, or an error is thrown.
.PP
The command prefix is executed in the global namespace, at the top of
call stack, following the appending of arguments as described in the
\fBrefchan\fR manual page. Command resolution happens at the

time of the call. Renaming the command, or destroying it means that
the next call of a handler method may fail, causing the channel
command invoking the handler to fail as well. Depending on the
subcommand being invoked, the error message may not be able to explain
the reason for that failure.
.PP
Every channel created with this subcommand knows which interpreter it
was created in, and only ever executes its handler command in that
interpreter, even if the channel was shared with and/or was moved into
a different interpreter. Each reflected channel also knows the thread
it was created in, and executes its handler command only in that
thread, even if the channel was moved into a different thread. To this

end all invocations of the handler are forwarded to the original
thread by posting special events to it. This means that the original
thread (i.e. the thread that executed the \fBchan create\fR command)
must have an active event loop, i.e. it must be able to process such
events. Otherwise the thread sending them will \fIblock
indefinitely\fR. Deadlock may occur.
.PP
Note that this permits the creation of a channel whose two endpoints
live in two different threads, providing a stream-oriented bridge
between these threads. In other words, we can provide a way for
regular stream communication between threads instead of having to send
commands.
.PP
When a thread or interpreter is deleted, all channels created with
this subcommand and using this thread/interpreter as their computing
base are deleted as well, in all interpreters they have been shared
with or moved into, and in whatever thread they have been transferred
to. While this pulls the rug out under the other thread(s) and/or
interpreter(s), this cannot be avoided. Trying to use such a channel
will cause the generation of a regular error about unknown channel
handles.
.PP
This subcommand is \fBsafe\fR and made accessible to safe
interpreters.  While it arranges for the execution of arbitrary Tcl
code the system also makes sure that the code is always executed
within the safe interpreter.
.RE
.\" METHOD: eof
.TP
\fBchan eof \fIchannel\fR
.
Test whether the last input operation on the channel called
\fIchannel\fR failed because the end of the data stream was reached,
returning 1 if end-of-file was reached, and 0 otherwise.
.\" METHOD: event
.TP
\fBchan event \fIchannel event\fR ?\fIscript\fR?
.
Arrange for the Tcl script \fIscript\fR to be installed as a \fIfile
event handler\fR to be called whenever the channel called
\fIchannel\fR enters the state described by \fIevent\fR (which must
be either \fBreadable\fR or \fBwritable\fR); only one such handler may


be installed per event per channel at a time.  If \fIscript\fR is the
empty string, the current handler is deleted (this also happens if the
channel is closed or the interpreter deleted).  If \fIscript\fR is
omitted, the currently installed script is returned (or an empty
string if no such handler is installed).  The callback is only
performed if the event loop is being serviced (e.g. via \fBvwait\fR or
\fBupdate\fR).
.RS
.PP



A file event handler is a binding between a channel and a script, such
that the script is evaluated whenever the channel becomes readable or

writable.  File event handlers are most commonly used to allow data to
be received from another process on an event-driven basis, so that the
receiver can continue to interact with the user or with other channels
while waiting for the data to arrive.  If an application invokes
\fBchan gets\fR or \fBchan read\fR on a blocking channel when there is
no input data available, the process will block; until the input data

arrives, it will not be able to service other events, so it will
appear to the user to
.QW "freeze up"
\&.
With \fBchan event\fR, the
process can tell when data is present and only invoke \fBchan gets\fR

or \fBchan read\fR when they will not block.
.PP
A channel is considered to be readable if there is unread data
available on the underlying device.  A channel is also considered to
be readable if there is unread data in an input buffer, except in the
special case where the most recent attempt to read from the channel
was a \fBchan gets\fR call that could not find a complete line in the
input buffer.  This feature allows a file to be read a line at a time
in non-blocking mode using events.  A channel is also considered to be
readable if an end of file or error condition is present on the
underlying file or device.  It is important for \fIscript\fR to check
for these conditions and handle them appropriately; for example, if
there is no special check for end of file, an infinite loop may occur
where \fIscript\fR reads no data, returns, and is immediately invoked
again.
.PP
A channel is considered to be writable if at least one byte of data
can be written to the underlying file or device without blocking, or
if an error condition is present on the underlying file or device.
Note that client sockets opened in asynchronous mode become writable
when they become connected or if the connection fails.
.PP
Event-driven I/O works best for channels that have been placed into
non-blocking mode with the \fBchan configure\fR command.  In blocking
mode, a \fBchan puts\fR command may block if you give it more data
than the underlying file or device can accept, and a \fBchan gets\fR
or \fBchan read\fR command will block if you attempt to read more data
than is ready; no events will be processed while the commands block.

In non-blocking mode \fBchan puts\fR, \fBchan read\fR, and \fBchan
gets\fR never block.
.PP
The script for a file event is executed at global level (outside the
context of any Tcl procedure) in the interpreter in which the \fBchan
event\fR command was invoked.  If an error occurs while executing the
script then the command registered with \fBinterp bgerror\fR is used
to report the error.  In addition, the file event handler is deleted
if it ever returns an error; this is done in order to prevent infinite
loops due to buggy handlers.
.RE
.\" METHOD: flush
.TP
\fBchan flush \fIchannel\fR
.
Ensures that all pending output for the channel called \fIchannel\fR
is written.
.RS
.PP
If the channel is in blocking mode the command does not return until
all the buffered output has been flushed to the channel. If the
channel is in non-blocking mode, the command may return before all
buffered output has been flushed; the remainder will be flushed in the
background as fast as the underlying file or device is able to absorb
it.
.RE
.\" METHOD: gets
.TP
\fBchan gets \fIchannel\fR ?\fIvarName\fR?
.
Reads a line from the channel consisting of all characters up to the next
end-of-line sequence or until end of file is seen. The line feed character
corresponding to end-of-line sequence is not included as part of the line.
If the \fIvarName\fR argument is specified, the line is stored in the variable
of that name and the command returns the length of the line. If \fIvarName\fR
is not specified, the command returns the line itself as the result of the command.
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
486
487
488
489
490

491
492
493
494
495
496
497
498

499

500
501
502

503
504
505

506
507
508

509
510
511



512


513
514

515


516
517


518
519
520
521
522
523
524
525

526
527

528


529
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
unchanged and it is possible to introspect, and in some cases recover, by
changing the encoding in use. See \fBENCODING ERROR EXAMPLES\fR later.
.RE
.\" METHOD: names
.TP
\fBchan names\fR ?\fIpattern\fR?
.
Returns a list of all channel names, or if \fIpattern\fR is given, only those

names that match according to the rules of \fBstring match\fR.
.\" METHOD: pending
.TP
\fBchan pending \fImode channelName\fR
.

Returns the number of bytes of input
when \fImode\fR is
.QW\fBinput\fR
, or output when \fImode\fR is
.QW\fBoutput\fR
, that are currently internally buffered for the channel.  Useful in a readable
event callback to impose limits on input line length to avoid a potential
denial-of-service attack where an extremely long line exceeds the available

memory to buffer it.  Returns -1 if the channel was not opened for the mode in
question.
.\" METHOD: pipe
.TP
\fBchan pipe\fR
.
Creates a pipe, i.e. a readable channel and a writable channel, and returns the
names of the readable channel and the writable channel.  Data written to the
writable channel can be read from the readable channel.  Because the pipe is a
real system-level pipe, it can be connected to other processes using
redirection.  For example, to redirect \fBstderr\fR from a subprocess into one
channel, and \fBstdout\fR into another, \fBexec\fR with "2>@" and ">@", each

onto the writable side of a pipe, closing the writable side immediately
thereafter so that EOF is signaled on the read side once the subprocess has
closed its output, typically on exit.
.RS
.PP
Due to buffering, data written to one side of a pipe might not immediately
become available on the other side.  Tcl's own buffers can be configured via
\fBchan configure -buffering\fR, but overall behaviour still depends on
operating system buffers outside of Tcl's control. Once the write side of the

channel is closed, any data remaining in the buffers is flushed through to the
read side.  It may be useful to arrange for the connected process to flush at
some point after writing to the channel or to have it use some system-provided
mechanism to configure buffering.  When two pipes are connected to the same
process, one to send data to the process, and one to read data from the
process, a deadlock may occur if the channels are in blocking mode:  If
reading, the channel may block waiting for data that can never come because
buffers are only flushed on subsequent writes, and if writing, the channel may
block while waiting for the buffers to become free, which can never happen
because the reader can not read while the writer is blocking.  To avoid this
issue, either put the channels into non-blocking mode and use event handlers,
or place the read channel and the write channel in separate interpreters in
separate threads.

.RE
.\" METHOD: pop
.TP
\fBchan pop \fIchannelName\fR
.
Removes the topmost transformation handler from the channel if there is one,

and closes the channel otherwise. The result is normally the empty string, but
may be an error in some situations, e.g. when closing the underlying resource
results in an error.
.\" METHOD: postevent
.TP
\fBchan postevent \fIchannelName eventSpec\fR
.
For use by handlers established with \fBchan create\fR.  Notifies Tcl that

that one or more event(s) listed in \fIeventSpec\fR, each of which is either

.QW\fBread\fR
or
.QW\fBwrite\fR.

, have occurred.
.RS
.PP

For use only by handlers for a channel created by \fBchan create\fR.  It is an
error to post an event for any other channel.
.PP

Since only the handler for a reflected channel channel should post events it is
an error to post an event from any interpreter other than the interpreter that
created the channel.



.PP


It is an error to post an event that the channel has no interest in.  See
\fBwatch\fR in the \fBrefchan\fR documentation for more information

.PP


\fBchan postevent\fR is available in safe interpreters, as any handler for a
reflected channel would have been created, and will be evaluated in that


interpreter as well.
.RE
.\" METHOD: push
.TP
\fBchan push \fIchannelName cmdPrefix\fR
.
Adds a new transformation handler on top of the channel and returns a handle
for the transformation.  \fIcmdPrefix\fR is the first words of a command that

provides the interface documented for \fBtranschan\fR, and transforms data on
the channel, It is an error if handler does not support the mode(s) the channel

is in.


.\" METHOD: puts
.TP
\fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannelName\fR? \fIstring\fR
.


Writes \fIstring\fR and a line feed to the channel.  If \fB\-nonewline\fR is
given, the trailing line feed is not written. The default channel is
\fBstdout\fR.
.RS
.PP
Each line feed in the output is translated to the appropriate end of line

sequence as per the \fB\-translation\fR configuration setting of the channel.



.PP
Because Tcl internally buffers output, characters written to a channel may not
immediately be available at the destination.  Tcl normally delays output until
the buffer is full or the channel is closed. \fBchan flush\fR forces output in
the direction of the destination.


.PP
When the output for a channel in blocking mode fills up, \fBchan puts\fR blocks
until space in the buffer is available again. On the other hand for a channel in
non-blocking mode, it returns immediately and the data is written in the


background as fast possible, constrained by the speed at which as the
destination accepts it. Output to a channel in non-blocking mode only works
properly when the application enters the event loop. When a channel is in



non-blocking mode, Tcl's internal buffers can hold an arbitrary amount of data,
possibly consuming a large amount of memory. To avoid wasting memory, channels
in non-blocking mode should normally be handled using \fBchan event\fR, where
the application only invokes \fBchan puts\fR after being notified through a file
event handler that the channel is ready for more output data.
.PP
The command will raise an error exception with POSIX error code \fBEILSEQ\fR if
the encoding profile \fBstrict\fR is in effect for the channel and the output
data cannot be encoded in the encoding configured for the channel. Data
may be partially written to the channel in this case.
.RE
.\" METHOD: read
.TP
\fBchan read \fIchannelName\fR ?\fInumChars\fR?
.TP
\fBchan read \fR?\fB\-nonewline\fR? \fIchannelName\fR
.
Reads and returns the next \fInumChars\fR characters from the channel. If

\fInumChars\fR is omitted, all available characters up to the end of the file
are read, or if the channel is in non-blocking mode, all currently-available
characters are read.  If there is an error on the channel, reading ceases and
an error is returned.  If \fInumChars\fR is not given, \fB\-nonewline\fR

may be given, causing any trailing line feed to be trimmed.
.RS
.PP
If the channel is in non-blocking mode, fewer characters than requested may be


returned.  If the channel is configured to use a multi-byte encoding, bytes

that do not form a complete character are retained in the buffers until enough
bytes to complete the character accumulate, or the end of the data is reached.
\fB\-nonewline\fR is ignored if characters are returned before reaching the end
of the file.
.PP
Each end-of-line sequence according to the value of \fB\-translation\fR is
translated into a line feed.


.PP
When reading from a serial port, most applications should configure the serial
port channel to be in non-blocking mode, but not necessarily use an event






handler since most serial ports are comparatively slow.  It is entirely
possible to get a \fBreadable\fR event for each individual character.  In









blocking mode, \fBchan read\fR blocks forever when reading to the end of the
data if there is no \fBchan configure -eofchar\fR configured for the channel.


.PP
If the encoding profile \fBstrict\fR is in effect for the channel, the command
will raise an exception with the POSIX error code \fBEILSEQ\fR if any encoding
errors are encountered in the channel input data. If the channel is in blocking
mode, the error is thrown after advancing the file pointer to the beginning of
the invalid data. The successfully decoded leading portion of the data prior to
the error location is returned as the value of the \fB\-data\fR key of the error
option dictionary. If the channel is in non-blocking mode, the successfully
decoded portion of data is returned by the command without an error
exception being raised. A subsequent read will start at the invalid data
and immediately raise a \fBEILSEQ\fR POSIX error exception. Unlike the
blocking channel case, the \fB\-data\fR key is not present in the
error option dictionary. In the case of exception thrown due to encoding
errors, it is possible to introspect, and in some cases recover, by
changing the encoding in use. See \fBENCODING ERROR EXAMPLES\fR later.
.RE
.\" METHOD: seek
.TP
\fBchan seek \fIchannelName offset\fR ?\fIorigin\fR?
.
Sets the current position for the data in the channel to integer \fIoffset\fR
bytes relative to \fIorigin\fR.  A negative offset moves the current position
backwards from the origin.  \fIorigin\fR is one of the
following:
.RS
.IP \fBstart\fR

The origin is the start of the data.  This is the default.
.IP \fBcurrent\fR

The origin is the current position.

.IP \fBend\fR



The origin is the end of the data.
.PP


\fBChan seek\fR flushes all buffered output even if the channel is in

non-blocking mode, discards any buffered and unread input, and returns the

empty string or an error if the channel does not support seeking.
.PP
\fIoffset\fR values are byte offsets, not character offsets.  Unlike \fBchan
read\fR, both \fBchan seek\fR and \fBchan tell\fR operate in terms of bytes,
not characters,
.RE
.\" METHOD: tell
.TP
\fBchan tell \fIchannelName\fR
.

Returns the offset in bytes of the current position in the underlying data, or
-1 if the channel does not support seeking. The value can be passed to \fBchan
seek\fR to set current position to that offset.


.\" METHOD: truncate
.TP
\fBchan truncate \fIchannelName\fR ?\fIlength\fR?
.
Flushes the channel and truncates the data in the channel to \fIlength\fR
bytes, or to the current position in bytes if \fIlength\fR is omitted.


.
.SH EXAMPLES
.SS "SIMPLE CHANNEL OPERATION EXAMPLES"
.PP
Instruct Tcl to always send output to \fBstdout\fR immediately,
whether or not it is to a terminal:
.PP







|
>
|


|

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




|
|
<
|
|
|
>
|
|
<


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



|

|
>
|
|
|


|

|
>
|
>
|
<
<
>
|


>
|
|

>
|
<
|
>
>
>

>
>
|
|
>

>
>
|
<
>
>
|



|

|
|
>
|
<
>
|
>
>


|

>
>
|
|



|
>
|
>
>
>

|
|
|
<
>
>

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








|

|

|
>
|
|
|
|
>
|


|
>
>
|
>
|
|
|
|

|
|
>
>

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


















|

|
|
|
|


>
|

>
|
>

>
>
>
|

>
>
|
>
|
>
|

|
|
|



|

>
|
|
|
>
>


|

|
|
>
>







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
unchanged and it is possible to introspect, and in some cases recover, by
changing the encoding in use. See \fBENCODING ERROR EXAMPLES\fR later.
.RE
.\" METHOD: names
.TP
\fBchan names\fR ?\fIpattern\fR?
.
Produces a list of all channel names. If \fIpattern\fR is specified,
only those channel names that match it (according to the rules of
\fBstring match\fR) will be returned.
.\" METHOD: pending
.TP
\fBchan pending \fImode channel\fR
.
Depending on whether \fImode\fR is \fBinput\fR or \fBoutput\fR,
returns the number of


bytes of input or output (respectively) currently buffered

internally for \fIchannel\fR (especially useful in a readable event
callback to impose application-specific limits on input line lengths to avoid
a potential denial-of-service attack where a hostile user crafts
an extremely long line that exceeds the available memory to buffer it).
Returns -1 if the channel was not opened for the mode in question.

.\" METHOD: pipe
.TP
\fBchan pipe\fR
.
Creates a standalone pipe whose read- and write-side channels are
returned as a 2-element list, the first element being the read side and

the second the write side. Can be useful e.g. to redirect
separately \fBstderr\fR and \fBstdout\fR from a subprocess. To do
this, spawn with "2>@" or
">@" redirection operators onto the write side of a pipe, and then
immediately close it in the parent. This is necessary to get an EOF on
the read side once the child has exited or otherwise closed its output.

.RS
.PP
Note that the pipe buffering semantics can vary at the operating system level
substantially; it is not safe to assume that a write performed on the output

side of the pipe will appear instantly to the input side. This is a
fundamental difference and Tcl cannot conceal it. The overall stream semantics
\fIare\fR compatible, so blocking reads and writes will not see most of the
differences, but the details of what exactly gets written when are not. This
is most likely to show up when using pipelines for testing; care should be


taken to ensure that deadlocks do not occur and that potential short reads are







allowed for.
.RE
.\" METHOD: pop
.TP
\fBchan pop \fIchannel\fR
.
Removes the topmost transformation from the channel \fIchannel\fR, if there
is any. If there are no transformations added to \fIchannel\fR, this is
equivalent to \fBchan close\fR of that channel. The result is normally the
empty string, but can be an error in some situations (i.e. where the
underlying system stream is closed and that results in an error).
.\" METHOD: postevent
.TP
\fBchan postevent \fIchannel eventSpec\fR
.
This subcommand is used by command handlers specified with \fBchan
create\fR. It notifies the channel represented by the handle
\fIchannel\fR that the event(s) listed in the \fIeventSpec\fR have
occurred. The argument has to be a list containing any of the strings
\fBread\fR and \fBwrite\fR. The list must contain at least one


element as it does not make sense to invoke the command if there are
no events to post.
.RS
.PP
Note that this subcommand can only be used with channel handles that
were created/opened by \fBchan create\fR. All other channels will
cause this subcommand to report an error.
.PP
As only the Tcl level of a channel, i.e. its command handler, should
post events to it we also restrict the usage of this command to the

interpreter that created the channel. In other words, posting events
to a reflected channel from an interpreter that does not contain it's
implementation is not allowed. Attempting to post an event from any
other interpreter will cause this subcommand to report an error.
.PP
Another restriction is that it is not possible to post events that the
I/O core has not registered an interest in. Trying to do so will cause
the method to throw an error. See the command handler method
\fBwatch\fR described in \fBrefchan\fR, the document specifying
the API of command handlers for reflected channels.
.PP
This command is \fBsafe\fR and made accessible to safe interpreters.
It can trigger the execution of \fBchan event\fR handlers, whether in the
current interpreter or in other interpreters or other threads, even

where the event is posted from a safe interpreter and listened for by
a trusted interpreter. \fBChan event\fR handlers are \fIalways\fR
executed in the interpreter that set them up.
.RE
.\" METHOD: push
.TP
\fBchan push \fIchannel cmdPrefix\fR
.
Adds a new transformation on top of the channel \fIchannel\fR. The
\fIcmdPrefix\fR argument describes a list of one or more words which represent
a handler that will be used to implement the transformation. The command
prefix must provide the API described in the \fBtranschan\fR manual page.

The result of this subcommand is a handle to the transformation. Note that it
is important to make sure that the transformation is capable of supporting the
channel mode that it is used with or this can make the channel neither
readable nor writable.
.\" METHOD: puts
.TP
\fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannel\fR? \fIstring\fR
.
Writes \fIstring\fR to the channel named \fIchannel\fR followed by a
newline character. A trailing newline character is written unless the
optional flag \fB\-nonewline\fR is given. If \fIchannel\fR is
omitted, the string is written to the standard output channel,
\fBstdout\fR.
.RS
.PP
Newline characters in the output are translated by \fBchan puts\fR to
platform-specific end-of-line sequences according to the currently
configured value of the \fB\-translation\fR option for the channel
(for example, on PCs newlines are normally replaced with
carriage-return-linefeed sequences; see \fBchan configure\fR above for
details).
.PP
Tcl buffers output internally, so characters written with \fBchan
puts\fR may not appear immediately on the output file or device; Tcl
will normally delay output until the buffer is full or the channel is

closed.  You can force output to appear immediately with the \fBchan
flush\fR command.
.PP
When the output buffer fills up, the \fBchan puts\fR command will
normally block until all the buffered data has been accepted for
output by the operating system.  If \fIchannel\fR is in non-blocking
mode then the \fBchan puts\fR command will not block even if the
operating system cannot accept the data.  Instead, Tcl continues to
buffer the data and writes it in the background as fast as the

underlying file or device can accept it.  The application must use the
Tcl event loop for non-blocking output to work; otherwise Tcl never
finds out that the file or device is ready for more output data.  It
is possible for an arbitrarily large amount of data to be buffered for
a channel in non-blocking mode, which could consume a large amount of
memory.  To avoid wasting memory, non-blocking I/O should normally be
used in an event-driven fashion with the \fBchan event\fR command
(do not invoke \fBchan puts\fR unless you have recently been notified
via a file event that the channel is ready for more output data).
.PP
The command will raise an error exception with POSIX error code \fBEILSEQ\fR if
the encoding profile \fBstrict\fR is in effect for the channel and the output
data cannot be encoded in the encoding configured for the channel. Data
may be partially written to the channel in this case.
.RE
.\" METHOD: read
.TP
\fBchan read \fIchannel\fR ?\fInumChars\fR?
.TP
\fBchan read \fR?\fB\-nonewline\fR? \fIchannel\fR
.
In the first form, the result will be the next \fInumChars\fR
characters read from the channel named \fIchannel\fR; if
\fInumChars\fR is omitted, all characters up to the point when the
channel would signal a failure (whether an end-of-file, blocked or
other error condition) are read. In the second form (i.e. when
\fInumChars\fR has been omitted) the flag \fB\-nonewline\fR may be
given to indicate that any trailing newline in the string that has
been read should be trimmed.
.RS
.PP
If \fIchannel\fR is in non-blocking mode, \fBchan read\fR may not
read as many characters as requested: once all available input has
been read, the command will return the data that is available rather
than blocking for more input.  If the channel is configured to use a
multi-byte encoding, then there may actually be some bytes remaining
in the internal buffers that do not form a complete character.  These
bytes will not be returned until a complete character is available or
end-of-file is reached.  The \fB\-nonewline\fR switch is ignored if
the command returns before reaching the end of the file.
.PP
\fBChan read\fR translates end-of-line sequences in the input into
newline characters according to the \fB\-translation\fR option for the
channel (see \fBchan configure\fR above for a discussion on the ways
in which \fBchan configure\fR will alter input).
.PP
When reading from a serial port, most applications should configure
the serial port channel to be non-blocking, like this:
.PP
.CS
\fBchan configure \fIchannel \fB\-blocking \fI0\fR.
.CE
.PP
Then \fBchan read\fR behaves much like described above.  Note that
most serial ports are comparatively slow; it is entirely possible to
get a \fBreadable\fR event for each character read from them. Care
must be taken when using \fBchan read\fR on blocking serial ports:
.TP
\fBchan read \fIchannel numChars\fR
.
In this form \fBchan read\fR blocks until \fInumChars\fR have been
received from the serial port.
.TP
\fBchan read \fIchannel\fR
.
In this form \fBchan read\fR blocks until the reception of the
end-of-file character, see \fBchan configure -eofchar\fR. If there no
end-of-file character has been configured for the channel, then
\fBchan read\fR will block forever.
.PP
If the encoding profile \fBstrict\fR is in effect for the channel, the command
will raise an exception with the POSIX error code \fBEILSEQ\fR if any encoding
errors are encountered in the channel input data. If the channel is in blocking
mode, the error is thrown after advancing the file pointer to the beginning of
the invalid data. The successfully decoded leading portion of the data prior to
the error location is returned as the value of the \fB\-data\fR key of the error
option dictionary. If the channel is in non-blocking mode, the successfully
decoded portion of data is returned by the command without an error
exception being raised. A subsequent read will start at the invalid data
and immediately raise a \fBEILSEQ\fR POSIX error exception. Unlike the
blocking channel case, the \fB\-data\fR key is not present in the
error option dictionary. In the case of exception thrown due to encoding
errors, it is possible to introspect, and in some cases recover, by
changing the encoding in use. See \fBENCODING ERROR EXAMPLES\fR later.
.RE
.\" METHOD: seek
.TP
\fBchan seek \fIchannel offset\fR ?\fIorigin\fR?
.
Sets the current access position within the underlying data stream for
the channel named \fIchannel\fR to be \fIoffset\fR bytes relative to
\fIorigin\fR. \fIOffset\fR must be an integer (which may be negative)
and \fIorigin\fR must be one of the following:
.RS
.IP \fBstart\fR
The new access position will be \fIoffset\fR bytes from the start
of the underlying file or device.
.IP \fBcurrent\fR
The new access position will be \fIoffset\fR bytes from the current
access position; a negative \fIoffset\fR moves the access position
backwards in the underlying file or device.
.IP \fBend\fR
The new access position will be \fIoffset\fR bytes from the end of the
file or device.  A negative \fIoffset\fR places the access position
before the end of file, and a positive \fIoffset\fR places the access
position after the end of file.
.PP
The \fIorigin\fR argument defaults to \fBstart\fR.
.PP
\fBChan seek\fR flushes all buffered output for the channel before the
command returns, even if the channel is in non-blocking mode.  It also
discards any buffered and unread input.  This command returns an empty
string.  An error occurs if this command is applied to channels whose
underlying file or device does not support seeking.
.PP
Note that \fIoffset\fR values are byte offsets, not character offsets.
Both \fBchan seek\fR and \fBchan tell\fR operate in terms of bytes,
not characters, unlike \fBchan read\fR.
.RE
.\" METHOD: tell
.TP
\fBchan tell \fIchannel\fR
.
Returns a number giving the current access position within the
underlying data stream for the channel named \fIchannel\fR. This
value returned is a byte offset that can be passed to \fBchan seek\fR
in order to set the channel to a particular position.  Note that this
value is in terms of bytes, not characters like \fBchan read\fR.  The
value returned is -1 for channels that do not support seeking.
.\" METHOD: truncate
.TP
\fBchan truncate \fIchannel\fR ?\fIlength\fR?
.
Sets the byte length of the underlying data stream for the channel
named \fIchannel\fR to be \fIlength\fR (or to the current byte
offset within the underlying data stream if \fIlength\fR is
omitted). The channel is flushed before truncation.
.
.SH EXAMPLES
.SS "SIMPLE CHANNEL OPERATION EXAMPLES"
.PP
Instruct Tcl to always send output to \fBstdout\fR immediately,
whether or not it is to a terminal:
.PP
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
.CE
.PP
A network server that echoes its input line-by-line without
preventing servicing of other connections at the same time:
.PP
.CS
# This is a very simple logger...
proc log message {
    \fBchan puts\fR stdout $message
}

# This is called whenever a new client connects to the server
proc connect {chan host port} {
    set clientName [format <%s:%d> $host $port]
    log "connection from $clientName"







|







901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
.CE
.PP
A network server that echoes its input line-by-line without
preventing servicing of other connections at the same time:
.PP
.CS
# This is a very simple logger...
proc log {message} {
    \fBchan puts\fR stdout $message
}

# This is called whenever a new client connects to the server
proc connect {chan host port} {
    set clientName [format <%s:%d> $host $port]
    log "connection from $clientName"
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
example that when the error is reported the file position remains
unchanged so that the \fBchan gets\fR during recovery returns the
full line.
.PP
.CS
% set f [open test_A_195_B.txt r]
file384b6a8
% chan configure $f -encoding utf-8 -profile strict
% catch {chan gets $f} e d
1
% set d
-code 1 -level 0
-errorstack {INNER {invokeStk1 gets file384b6a8}}
-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}
-errorinfo {...} -errorline 1
% chan tell $f
0
% chan configure $f -encoding binary -profile strict
% chan gets $f
AÃB
.CE
.PP
The following example is similar to the above but demonstrates recovery after a
blocking read. The successfully decoded data "A" is returned in the error options
dictionary key \fB\-data\fR. The file position is advanced on the encoding error
position 1. The data at the error position is thus recovered by the next
\fBchan read\fR command.
.PP
.CS
% set f [open test_A_195_B.txt r]
file35a65a0
% chan configure $f -encoding utf-8 -profile strict -blocking 1
% catch {chan read $f} e d
1
% set d
-data A -code 1 -level 0
-errorstack {INNER {invokeStk1 read file35a65a0}}
-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}
-errorinfo {...} -errorline 1
% chan tell $f
1
% chan configure $f -encoding binary -profile strict
% chan read $f
ÃB
% chan close $f
.CE
.PP
Finally the same example, but this time with a non-blocking channel.
.PP
.CS
% set f [open test_A_195_B.txt r]
file35a65a0
% chan configure $f -encoding utf-8 -profile strict -blocking 0
% chan read $f
A
% chan tell $f
1
% catch {chan read $f} e d
1
% set d







|









|













|









|










|







1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
example that when the error is reported the file position remains
unchanged so that the \fBchan gets\fR during recovery returns the
full line.
.PP
.CS
% set f [open test_A_195_B.txt r]
file384b6a8
% chan configure $f -encoding utf-8
% catch {chan gets $f} e d
1
% set d
-code 1 -level 0
-errorstack {INNER {invokeStk1 gets file384b6a8}}
-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}
-errorinfo {...} -errorline 1
% chan tell $f
0
% chan configure $f -encoding binary
% chan gets $f
AÃB
.CE
.PP
The following example is similar to the above but demonstrates recovery after a
blocking read. The successfully decoded data "A" is returned in the error options
dictionary key \fB\-data\fR. The file position is advanced on the encoding error
position 1. The data at the error position is thus recovered by the next
\fBchan read\fR command.
.PP
.CS
% set f [open test_A_195_B.txt r]
file35a65a0
% chan configure $f -encoding utf-8 -blocking 1
% catch {chan read $f} e d
1
% set d
-data A -code 1 -level 0
-errorstack {INNER {invokeStk1 read file35a65a0}}
-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}
-errorinfo {...} -errorline 1
% chan tell $f
1
% chan configure $f -encoding binary
% chan read $f
ÃB
% chan close $f
.CE
.PP
Finally the same example, but this time with a non-blocking channel.
.PP
.CS
% set f [open test_A_195_B.txt r]
file35a65a0
% chan configure $f -encoding utf-8 -blocking 0
% chan read $f
A
% chan tell $f
1
% catch {chan read $f} e d
1
% set d

Changes to doc/close.n.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
.TH close n 7.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
close \- Close an open channel
.SH SYNOPSIS
\fBclose \fIchannelId\fR ?\fBr\fR(\fBead\fR)|\fBw\fR(\fBrite\fR)?
.BE
.SH DESCRIPTION
.PP
The \fBclose\fR command has been superceded by the \fBchan close\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
.TH close n 7.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
close \- Close an open channel
.SH SYNOPSIS
\fBclose \fIchannel\fR ?\fBr\fR(\fBead\fR)|\fBw\fR(\fBrite\fR)?
.BE
.SH DESCRIPTION
.PP
The \fBclose\fR command has been superceded by the \fBchan close\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)

Changes to doc/configurable.n.

1
2
3
4
5
6
7
8
9
'\"
'\" Copyright © 2019 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH configurable n 0.4 TclOO "TclOO Commands"
.so man.macros
.BS

|







1
2
3
4
5
6
7
8
9
'\"
'\" Copyright (c) 2019 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH configurable n 0.4 TclOO "TclOO Commands"
.so man.macros
.BS

Changes to doc/encoding.n.

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
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
'\"
'\" Copyright (c) 1998 Scriptics Corporation.
'\" Copyright (c) 2023 Nathan Coulter
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH encoding n "8.1" Tcl "Tcl Built-In Commands"
.so man.macros
.BS
.SH NAME
encoding \- Work with encodings
.SH SYNOPSIS
\fBencoding \fIoperation\fR ?\fIarg arg ...\fR?
.BE
.SH INTRODUCTION
.PP
In Tcl every string is composed of Unicode values.  Text may be encoded into an
encoding such as cp1252, iso8859-1, Shift\-JIS, utf-8, utf-16, etc. Not every
Unicode value is encodable in every encoding, and some encodings can encode
values that are not available in Unicode.
.PP
Even though Unicode is for encoding the written texts of human languages, any
sequence of bytes can be encoded as the first 255 Unicode values. In particular,
iso8859-1 is an encoding (a superset of classic ASCII) for a subset of Unicode
in which each byte is a Unicode value of 255
or less; any sequence of bytes can be considered to be a Unicode string
encoded in iso8859-1.  To work with binary data in Tcl, decode it from
iso8859-1 when reading it in, and encode it into iso8859-1 when writing it out,
ensuring that each character in the string has a value of 255 or less.
Decoding such a string does nothing, and encoding encoding such a string also
does nothing.
.PP
For example, the following is true:
.CS

set text {In Tcl binary data is treated as Unicode text and it just works.}
set encoded [\fBencoding convertto\fR iso8859-1 $text]
expr {$text eq $encoded}; #-> 1
.CE

The following is also true:
.CS
set decoded [\fBencoding convertfrom\fR iso8859-1 $text]
expr {$text eq $decoded}; #-> 1
.CE
.SH DESCRIPTION
.PP
Performs one of the following encoding \fIoperations\fR:

.\" METHOD: convertfrom
.TP
\fBencoding convertfrom\fR ?\fIencoding\fR? \fIdata\fR

.TP
\fBencoding convertfrom\fR ?\fB\-profile \fIprofile\fR? ?\fB\-failindex var\fR? \fIencoding data\fR

.

Decodes \fIdata\fR encoded in \fIencoding\fR. If \fIencoding\fR is not
specified the current system encoding is used.

.VS "TCL8.7 TIP607, TIP656"
\fB\-profile\fR determines how invalid data for the encoding are handled.  See
the \fBPROFILES\fR section below for details.  Returns an error if decoding

fails.  However, if \fB\-failindex\fR given, returns the result of the


conversion up to the point of termination, and stores in \fBvar\fR the index of


the character that could not be converted. If no errors are encountered the
entire result of the conversion is returned and the value \fB-1\fR is stored in
\fBvar\fR.
.VE "TCL8.7 TIP607, TIP656"
.\" METHOD: convertto
.TP
\fBencoding convertto\fR ?\fIencoding\fR? \fIdata\fR
.TP
\fBencoding convertto\fR ?\fB\-profile \fIprofile\fR? ?\fB\-failindex var\fR? \fIencoding data\fR
.


Converts \fIstring\fR to \fIencoding\fR.  If \fIencoding\fR is not given, the
current system encoding is used.

.VS "TCL8.7 TIP607, TIP656"

See \fBencoding convertfrom\fR for the meaning of \fB\-profile\fR and
\fB\-failindex\fR.
.VE "TCL8.7 TIP607, TIP656"
.\" METHOD: dirs
.TP
\fBencoding dirs\fR ?\fIdirectoryList\fR?
.


Sets the search path for \fB*.enc\fR encoding data files to the list of
directories given by \fIdirectoryList\fR.  If \fIdirectoryList\fR is not given,
returns the current list of directories that make up the search path.  It is
not an error for an item in \fIdirectoryList\fR to not refer to a readable,


searchable directory.
.\" METHOD: names
.TP
\fBencoding names\fR
.

Returns a list of the names of available encodings.
The encodings
.QW utf-8
and
.QW iso8859-1
are guaranteed to be present in the list.
.\" METHOD: profiles
.TP
\fBencoding profiles\fR
.VS "TCL8.7 TIP656"
Returns a list of names of available encoding profiles. See \fBPROFILES\fR
below.
.VE "TCL8.7 TIP656"
.\" METHOD: system
.TP
\fBencoding system\fR ?\fIencoding\fR?
.
Sets the system encoding to \fIencoding\fR. If \fIencoding\fR is not given,
returns the current system encoding.  The system encoding is used to pass
strings to system calls.
.\" Do not put .VS on whole section as that messes up the bullet list alignment
.SH PROFILES
.PP
.VS "TCL8.7 TIP656"



Each \fIprofile\fR is a distinct strategy for dealing with invalid data for an
encoding.














.PP
The following profiles are currently implemented.

.VE "TCL8.7 TIP656"
.TP
\fBstrict\fR
.VS "TCL8.7 TIP656"
The default profile.  The operation fails when invalid data for the encoding


are encountered.
.VE "TCL8.7 TIP656"


.TP
\fBtcl8\fR
.VS "TCL8.7 TIP656"


Provides for behaviour identical to that of Tcl 8.6: When
decoding, for encodings \fBother than utf-8\fR, each invalid byte is interpreted

as the Unicode value given by that one byte. For example, the byte 0x80, which
is invalid in the ASCII encoding would be mapped to the Unicode value U+0080.
For \fButf-8\fR, each invalid byte that is a valid CP1252 character is
interpreted as the Unicode value for that character, while each byte that is
not is treated as the Unicode value given by that one byte. For example, byte
0x80 is defined by CP1252 and is therefore mapped to its Unicode equivalent
U+20AC while byte 0x81 which is not defined by CP1252 is mapped to U+0081. As
an additional special case, the sequence 0xC0 0x80 is mapped to U+0000.
.RS
.PP

When encoding, each character that cannot be represented in the encoding is
replaced by an encoding-dependent character, usually the question mark \fB?\fR.
.RE
.VE "TCL8.7 TIP656"
.TP
\fBreplace\fR




.VS "TCL8.7 TIP 656"

When decoding, invalid bytes are replaced by U+FFFD, the Unicode REPLACEMENT
CHARACTER.
.RS
.PP

When encoding, Unicode values that cannot be represented in the target encoding
are transformed to an encoding-specific fallback character, U+FFFD REPLACEMENT
CHARACTER for UTF targets, and generally `?` for other encodings.
.RE

.VE "TCL8.7 TIP656"
.SH EXAMPLES
.PP
These examples use the utility proc below that prints the Unicode value for
each character in a string.
.PP
.CS
proc codepoints s {join [lmap c [split $s {}] {
    string cat U+ [format %.6X [scan $c %c]]}]
}
.CE
.PP
Example 1: Convert from euc-jp:
.PP
.CS
% codepoints [\fBencoding convertfrom\fR euc-jp \exA4\exCF]
U+00306F
.CE
.PP
The result is the Unicode value
.QW "\eu306F" ,
which is the Hiragana letter HA.
.VS "TCL8.7 TIP607, TIP656"
.PP
Example 2: Error handling based on profiles:
.PP
The letter \fBA\fR is Unicode character U+0041 and the byte "\ex80" is invalid


<








|

|



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

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


|
>



>

|
>

>
|
|
>

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





|

>
>
|
|
>

>
|
<





>
>
|
|
|
|
>
>
|




>
|









|
<





|
|
|




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

|
>
|


<
<
>
>
|
<
>
>


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


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



|
|







|


|



|







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
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
'\"
'\" Copyright (c) 1998 Scriptics Corporation.

'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH encoding n "8.1" Tcl "Tcl Built-In Commands"
.so man.macros
.BS
.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 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 4



bytes per character), or a custom encoding start as 8 bit binary data.


.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:
.\" METHOD: convertfrom
.TP
\fBencoding convertfrom\fR ?\fIencoding\fR? \fIdata\fR
.VS "TCL8.7 TIP607, TIP656"
.TP
\fBencoding convertfrom\fR ?\fB-profile \fIprofile\fR? ?\fB-failindex var\fR? \fIencoding data\fR
.VE "TCL8.7 TIP607, TIP656"
.
Converts \fIdata\fR, which should be in binary string encoded as per
\fIencoding\fR, to a Tcl string. If \fIencoding\fR is not specified, the current
system encoding is used.
.PP
.VS "TCL8.7 TIP607, TIP656"
The \fB-profile\fR option determines the command behavior in the presence
of conversion errors. See the \fBPROFILES\fR section below for details. Any premature
termination of processing due to errors is reported through an exception if
the \fB-failindex\fR option is not specified.
.PP
If the \fB-failindex\fR is specified, instead of an exception being raised
on premature termination, the result of the conversion up to the point of the
error is returned as the result of the command. In addition, the index
of the source byte triggering the error is stored in \fBvar\fR. If no
errors are encountered, the entire result of the conversion is returned and
the value \fB-1\fR is stored in \fBvar\fR.

.VE "TCL8.7 TIP607, TIP656"
.\" METHOD: convertto
.TP
\fBencoding convertto\fR ?\fIencoding\fR? \fIdata\fR
.TP
\fBencoding convertto\fR ?\fB-profile \fIprofile\fR? ?\fB-failindex var\fR? \fIencoding data\fR
.
Convert \fIstring\fR to the specified \fIencoding\fR. The result is a Tcl binary
string that contains the sequence of bytes representing the converted string in
the specified encoding. If \fIencoding\fR is not specified, the current system
encoding is used.
.PP
.VS "TCL8.7 TIP607, TIP656"
The \fB-profile\fR and \fB-failindex\fR options have the same effect as
described for the \fBencoding convertfrom\fR command.

.VE "TCL8.7 TIP607, TIP656"
.\" METHOD: dirs
.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.
.\" METHOD: names
.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.
.\" METHOD: profiles
.TP
\fBencoding profiles\fR
.VS "TCL8.7 TIP656"
Returns a list of the names of encoding profiles. See \fBPROFILES\fR below.

.VE "TCL8.7 TIP656"
.\" METHOD: system
.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.
.\" Do not put .VS on whole section as that messes up the bullet list alignment
.SH PROFILES
.PP
.VS "TCL8.7 TIP656"
Operations involving encoding transforms may encounter several types of
errors such as invalid sequences in the source data, characters that
cannot be encoded in the target encoding and so on.
A \fIprofile\fR prescribes the strategy for dealing with such errors
in one of two ways:
.VE "TCL8.7 TIP656"
.
.IP \(bu
.VS "TCL8.7 TIP656"
Terminating further processing of the source data. The profile does not
determine how this premature termination is conveyed to the caller. By default,
this is signalled by raising an exception. If the \fB-failindex\fR option
is specified, errors are reported through that mechanism.
.VE "TCL8.7 TIP656"
.IP \(bu
.VS "TCL8.7 TIP656"
Continue further processing of the source data using a fallback strategy such
as replacing or discarding the offending bytes in a profile-defined manner.
.VE "TCL8.7 TIP656"
.PP
The following profiles are currently implemented with \fBstrict\fR being
the default if the \fB-profile\fR is not specified.
.VS "TCL8.7 TIP656"
.TP
\fBstrict\fR


.
The \fBstrict\fR profile always stops processing when an conversion error is
encountered. The error is signalled via an exception or the \fB-failindex\fR

option mechanism. The \fBstrict\fR profile implements a Unicode standard
conformant behavior.
.TP
\fBtcl8\fR

.
The \fBtcl8\fR profile always follows the first strategy above and corresponds
to the behavior of encoding transforms in Tcl 8.6. When converting from an
external encoding \fBother than utf-8\fR to Tcl strings with the \fBencoding
convertfrom\fR command, invalid bytes are mapped to their numerically equivalent
code points. For example, the byte 0x80 which is invalid in ASCII would be

mapped to code point U+0080. When converting from \fButf-8\fR, invalid bytes
that are defined in CP1252 are mapped to their Unicode equivalents while those
that are not fall back to the numerical equivalents. For example, byte 0x80 is
defined by CP1252 and is therefore mapped to its Unicode equivalent U+20AC while
byte 0x81 which is not defined by CP1252 is mapped to U+0081. As an additional
special case, the sequence 0xC0 0x80 is mapped to U+0000.


When converting from Tcl strings to an external encoding format using
\fBencoding convertto\fR, characters that cannot be represented in the
target encoding are replaced by an encoding-dependent character, usually

the question mark \fB?\fR.
.TP
\fBreplace\fR
.
Like the \fBtcl8\fR profile, the \fBreplace\fR profile always continues
processing on conversion errors but follows a Unicode standard conformant
method for substitution of invalid source data.

When converting an encoded byte sequence to a Tcl string using
\fBencoding convertfrom\fR, invalid bytes
are replaced by the U+FFFD REPLACEMENT CHARACTER code point.


When encoding a Tcl string with \fBencoding convertto\fR,
code points that cannot be represented in the
target encoding are transformed to an encoding-specific fallback character,
U+FFFD REPLACEMENT CHARACTER for UTF targets and generally `?` for other

encodings.
.VE "TCL8.7 TIP656"
.SH EXAMPLES
.PP
These examples use the utility proc below that prints the Unicode code points
comprising a Tcl string.
.PP
.CS
proc codepoints s {join [lmap c [split $s {}] {
    string cat U+ [format %.6X [scan $c %c]]}]
}
.CE
.PP
Example 1: convert a byte sequence in Japanese euc-jp encoding to a TCL string:
.PP
.CS
% codepoints [\fBencoding convertfrom\fR euc-jp "\exA4\exCF"]
U+00306F
.CE
.PP
The result is the unicode codepoint
.QW "\eu306F" ,
which is the Hiragana letter HA.
.VS "TCL8.7 TIP607, TIP656"
.PP
Example 2: Error handling based on profiles:
.PP
The letter \fBA\fR is Unicode character U+0041 and the byte "\ex80" is invalid
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
% codepoints [\fBencoding convertfrom\fR -profile strict ascii A\ex80]
unexpected byte sequence starting at index 1: '\ex80'
.CE
.PP
Example 3: Get partial data and the error location:
.PP
.CS
% codepoints [\fBencoding convertfrom\fR -failindex idx ascii AB\ex80]
U+000041 U+000042
% set idx
2
.CE
.PP
Example 4: Encode a character that is not representable in ISO8859-1:
.PP
.CS
% \fBencoding convertto\fR iso8859-1 A\eu0141
A?
% \fBencoding convertto\fR -profile strict iso8859-1 A\eu0141
unexpected character at index 1: 'U+000141'
% \fBencoding convertto\fR -failindex idx iso8859-1 A\eu0141
A
% set idx
1
.CE
.VE "TCL8.7 TIP607, TIP656"
.PP
.SH "SEE ALSO"
Tcl_GetEncoding(3), fconfigure(n)
.SH KEYWORDS
encoding, unicode
.\" Local Variables:
.\" mode: nroff
.\" End:







|












|













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
% codepoints [\fBencoding convertfrom\fR -profile strict ascii A\ex80]
unexpected byte sequence starting at index 1: '\ex80'
.CE
.PP
Example 3: Get partial data and the error location:
.PP
.CS
% codepoints [\fBencoding convertfrom\fR -profile strict -failindex idx ascii AB\ex80]
U+000041 U+000042
% set idx
2
.CE
.PP
Example 4: Encode a character that is not representable in ISO8859-1:
.PP
.CS
% \fBencoding convertto\fR iso8859-1 A\eu0141
A?
% \fBencoding convertto\fR -profile strict iso8859-1 A\eu0141
unexpected character at index 1: 'U+000141'
% \fBencoding convertto\fR -profile strict -failindex idx iso8859-1 A\eu0141
A
% set idx
1
.CE
.VE "TCL8.7 TIP607, TIP656"
.PP
.SH "SEE ALSO"
Tcl_GetEncoding(3), fconfigure(n)
.SH KEYWORDS
encoding, unicode
.\" Local Variables:
.\" mode: nroff
.\" End:

Changes to doc/eof.n.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
.TH eof n 7.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
eof \- Check for end of file condition on channel
.SH SYNOPSIS
\fBeof \fIchannelId\fR
.BE
.SH DESCRIPTION
.PP
The \fBeof\fR command has been superceded by the \fBchan eof\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
.TH eof n 7.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
eof \- Check for end of file condition on channel
.SH SYNOPSIS
\fBeof \fIchannel\fR
.BE
.SH DESCRIPTION
.PP
The \fBeof\fR command has been superceded by the \fBchan eof\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)

Changes to doc/fblocked.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
'\"
'\" Copyright (c) 1996 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 fblocked n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
fblocked \- Test whether the last input operation exhausted all available input
.SH SYNOPSIS
\fBfblocked \fIchannelId\fR
.BE
.SH DESCRIPTION
.PP
The \fBfblocked\fR command has been superceded by the \fBchan blocked\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
'\"
'\" Copyright (c) 1996 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 fblocked n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
fblocked \- Test whether the last input operation exhausted all available input
.SH SYNOPSIS
\fBfblocked \fIchannel\fR
.BE
.SH DESCRIPTION
.PP
The \fBfblocked\fR command has been superceded by the \fBchan blocked\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)

Changes to doc/fconfigure.n.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
fconfigure \- Set and get options on a channel
.SH SYNOPSIS
.nf
\fBfconfigure \fIchannelId\fR
\fBfconfigure \fIchannelId name\fR
\fBfconfigure \fIchannelId name value \fR?\fIname value ...\fR?
.fi
.BE
.SH DESCRIPTION
.PP
The \fBfconfigure\fR command has been superceded by the \fBchan configure\fR
command which supports the same syntax and options.
.SH "SEE ALSO"







|
|
|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
fconfigure \- Set and get options on a channel
.SH SYNOPSIS
.nf
\fBfconfigure \fIchannel\fR
\fBfconfigure \fIchannel name\fR
\fBfconfigure \fIchannel name value \fR?\fIname value ...\fR?
.fi
.BE
.SH DESCRIPTION
.PP
The \fBfconfigure\fR command has been superceded by the \fBchan configure\fR
command which supports the same syntax and options.
.SH "SEE ALSO"

Changes to doc/fileevent.n.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
.TH fileevent n 7.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
fileevent \- Execute a script when a channel becomes readable or writable
.SH SYNOPSIS
\fBfileevent \fIchannelId \fBreadable \fR?\fIscript\fR?
.sp
\fBfileevent \fIchannelId \fBwritable \fR?\fIscript\fR?
.BE
.SH DESCRIPTION
.PP
The \fBfileevent\fR command has been superceded by the \fBchan event\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)







|

|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
.TH fileevent n 7.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
fileevent \- Execute a script when a channel becomes readable or writable
.SH SYNOPSIS
\fBfileevent \fIchannel \fBreadable \fR?\fIscript\fR?
.sp
\fBfileevent \fIchannel \fBwritable \fR?\fIscript\fR?
.BE
.SH DESCRIPTION
.PP
The \fBfileevent\fR command has been superceded by the \fBchan event\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)

Changes to doc/flush.n.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
.TH flush n 7.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
flush \- Flush buffered output for a channel
.SH SYNOPSIS
\fBflush \fIchannelId\fR
.BE
.SH DESCRIPTION
.PP
The \fBflush\fR command has been superceded by the \fBchan flush\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
.TH flush n 7.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
flush \- Flush buffered output for a channel
.SH SYNOPSIS
\fBflush \fIchannel\fR
.BE
.SH DESCRIPTION
.PP
The \fBflush\fR command has been superceded by the \fBchan flush\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)

Changes to doc/format.n.

137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
function of the \fBexpr\fR command (at least a 64-bit range).
If it is \fBz\fR or \fBt\fR it specifies that the integer value is
truncated to the range determined by the value of the \fBpointerSize\fR
element of the \fBtcl_platform\fR array.
If it is \fBL\fR it specifies that an integer or double value is taken
without truncation for conversion to a formatted substring.
If neither of those are present, the integer value is
truncated to the range determined by the value of the
\fBwordSize\fR element of the \fBtcl_platform\fR array).
.SS "MANDATORY CONVERSION TYPE"
.PP
The last thing in a conversion specifier is an alphabetic character
that determines what kind of conversion to perform.
The following conversion characters are currently supported:
.IP \fBd\fR 10
Convert integer to signed decimal string.







|
<







137
138
139
140
141
142
143
144

145
146
147
148
149
150
151
function of the \fBexpr\fR command (at least a 64-bit range).
If it is \fBz\fR or \fBt\fR it specifies that the integer value is
truncated to the range determined by the value of the \fBpointerSize\fR
element of the \fBtcl_platform\fR array.
If it is \fBL\fR it specifies that an integer or double value is taken
without truncation for conversion to a formatted substring.
If neither of those are present, the integer value is
truncated to a 32-bit range.

.SS "MANDATORY CONVERSION TYPE"
.PP
The last thing in a conversion specifier is an alphabetic character
that determines what kind of conversion to perform.
The following conversion characters are currently supported:
.IP \fBd\fR 10
Convert integer to signed decimal string.

Changes to doc/gets.n.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
.TH gets n 7.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
gets \- Read a line from a channel
.SH SYNOPSIS
\fBgets \fIchannelId\fR ?\fIvarName\fR?
.BE
.SH DESCRIPTION
.PP
The \fBgets\fR command has been superceded by the \fBchan gets\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
.TH gets n 7.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
gets \- Read a line from a channel
.SH SYNOPSIS
\fBgets \fIchannel\fR ?\fIvarName\fR?
.BE
.SH DESCRIPTION
.PP
The \fBgets\fR command has been superceded by the \fBchan gets\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)

Changes to doc/http.n.

255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
.\" OPTION: -useragent
.TP
\fB\-useragent\fI string\fR
.
The value of the User-Agent header in the HTTP request.  In an unsafe
interpreter, the default value depends upon the operating system, and
the version numbers of \fBhttp\fR and \fBTcl\fR, and is (for example)
.QW "\fBMozilla/5.0 (Windows; U; Windows NT 10.0) http/2.9.0 Tcl/8.6.9\fR" .
A safe interpreter cannot determine its operating system, and so the default
in a safe interpreter is to use a Windows 10 value with the current version
numbers of \fBhttp\fR and \fBTcl\fR.
.\" OPTION: -zip
.TP
\fB\-zip\fI boolean\fR
.







|







255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
.\" OPTION: -useragent
.TP
\fB\-useragent\fI string\fR
.
The value of the User-Agent header in the HTTP request.  In an unsafe
interpreter, the default value depends upon the operating system, and
the version numbers of \fBhttp\fR and \fBTcl\fR, and is (for example)
.QW "\fBMozilla/5.0 (Windows; U; Windows NT 10.0) http/2.10.0 Tcl/9.0.0\fR" .
A safe interpreter cannot determine its operating system, and so the default
in a safe interpreter is to use a Windows 10 value with the current version
numbers of \fBhttp\fR and \fBTcl\fR.
.\" OPTION: -zip
.TP
\fB\-zip\fI boolean\fR
.

Changes to doc/interp.n.

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
application. If your machine has a limit on the size of the C stack, you
may get stack overflows before reaching the limit set by the command. If
this happens, see if there is a mechanism in your system for increasing
the maximum size of the C stack.
.RE
.\" METHOD: share
.TP
\fBinterp share\fI srcPath channelId destPath\fR
.
Causes the IO channel identified by \fIchannelId\fR to become shared
between the interpreter identified by \fIsrcPath\fR and the interpreter
identified by \fIdestPath\fR. Both interpreters have the same permissions
on the IO channel.
Both interpreters must close it to close the underlying IO channel; IO
channels accessible in an interpreter are automatically closed when an
interpreter is destroyed.
.\" METHOD: target
.TP
\fBinterp target\fI path alias\fR
.
Returns a Tcl list describing the target interpreter for an alias. The
alias is specified with an interpreter path and source command name, just
as in \fBinterp alias\fR above. The name of the target interpreter is
returned as an interpreter path, relative to the invoking interpreter.
If the target interpreter for the alias is the invoking interpreter then an
empty list is returned. If the target interpreter for the alias is not the
invoking interpreter or one of its descendants then an error is generated.
The target command does not have to be defined at the time of this invocation.
.\" METHOD: transfer
.TP
\fBinterp transfer\fI srcPath channelId destPath\fR
.
Causes the IO channel identified by \fIchannelId\fR to become available in
the interpreter identified by \fIdestPath\fR and unavailable in the
interpreter identified by \fIsrcPath\fR.
.SH "CHILD COMMAND"
.PP
For each child interpreter created with the \fBinterp\fR command, a
new Tcl command is created in the parent interpreter with the same
name as the new interpreter. This command may be used to invoke







|

|




















|

|







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
application. If your machine has a limit on the size of the C stack, you
may get stack overflows before reaching the limit set by the command. If
this happens, see if there is a mechanism in your system for increasing
the maximum size of the C stack.
.RE
.\" METHOD: share
.TP
\fBinterp share\fI srcPath channel destPath\fR
.
Causes the IO channel identified by \fIchannel\fR to become shared
between the interpreter identified by \fIsrcPath\fR and the interpreter
identified by \fIdestPath\fR. Both interpreters have the same permissions
on the IO channel.
Both interpreters must close it to close the underlying IO channel; IO
channels accessible in an interpreter are automatically closed when an
interpreter is destroyed.
.\" METHOD: target
.TP
\fBinterp target\fI path alias\fR
.
Returns a Tcl list describing the target interpreter for an alias. The
alias is specified with an interpreter path and source command name, just
as in \fBinterp alias\fR above. The name of the target interpreter is
returned as an interpreter path, relative to the invoking interpreter.
If the target interpreter for the alias is the invoking interpreter then an
empty list is returned. If the target interpreter for the alias is not the
invoking interpreter or one of its descendants then an error is generated.
The target command does not have to be defined at the time of this invocation.
.\" METHOD: transfer
.TP
\fBinterp transfer\fI srcPath channel destPath\fR
.
Causes the IO channel identified by \fIchannel\fR to become available in
the interpreter identified by \fIdestPath\fR and unavailable in the
interpreter identified by \fIsrcPath\fR.
.SH "CHILD COMMAND"
.PP
For each child interpreter created with the \fBinterp\fR command, a
new Tcl command is created in the parent interpreter with the same
name as the new interpreter. This command may be used to invoke

Changes to doc/namespace.n.

491
492
493
494
495
496
497
498
499


500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
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
If you provide a fully-qualified name that starts with a \fB::\fR,
there is no question about what command, variable, or namespace
you mean.
However, if the name does not start with a \fB::\fR
(i.e., is \fIrelative\fR),
Tcl follows basic rules for looking it up:
.IP \(bu
\fBVariable names\fR are always resolved by looking first in the current
namespace, and then in the global namespace.


.IP \(bu
\fBCommand names\fR are always resolved by looking in the current namespace
first. If not found there, they are searched for in every namespace on the
current namespace's command path (which is empty by default). If not found
there, command names are looked up in the global namespace (or, failing that,
are processed by the appropriate \fBnamespace unknown\fR handler.)
.IP \(bu
\fBNamespace names\fR are always resolved by looking in only the current
namespace.
.PP
In the following example,
.PP
.CS
set traceLevel 0
\fBnamespace eval\fR Debug {
    printTrace $traceLevel
}
.CE
.PP
Tcl looks for \fBtraceLevel\fR in the namespace \fBDebug\fR
and then in the global namespace.
It looks up the command \fBprintTrace\fR in the same way.
If a variable or command name is not found in either context,
the name is undefined.
To make this point absolutely clear, consider the following example:
.PP
.CS
set traceLevel 0
\fBnamespace eval\fR Foo {
    variable traceLevel 3

    \fBnamespace eval\fR Debug {
        printTrace $traceLevel
    }
}
.CE
.PP
Here Tcl looks for \fBtraceLevel\fR first in the namespace \fBFoo::Debug\fR.
Since it is not found there, Tcl then looks for it
in the global namespace.
The variable \fBFoo::traceLevel\fR is completely ignored
during the name resolution process.
.PP
You can use the \fBnamespace which\fR command to clear up any question
about name resolution.
For example, the command:
.PP
.CS
\fBnamespace eval\fR Foo::Debug {\fBnamespace which\fR -variable traceLevel}
.CE
.PP
returns \fB::traceLevel\fR.
On the other hand, the command,
.PP
.CS
\fBnamespace eval\fR Foo {\fBnamespace which\fR -variable traceLevel}
.CE
.PP
returns \fB::Foo::traceLevel\fR.
.PP
As mentioned above,
namespace names are looked up differently
than the names of variables and commands.
Namespace names are always resolved in the current namespace.
This means, for example,
that a \fBnamespace eval\fR command that creates a new namespace
always creates a child of the current namespace
unless the new namespace name begins with \fB::\fR.
.PP
Tcl has no access control to limit what variables, commands,
or namespaces you can reference.







|
|
>
>



















|
<

|














|
<
<
|
|









|
|





|


|
|
|







491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521

522
523
524
525
526
527
528
529
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
If you provide a fully-qualified name that starts with a \fB::\fR,
there is no question about what command, variable, or namespace
you mean.
However, if the name does not start with a \fB::\fR
(i.e., is \fIrelative\fR),
Tcl follows basic rules for looking it up:
.IP \(bu
\fBVariable names\fR are always resolved starting in the current
namespace. In the absence of special resolvers, foo::bar::baz refers to
a variable named "baz" in a namespace named "bar" that is a child of a
namespace named "foo" that is a child of the current namespace of the interpreter.
.IP \(bu
\fBCommand names\fR are always resolved by looking in the current namespace
first. If not found there, they are searched for in every namespace on the
current namespace's command path (which is empty by default). If not found
there, command names are looked up in the global namespace (or, failing that,
are processed by the appropriate \fBnamespace unknown\fR handler.)
.IP \(bu
\fBNamespace names\fR are always resolved by looking in only the current
namespace.
.PP
In the following example,
.PP
.CS
set traceLevel 0
\fBnamespace eval\fR Debug {
    printTrace $traceLevel
}
.CE
.PP
Tcl looks for \fBtraceLevel\fR in the namespace \fBDebug\fR.

It looks up the command \fBprintTrace\fR in the same way.
If a variable or command name is not found,
the name is undefined.
To make this point absolutely clear, consider the following example:
.PP
.CS
set traceLevel 0
\fBnamespace eval\fR Foo {
    variable traceLevel 3

    \fBnamespace eval\fR Debug {
        printTrace $traceLevel
    }
}
.CE
.PP
Here Tcl looks for \fBtraceLevel\fR in the namespace \fBFoo::Debug\fR.


The variables \fBFoo::traceLevel\fR and \fBFoo::Debug::traceLevel\fR
are completely ignored during the name resolution process.
.PP
You can use the \fBnamespace which\fR command to clear up any question
about name resolution.
For example, the command:
.PP
.CS
\fBnamespace eval\fR Foo::Debug {\fBnamespace which\fR -variable traceLevel}
.CE
.PP
returns the empty string.
The command,
.PP
.CS
\fBnamespace eval\fR Foo {\fBnamespace which\fR -variable traceLevel}
.CE
.PP
returns the empty string as well.
.PP
As mentioned above,
namespace names and variables are looked up differently
than the names of commands.
Namespace names and variables are always resolved in the current namespace.
This means, for example,
that a \fBnamespace eval\fR command that creates a new namespace
always creates a child of the current namespace
unless the new namespace name begins with \fB::\fR.
.PP
Tcl has no access control to limit what variables, commands,
or namespaces you can reference.

Changes to doc/puts.n.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
.TH puts n 7.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
puts \- Write to a channel
.SH SYNOPSIS
\fBputs \fR?\fB\-nonewline\fR? ?\fIchannelId\fR? \fIstring\fR
.BE
.SH DESCRIPTION
.PP
The \fBputs\fR command has been superceded by the \fBchan puts\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
.TH puts n 7.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
puts \- Write to a channel
.SH SYNOPSIS
\fBputs \fR?\fB\-nonewline\fR? ?\fIchannel\fR? \fIstring\fR
.BE
.SH DESCRIPTION
.PP
The \fBputs\fR command has been superceded by the \fBchan puts\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)

Changes to doc/read.n.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
.TH read n 8.1 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
read \- Read from a channel
.SH SYNOPSIS
\fBread \fR?\fB\-nonewline\fR? \fIchannelId\fR
.sp
\fBread \fIchannelId numChars\fR
.BE
.SH DESCRIPTION
.PP
The \fBread\fR command has been superceded by the \fBchan read\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)







|

|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
.TH read n 8.1 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
read \- Read from a channel
.SH SYNOPSIS
\fBread \fR?\fB\-nonewline\fR? \fIchannel\fR
.sp
\fBread \fIchannel numChars\fR
.BE
.SH DESCRIPTION
.PP
The \fBread\fR command has been superceded by the \fBchan read\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)

Changes to doc/refchan.n.

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
.\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
refchan \- command handler API of reflected channels
.SH SYNOPSIS
.nf
\fBchan create \fImode cmdPrefix\fR

\fIcmdPrefix \fBblocking\fI channelId mode\fR
\fIcmdPrefix \fBcget\fI channelId option\fR
\fIcmdPrefix \fBcgetall\fI channelId\fR
\fIcmdPrefix \fBconfigure\fI channelId option value\fR
\fIcmdPrefix \fBfinalize\fI channelId\fR
\fIcmdPrefix \fBinitialize\fI channelId mode\fR
\fIcmdPrefix \fBread\fI channelId count\fR
\fIcmdPrefix \fBseek\fI channelId offset base\fR
\fIcmdPrefix \fBwatch\fI channelId eventspec\fR
\fIcmdPrefix \fBwrite\fI channelId data\fR
.fi
.BE
.SH DESCRIPTION
.PP
The Tcl-level handler for a reflected channel has to be a command with
subcommands (termed an \fIensemble\fR, as it is a command such as that
created by \fBnamespace ensemble\fR \fBcreate\fR, though the implementation
of handlers for reflected channel \fIis not\fR tied to \fBnamespace
ensemble\fRs in any way; see \fBEXAMPLE\fR below for how to build an
\fBoo::class\fR that supports the API). Note that \fIcmdPrefix\fR is whatever was
specified in the call to \fBchan create\fR, and may consist of
multiple arguments; this will be expanded to multiple words in place
of the prefix.
.PP
Of all the possible subcommands, the handler \fImust\fR support
\fBinitialize\fR, \fBfinalize\fR, and \fBwatch\fR. Support for the
other subcommands is optional.
.SS "MANDATORY SUBCOMMANDS"
.\" METHOD: initialize
.TP
\fIcmdPrefix \fBinitialize \fIchannelId mode\fR
.
An invocation of this subcommand will be the first call the
\fIcmdPrefix\fR will receive for the specified new \fIchannelId\fR. It
is the responsibility of this subcommand to set up any internal data
structures required to keep track of the channel and its state.
.RS
.PP
The return value of the method has to be a list containing the names
of all subcommands supported by the \fIcmdPrefix\fR. This also tells
the Tcl core which version of the API for reflected channels is used by







|
|
|
|
|
|
|
|
|
|




















|


|







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
.\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
refchan \- command handler API of reflected channels
.SH SYNOPSIS
.nf
\fBchan create \fImode cmdPrefix\fR

\fIcmdPrefix \fBblocking\fI channel mode\fR
\fIcmdPrefix \fBcget\fI channel option\fR
\fIcmdPrefix \fBcgetall\fI channel\fR
\fIcmdPrefix \fBconfigure\fI channel option value\fR
\fIcmdPrefix \fBfinalize\fI channel\fR
\fIcmdPrefix \fBinitialize\fI channel mode\fR
\fIcmdPrefix \fBread\fI channel count\fR
\fIcmdPrefix \fBseek\fI channel offset base\fR
\fIcmdPrefix \fBwatch\fI channel eventspec\fR
\fIcmdPrefix \fBwrite\fI channel data\fR
.fi
.BE
.SH DESCRIPTION
.PP
The Tcl-level handler for a reflected channel has to be a command with
subcommands (termed an \fIensemble\fR, as it is a command such as that
created by \fBnamespace ensemble\fR \fBcreate\fR, though the implementation
of handlers for reflected channel \fIis not\fR tied to \fBnamespace
ensemble\fRs in any way; see \fBEXAMPLE\fR below for how to build an
\fBoo::class\fR that supports the API). Note that \fIcmdPrefix\fR is whatever was
specified in the call to \fBchan create\fR, and may consist of
multiple arguments; this will be expanded to multiple words in place
of the prefix.
.PP
Of all the possible subcommands, the handler \fImust\fR support
\fBinitialize\fR, \fBfinalize\fR, and \fBwatch\fR. Support for the
other subcommands is optional.
.SS "MANDATORY SUBCOMMANDS"
.\" METHOD: initialize
.TP
\fIcmdPrefix \fBinitialize \fIchannel mode\fR
.
An invocation of this subcommand will be the first call the
\fIcmdPrefix\fR will receive for the specified new \fIchannel\fR. It
is the responsibility of this subcommand to set up any internal data
structures required to keep track of the channel and its state.
.RS
.PP
The return value of the method has to be a list containing the names
of all subcommands supported by the \fIcmdPrefix\fR. This also tells
the Tcl core which version of the API for reflected channels is used by
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
125
126
127
128
129
130
131
132
will usually contain at least one element.
.PP
The subcommand must throw an error if the chosen mode is not
supported by the \fIcmdPrefix\fR.
.RE
.\" METHOD: finalize
.TP
\fIcmdPrefix \fBfinalize \fIchannelId\fR
.
An invocation of this subcommand will be the last call the
\fIcmdPrefix\fR will receive for the specified \fIchannelId\fR. It will
be generated just before the destruction of the data structures of the
channel held by the Tcl core. The command handler \fImust not\fR
access the \fIchannelId\fR anymore in no way. Upon this subcommand being
called, any internal resources allocated to this channel must be
cleaned up.
.RS
.PP
The return value of this subcommand is ignored.
.PP
If the subcommand throws an error the command which caused its
invocation (usually \fBchan close\fR) will appear to have thrown this
error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is
treated as (and converted to) an error.
.PP
This subcommand is not invoked if the creation of the channel was
aborted during \fBinitialize\fR (See above).
.RE
.\" METHOD: watch
.TP
\fIcmdPrefix \fBwatch \fIchannelId eventspec\fR
.
This subcommand notifies the \fIcmdPrefix\fR that the specified
\fIchannelId\fR is interested in the events listed in the
\fIeventspec\fR. This argument is a list containing any of \fBread\fR
and \fBwrite\fR. The list may be empty, which signals that the
channel does not wish to be notified of any events. In that situation,
the handler should disable event generation completely.
.RS
.PP
\fBWarning:\fR Any return value of the subcommand is ignored. This
includes all errors thrown by the subcommand, \fBbreak\fR, \fBcontinue\fR, and
custom return codes.
.PP
This subcommand interacts with \fBchan postevent\fR. Trying to post an
event which was not listed in the last call to \fBwatch\fR will cause
\fBchan postevent\fR to throw an error.
.RE
.SS "OPTIONAL SUBCOMMANDS"
.\" METHOD: read
.TP
\fIcmdPrefix \fBread \fIchannelId count\fR
.
This \fIoptional\fR subcommand is called when the user requests data from the
channel \fIchannelId\fR. \fIcount\fR specifies how many \fIbytes\fR have been
requested. If the subcommand is not supported then it is not possible to read
from the channel handled by the command.
.RS
.PP
The return value of this subcommand is taken as the requested data
\fIbytes\fR. If the returned data contains more bytes than requested,
an error will be signaled and later thrown by the command which







|


|


|
















|


|

















|


|







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
125
126
127
128
129
130
131
132
will usually contain at least one element.
.PP
The subcommand must throw an error if the chosen mode is not
supported by the \fIcmdPrefix\fR.
.RE
.\" METHOD: finalize
.TP
\fIcmdPrefix \fBfinalize \fIchannel\fR
.
An invocation of this subcommand will be the last call the
\fIcmdPrefix\fR will receive for the specified \fIchannel\fR. It will
be generated just before the destruction of the data structures of the
channel held by the Tcl core. The command handler \fImust not\fR
access the \fIchannel\fR anymore in no way. Upon this subcommand being
called, any internal resources allocated to this channel must be
cleaned up.
.RS
.PP
The return value of this subcommand is ignored.
.PP
If the subcommand throws an error the command which caused its
invocation (usually \fBchan close\fR) will appear to have thrown this
error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is
treated as (and converted to) an error.
.PP
This subcommand is not invoked if the creation of the channel was
aborted during \fBinitialize\fR (See above).
.RE
.\" METHOD: watch
.TP
\fIcmdPrefix \fBwatch \fIchannel eventspec\fR
.
This subcommand notifies the \fIcmdPrefix\fR that the specified
\fIchannel\fR is interested in the events listed in the
\fIeventspec\fR. This argument is a list containing any of \fBread\fR
and \fBwrite\fR. The list may be empty, which signals that the
channel does not wish to be notified of any events. In that situation,
the handler should disable event generation completely.
.RS
.PP
\fBWarning:\fR Any return value of the subcommand is ignored. This
includes all errors thrown by the subcommand, \fBbreak\fR, \fBcontinue\fR, and
custom return codes.
.PP
This subcommand interacts with \fBchan postevent\fR. Trying to post an
event which was not listed in the last call to \fBwatch\fR will cause
\fBchan postevent\fR to throw an error.
.RE
.SS "OPTIONAL SUBCOMMANDS"
.\" METHOD: read
.TP
\fIcmdPrefix \fBread \fIchannel count\fR
.
This \fIoptional\fR subcommand is called when the user requests data from the
channel \fIchannel\fR. \fIcount\fR specifies how many \fIbytes\fR have been
requested. If the subcommand is not supported then it is not possible to read
from the channel handled by the command.
.RS
.PP
The return value of this subcommand is taken as the requested data
\fIbytes\fR. If the returned data contains more bytes than requested,
an error will be signaled and later thrown by the command which
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
If the subcommand throws any other error, the command which caused its
invocation (usually \fBgets\fR, or \fBread\fR) will appear to have
thrown this error. Any exception beyond \fBerror\fR, (e.g.,\ \fBbreak\fR,
etc.) is treated as and converted to an error.
.RE
.\" METHOD: write
.TP
\fIcmdPrefix \fBwrite \fIchannelId data\fR
.
This \fIoptional\fR subcommand is called when the user writes data to
the channel \fIchannelId\fR. The \fIdata\fR argument contains \fIbytes\fR, not
characters. Any type of transformation (EOL, encoding) configured for
the channel has already been applied at this point. If this subcommand
is not supported then it is not possible to write to the channel
handled by the command.
.RS
.PP
The return value of the subcommand is taken as the number of bytes







|


|







172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
If the subcommand throws any other error, the command which caused its
invocation (usually \fBgets\fR, or \fBread\fR) will appear to have
thrown this error. Any exception beyond \fBerror\fR, (e.g.,\ \fBbreak\fR,
etc.) is treated as and converted to an error.
.RE
.\" METHOD: write
.TP
\fIcmdPrefix \fBwrite \fIchannel data\fR
.
This \fIoptional\fR subcommand is called when the user writes data to
the channel \fIchannel\fR. The \fIdata\fR argument contains \fIbytes\fR, not
characters. Any type of transformation (EOL, encoding) configured for
the channel has already been applied at this point. If this subcommand
is not supported then it is not possible to write to the channel
handled by the command.
.RS
.PP
The return value of the subcommand is taken as the number of bytes
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
If the subcommand throws any other error the command which caused its
invocation (usually \fBputs\fR) will appear to have thrown this error.
Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated
as and converted to an error.
.RE
.\" METHOD: seek
.TP
\fIcmdPrefix \fBseek \fIchannelId offset base\fR
.
This \fIoptional\fR subcommand is responsible for the handling of
\fBchan seek\fR and \fBchan tell\fR requests on the channel
\fIchannelId\fR. If it is not supported then seeking will not be possible for
the channel.
.RS
.PP
The \fIbase\fR argument is the same as the equivalent argument of the
builtin \fBchan seek\fR, namely:
.IP \fBstart\fR 10
Seeking is relative to the beginning of the channel.







|



|







230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
If the subcommand throws any other error the command which caused its
invocation (usually \fBputs\fR) will appear to have thrown this error.
Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated
as and converted to an error.
.RE
.\" METHOD: seek
.TP
\fIcmdPrefix \fBseek \fIchannel offset base\fR
.
This \fIoptional\fR subcommand is responsible for the handling of
\fBchan seek\fR and \fBchan tell\fR requests on the channel
\fIchannel\fR. If it is not supported then seeking will not be possible for
the channel.
.RS
.PP
The \fIbase\fR argument is the same as the equivalent argument of the
builtin \fBchan seek\fR, namely:
.IP \fBstart\fR 10
Seeking is relative to the beginning of the channel.
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
.PP
The offset/base combination of 0/\fBcurrent\fR signals a \fBchan tell\fR
request, i.e.,\ seek nothing relative to the current location, making
the new location identical to the current one, which is then returned.
.RE
.\" METHOD: configure
.TP
\fIcmdPrefix \fBconfigure \fIchannelId option value\fR
.
This \fIoptional\fR subcommand is for setting the type-specific options of
channel \fIchannelId\fR. The \fIoption\fR argument indicates the option to be
written, and the \fIvalue\fR argument indicates the value to set the option to.
.RS
.PP
This subcommand will never try to update more than one option at a
time; that is behavior implemented in the Tcl channel core.
.PP
The return value of the subcommand is ignored.
.PP
If the subcommand throws an error the command which performed the
(re)configuration or query (usually \fBfconfigure\fR or
\fBchan configure\fR) will appear to have thrown this error. Any exception
beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and
converted to an error.
.RE
.\" METHOD: cget
.TP
\fIcmdPrefix \fBcget \fIchannelId option\fR
.
This \fIoptional\fR subcommand is used when reading a single type-specific
option of channel \fIchannelId\fR. If this subcommand is supported then the
subcommand \fBcgetall\fR must be supported as well.
.RS
.PP
The subcommand should return the value of the specified \fIoption\fR.
.PP
If the subcommand throws an error, the command which performed the
(re)configuration or query (usually \fBfconfigure\fR or \fBchan configure\fR)
will appear to have thrown this error. Any exception beyond \fIerror\fR
(e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error.
.RE
.\" METHOD: cgetall
.TP
\fIcmdPrefix \fBcgetall \fIchannelId\fR
.
This \fIoptional\fR subcommand is used for reading all type-specific options
of channel \fIchannelId\fR. If this subcommand is supported then the
subcommand \fBcget\fR has to be supported as well.
.RS
.PP
The subcommand should return a list of all options and their values.
This list must have an even number of elements.
.PP
If the subcommand throws an error the command which performed the
(re)configuration or query (usually \fBfconfigure\fR or \fBchan configure\fR)
will appear to have thrown this error. Any exception beyond \fBerror\fR
(e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error.
.RE
.\" METHOD: blocking
.TP
\fIcmdPrefix \fBblocking \fIchannelId mode\fR
.
This \fIoptional\fR subcommand handles changes to the blocking mode of the
channel \fIchannelId\fR. The \fImode\fR is a boolean flag. A true value means
that the channel has to be set to blocking, and a false value means that the
channel should be non-blocking.
.RS
.PP
The return value of the subcommand is ignored.
.PP
If the subcommand throws an error the command which caused its
invocation (usually \fBfconfigure\fR or \fBchan configure\fR) will appear to
have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR,
etc.) is treated as and converted to an error.
.RE
.\" METHOD: truncate
.TP
\fIcmdPrefix \fBtruncate\fI channelId length\fR
.
This \fIoptional\fR subcommand handles changing the length of the
underlying data stream for the channel \fIchannelId\fR. Its length
gets set to \fIlength\fR.
.RS
.PP
If the subcommand throws an error the command which caused its
invocation (usually \fBchan truncate\fR) will appear to have thrown
this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR,
etc.) is treated as and converted to an error.







|


|
















|


|












|


|













|


|













|


|







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
.PP
The offset/base combination of 0/\fBcurrent\fR signals a \fBchan tell\fR
request, i.e.,\ seek nothing relative to the current location, making
the new location identical to the current one, which is then returned.
.RE
.\" METHOD: configure
.TP
\fIcmdPrefix \fBconfigure \fIchannel option value\fR
.
This \fIoptional\fR subcommand is for setting the type-specific options of
channel \fIchannel\fR. The \fIoption\fR argument indicates the option to be
written, and the \fIvalue\fR argument indicates the value to set the option to.
.RS
.PP
This subcommand will never try to update more than one option at a
time; that is behavior implemented in the Tcl channel core.
.PP
The return value of the subcommand is ignored.
.PP
If the subcommand throws an error the command which performed the
(re)configuration or query (usually \fBfconfigure\fR or
\fBchan configure\fR) will appear to have thrown this error. Any exception
beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and
converted to an error.
.RE
.\" METHOD: cget
.TP
\fIcmdPrefix \fBcget \fIchannel option\fR
.
This \fIoptional\fR subcommand is used when reading a single type-specific
option of channel \fIchannel\fR. If this subcommand is supported then the
subcommand \fBcgetall\fR must be supported as well.
.RS
.PP
The subcommand should return the value of the specified \fIoption\fR.
.PP
If the subcommand throws an error, the command which performed the
(re)configuration or query (usually \fBfconfigure\fR or \fBchan configure\fR)
will appear to have thrown this error. Any exception beyond \fIerror\fR
(e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error.
.RE
.\" METHOD: cgetall
.TP
\fIcmdPrefix \fBcgetall \fIchannel\fR
.
This \fIoptional\fR subcommand is used for reading all type-specific options
of channel \fIchannel\fR. If this subcommand is supported then the
subcommand \fBcget\fR has to be supported as well.
.RS
.PP
The subcommand should return a list of all options and their values.
This list must have an even number of elements.
.PP
If the subcommand throws an error the command which performed the
(re)configuration or query (usually \fBfconfigure\fR or \fBchan configure\fR)
will appear to have thrown this error. Any exception beyond \fBerror\fR
(e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error.
.RE
.\" METHOD: blocking
.TP
\fIcmdPrefix \fBblocking \fIchannel mode\fR
.
This \fIoptional\fR subcommand handles changes to the blocking mode of the
channel \fIchannel\fR. The \fImode\fR is a boolean flag. A true value means
that the channel has to be set to blocking, and a false value means that the
channel should be non-blocking.
.RS
.PP
The return value of the subcommand is ignored.
.PP
If the subcommand throws an error the command which caused its
invocation (usually \fBfconfigure\fR or \fBchan configure\fR) will appear to
have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR,
etc.) is treated as and converted to an error.
.RE
.\" METHOD: truncate
.TP
\fIcmdPrefix \fBtruncate\fI channel length\fR
.
This \fIoptional\fR subcommand handles changing the length of the
underlying data stream for the channel \fIchannel\fR. Its length
gets set to \fIlength\fR.
.RS
.PP
If the subcommand throws an error the command which caused its
invocation (usually \fBchan truncate\fR) will appear to have thrown
this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR,
etc.) is treated as and converted to an error.

Changes to doc/return.n.

74
75
76
77
78
79
80
81



82
83
84
85
86
87
88
The return code of the procedure is 4 (\fBTCL_CONTINUE\fR).  The
procedure command behaves in its calling context as if it
were the command \fBcontinue\fR.
.TP 13
\fIvalue\fR
.
\fIValue\fR must be an integer;  it will be returned as the
return code for the current procedure.



.LP
When a procedure wants to signal that it has received invalid
arguments from its caller, it may use \fBreturn -code error\fR
with \fIresult\fR set to a suitable error message.  Otherwise
usage of the \fBreturn -code\fR option is mostly limited to
procedures that implement a new control structure.
.PP







|
>
>
>







74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
The return code of the procedure is 4 (\fBTCL_CONTINUE\fR).  The
procedure command behaves in its calling context as if it
were the command \fBcontinue\fR.
.TP 13
\fIvalue\fR
.
\fIValue\fR must be an integer;  it will be returned as the
return code for the current procedure. Applications
and packages should use values in the range 5 to 1073741823 (0x3fffffff)
for their own purposes. Values outside this range are reserved
for use by Tcl.
.LP
When a procedure wants to signal that it has received invalid
arguments from its caller, it may use \fBreturn -code error\fR
with \fIresult\fR set to a suitable error message.  Otherwise
usage of the \fBreturn -code\fR option is mostly limited to
procedures that implement a new control structure.
.PP

Changes to doc/safe.n.

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
Example of use with "Sync Mode" off: when initializing a safe interpreter
with a non-empty access path, the ::auto_path will be set to {} unless its
own value is also specified:
.RS
.PP
.CS
safe::interpCreate foo -accessPath {
    /usr/local/TclHome/lib/tcl8.6
    /usr/local/TclHome/lib/tcl8.6/http1.0
    /usr/local/TclHome/lib/tcl8.6/opt0.4
    /usr/local/TclHome/lib/tcl8.6/msgs
    /usr/local/TclHome/lib/tcl8.6/encoding
    /usr/local/TclHome/lib
}

# The child's ::auto_path must be given a suitable value:

safe::interpConfigure foo -autoPath {
    /usr/local/TclHome/lib/tcl8.6
    /usr/local/TclHome/lib
}

# The two commands can be combined:

safe::interpCreate foo -accessPath {
    /usr/local/TclHome/lib/tcl8.6
    /usr/local/TclHome/lib/tcl8.6/http1.0
    /usr/local/TclHome/lib/tcl8.6/opt0.4
    /usr/local/TclHome/lib/tcl8.6/msgs
    /usr/local/TclHome/lib/tcl8.6/encoding
    /usr/local/TclHome/lib
} -autoPath {
    /usr/local/TclHome/lib/tcl8.6
    /usr/local/TclHome/lib
}
.CE
.RE
.PP
Example of use with "Sync Mode" off: the command
\fBsafe::interpAddToAccessPath\fR does not change the safe interpreter's







|
|
|
|
|






|






|
|
|
|
|


|







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
Example of use with "Sync Mode" off: when initializing a safe interpreter
with a non-empty access path, the ::auto_path will be set to {} unless its
own value is also specified:
.RS
.PP
.CS
safe::interpCreate foo -accessPath {
    /usr/local/TclHome/lib/tcl9.0
    /usr/local/TclHome/lib/tcl9.0/http1.0
    /usr/local/TclHome/lib/tcl9.0/opt0.4
    /usr/local/TclHome/lib/tcl9.0/msgs
    /usr/local/TclHome/lib/tcl9.0/encoding
    /usr/local/TclHome/lib
}

# The child's ::auto_path must be given a suitable value:

safe::interpConfigure foo -autoPath {
    /usr/local/TclHome/lib/tcl9.0
    /usr/local/TclHome/lib
}

# The two commands can be combined:

safe::interpCreate foo -accessPath {
    /usr/local/TclHome/lib/tcl9.0
    /usr/local/TclHome/lib/tcl9.0/http1.0
    /usr/local/TclHome/lib/tcl9.0/opt0.4
    /usr/local/TclHome/lib/tcl9.0/msgs
    /usr/local/TclHome/lib/tcl9.0/encoding
    /usr/local/TclHome/lib
} -autoPath {
    /usr/local/TclHome/lib/tcl9.0
    /usr/local/TclHome/lib
}
.CE
.RE
.PP
Example of use with "Sync Mode" off: the command
\fBsafe::interpAddToAccessPath\fR does not change the safe interpreter's

Changes to doc/scan.n.

69
70
71
72
73
74
75
76

77
78
79
80
81
82

83
84
85

86
87
88
89
90
91
92
at most once and the empty positions will be filled in with empty strings.
.SS "OPTIONAL SIZE MODIFIER"
.PP
The size modifier field is used only when scanning a substring into
one of Tcl's integer values.  The size modifier field dictates the
integer range acceptable to be stored in a variable, or, for the inline
case, in a position in the result list.
The syntactically valid values for the size modifier are \fBh\fR, \fBL\fR,

\fBl\fR, and \fBll\fR.  The \fBh\fR size modifier value is equivalent
to the absence of a size modifier in the the conversion specifier.
Either one indicates the integer range to be stored is limited to the range
determined by the value of the \fBwordSize\fR element of the \fBtcl_platform\fR
array).  The \fBL\fR size modifier is equivalent to the \fBl\fR size
modifier. Either one indicates the integer range to be stored is

limited to the same range produced by the \fBwide()\fR function of
the \fBexpr\fR command.  The \fBll\fR size modifier indicates that
the integer range to be stored is unlimited.

.SS "MANDATORY CONVERSION CHARACTER"
.PP
The following conversion characters are supported:
.IP \fBd\fR
The input substring must be a decimal integer.
It is read in and the integer value is stored in the variable,
truncated as required by the size modifier value.







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







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
at most once and the empty positions will be filled in with empty strings.
.SS "OPTIONAL SIZE MODIFIER"
.PP
The size modifier field is used only when scanning a substring into
one of Tcl's integer values.  The size modifier field dictates the
integer range acceptable to be stored in a variable, or, for the inline
case, in a position in the result list.
The syntactically valid values for the size modifier are \fBh\fR,
\fBl\fR, \fBz\fR, \fBt\fR, \fBq\fR, \fBj\fR, \fBll\fR, and \fBL\fR.
The \fBh\fR size modifier value is equivalent to the absence of a size
modifier in the the conversion specifier.  Either one indicates the
integer range to be stored is limited to the 32-bit range.  The \fBL\fR

size modifier is equivalent to the \fBll\fR size modifier.  Either one
indicates the integer range to be stored is unlimited.  The \fBl\fR (or
\fBq\fR or \fBj\fR) size modifier indicates that the integer range to be
stored is limited to the same range produced by the \fBwide()\fR function
of the \fBexpr\fR command. The \fBz\fR and \fBt\fR modifiers indicate the
integer range to be the same as for either \fBh\fR or \fBl\fR, depending
on the value of the \fBpointerSize\fR element of the \fBtcl_platform\fR array.
.SS "MANDATORY CONVERSION CHARACTER"
.PP
The following conversion characters are supported:
.IP \fBd\fR
The input substring must be a decimal integer.
It is read in and the integer value is stored in the variable,
truncated as required by the size modifier value.
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
puts "X=$x, Y=$y"
.CE
.PP
An interactive session demonstrating the truncation of integer
values determined by size modifiers:
.PP
.CS
\fI%\fR set tcl_platform(wordSize)
4
\fI%\fR scan 20000000000000000000 %d
2147483647
\fI%\fR scan 20000000000000000000 %ld
9223372036854775807
\fI%\fR scan 20000000000000000000 %lld
20000000000000000000
.CE







<
<







245
246
247
248
249
250
251


252
253
254
255
256
257
258
puts "X=$x, Y=$y"
.CE
.PP
An interactive session demonstrating the truncation of integer
values determined by size modifiers:
.PP
.CS


\fI%\fR scan 20000000000000000000 %d
2147483647
\fI%\fR scan 20000000000000000000 %ld
9223372036854775807
\fI%\fR scan 20000000000000000000 %lld
20000000000000000000
.CE

Changes to doc/seek.n.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
.TH seek n 8.1 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
seek \- Change the access position for an open channel
.SH SYNOPSIS
\fBseek \fIchannelId offset \fR?\fIorigin\fR?
.BE
.SH DESCRIPTION
.PP
The \fBseek\fR command has been superceded by the \fBchan seek\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
.TH seek n 8.1 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
seek \- Change the access position for an open channel
.SH SYNOPSIS
\fBseek \fIchannel offset \fR?\fIorigin\fR?
.BE
.SH DESCRIPTION
.PP
The \fBseek\fR command has been superceded by the \fBchan seek\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)

Changes to doc/socket.n.

257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
set sockChan [\fBsocket\fR $server 9900]
gets $sockChan line1
gets $sockChan line2
close $sockChan
puts "The time on $server is $line1"
puts "That is [lindex $line2 0]s since the server started"
.CE
.SH "HISTORY"
Support for IPv6 was added in Tcl 8.6.
.SH "SEE ALSO"
chan(n), flush(n), open(n), read(n)
.SH KEYWORDS
asynchronous I/O, bind, channel, connection, domain name, host,
network address, socket, tcp
'\" Local Variables:
'\" mode: nroff







<
<







257
258
259
260
261
262
263


264
265
266
267
268
269
270
set sockChan [\fBsocket\fR $server 9900]
gets $sockChan line1
gets $sockChan line2
close $sockChan
puts "The time on $server is $line1"
puts "That is [lindex $line2 0]s since the server started"
.CE


.SH "SEE ALSO"
chan(n), flush(n), open(n), read(n)
.SH KEYWORDS
asynchronous I/O, bind, channel, connection, domain name, host,
network address, socket, tcp
'\" Local Variables:
'\" mode: nroff

Changes to doc/tell.n.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
.TH tell n 8.1 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
tell \- Return current access position for an open channel
.SH SYNOPSIS
\fBtell \fIchannelId\fR
.BE
.SH DESCRIPTION
.PP
The \fBtell\fR command has been superceded by the \fBchan tell\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
.TH tell n 8.1 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
tell \- Return current access position for an open channel
.SH SYNOPSIS
\fBtell \fIchannel\fR
.BE
.SH DESCRIPTION
.PP
The \fBtell\fR command has been superceded by the \fBchan tell\fR
command which supports the same syntax and options.
.SH "SEE ALSO"
chan(n)

Changes to doc/transchan.n.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
transchan \- command handler API of channel transforms
.SH SYNOPSIS
.nf
\fBchan push \fIchannelName cmdPrefix\fR

\fIcmdPrefix \fBclear \fIhandle\fR
\fIcmdPrefix \fBdrain \fIhandle\fR
\fIcmdPrefix \fBfinalize \fIhandle\fR
\fIcmdPrefix \fBflush \fIhandle\fR
\fIcmdPrefix \fBinitialize \fIhandle mode\fR
\fIcmdPrefix \fBlimit? \fIhandle\fR







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
transchan \- command handler API of channel transforms
.SH SYNOPSIS
.nf
\fBchan push \fIchannel cmdPrefix\fR

\fIcmdPrefix \fBclear \fIhandle\fR
\fIcmdPrefix \fBdrain \fIhandle\fR
\fIcmdPrefix \fBfinalize \fIhandle\fR
\fIcmdPrefix \fBflush \fIhandle\fR
\fIcmdPrefix \fBinitialize \fIhandle mode\fR
\fIcmdPrefix \fBlimit? \fIhandle\fR

Changes to generic/tcl.h.

490
491
492
493
494
495
496


497
498
499
500
501
502
503


504
505
506
507
508
509
510
 * TCL_RETURN		The command requests that the current function return;
 *			the interpreter's result contains the function's
 *			return value.
 * TCL_BREAK		The command requests that the innermost loop be
 *			exited; the interpreter's result is meaningless.
 * TCL_CONTINUE		Go on to the next iteration of the current loop; the
 *			interpreter's result is meaningless.


 */

#define TCL_OK			0
#define TCL_ERROR		1
#define TCL_RETURN		2
#define TCL_BREAK		3
#define TCL_CONTINUE		4



/*
 *----------------------------------------------------------------------------
 * Flags to control what substitutions are performed by Tcl_SubstObj():
 */

#define TCL_SUBST_COMMANDS	001







>
>







>
>







490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
 * TCL_RETURN		The command requests that the current function return;
 *			the interpreter's result contains the function's
 *			return value.
 * TCL_BREAK		The command requests that the innermost loop be
 *			exited; the interpreter's result is meaningless.
 * TCL_CONTINUE		Go on to the next iteration of the current loop; the
 *			interpreter's result is meaningless.
 * Integer return codes in the range TCL_CODE_USER_MIN to TCL_CODE_USER_MAX are
 * reserved for the use of packages.
 */

#define TCL_OK			0
#define TCL_ERROR		1
#define TCL_RETURN		2
#define TCL_BREAK		3
#define TCL_CONTINUE		4
#define TCL_CODE_USER_MIN	5
#define TCL_CODE_USER_MAX	0x3fffffff /*  1073741823 */

/*
 *----------------------------------------------------------------------------
 * Flags to control what substitutions are performed by Tcl_SubstObj():
 */

#define TCL_SUBST_COMMANDS	001

Changes to generic/tclArithSeries.c.

497
498
499
500
501
502
503
504
505

506
507
508
509
510
511
512
513

514


515



516
517
518
519
520
521
522
523
524
525
526
527
528
529
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
 * Results:
 *	A Tcl_Obj pointer.  No assignment on error.
 *
 * Side Effects:
 *	None.
 *----------------------------------------------------------------------
 */
static void
assignNumber(

    int useDoubles,
    Tcl_WideInt *intNumberPtr,
    double *dblNumberPtr,
    Tcl_Obj *numberObj)
{
    void *clientData;
    int tcl_number_type;


    if (Tcl_GetNumberFromObj(NULL, numberObj, &clientData, &tcl_number_type) != TCL_OK


	    || tcl_number_type == TCL_NUMBER_BIG) {



	return;
    }
    if (useDoubles) {
	if (tcl_number_type != TCL_NUMBER_INT) {
	    *dblNumberPtr = *(double *)clientData;
	} else {
	    *dblNumberPtr = (double)*(Tcl_WideInt *)clientData;
	}
    } else {
	if (tcl_number_type == TCL_NUMBER_INT) {
	    *intNumberPtr = *(Tcl_WideInt *)clientData;
	} else {
	    *intNumberPtr = (Tcl_WideInt)*(double *)clientData;
	}
    }

}

/*
 *----------------------------------------------------------------------
 *
 * TclNewArithSeriesObj --
 *
 *	Creates a new ArithSeries object. Some arguments may be NULL and will
 *	be computed based on the other given arguments.
 *      refcount = 0.
 *
 * Results:
 *	A Tcl_Obj pointer to the created ArithSeries object.
 *	An empty Tcl_Obj if the range is invalid.
 *
 * Side Effects:
 *	None.
 *----------------------------------------------------------------------
 */
int

TclNewArithSeriesObj(
    Tcl_Interp *interp,       /* For error reporting */
    Tcl_Obj **arithSeriesObj, /* return value */
    int useDoubles,           /* Flag indicates values start,
			      ** end, step, are treated as doubles */
    Tcl_Obj *startObj,        /* Starting value */
    Tcl_Obj *endObj,          /* Ending limit */
    Tcl_Obj *stepObj,         /* increment value */
    Tcl_Obj *lenObj)          /* Number of elements */
{
    double dstart, dend, dstep;
    Tcl_WideInt start, end, step;
    Tcl_WideInt len = -1;


    if (startObj) {
	assignNumber(useDoubles, &start, &dstart, startObj);


    } else {
	start = 0;
	dstart = start;
    }
    if (stepObj) {
	assignNumber(useDoubles, &step, &dstep, stepObj);


	if (useDoubles) {
	    step = dstep;
	} else {
	    dstep = step;
	}
	if (dstep == 0) {
	    TclNewObj(*arithSeriesObj);
	    return TCL_OK;
	}
    }
    if (endObj) {
	assignNumber(useDoubles, &end, &dend, endObj);


    }
    if (lenObj) {
	if (TCL_OK != Tcl_GetWideIntFromObj(interp, lenObj, &len)) {
	    return TCL_ERROR;
	}
    }

    if (startObj && endObj) {
	if (!stepObj) {
	    if (useDoubles) {
		dstep = (dstart < dend) ? 1.0 : -1.0;







|

>








>
|
>
>
|
>
>
>
|














>













|





<
>


<










>


|
>
>





|
>
>






|
|



|
>
>



|







497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
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
 * Results:
 *	A Tcl_Obj pointer.  No assignment on error.
 *
 * Side Effects:
 *	None.
 *----------------------------------------------------------------------
 */
static int
assignNumber(
    Tcl_Interp *interp,
    int useDoubles,
    Tcl_WideInt *intNumberPtr,
    double *dblNumberPtr,
    Tcl_Obj *numberObj)
{
    void *clientData;
    int tcl_number_type;

    if (Tcl_GetNumberFromObj(interp, numberObj, &clientData,
		&tcl_number_type) != TCL_OK) {
    	return TCL_ERROR;
    }
    if (tcl_number_type == TCL_NUMBER_BIG) {
    	/* bignum is not supported yet. */
    	Tcl_WideInt w;
	(void)Tcl_GetWideIntFromObj(interp, numberObj, &w);
	return TCL_ERROR;
    }
    if (useDoubles) {
	if (tcl_number_type != TCL_NUMBER_INT) {
	    *dblNumberPtr = *(double *)clientData;
	} else {
	    *dblNumberPtr = (double)*(Tcl_WideInt *)clientData;
	}
    } else {
	if (tcl_number_type == TCL_NUMBER_INT) {
	    *intNumberPtr = *(Tcl_WideInt *)clientData;
	} else {
	    *intNumberPtr = (Tcl_WideInt)*(double *)clientData;
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclNewArithSeriesObj --
 *
 *	Creates a new ArithSeries object. Some arguments may be NULL and will
 *	be computed based on the other given arguments.
 *      refcount = 0.
 *
 * Results:
 *	A Tcl_Obj pointer to the created ArithSeries object.
 *	NULL if the range is invalid.
 *
 * Side Effects:
 *	None.
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclNewArithSeriesObj(
    Tcl_Interp *interp,       /* For error reporting */

    int useDoubles,           /* Flag indicates values start,
			      ** end, step, are treated as doubles */
    Tcl_Obj *startObj,        /* Starting value */
    Tcl_Obj *endObj,          /* Ending limit */
    Tcl_Obj *stepObj,         /* increment value */
    Tcl_Obj *lenObj)          /* Number of elements */
{
    double dstart, dend, dstep;
    Tcl_WideInt start, end, step;
    Tcl_WideInt len = -1;
    Tcl_Obj *objPtr;

    if (startObj) {
	if (assignNumber(interp, useDoubles, &start, &dstart, startObj) != TCL_OK) {
	    return NULL;
	}
    } else {
	start = 0;
	dstart = start;
    }
    if (stepObj) {
	if (assignNumber(interp, useDoubles, &step, &dstep, stepObj) != TCL_OK) {
	    return NULL;
	}
	if (useDoubles) {
	    step = dstep;
	} else {
	    dstep = step;
	}
	if (dstep == 0) {
	    TclNewObj(objPtr);
	    return objPtr;
	}
    }
    if (endObj) {
	if (assignNumber(interp, useDoubles, &end, &dend, endObj) != TCL_OK) {
	    return NULL;
	}
    }
    if (lenObj) {
	if (TCL_OK != Tcl_GetWideIntFromObj(interp, lenObj, &len)) {
	    return NULL;
	}
    }

    if (startObj && endObj) {
	if (!stepObj) {
	    if (useDoubles) {
		dstep = (dstart < dend) ? 1.0 : -1.0;
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
	}
    }

    if (len > TCL_SIZE_MAX) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"max length of a Tcl list exceeded", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
	return TCL_ERROR;
    }

    if (arithSeriesObj) {
	*arithSeriesObj = (useDoubles)
	    ? NewArithSeriesDbl(dstart, dend, dstep, len)
	    : NewArithSeriesInt(start, end, step, len);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclArithSeriesObjIndex --
 *







|


<
|


<
|







639
640
641
642
643
644
645
646
647
648

649
650
651

652
653
654
655
656
657
658
659
	}
    }

    if (len > TCL_SIZE_MAX) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"max length of a Tcl list exceeded", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
	return NULL;
    }


    objPtr = (useDoubles)
	    ? NewArithSeriesDbl(dstart, dend, dstep, len)
	    : NewArithSeriesInt(start, end, step, len);

    return objPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclArithSeriesObjIndex --
 *
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
    TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx, &startObj);
    Tcl_IncrRefCount(startObj);
    TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx, &endObj);
    Tcl_IncrRefCount(endObj);
    TclArithSeriesObjStep(arithSeriesObj, &stepObj);
    Tcl_IncrRefCount(stepObj);

    if (Tcl_IsShared(arithSeriesObj) || (arithSeriesObj->refCount > 1)) {
	int status = TclNewArithSeriesObj(NULL, newObjPtr,
		arithSeriesRepPtr->isDouble, startObj, endObj, stepObj, NULL);

	Tcl_DecrRefCount(startObj);
	Tcl_DecrRefCount(endObj);
	Tcl_DecrRefCount(stepObj);
	return status;
    }

    /*
     * In-place is possible.
     */

    /*







|
|
|
|



|







840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
    TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx, &startObj);
    Tcl_IncrRefCount(startObj);
    TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx, &endObj);
    Tcl_IncrRefCount(endObj);
    TclArithSeriesObjStep(arithSeriesObj, &stepObj);
    Tcl_IncrRefCount(stepObj);

    if (Tcl_IsShared(arithSeriesObj) || ((arithSeriesObj->refCount > 1))) {
	Tcl_Obj *newSlicePtr = TclNewArithSeriesObj(interp,
	    arithSeriesRepPtr->isDouble, startObj, endObj, stepObj, NULL);
	*newObjPtr = newSlicePtr;
	Tcl_DecrRefCount(startObj);
	Tcl_DecrRefCount(endObj);
	Tcl_DecrRefCount(stepObj);
	return newSlicePtr ? TCL_OK : TCL_ERROR;
    }

    /*
     * In-place is possible.
     */

    /*
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
	TclSetIntObj(stepObj, step);
    }

    if (Tcl_IsShared(arithSeriesObj) || (arithSeriesObj->refCount > 1)) {
	Tcl_Obj *lenObj;

	TclNewIntObj(lenObj, len);
	if (TclNewArithSeriesObj(NULL, &resultObj, isDouble,
		startObj, endObj, stepObj, lenObj) != TCL_OK) {
	    resultObj = NULL;
	}
	Tcl_DecrRefCount(lenObj);
    } else {
	/*
	 * In-place is possible.
	 */

	TclInvalidateStringRep(arithSeriesObj);







|
|
<
<







1051
1052
1053
1054
1055
1056
1057
1058
1059


1060
1061
1062
1063
1064
1065
1066
	TclSetIntObj(stepObj, step);
    }

    if (Tcl_IsShared(arithSeriesObj) || (arithSeriesObj->refCount > 1)) {
	Tcl_Obj *lenObj;

	TclNewIntObj(lenObj, len);
	resultObj = TclNewArithSeriesObj(interp, isDouble,
	    startObj, endObj, stepObj, lenObj);


	Tcl_DecrRefCount(lenObj);
    } else {
	/*
	 * In-place is possible.
	 */

	TclInvalidateStringRep(arithSeriesObj);
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087

    Tcl_DecrRefCount(startObj);
    Tcl_DecrRefCount(endObj);
    Tcl_DecrRefCount(stepObj);

    *newObjPtr = resultObj;

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfArithSeries --
 *







|







1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097

    Tcl_DecrRefCount(startObj);
    Tcl_DecrRefCount(endObj);
    Tcl_DecrRefCount(stepObj);

    *newObjPtr = resultObj;

    return resultObj ? TCL_OK : TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfArithSeries --
 *

Changes to generic/tclBasic.c.

233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
static Tcl_NRPostProc	TEOV_Exception;
static Tcl_NRPostProc	TEOV_NotFoundCallback;
static Tcl_NRPostProc	TEOV_RestoreVarFrame;
static Tcl_NRPostProc	TEOV_RunLeaveTraces;
static Tcl_NRPostProc	EvalObjvCore;
static Tcl_NRPostProc	Dispatch;

static Tcl_ObjCmdProc2 NRInjectObjCmd;
static Tcl_NRPostProc NRPostInvoke;
static Tcl_ObjCmdProc2 CoroTypeObjCmd;
static Tcl_ObjCmdProc2 TclNRCoroInjectObjCmd;
static Tcl_ObjCmdProc2 TclNRCoroProbeObjCmd;
static Tcl_NRPostProc InjectHandler;
static Tcl_NRPostProc InjectHandlerPostCall;








<







233
234
235
236
237
238
239

240
241
242
243
244
245
246
static Tcl_NRPostProc	TEOV_Exception;
static Tcl_NRPostProc	TEOV_NotFoundCallback;
static Tcl_NRPostProc	TEOV_RestoreVarFrame;
static Tcl_NRPostProc	TEOV_RunLeaveTraces;
static Tcl_NRPostProc	EvalObjvCore;
static Tcl_NRPostProc	Dispatch;


static Tcl_NRPostProc NRPostInvoke;
static Tcl_ObjCmdProc2 CoroTypeObjCmd;
static Tcl_ObjCmdProc2 TclNRCoroInjectObjCmd;
static Tcl_ObjCmdProc2 TclNRCoroProbeObjCmd;
static Tcl_NRPostProc InjectHandler;
static Tcl_NRPostProc InjectHandlerPostCall;

1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
    /* Adding the bytecode assembler command */
    cmdPtr = (Command *) Tcl_NRCreateCommand2(interp,
	    "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
	    TclNRAssembleObjCmd, NULL, NULL);
    cmdPtr->compileProc = &TclCompileAssembleCmd;

    /* Coroutine monkeybusiness */
    Tcl_NRCreateCommand2(interp, "::tcl::unsupported::inject", NULL,
	    NRInjectObjCmd, NULL, NULL);
    Tcl_CreateObjCommand2(interp, "::tcl::unsupported::corotype",
	    CoroTypeObjCmd, NULL, NULL);

    /* Export unsupported commands */
    nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
    if (nsPtr) {
	Tcl_Export(interp, nsPtr, "*", 1);







<
<







1182
1183
1184
1185
1186
1187
1188


1189
1190
1191
1192
1193
1194
1195
    /* Adding the bytecode assembler command */
    cmdPtr = (Command *) Tcl_NRCreateCommand2(interp,
	    "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
	    TclNRAssembleObjCmd, NULL, NULL);
    cmdPtr->compileProc = &TclCompileAssembleCmd;

    /* Coroutine monkeybusiness */


    Tcl_CreateObjCommand2(interp, "::tcl::unsupported::corotype",
	    CoroTypeObjCmd, NULL, NULL);

    /* Export unsupported commands */
    nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
    if (nsPtr) {
	Tcl_Export(interp, nsPtr, "*", 1);
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

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclNREvalList --
 *
 *	Callback to invoke command as list, used in order to delayed
 *	processing of canonical list command in sane environment.
 *
 *----------------------------------------------------------------------
 */

static int
TclNREvalList(
    void *data[],
    Tcl_Interp *interp,
    TCL_UNUSED(int) /*result*/)
{
    Tcl_Size objc;
    Tcl_Obj **objv;
    Tcl_Obj *listPtr = (Tcl_Obj *)data[0];

    Tcl_IncrRefCount(listPtr);

    TclMarkTailcall(interp);
    TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL);
    TclListObjGetElements(NULL, listPtr, &objc, &objv);
    return TclNREvalObjv(interp, objc, objv, 0, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * CoroTypeObjCmd --
 *
 *	Implementation of [::tcl::unsupported::corotype] command.
 *
 *----------------------------------------------------------------------
 */








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







9303
9304
9305
9306
9307
9308
9309





























9310
9311
9312
9313
9314
9315
9316

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *





























 * CoroTypeObjCmd --
 *
 *	Implementation of [::tcl::unsupported::corotype] command.
 *
 *----------------------------------------------------------------------
 */

9657
9658
9659
9660
9661
9662
9663
9664
9665
9666
9667
9668
9669
9670
9671
9672
9673
9674
9675
9676
9677
9678
9679
9680
9681
9682
9683
9684
9685
9686
9687
9688
9689
9690
9691
9692
9693
9694
9695
9696
9697
9698
9699
9700
9701
9702
9703
9704
9705
9706
9707
9708
9709
9710
9711
9712
9713
9714
9715
9716
9717
9718
9719
9720
9721
9722
9723
9724
9725
	Tcl_Size numLevels = iPtr->numLevels;
	iPtr->numLevels = corPtr->auxNumLevels;
	corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
	iPtr->execEnvPtr = corPtr->callerEEPtr;
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * NRInjectObjCmd --
 *
 *	Implementation of [::tcl::unsupported::inject] command.
 *
 *----------------------------------------------------------------------
 */

static int
NRInjectObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const objv[])
{
    CoroutineData *corPtr;
    ExecEnv *savedEEPtr = iPtr->execEnvPtr;

    /*
     * Usage more or less like tailcall:
     *   inject coroName cmd ?arg1 arg2 ...?
     */

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
	return TCL_ERROR;
    }

    corPtr = GetCoroutineFromObj(interp, objv[1],
	    "can only inject a command into a coroutine");
    if (!corPtr) {
	return TCL_ERROR;
    }
    if (!COR_IS_SUSPENDED(corPtr)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"can only inject a command into a suspended coroutine", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (char *)NULL);
	return TCL_ERROR;
    }

    /*
     * Add the callback to the coro's execEnv, so that it is the first thing
     * to happen when the coro is resumed.
     */

    iPtr->execEnvPtr = corPtr->eePtr;
    TclNRAddCallback(interp, TclNREvalList, Tcl_NewListObj(objc - 2, objv + 2),
	    NULL, NULL, NULL);
    iPtr->execEnvPtr = savedEEPtr;

    return TCL_OK;
}

int
TclNRInterpCoroutine(
    void *clientData,
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Size objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */







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







9625
9626
9627
9628
9629
9630
9631























































9632
9633
9634
9635
9636
9637
9638
	Tcl_Size numLevels = iPtr->numLevels;
	iPtr->numLevels = corPtr->auxNumLevels;
	corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
	iPtr->execEnvPtr = corPtr->callerEEPtr;
    }
    return result;
}
























































int
TclNRInterpCoroutine(
    void *clientData,
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Size objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */

Changes to generic/tclCmdIL.c.

98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120

/*
 * Definitions for [lseq] command
 */
static const char *const seq_operations[] = {
    "..", "to", "count", "by", NULL
};
typedef enum Sequence_Operators {
    LSEQ_DOTS, LSEQ_TO, LSEQ_COUNT, LSEQ_BY
} SequenceOperators;
static const char *const seq_step_keywords[] = {"by", NULL};
typedef enum Step_Operators {
    STEP_BY = 4
} SequenceByMode;
typedef enum Sequence_Decoded {
     NoneArg, NumericArg, RangeKeywordArg, ByKeywordArg
} SequenceDecoded;

/*
 * Forward declarations for procedures defined in this file:
 */

static int		DictionaryCompare(const char *left, const char *right);







|


<
|
<
<
<
|







98
99
100
101
102
103
104
105
106
107

108



109
110
111
112
113
114
115
116

/*
 * Definitions for [lseq] command
 */
static const char *const seq_operations[] = {
    "..", "to", "count", "by", NULL
};
typedef enum {
    LSEQ_DOTS, LSEQ_TO, LSEQ_COUNT, LSEQ_BY
} SequenceOperators;

typedef enum {



     NoneArg, NumericArg, RangeKeywordArg, ErrArg, LastArg = 8
} SequenceDecoded;

/*
 * Forward declarations for procedures defined in this file:
 */

static int		DictionaryCompare(const char *left, const char *right);
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036

4037
4038
4039
4040
4041

4042

4043


4044
4045
4046
4047
4048


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
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
4105
4106
4107
4108
4109
4110
4111
 *  Return Value
 *    0 - failure, unexpected value
 *    1 - value is a number
 *    2 - value is an operand keyword
 *    3 - value is a by keyword
 *
 *  The decoded value will be assigned to the appropriate
 *  pointer, if supplied.
 */

static SequenceDecoded
SequenceIdentifyArgument(
     Tcl_Interp *interp,        /* for error reporting  */
     Tcl_Obj *argPtr,           /* Argument to decode   */

     Tcl_Obj **numValuePtr,     /* Return numeric value */
     int *keywordIndexPtr)      /* Return keyword enum  */
{
    int status;
    SequenceOperators opmode;

    SequenceByMode bymode;

    void *clientData;



    status = Tcl_GetNumberFromObj(NULL, argPtr, &clientData, keywordIndexPtr);
    if (status == TCL_OK) {
	if (numValuePtr) {
	    *numValuePtr = argPtr;


	}

	return NumericArg;

    } else {

	/* Check for an index expression */
	long value;
	double dvalue;
	Tcl_Obj *exprValueObj;
	int keyword;
	Tcl_InterpState savedstate;
	savedstate = Tcl_SaveInterpState(interp, status);
	if (Tcl_ExprLongObj(interp, argPtr, &value) != TCL_OK) {
	    status = Tcl_RestoreInterpState(interp, savedstate);
	    exprValueObj = argPtr;
	} else {
	    // Determine if expression is double or int
	    if (Tcl_ExprDoubleObj(interp, argPtr, &dvalue) != TCL_OK) {

		keyword = TCL_NUMBER_INT;
		exprValueObj = argPtr;
	    } else {
		if (floor(dvalue) == dvalue) {
		    TclNewIntObj(exprValueObj, value);
		    keyword = TCL_NUMBER_INT;
		} else {
		    TclNewDoubleObj(exprValueObj, dvalue);
		    keyword = TCL_NUMBER_DOUBLE;
		}
	    }
	    status = Tcl_RestoreInterpState(interp, savedstate);
	    if (numValuePtr) {
		*numValuePtr = exprValueObj;
	    }
	    if (keywordIndexPtr) {
		*keywordIndexPtr = keyword ;// type of expression result
	    }
	    return NumericArg;
	}




    }


    status = Tcl_GetIndexFromObj(NULL, argPtr, seq_operations,
				 "range operation", 0, &opmode);
    if (status == TCL_OK) {
	if (keywordIndexPtr) {
	    *keywordIndexPtr = opmode;
	}
	return RangeKeywordArg;
    }

    status = Tcl_GetIndexFromObj(NULL, argPtr, seq_step_keywords,
				 "step keyword", 0, &bymode);
    if (status == TCL_OK) {
	if (keywordIndexPtr) {
	    *keywordIndexPtr = bymode;
	}
	return ByKeywordArg;
    }
    return NoneArg;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LseqObjCmd --
 *







|






>



|

>
|
>
|
>
>
|
|
|
<

>
>

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

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

<







4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047

4048
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
4076
4077
4078

4079
4080


4081
4082
4083




4084

4085
4086

4087
4088
4089
4090
4091
4092
4093
 *  Return Value
 *    0 - failure, unexpected value
 *    1 - value is a number
 *    2 - value is an operand keyword
 *    3 - value is a by keyword
 *
 *  The decoded value will be assigned to the appropriate
 *  pointer, numValuePtr reference count is incremented.
 */

static SequenceDecoded
SequenceIdentifyArgument(
     Tcl_Interp *interp,        /* for error reporting  */
     Tcl_Obj *argPtr,           /* Argument to decode   */
     int allowedArgs,		/* Flags if keyword or numeric allowed. */
     Tcl_Obj **numValuePtr,     /* Return numeric value */
     int *keywordIndexPtr)      /* Return keyword enum  */
{
    int result = TCL_ERROR;
    SequenceOperators opmode;
    void *internalPtr;

    if (allowedArgs & NumericArg) {
	/* speed-up a bit (and avoid shimmer for compiled expressions) */
	if (TclHasInternalRep(argPtr, &tclExprCodeType)) {
	   goto doExpr;
	}
	result = Tcl_GetNumberFromObj(NULL, argPtr, &internalPtr, keywordIndexPtr);
	if (result == TCL_OK) {

	    *numValuePtr = argPtr;
	    Tcl_IncrRefCount(argPtr);
	    return NumericArg;
	}
    }
    if (allowedArgs & RangeKeywordArg) {
	result = Tcl_GetIndexFromObj(NULL, argPtr, seq_operations,
			"range operation", 0, &opmode);
    }
    if (result == TCL_OK) {
	if (allowedArgs & LastArg) {


	    /* keyword found, but no followed number */

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		  "missing \"%s\" value.", TclGetString(argPtr)));

	    return ErrArg;



	}
	*keywordIndexPtr = opmode;




	return RangeKeywordArg;
    } else {






	Tcl_Obj *exprValueObj;

	if (!(allowedArgs & NumericArg)) {


	    return NoneArg;
	}
    doExpr:
	/* Check for an index expression */
	if (Tcl_ExprObj(interp, argPtr, &exprValueObj) != TCL_OK) {
	    return ErrArg;
	}
	int keyword;
	/* Determine if result of expression is double or int */
	if (Tcl_GetNumberFromObj(interp, exprValueObj, &internalPtr,

		&keyword) != TCL_OK
	) {


	    return ErrArg;
	}
	*numValuePtr = exprValueObj; /* incremented in Tcl_ExprObj */




	*keywordIndexPtr = keyword; /* type of expression result */

	return NumericArg;
    }

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LseqObjCmd --
 *
4148
4149
4150
4151
4152
4153
4154
4155

4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
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
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
    Tcl_Obj *const objv[]) /* The argument objects. */
{
    Tcl_Obj *elementCount = NULL;
    Tcl_Obj *start = NULL, *end = NULL, *step = NULL;
    Tcl_WideInt values[5];
    Tcl_Obj *numValues[5];
    Tcl_Obj *numberObj;
    int status = TCL_ERROR, keyword, useDoubles = 0;

    Tcl_Obj *arithSeriesPtr;
    SequenceOperators opmode;
    SequenceDecoded decoded;
    Tcl_Size i;
    int arg_key = 0, value_i = 0;
    // Default constants
    Tcl_Obj *zero = Tcl_NewIntObj(0);
    Tcl_Obj *one = Tcl_NewIntObj(1);

    /*
     * Create a decoding key by looping through the arguments and identify
     * what kind of argument each one is.  Encode each argument as a decimal
     * digit.
     */
    if (objc > 6) {
	 /* Too many arguments */
	 arg_key=0;

    } else for (i=1; i<objc; i++) {
	 arg_key = (arg_key * 10);
	 numValues[value_i] = NULL;
	 decoded = SequenceIdentifyArgument(interp, objv[i], &numberObj, &keyword);


	 switch (decoded) {

	 case NoneArg:
	      /*
	       * Unrecognizable argument
	       * Reproduce operation error message
	       */
	      status = Tcl_GetIndexFromObj(interp, objv[i], seq_operations,
		           "operation", 0, &opmode);
	      goto done;

	 case NumericArg:

	      arg_key += NumericArg;





	      numValues[value_i] = numberObj;
	      Tcl_IncrRefCount(numValues[value_i]);
	      values[value_i] = keyword;  // This is the TCL_NUMBER_* value
	      useDoubles = useDoubles ? useDoubles : keyword == TCL_NUMBER_DOUBLE;
	      value_i++;
	      break;

	 case RangeKeywordArg:
	      arg_key += RangeKeywordArg;
	      values[value_i] = keyword;
	      value_i++;
	      break;

	 case ByKeywordArg:
	      arg_key += ByKeywordArg;
	      values[value_i] = keyword;
	      value_i++;
	      break;

	 default:
	      arg_key += 9; // Error state
	      value_i++;
	      break;
	 }
    }

    /*
     * The key encoding defines a valid set of arguments, or indicates an
     * error condition; process the values accordningly.
     */
    switch (arg_key) {

/*    No argument */
    case 0:
	 Tcl_WrongNumArgs(interp, 1, objv,
	     "n ??op? n ??by? n??");
	 goto done;
	 break;

/*    lseq n */
    case 1:
	start = zero;
	elementCount = numValues[0];
	end = NULL;
	step = one;
	break;







|
>





|
|
|







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

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

|
|
<
<
<
|
<
<
|
|
|

|
|
<
|
|








<
<
<
<
<
<
<







4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163

4164
4165
4166
4167
4168
4169
4170
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
4200
4201
4202
4203
4204
4205







4206
4207
4208
4209
4210
4211
4212
    Tcl_Obj *const objv[]) /* The argument objects. */
{
    Tcl_Obj *elementCount = NULL;
    Tcl_Obj *start = NULL, *end = NULL, *step = NULL;
    Tcl_WideInt values[5];
    Tcl_Obj *numValues[5];
    Tcl_Obj *numberObj;
    int status = TCL_ERROR, keyword, useDoubles = 0, allowedArgs = NumericArg;
    int remNums = 3;
    Tcl_Obj *arithSeriesPtr;
    SequenceOperators opmode;
    SequenceDecoded decoded;
    Tcl_Size i;
    int arg_key = 0, value_i = 0;
    /* Default constants */
    #define zero ((Interp *)interp)->execEnvPtr->constants[0];
    #define one ((Interp *)interp)->execEnvPtr->constants[1];

    /*
     * Create a decoding key by looping through the arguments and identify
     * what kind of argument each one is.  Encode each argument as a decimal
     * digit.
     */
    if (objc > 6) {
	/* Too many arguments */
	goto syntax;
    }
    for (i = 1; i < objc; i++) {
	arg_key = (arg_key * 10);
	numValues[value_i] = NULL;
	decoded = SequenceIdentifyArgument(interp, objv[i],
			allowedArgs | (i == objc-1 ? LastArg : 0),
			&numberObj, &keyword);
	switch (decoded) {

	  case NoneArg:
	    /*
	     * Unrecognizable argument
	     * Reproduce operation error message
	     */
	    status = Tcl_GetIndexFromObj(interp, objv[i], seq_operations,
			"operation", 0, &opmode);
	    goto done;

	  case NumericArg:
	    remNums--;
	    arg_key += NumericArg;
	    allowedArgs = RangeKeywordArg;
	    /* if last number but 2 arguments remain, next is not numeric */
	    if ((remNums != 1) || ((objc-1-i) != 2)) {
		allowedArgs |= NumericArg;
	    }
	    numValues[value_i] = numberObj;

	    values[value_i] = keyword;  /* TCL_NUMBER_* */
	    useDoubles |= (keyword == TCL_NUMBER_DOUBLE) ? 1 : 0;
	    value_i++;
	    break;

	  case RangeKeywordArg:
	    arg_key += RangeKeywordArg;



	    allowedArgs = NumericArg;   /* after keyword always numeric only */


	    values[value_i] = keyword;  /* SequenceOperators */
	    value_i++;
	    break;

	  default: /* Error state */
	    status = TCL_ERROR;

	    goto done;
	}
    }

    /*
     * The key encoding defines a valid set of arguments, or indicates an
     * error condition; process the values accordningly.
     */
    switch (arg_key) {








/*    lseq n */
    case 1:
	start = zero;
	elementCount = numValues[0];
	end = NULL;
	step = one;
	break;
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
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
4394
4395
4396



4397
4398
4399


4400

4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
	    break;
	default:
	    goto done;
	    break;
	}
	break;

/*    Error cases: incomplete arguments */
    case 12:
	 opmode = (SequenceOperators)values[1]; goto KeywordError; break;
    case 112:
	 opmode = (SequenceOperators)values[2]; goto KeywordError; break;
    case 1212:
	 opmode = (SequenceOperators)values[3]; goto KeywordError; break;
    KeywordError:
	 switch (opmode) {
	 case LSEQ_DOTS:
	 case LSEQ_TO:
	      Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		  "missing \"to\" value."));
	      break;
	 case LSEQ_COUNT:
	      Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		  "missing \"count\" value."));
	      break;
	 case LSEQ_BY:
	      Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		  "missing \"by\" value."));
	      break;
	 }
	 goto done;
	 break;

/*    All other argument errors */
    default:

	 Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??");
	 goto done;
	 break;
    }






















    /*
     * Success!  Now lets create the series object.
     */
    status = TclNewArithSeriesObj(interp, &arithSeriesPtr,
		  useDoubles, start, end, step, elementCount);



    if (status == TCL_OK) {
	Tcl_SetObjResult(interp, arithSeriesPtr);
    }

 done:
    // Free number arguments.
    while (--value_i>=0) {
	if (numValues[value_i]) {



	    Tcl_DecrRefCount(numValues[value_i]);
	}
    }




    // Free constants
    Tcl_DecrRefCount(zero);
    Tcl_DecrRefCount(one);

    return status;
}

/*
 *----------------------------------------------------------------------
 *







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


>




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




|


>
>
|







>
>
>



>
>
|
>
|
|
|







4320
4321
4322
4323
4324
4325
4326


























4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
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
	    break;
	default:
	    goto done;
	    break;
	}
	break;



























/*    All other argument errors */
    default:
      syntax:
	 Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??");
	 goto done;
	 break;
    }

    /* Count needs to be integer, so try to convert if possible */
    if (elementCount && TclHasInternalRep(elementCount, &tclDoubleType)) {
	double d;
	(void)Tcl_GetDoubleFromObj(NULL, elementCount, &d);
	if (floor(d) == d) {
	    if ((d >= (double)WIDE_MAX) || (d <= (double)WIDE_MIN)) {
		mp_int big;

		if (Tcl_InitBignumFromDouble(NULL, d, &big) == TCL_OK) {
		    elementCount = Tcl_NewBignumObj(&big);
		    keyword = TCL_NUMBER_INT;
		}
		/* Infinity, don't convert, let fail later */
	    } else {
		elementCount = Tcl_NewWideIntObj((Tcl_WideInt)d);
		keyword = TCL_NUMBER_INT;
	    }
	}
    }


    /*
     * Success!  Now lets create the series object.
     */
    arithSeriesPtr = TclNewArithSeriesObj(interp,
		  useDoubles, start, end, step, elementCount);

    status = TCL_ERROR;
    if (arithSeriesPtr) {
	status = TCL_OK;
	Tcl_SetObjResult(interp, arithSeriesPtr);
    }

 done:
    // Free number arguments.
    while (--value_i>=0) {
	if (numValues[value_i]) {
	    if (elementCount == numValues[value_i]) {
		elementCount = NULL;
	    }
	    Tcl_DecrRefCount(numValues[value_i]);
	}
    }
    if (elementCount) {
	Tcl_DecrRefCount(elementCount);
    }

    /* Undef constants */
    #undef zero
    #undef one

    return status;
}

/*
 *----------------------------------------------------------------------
 *

Changes to generic/tclEncoding.c.

30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
				 * into UTF-8. */
    Tcl_EncodingConvertProc *fromUtfProc;
				/* Function to convert from UTF-8 into
				 * external encoding. */
    Tcl_EncodingFreeProc *freeProc;
				/* If non-NULL, function to call when this
				 * encoding is deleted. */
    void *clientData;	/* Arbitrary value associated with encoding
				 * type. Passed to conversion functions. */
    Tcl_Size nullSize;	/* Number of 0x00 bytes that signify
				 * end-of-string in this encoding. This number
				 * is used to determine the source string
				 * length when the srcLen argument is
				 * negative. This number can be 1, 2, or 4. */
    LengthProc *lengthProc;	/* Function to compute length of
				 * null-terminated strings in this encoding.
				 * If nullSize is 1, this is strlen; if







|

|







30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
				 * into UTF-8. */
    Tcl_EncodingConvertProc *fromUtfProc;
				/* Function to convert from UTF-8 into
				 * external encoding. */
    Tcl_EncodingFreeProc *freeProc;
				/* If non-NULL, function to call when this
				 * encoding is deleted. */
    void *clientData;		/* Arbitrary value associated with encoding
				 * type. Passed to conversion functions. */
    Tcl_Size nullSize;		/* Number of 0x00 bytes that signify
				 * end-of-string in this encoding. This number
				 * is used to determine the source string
				 * length when the srcLen argument is
				 * negative. This number can be 1, 2, or 4. */
    LengthProc *lengthProc;	/* Function to compute length of
				 * null-terminated strings in this encoding.
				 * If nullSize is 1, this is strlen; if
115
116
117
118
119
120
121
122

123
124
125
126
127
128
129
				 * conversion. */
    char prefixBytes[256];	/* If a byte in the input stream is the first
				 * character of one of the escape sequences in
				 * the following array, the corresponding
				 * entry in this array is 1, otherwise it is
				 * 0. */
    int numSubTables;		/* Length of following array. */
    EscapeSubTable subTables[TCLFLEXARRAY];/* Information about each EscapeSubTable used

				 * by this encoding type. The actual size is
				 * as large as necessary to hold all
				 * EscapeSubTables. */
} EscapeEncodingData;

/*
 * Constants used when loading an encoding file to identify the type of the







|
>







115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
				 * conversion. */
    char prefixBytes[256];	/* If a byte in the input stream is the first
				 * character of one of the escape sequences in
				 * the following array, the corresponding
				 * entry in this array is 1, otherwise it is
				 * 0. */
    int numSubTables;		/* Length of following array. */
    EscapeSubTable subTables[TCLFLEXARRAY];
				/* Information about each EscapeSubTable used
				 * by this encoding type. The actual size is
				 * as large as necessary to hold all
				 * EscapeSubTables. */
} EscapeEncodingData;

/*
 * Constants used when loading an encoding file to identify the type of the
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
    int value;
} encodingProfiles[] = {
    {"replace", TCL_ENCODING_PROFILE_REPLACE},
    {"strict", TCL_ENCODING_PROFILE_STRICT},
    {"tcl8", TCL_ENCODING_PROFILE_TCL8},
};

#define PROFILE_TCL8(flags_)                                           \
    (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_TCL8)

#define PROFILE_REPLACE(flags_)                                        \
    (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_REPLACE)

#define PROFILE_STRICT(flags_)                                         \
    (!PROFILE_TCL8(flags_) && !PROFILE_REPLACE(flags_))

#define UNICODE_REPLACE_CHAR 0xFFFD
#define SURROGATE(c_)      (((c_) & ~0x7FF) == 0xD800)
#define HIGH_SURROGATE(c_) (((c_) & ~0x3FF) == 0xD800)
#define LOW_SURROGATE(c_)  (((c_) & ~0x3FF) == 0xDC00)

/*
 * The following variable is used in the sparse matrix code for a
 * TableEncoding to represent a page in the table that has no entries.
 */

static unsigned short emptyPage[256];







|


|


|



|
|
|







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
    int value;
} encodingProfiles[] = {
    {"replace", TCL_ENCODING_PROFILE_REPLACE},
    {"strict", TCL_ENCODING_PROFILE_STRICT},
    {"tcl8", TCL_ENCODING_PROFILE_TCL8},
};

#define PROFILE_TCL8(flags_) \
    (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_TCL8)

#define PROFILE_REPLACE(flags_) \
    (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_REPLACE)

#define PROFILE_STRICT(flags_) \
    (!PROFILE_TCL8(flags_) && !PROFILE_REPLACE(flags_))

#define UNICODE_REPLACE_CHAR 0xFFFD
#define SURROGATE(c_)		(((c_) & ~0x7FF) == 0xD800)
#define HIGH_SURROGATE(c_)	(((c_) & ~0x3FF) == 0xD800)
#define LOW_SURROGATE(c_)	(((c_) & ~0x3FF) == 0xDC00)

/*
 * The following variable is used in the sparse matrix code for a
 * TableEncoding to represent a page in the table that has no entries.
 */

static unsigned short emptyPage[256];
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
static Tcl_EncodingConvertProc	UtfToUtf16Proc;
static Tcl_EncodingConvertProc	UtfToUcs2Proc;
static Tcl_EncodingConvertProc	UtfToUtfProc;
static Tcl_EncodingConvertProc	Iso88591FromUtfProc;
static Tcl_EncodingConvertProc	Iso88591ToUtfProc;

/*
 * A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field
 * of the internalrep. This should help the lifetime of encodings be more useful.
 * See concerns raised in [Bug 1077262].
 */

static const Tcl_ObjType encodingType = {
    "encoding",
    FreeEncodingInternalRep,
    DupEncodingInternalRep,
    NULL,







|
|
|







256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
static Tcl_EncodingConvertProc	UtfToUtf16Proc;
static Tcl_EncodingConvertProc	UtfToUcs2Proc;
static Tcl_EncodingConvertProc	UtfToUtfProc;
static Tcl_EncodingConvertProc	Iso88591FromUtfProc;
static Tcl_EncodingConvertProc	Iso88591ToUtfProc;

/*
 * A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1
 * field of the internalrep. This should help the lifetime of encodings be more
 * useful. See concerns raised in [Bug 1077262].
 */

static const Tcl_ObjType encodingType = {
    "encoding",
    FreeEncodingInternalRep,
    DupEncodingInternalRep,
    NULL,
506
507
508
509
510
511
512

513
514

515


516
517
518
519
520
521
522
/*
 * NOTE: THESE BIT DEFINITIONS SHOULD NOT OVERLAP WITH INTERNAL USE BITS
 * DEFINED IN tcl.h (TCL_ENCODING_* et al). Be cognizant of this
 * when adding bits. TODO - should really be defined in a single file.
 *
 * To prevent conflicting bits, only define bits within 0xff00 mask here.
 */

#define TCL_ENCODING_LE	0x100   /* Used to distinguish LE/BE variants */
#define ENCODING_UTF	0x200	/* For UTF-8 encoding, allow 4-byte output sequences */

#define ENCODING_INPUT	0x400   /* For UTF-8/CESU-8 encoding, means external -> internal */



void
TclInitEncodingSubsystem(void)
{
    Tcl_EncodingType type;
    TableEncodingData *dataPtr;
    unsigned size;







>
|
|
>
|
>
>







507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
/*
 * NOTE: THESE BIT DEFINITIONS SHOULD NOT OVERLAP WITH INTERNAL USE BITS
 * DEFINED IN tcl.h (TCL_ENCODING_* et al). Be cognizant of this
 * when adding bits. TODO - should really be defined in a single file.
 *
 * To prevent conflicting bits, only define bits within 0xff00 mask here.
 */
enum InternalEncodingFlags {
    TCL_ENCODING_LE = 0x100,	/* Used to distinguish LE/BE variants */
    ENCODING_UTF = 0x200,	/* For UTF-8 encoding, allow 4-byte output
				 * sequences */
    ENCODING_INPUT = 0x400	/* For UTF-8/CESU-8 encoding, means
				 * external -> internal */
};

void
TclInitEncodingSubsystem(void)
{
    Tcl_EncodingType type;
    TableEncodingData *dataPtr;
    unsigned size;
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
    type.clientData	= INT2PTR(ENCODING_UTF);
    tclUtf8Encoding = Tcl_CreateEncoding(&type);
    type.clientData	= NULL;
    type.encodingName	= "cesu-8";
    Tcl_CreateEncoding(&type);

    type.toUtfProc	= Utf16ToUtfProc;
    type.fromUtfProc    = UtfToUcs2Proc;
    type.freeProc	= NULL;
    type.nullSize	= 2;
    type.encodingName   = "ucs-2le";
    type.clientData	= INT2PTR(TCL_ENCODING_LE);
    Tcl_CreateEncoding(&type);
    type.encodingName   = "ucs-2be";
    type.clientData	= NULL;
    Tcl_CreateEncoding(&type);
    type.encodingName   = "ucs-2";
    type.clientData	= INT2PTR(leFlags);
    Tcl_CreateEncoding(&type);

    type.toUtfProc	= Utf32ToUtfProc;
    type.fromUtfProc    = UtfToUtf32Proc;
    type.freeProc	= NULL;
    type.nullSize	= 4;
    type.encodingName   = "utf-32le";
    type.clientData	= INT2PTR(TCL_ENCODING_LE);
    Tcl_CreateEncoding(&type);
    type.encodingName   = "utf-32be";
    type.clientData	= NULL;
    Tcl_CreateEncoding(&type);
    type.encodingName   = "utf-32";
    type.clientData	= INT2PTR(leFlags);
    Tcl_CreateEncoding(&type);

    type.toUtfProc	= Utf16ToUtfProc;
    type.fromUtfProc    = UtfToUtf16Proc;
    type.freeProc	= NULL;
    type.nullSize	= 2;
    type.encodingName   = "utf-16le";
    type.clientData	= INT2PTR(TCL_ENCODING_LE);
    Tcl_CreateEncoding(&type);
    type.encodingName   = "utf-16be";
    type.clientData	= NULL;
    Tcl_CreateEncoding(&type);
    type.encodingName   = "utf-16";
    type.clientData	= INT2PTR(leFlags);
    Tcl_CreateEncoding(&type);

#ifndef TCL_NO_DEPRECATED
    type.encodingName   = "unicode";
    Tcl_CreateEncoding(&type);
#endif

    /*
     * Need the iso8859-1 encoding in order to process binary data, so force
     * it to always be embedded. Note that this encoding *must* be a proper
     * table encoding or some of the escape encodings crash! Hence the ugly







|


|


|


|




|


|


|


|







|


|


|




|







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
    type.clientData	= INT2PTR(ENCODING_UTF);
    tclUtf8Encoding = Tcl_CreateEncoding(&type);
    type.clientData	= NULL;
    type.encodingName	= "cesu-8";
    Tcl_CreateEncoding(&type);

    type.toUtfProc	= Utf16ToUtfProc;
    type.fromUtfProc	= UtfToUcs2Proc;
    type.freeProc	= NULL;
    type.nullSize	= 2;
    type.encodingName	= "ucs-2le";
    type.clientData	= INT2PTR(TCL_ENCODING_LE);
    Tcl_CreateEncoding(&type);
    type.encodingName	= "ucs-2be";
    type.clientData	= NULL;
    Tcl_CreateEncoding(&type);
    type.encodingName	= "ucs-2";
    type.clientData	= INT2PTR(leFlags);
    Tcl_CreateEncoding(&type);

    type.toUtfProc	= Utf32ToUtfProc;
    type.fromUtfProc	= UtfToUtf32Proc;
    type.freeProc	= NULL;
    type.nullSize	= 4;
    type.encodingName	= "utf-32le";
    type.clientData	= INT2PTR(TCL_ENCODING_LE);
    Tcl_CreateEncoding(&type);
    type.encodingName	= "utf-32be";
    type.clientData	= NULL;
    Tcl_CreateEncoding(&type);
    type.encodingName	= "utf-32";
    type.clientData	= INT2PTR(leFlags);
    Tcl_CreateEncoding(&type);

    type.toUtfProc	= Utf16ToUtfProc;
    type.fromUtfProc    = UtfToUtf16Proc;
    type.freeProc	= NULL;
    type.nullSize	= 2;
    type.encodingName	= "utf-16le";
    type.clientData	= INT2PTR(TCL_ENCODING_LE);
    Tcl_CreateEncoding(&type);
    type.encodingName	= "utf-16be";
    type.clientData	= NULL;
    Tcl_CreateEncoding(&type);
    type.encodingName	= "utf-16";
    type.clientData	= INT2PTR(leFlags);
    Tcl_CreateEncoding(&type);

#ifndef TCL_NO_DEPRECATED
    type.encodingName	= "unicode";
    Tcl_CreateEncoding(&type);
#endif

    /*
     * Need the iso8859-1 encoding in order to process binary data, so force
     * it to always be embedded. Note that this encoding *must* be a proper
     * table encoding or some of the escape encodings crash! Hence the ugly
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_GetEncodingNulLength --
 *
 *	Given an encoding, return the number of nul bytes used for the
 *      string termination.
 *
 * Results:
 *	The number of nul bytes used for the string termination.
 *
 * Side effects:
 *	None.
 *







|







925
926
927
928
929
930
931
932
933
934
935
936
937
938
939

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_GetEncodingNulLength --
 *
 *	Given an encoding, return the number of nul bytes used for the
 *	string termination.
 *
 * Results:
 *	The number of nul bytes used for the string termination.
 *
 * Side effects:
 *	None.
 *
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
 *	"flags" controls the behavior if any of the bytes in
 *	the source buffer are invalid or cannot be represented in utf-8.
 *	Possible flags values:
 *	target encoding. It should be composed by OR-ing the following:
 *	- *At most one* of TCL_ENCODING_PROFILE{DEFAULT,TCL8,STRICT}
 *
 * Results:
 *      The return value is one of
 *        TCL_OK: success. Converted string in *dstPtr
 *        TCL_ERROR: error in passed parameters. Error message in interp
 *        TCL_CONVERT_MULTIBYTE: source ends in truncated multibyte sequence
 *        TCL_CONVERT_SYNTAX: source is not conformant to encoding definition
 *        TCL_CONVERT_UNKNOWN: source contained a character that could not
 *            be represented in target encoding.
 *
 * Side effects:
 *
 *      TCL_OK: The converted bytes are stored in the DString and NUL
 *          terminated in an encoding-specific manner.
 *      TCL_ERROR: an error, message is stored in the interp if not NULL.
 *      TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored
 *          in the interpreter (if not NULL). If errorLocPtr is not NULL,
 *          no error message is stored as it is expected the caller is
 *          interested in whatever is decoded so far and not treating this
 *          as an error condition.
 *
 *      In addition, *dstPtr is always initialized and must be cleared
 *      by the caller irrespective of the return code.
 *
 *-------------------------------------------------------------------------
 */

int
Tcl_ExternalToUtfDStringEx(
    Tcl_Interp *interp,         /* For error messages. May be NULL. */
    Tcl_Encoding encoding,	/* The encoding for the source string, or NULL
				 * for the default system encoding. */
    const char *src,		/* Source string in specified encoding. */
    Tcl_Size srcLen,		/* Source string length in bytes, or < 0 for
				 * encoding-specific string length. */
    int flags,			/* Conversion control flags. */
    Tcl_DString *dstPtr,	/* Uninitialized or free DString in which the
				 * converted string is stored. */
    Tcl_Size *errorLocPtr)      /* Where to store the error location
                                 * (or TCL_INDEX_NONE if no error). May
				 * be NULL. */
{
    char *dst;
    Tcl_EncodingState state;
    const Encoding *encodingPtr;
    int result;
    Tcl_Size dstLen, soFar;







|
|
|
|
|
|
|


<
|
|
|
|
|
|
|
|

|
|






|








|
|







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
 *	"flags" controls the behavior if any of the bytes in
 *	the source buffer are invalid or cannot be represented in utf-8.
 *	Possible flags values:
 *	target encoding. It should be composed by OR-ing the following:
 *	- *At most one* of TCL_ENCODING_PROFILE{DEFAULT,TCL8,STRICT}
 *
 * Results:
 *	The return value is one of
 *	  TCL_OK: success. Converted string in *dstPtr
 *	  TCL_ERROR: error in passed parameters. Error message in interp
 *	  TCL_CONVERT_MULTIBYTE: source ends in truncated multibyte sequence
 *	  TCL_CONVERT_SYNTAX: source is not conformant to encoding definition
 *	  TCL_CONVERT_UNKNOWN: source contained a character that could not
 *	      be represented in target encoding.
 *
 * Side effects:

 *	TCL_OK: The converted bytes are stored in the DString and NUL
 *	    terminated in an encoding-specific manner.
 *	TCL_ERROR: an error, message is stored in the interp if not NULL.
 *	TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored
 *	    in the interpreter (if not NULL). If errorLocPtr is not NULL,
 *	    no error message is stored as it is expected the caller is
 *	    interested in whatever is decoded so far and not treating this
 *	    as an error condition.
 *
 *	In addition, *dstPtr is always initialized and must be cleared
 *	by the caller irrespective of the return code.
 *
 *-------------------------------------------------------------------------
 */

int
Tcl_ExternalToUtfDStringEx(
    Tcl_Interp *interp,		/* For error messages. May be NULL. */
    Tcl_Encoding encoding,	/* The encoding for the source string, or NULL
				 * for the default system encoding. */
    const char *src,		/* Source string in specified encoding. */
    Tcl_Size srcLen,		/* Source string length in bytes, or < 0 for
				 * encoding-specific string length. */
    int flags,			/* Conversion control flags. */
    Tcl_DString *dstPtr,	/* Uninitialized or free DString in which the
				 * converted string is stored. */
    Tcl_Size *errorLocPtr)	/* Where to store the error location
				 * (or TCL_INDEX_NONE if no error). May
				 * be NULL. */
{
    char *dst;
    Tcl_EncodingState state;
    const Encoding *encodingPtr;
    int result;
    Tcl_Size dstLen, soFar;
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

	    Tcl_DStringSetLength(dstPtr, soFar);
	    if (errorLocPtr) {
		/*
		 * Do not write error message into interpreter if caller
		 * wants to know error location.
		 */
		*errorLocPtr = result == TCL_OK ? TCL_INDEX_NONE : nBytesProcessed;

	    } else {
		/* Caller wants error message on failure */
		if (result != TCL_OK && interp != NULL) {
		    char buf[TCL_INTEGER_SPACE];
		    snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "d", nBytesProcessed);

		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "unexpected byte sequence starting at index %"
			    TCL_SIZE_MODIFIER "d: '\\x%02X'",
			    nBytesProcessed, UCHAR(srcStart[nBytesProcessed])));
		    Tcl_SetErrorCode(
			    interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, (void *)NULL);

		}
	    }
	    if (result != TCL_OK) {
		errno = (result == TCL_CONVERT_NOSPACE) ? ENOMEM : EILSEQ;
	    }
	    return result;
	}







|
>




|
>





|
>







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

	    Tcl_DStringSetLength(dstPtr, soFar);
	    if (errorLocPtr) {
		/*
		 * Do not write error message into interpreter if caller
		 * wants to know error location.
		 */
		*errorLocPtr = result == TCL_OK
			? TCL_INDEX_NONE : nBytesProcessed;
	    } else {
		/* Caller wants error message on failure */
		if (result != TCL_OK && interp != NULL) {
		    char buf[TCL_INTEGER_SPACE];
		    snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "d",
			    nBytesProcessed);
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "unexpected byte sequence starting at index %"
			    TCL_SIZE_MODIFIER "d: '\\x%02X'",
			    nBytesProcessed, UCHAR(srcStart[nBytesProcessed])));
		    Tcl_SetErrorCode(
			    interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf,
			    (void *)NULL);
		}
	    }
	    if (result != TCL_OK) {
		errno = (result == TCL_CONVERT_NOSPACE) ? ENOMEM : EILSEQ;
	    }
	    return result;
	}
1283
1284
1285
1286
1287
1288
1289
1290
1291

1292
1293
1294
1295
1296
1297
1298

int
Tcl_ExternalToUtf(
    TCL_UNUSED(Tcl_Interp *),	/* TODO: Re-examine this. */
    Tcl_Encoding encoding,	/* The encoding for the source string, or NULL
				 * for the default system encoding. */
    const char *src,		/* Source string in specified encoding. */
    Tcl_Size srcLen,		/* Source string length in bytes, or TCL_INDEX_NONE for
				 * encoding-specific string length. */

    int flags,			/* Conversion control flags. */
    Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion. Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst,			/* Output buffer in which converted string is







|
|
>







1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306

int
Tcl_ExternalToUtf(
    TCL_UNUSED(Tcl_Interp *),	/* TODO: Re-examine this. */
    Tcl_Encoding encoding,	/* The encoding for the source string, or NULL
				 * for the default system encoding. */
    const char *src,		/* Source string in specified encoding. */
    Tcl_Size srcLen,		/* Source string length in bytes, or
				 * TCL_INDEX_NONE for encoding-specific string
				 * length. */
    int flags,			/* Conversion control flags. */
    Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion. Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst,			/* Output buffer in which converted string is
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
 *	Convert a source buffer from UTF-8 to the specified encoding.
 *	The parameter flags controls the behavior, if any of the bytes in
 *	the source buffer are invalid or cannot be represented in the
 *	target encoding. It should be composed by OR-ing the following:
 *	- *At most one* of TCL_ENCODING_PROFILE_*
 *
 * Results:
 *      The return value is one of
 *        TCL_OK: success. Converted string in *dstPtr
 *        TCL_ERROR: error in passed parameters. Error message in interp
 *        TCL_CONVERT_MULTIBYTE: source ends in truncated multibyte sequence
 *        TCL_CONVERT_SYNTAX: source is not conformant to encoding definition
 *        TCL_CONVERT_UNKNOWN: source contained a character that could not
 *            be represented in target encoding.
 *
 * Side effects:
 *
 *      TCL_OK: The converted bytes are stored in the DString and NUL
 *          terminated in an encoding-specific manner
 *      TCL_ERROR: an error, message is stored in the interp if not NULL.
 *      TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored
 *          in the interpreter (if not NULL). If errorLocPtr is not NULL,
 *          no error message is stored as it is expected the caller is
 *          interested in whatever is decoded so far and not treating this
 *          as an error condition.
 *
 *      In addition, *dstPtr is always initialized and must be cleared
 *      by the caller irrespective of the return code.
 *
 *-------------------------------------------------------------------------
 */

int
Tcl_UtfToExternalDStringEx(
    Tcl_Interp *interp,         /* For error messages. May be NULL. */
    Tcl_Encoding encoding,	/* The encoding for the converted string, or
				 * NULL for the default system encoding. */
    const char *src,		/* Source string in UTF-8. */
    Tcl_Size srcLen,		/* Source string length in bytes, or < 0 for
				 * strlen(). */
    int flags,			/* Conversion control flags. */
    Tcl_DString *dstPtr,	/* Uninitialized or free DString in which the
				 * converted string is stored. */
    Tcl_Size *errorLocPtr)      /* Where to store the error location
                                 * (or TCL_INDEX_NONE if no error). May
				 * be NULL. */
{
    char *dst;
    Tcl_EncodingState state;
    const Encoding *encodingPtr;
    int result;
    const char *srcStart = src;







|
|
|
|
|
|
|


<
|
|
|
|
|
|
|
|

|
|






|








|
|







1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459

1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
 *	Convert a source buffer from UTF-8 to the specified encoding.
 *	The parameter flags controls the behavior, if any of the bytes in
 *	the source buffer are invalid or cannot be represented in the
 *	target encoding. It should be composed by OR-ing the following:
 *	- *At most one* of TCL_ENCODING_PROFILE_*
 *
 * Results:
 *	The return value is one of
 *	  TCL_OK: success. Converted string in *dstPtr
 *	  TCL_ERROR: error in passed parameters. Error message in interp
 *	  TCL_CONVERT_MULTIBYTE: source ends in truncated multibyte sequence
 *	  TCL_CONVERT_SYNTAX: source is not conformant to encoding definition
 *	  TCL_CONVERT_UNKNOWN: source contained a character that could not
 *	      be represented in target encoding.
 *
 * Side effects:

 *	TCL_OK: The converted bytes are stored in the DString and NUL
 *	    terminated in an encoding-specific manner
 *	TCL_ERROR: an error, message is stored in the interp if not NULL.
 *	TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored
 *	    in the interpreter (if not NULL). If errorLocPtr is not NULL,
 *	    no error message is stored as it is expected the caller is
 *	    interested in whatever is decoded so far and not treating this
 *	    as an error condition.
 *
 *	In addition, *dstPtr is always initialized and must be cleared
 *	by the caller irrespective of the return code.
 *
 *-------------------------------------------------------------------------
 */

int
Tcl_UtfToExternalDStringEx(
    Tcl_Interp *interp,		/* For error messages. May be NULL. */
    Tcl_Encoding encoding,	/* The encoding for the converted string, or
				 * NULL for the default system encoding. */
    const char *src,		/* Source string in UTF-8. */
    Tcl_Size srcLen,		/* Source string length in bytes, or < 0 for
				 * strlen(). */
    int flags,			/* Conversion control flags. */
    Tcl_DString *dstPtr,	/* Uninitialized or free DString in which the
				 * converted string is stored. */
    Tcl_Size *errorLocPtr)	/* Where to store the error location
				 * (or TCL_INDEX_NONE if no error). May
				 * be NULL. */
{
    char *dst;
    Tcl_EncodingState state;
    const Encoding *encodingPtr;
    int result;
    const char *srcStart = src;
1543
1544
1545
1546
1547
1548
1549
1550

1551
1552
1553
1554
1555
1556
1557
1558
1559

1560
1561
1562
1563
1564
1565
1566
		Tcl_DStringSetLength(dstPtr, i--);
	    }
	    if (errorLocPtr) {
		/*
		 * Do not write error message into interpreter if caller
		 * wants to know error location.
		 */
		*errorLocPtr = result == TCL_OK ? TCL_INDEX_NONE : nBytesProcessed;

	    } else {
		/* Caller wants error message on failure */
		if (result != TCL_OK && interp != NULL) {
		    Tcl_Size pos = Tcl_NumUtfChars(srcStart, nBytesProcessed);
		    int ucs4;
		    char buf[TCL_INTEGER_SPACE];

		    TclUtfToUniChar(&srcStart[nBytesProcessed], &ucs4);
		    snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "d", nBytesProcessed);

		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "unexpected character at index %" TCL_SIZE_MODIFIER
			    "u: 'U+%06X'",
			    pos, ucs4));
		    Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE",
			    buf, (void *)NULL);
		}







|
>








|
>







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
		Tcl_DStringSetLength(dstPtr, i--);
	    }
	    if (errorLocPtr) {
		/*
		 * Do not write error message into interpreter if caller
		 * wants to know error location.
		 */
		*errorLocPtr = result == TCL_OK
			? TCL_INDEX_NONE : nBytesProcessed;
	    } else {
		/* Caller wants error message on failure */
		if (result != TCL_OK && interp != NULL) {
		    Tcl_Size pos = Tcl_NumUtfChars(srcStart, nBytesProcessed);
		    int ucs4;
		    char buf[TCL_INTEGER_SPACE];

		    TclUtfToUniChar(&srcStart[nBytesProcessed], &ucs4);
		    snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "d",
			    nBytesProcessed);
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "unexpected character at index %" TCL_SIZE_MODIFIER
			    "u: 'U+%06X'",
			    pos, ucs4));
		    Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE",
			    buf, (void *)NULL);
		}
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618

int
Tcl_UtfToExternal(
    TCL_UNUSED(Tcl_Interp *),	/* TODO: Re-examine this. */
    Tcl_Encoding encoding,	/* The encoding for the converted string, or
				 * NULL for the default system encoding. */
    const char *src,		/* Source string in UTF-8. */
    Tcl_Size srcLen,		/* Source string length in bytes, or TCL_INDEX_NONE for
				 * strlen(). */
    int flags,			/* Conversion control flags. */
    Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion. Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst,			/* Output buffer in which converted string







|
|







1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627

int
Tcl_UtfToExternal(
    TCL_UNUSED(Tcl_Interp *),	/* TODO: Re-examine this. */
    Tcl_Encoding encoding,	/* The encoding for the converted string, or
				 * NULL for the default system encoding. */
    const char *src,		/* Source string in UTF-8. */
    Tcl_Size srcLen,		/* Source string length in bytes, or
				 * TCL_INDEX_NONE for strlen(). */
    int flags,			/* Conversion control flags. */
    Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion. Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst,			/* Output buffer in which converted string
1812
1813
1814
1815
1816
1817
1818
1819

1820
1821
1822
1823
1824
1825
1826
	    TclSetProcessGlobalValue(&encodingFileMap, map);
	}
    }

    if ((NULL == chan) && (interp != NULL)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"unknown encoding \"%s\"", name));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (void *)NULL);

    }
    Tcl_DecrRefCount(fileNameObj);
    Tcl_DecrRefCount(searchPath);

    return chan;
}








|
>







1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
	    TclSetProcessGlobalValue(&encodingFileMap, map);
	}
    }

    if ((NULL == chan) && (interp != NULL)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"unknown encoding \"%s\"", name));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name,
		(void *)NULL);
    }
    Tcl_DecrRefCount(fileNameObj);
    Tcl_DecrRefCount(searchPath);

    return chan;
}

1886
1887
1888
1889
1890
1891
1892
1893

1894
1895
1896
1897
1898
1899
1900
    case 'E':
	encoding = LoadEscapeEncoding(name, chan);
	break;
    }
    if ((encoding == NULL) && (interp != NULL)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"invalid encoding file \"%s\"", name));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (void *)NULL);

    }
    Tcl_CloseEx(NULL, chan, 0);

    return encoding;
}

/*







|
>







1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
    case 'E':
	encoding = LoadEscapeEncoding(name, chan);
	break;
    }
    if ((encoding == NULL) && (interp != NULL)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"invalid encoding file \"%s\"", name));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name,
		(void *)NULL);
    }
    Tcl_CloseEx(NULL, chan, 0);

    return encoding;
}

/*
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
		/*
		 * To avoid infinite recursion in [encoding system iso2022-*]
		 */

		e = (Encoding *) Tcl_GetEncoding(NULL, est.name);
		if ((e != NULL) && (e->toUtfProc != TableToUtfProc)
			&& (e->toUtfProc != Iso88591ToUtfProc)) {
		   Tcl_FreeEncoding((Tcl_Encoding) e);
		   e = NULL;
		}
		est.encodingPtr = e;
		Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est));
	    }
	}
	Tcl_Free(argv);
	Tcl_DStringFree(&lineString);







|
|







2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
		/*
		 * To avoid infinite recursion in [encoding system iso2022-*]
		 */

		e = (Encoding *) Tcl_GetEncoding(NULL, est.name);
		if ((e != NULL) && (e->toUtfProc != TableToUtfProc)
			&& (e->toUtfProc != Iso88591ToUtfProc)) {
		    Tcl_FreeEncoding((Tcl_Encoding) e);
		    e = NULL;
		}
		est.encodingPtr = e;
		Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est));
	    }
	}
	Tcl_Free(argv);
	Tcl_DStringFree(&lineString);
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
	    result = TCL_CONVERT_MULTIBYTE;
	    break;
	}
	if (dst > dstEnd) {
	    result = TCL_CONVERT_NOSPACE;
	    break;
	}

	if (UCHAR(*src) < 0x80 && !((UCHAR(*src) == 0) && (flags & ENCODING_INPUT))) {
	    /*
	     * Copy 7bit characters, but skip null-bytes when we are in input
	     * mode, so that they get converted to \xC0\x80.
	     */
	    *dst++ = *src++;
	} else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) &&
		 (UCHAR(src[1]) == 0x80) &&
		 (!(flags & ENCODING_INPUT) || !PROFILE_TCL8(profile))) {
	    /* Special sequence \xC0\x80 */
	    if (!PROFILE_TCL8(profile) && (flags & ENCODING_INPUT)) {
		if (PROFILE_REPLACE(profile)) {
		   dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst);
		   src += 2;
		} else {
		   /* PROFILE_STRICT */
		   result = TCL_CONVERT_SYNTAX;
		   break;
		}
	    } else {
		/*
		 * Convert 0xC080 to real nulls when we are in output mode,
		 * irrespective of the profile.
		 */
		*dst++ = 0;







>
|











|
|

|
|
|







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
	    result = TCL_CONVERT_MULTIBYTE;
	    break;
	}
	if (dst > dstEnd) {
	    result = TCL_CONVERT_NOSPACE;
	    break;
	}
	if (UCHAR(*src) < 0x80
		&& !((UCHAR(*src) == 0) && (flags & ENCODING_INPUT))) {
	    /*
	     * Copy 7bit characters, but skip null-bytes when we are in input
	     * mode, so that they get converted to \xC0\x80.
	     */
	    *dst++ = *src++;
	} else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) &&
		 (UCHAR(src[1]) == 0x80) &&
		 (!(flags & ENCODING_INPUT) || !PROFILE_TCL8(profile))) {
	    /* Special sequence \xC0\x80 */
	    if (!PROFILE_TCL8(profile) && (flags & ENCODING_INPUT)) {
		if (PROFILE_REPLACE(profile)) {
		    dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst);
		    src += 2;
		} else {
		    /* PROFILE_STRICT */
		    result = TCL_CONVERT_SYNTAX;
		    break;
		}
	    } else {
		/*
		 * Convert 0xC080 to real nulls when we are in output mode,
		 * irrespective of the profile.
		 */
		*dst++ = 0;
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
	     * the user has explicitly asked to be told.
	     */

	    if (flags & ENCODING_INPUT) {
		/* Incomplete bytes for modified UTF-8 target */
		if (PROFILE_STRICT(profile)) {
		    result = (flags & TCL_ENCODING_CHAR_LIMIT)
			       ? TCL_CONVERT_MULTIBYTE
			       : TCL_CONVERT_SYNTAX;
		    break;
		}
	    }
	    if (PROFILE_REPLACE(profile)) {
		ch = UNICODE_REPLACE_CHAR;
		++src;
	    } else {
		/* TCL_ENCODING_PROFILE_TCL8 */
		char chbuf[2];
		chbuf[0] = UCHAR(*src++); chbuf[1] = 0;
		TclUtfToUniChar(chbuf, &ch);
	    }
	    dst += Tcl_UniCharToUtf(ch, dst);
	} else {
	    size_t len = TclUtfToUniChar(src, &ch);
	    if (flags & ENCODING_INPUT) {
		if (((len < 2) && (ch != 0)) || ((ch > 0xFFFF) && !(flags & ENCODING_UTF))) {

		    if (PROFILE_STRICT(profile)) {
			result = TCL_CONVERT_SYNTAX;
			break;
		    } else if (PROFILE_REPLACE(profile)) {
			ch = UNICODE_REPLACE_CHAR;
		    }
		}
	    }

	    const char *saveSrc = src;
	    src += len;
	    if (!(flags & ENCODING_UTF) && !(flags & ENCODING_INPUT) && (ch > 0x3FF)) {

		if (ch > 0xFFFF) {
		    /* CESU-8 6-byte sequence for chars > U+FFFF */
		    ch -= 0x10000;
		    *dst++ = 0xED;
		    *dst++ = (char) (((ch >> 16) & 0x0F) | 0xA0);
		    *dst++ = (char) (((ch >> 10) & 0x3F) | 0x80);
		    ch = (ch & 0x0CFF) | 0xDC00;
		}
		*dst++ = (char)(((ch >> 12) | 0xE0) & 0xEF);
		*dst++ = (char)(((ch >> 6) | 0x80) & 0xBF);
		*dst++ = (char)((ch | 0x80) & 0xBF);
		continue;
	    } else if (SURROGATE(ch)) {
		if (PROFILE_STRICT(profile)) {
		    result = (flags & ENCODING_INPUT) ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN;

		    src = saveSrc;
		    break;
		} else if (PROFILE_REPLACE(profile)) {
		    ch = UNICODE_REPLACE_CHAR;
		}
	    }
	    dst += Tcl_UniCharToUtf(ch, dst);







|
|
















|
>











|
>














|
>







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
	     * the user has explicitly asked to be told.
	     */

	    if (flags & ENCODING_INPUT) {
		/* Incomplete bytes for modified UTF-8 target */
		if (PROFILE_STRICT(profile)) {
		    result = (flags & TCL_ENCODING_CHAR_LIMIT)
			    ? TCL_CONVERT_MULTIBYTE
			    : TCL_CONVERT_SYNTAX;
		    break;
		}
	    }
	    if (PROFILE_REPLACE(profile)) {
		ch = UNICODE_REPLACE_CHAR;
		++src;
	    } else {
		/* TCL_ENCODING_PROFILE_TCL8 */
		char chbuf[2];
		chbuf[0] = UCHAR(*src++); chbuf[1] = 0;
		TclUtfToUniChar(chbuf, &ch);
	    }
	    dst += Tcl_UniCharToUtf(ch, dst);
	} else {
	    size_t len = TclUtfToUniChar(src, &ch);
	    if (flags & ENCODING_INPUT) {
		if (((len < 2) && (ch != 0))
			|| ((ch > 0xFFFF) && !(flags & ENCODING_UTF))) {
		    if (PROFILE_STRICT(profile)) {
			result = TCL_CONVERT_SYNTAX;
			break;
		    } else if (PROFILE_REPLACE(profile)) {
			ch = UNICODE_REPLACE_CHAR;
		    }
		}
	    }

	    const char *saveSrc = src;
	    src += len;
	    if (!(flags & ENCODING_UTF) && !(flags & ENCODING_INPUT)
		    && (ch > 0x3FF)) {
		if (ch > 0xFFFF) {
		    /* CESU-8 6-byte sequence for chars > U+FFFF */
		    ch -= 0x10000;
		    *dst++ = 0xED;
		    *dst++ = (char) (((ch >> 16) & 0x0F) | 0xA0);
		    *dst++ = (char) (((ch >> 10) & 0x3F) | 0x80);
		    ch = (ch & 0x0CFF) | 0xDC00;
		}
		*dst++ = (char)(((ch >> 12) | 0xE0) & 0xEF);
		*dst++ = (char)(((ch >> 6) | 0x80) & 0xBF);
		*dst++ = (char)((ch | 0x80) & 0xBF);
		continue;
	    } else if (SURROGATE(ch)) {
		if (PROFILE_STRICT(profile)) {
		    result = (flags & ENCODING_INPUT)
			    ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN;
		    src = saveSrc;
		    break;
		} else if (PROFILE_REPLACE(profile)) {
		    ch = UNICODE_REPLACE_CHAR;
		}
	    }
	    dst += Tcl_UniCharToUtf(ch, dst);
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
Utf32ToUtfProc(
    void *clientData,	/* additional flags, e.g. TCL_ENCODING_LE */
    const char *src,		/* Source string in Unicode. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    TCL_UNUSED(Tcl_EncodingState *),
    char *dst,			/* Output buffer in which converted string is
				 * stored. */
    int dstLen,			/* The maximum length of output buffer in







|







2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
Utf32ToUtfProc(
    void *clientData,		/* additional flags, e.g. TCL_ENCODING_LE */
    const char *src,		/* Source string in Unicode. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    TCL_UNUSED(Tcl_EncodingState *),
    char *dst,			/* Output buffer in which converted string is
				 * stored. */
    int dstLen,			/* The maximum length of output buffer in
2639
2640
2641
2642
2643
2644
2645
2646

2647
2648

2649
2650
2651
2652
2653
2654
2655
    for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
	if (dst > dstEnd) {
	    result = TCL_CONVERT_NOSPACE;
	    break;
	}

	if (flags & TCL_ENCODING_LE) {
	    ch = (unsigned int)(src[3] & 0xFF) << 24 | (src[2] & 0xFF) << 16 | (src[1] & 0xFF) << 8 | (src[0] & 0xFF);

	} else {
	    ch = (unsigned int)(src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16 | (src[2] & 0xFF) << 8 | (src[3] & 0xFF);

	}
	if ((unsigned)ch > 0x10FFFF) {
	    if (PROFILE_STRICT(flags)) {
		result = TCL_CONVERT_SYNTAX;
		break;
	    }
	    ch = UNICODE_REPLACE_CHAR;







|
>

|
>







2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
    for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
	if (dst > dstEnd) {
	    result = TCL_CONVERT_NOSPACE;
	    break;
	}

	if (flags & TCL_ENCODING_LE) {
	    ch = (unsigned int)(src[3] & 0xFF) << 24 | (src[2] & 0xFF) << 16
		    | (src[1] & 0xFF) << 8 | (src[0] & 0xFF);
	} else {
	    ch = (unsigned int)(src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16
		    | (src[2] & 0xFF) << 8 | (src[3] & 0xFF);
	}
	if ((unsigned)ch > 0x10FFFF) {
	    if (PROFILE_STRICT(flags)) {
		result = TCL_CONVERT_SYNTAX;
		break;
	    }
	    ch = UNICODE_REPLACE_CHAR;
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
UtfToUtf32Proc(
    void *clientData,	/* additional flags, e.g. TCL_ENCODING_LE */
    const char *src,		/* Source string in UTF-8. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    TCL_UNUSED(Tcl_EncodingState *),
    char *dst,			/* Output buffer in which converted string is
				 * stored. */
    int dstLen,			/* The maximum length of output buffer in







|







2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
UtfToUtf32Proc(
    void *clientData,		/* additional flags, e.g. TCL_ENCODING_LE */
    const char *src,		/* Source string in UTF-8. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    TCL_UNUSED(Tcl_EncodingState *),
    char *dst,			/* Output buffer in which converted string is
				 * stored. */
    int dstLen,			/* The maximum length of output buffer in
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
Utf16ToUtfProc(
    void *clientData,	/* additional flags, e.g. TCL_ENCODING_LE */
    const char *src,		/* Source string in Unicode. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    TCL_UNUSED(Tcl_EncodingState *),
    char *dst,			/* Output buffer in which converted string is
				 * stored. */
    int dstLen,			/* The maximum length of output buffer in







|







2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
Utf16ToUtfProc(
    void *clientData,		/* additional flags, e.g. TCL_ENCODING_LE */
    const char *src,		/* Source string in Unicode. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    TCL_UNUSED(Tcl_EncodingState *),
    char *dst,			/* Output buffer in which converted string is
				 * stored. */
    int dstLen,			/* The maximum length of output buffer in
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

    srcStart = src;
    srcEnd = src + srcLen;

    dstStart = dst;
    dstEnd = dst + dstLen - TCL_UTF_MAX;

    for (numChars = 0; src < srcEnd && numChars <= charLimit; src += 2, numChars++) {

	if (dst > dstEnd) {
	    result = TCL_CONVERT_NOSPACE;
	    break;
	}

	unsigned short prev = ch;
	if (flags & TCL_ENCODING_LE) {
	    ch = (src[1] & 0xFF) << 8 | (src[0] & 0xFF);
	} else {
	    ch = (src[0] & 0xFF) << 8 | (src[1] & 0xFF);
	}
	if (HIGH_SURROGATE(prev) && !LOW_SURROGATE(ch)) {
	    if (PROFILE_STRICT(flags)) {
		result = TCL_CONVERT_SYNTAX;
		src -= 2; /* Go back to beginning of high surrogate */
		dst--; /* Also undo writing a single byte too much */
		numChars--;
		break;
	    } else if (PROFILE_REPLACE(flags)) {
		/*
		 * Previous loop wrote a single byte to mark the high surrogate.
		 * Replace it with the replacement character. Further, restart
		 * current loop iteration since need to recheck destination space
		 * and reset processing of current character.
		 */
		ch = UNICODE_REPLACE_CHAR;
		dst--;
		dst += Tcl_UniCharToUtf(ch, dst);
		src -= 2;
		numChars--;
		continue;
	    } else {

	    /* Bug [10c2c17c32]. If Hi surrogate not followed by Lo surrogate, finish 3-byte UTF-8 */


		dst += Tcl_UniCharToUtf(-1, dst);
	    }
	}

	/*
	 * Special case for 1-byte utf chars for speed. Make sure we work with
	 * unsigned short-size data.







|
>














|
|






|
|








>
|
>
>







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

    srcStart = src;
    srcEnd = src + srcLen;

    dstStart = dst;
    dstEnd = dst + dstLen - TCL_UTF_MAX;

    for (numChars = 0; src < srcEnd && numChars <= charLimit;
	    src += 2, numChars++) {
	if (dst > dstEnd) {
	    result = TCL_CONVERT_NOSPACE;
	    break;
	}

	unsigned short prev = ch;
	if (flags & TCL_ENCODING_LE) {
	    ch = (src[1] & 0xFF) << 8 | (src[0] & 0xFF);
	} else {
	    ch = (src[0] & 0xFF) << 8 | (src[1] & 0xFF);
	}
	if (HIGH_SURROGATE(prev) && !LOW_SURROGATE(ch)) {
	    if (PROFILE_STRICT(flags)) {
		result = TCL_CONVERT_SYNTAX;
		src -= 2;	/* Go back to beginning of high surrogate */
		dst--;		/* Also undo writing a single byte too much */
		numChars--;
		break;
	    } else if (PROFILE_REPLACE(flags)) {
		/*
		 * Previous loop wrote a single byte to mark the high surrogate.
		 * Replace it with the replacement character. Further, restart
		 * current loop iteration since need to recheck destination
		 * space and reset processing of current character.
		 */
		ch = UNICODE_REPLACE_CHAR;
		dst--;
		dst += Tcl_UniCharToUtf(ch, dst);
		src -= 2;
		numChars--;
		continue;
	    } else {
		/*
		 * Bug [10c2c17c32]. If Hi surrogate not followed by Lo
		 * surrogate, finish 3-byte UTF-8
		 */
		dst += Tcl_UniCharToUtf(-1, dst);
	    }
	}

	/*
	 * Special case for 1-byte utf chars for speed. Make sure we work with
	 * unsigned short-size data.
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
UtfToUtf16Proc(
    void *clientData,	/* additional flags, e.g. TCL_ENCODING_LE */
    const char *src,		/* Source string in UTF-8. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    TCL_UNUSED(Tcl_EncodingState *),
    char *dst,			/* Output buffer in which converted string is
				 * stored. */
    int dstLen,			/* The maximum length of output buffer in







|







3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
UtfToUtf16Proc(
    void *clientData,		/* additional flags, e.g. TCL_ENCODING_LE */
    const char *src,		/* Source string in UTF-8. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    TCL_UNUSED(Tcl_EncodingState *),
    char *dst,			/* Output buffer in which converted string is
				 * stored. */
    int dstLen,			/* The maximum length of output buffer in
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
UtfToUcs2Proc(
    void *clientData,	/* additional flags, e.g. TCL_ENCODING_LE */
    const char *src,		/* Source string in UTF-8. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    TCL_UNUSED(Tcl_EncodingState *),
    char *dst,			/* Output buffer in which converted string is
				 * stored. */
    int dstLen,			/* The maximum length of output buffer in







|







3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
UtfToUcs2Proc(
    void *clientData,		/* additional flags, e.g. TCL_ENCODING_LE */
    const char *src,		/* Source string in UTF-8. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    TCL_UNUSED(Tcl_EncodingState *),
    char *dst,			/* Output buffer in which converted string is
				 * stored. */
    int dstLen,			/* The maximum length of output buffer in
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
TableToUtfProc(
    void *clientData,	/* TableEncodingData that specifies
				 * encoding. */
    const char *src,		/* Source string in specified encoding. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    TCL_UNUSED(Tcl_EncodingState *),
    char *dst,			/* Output buffer in which converted string is
				 * stored. */







|







3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
TableToUtfProc(
    void *clientData,		/* TableEncodingData that specifies
				 * encoding. */
    const char *src,		/* Source string in specified encoding. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    TCL_UNUSED(Tcl_EncodingState *),
    char *dst,			/* Output buffer in which converted string is
				 * stored. */
3266
3267
3268
3269
3270
3271
3272
3273

3274
3275
3276
3277
3278
3279
3280
		    break;
		} else if (PROFILE_STRICT(flags)) {
		    result = TCL_CONVERT_SYNTAX;
		    break;
		} else if (PROFILE_REPLACE(flags)) {
		    ch = UNICODE_REPLACE_CHAR;
		} else {
		    /* For prefix bytes, we don't fallback to cp1252, see [1355b9a874] */

		    ch = byte;
		}
	    } else {
		ch = toUnicode[byte][*((unsigned char *)++src)];
	    }
	} else {
	    ch = pageZero[byte];







|
>







3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
		    break;
		} else if (PROFILE_STRICT(flags)) {
		    result = TCL_CONVERT_SYNTAX;
		    break;
		} else if (PROFILE_REPLACE(flags)) {
		    ch = UNICODE_REPLACE_CHAR;
		} else {
		    /* For prefix bytes, we don't fallback to cp1252, see
		     * [1355b9a874] */
		    ch = byte;
		}
	    } else {
		ch = toUnicode[byte][*((unsigned char *)++src)];
	    }
	} else {
	    ch = pageZero[byte];
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
TableFromUtfProc(
    void *clientData,	/* TableEncodingData that specifies
				 * encoding. */
    const char *src,		/* Source string in UTF-8. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    TCL_UNUSED(Tcl_EncodingState *),
    char *dst,			/* Output buffer in which converted string is
				 * stored. */







|







3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
TableFromUtfProc(
    void *clientData,		/* TableEncodingData that specifies
				 * encoding. */
    const char *src,		/* Source string in UTF-8. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    TCL_UNUSED(Tcl_EncodingState *),
    char *dst,			/* Output buffer in which converted string is
				 * stored. */
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
 *	Memory freed.
 *
 *---------------------------------------------------------------------------
 */

static void
TableFreeProc(
    void *clientData)	/* TableEncodingData that specifies
				 * encoding. */
{
    TableEncodingData *dataPtr = (TableEncodingData *)clientData;

    /*
     * Make sure we aren't freeing twice on shutdown. [Bug 219314]
     */







|







3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
 *	Memory freed.
 *
 *---------------------------------------------------------------------------
 */

static void
TableFreeProc(
    void *clientData)		/* TableEncodingData that specifies
				 * encoding. */
{
    TableEncodingData *dataPtr = (TableEncodingData *)clientData;

    /*
     * Make sure we aren't freeing twice on shutdown. [Bug 219314]
     */
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
EscapeToUtfProc(
    void *clientData,	/* EscapeEncodingData that specifies
				 * encoding. */
    const char *src,		/* Source string in specified encoding. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion. Contents of statePtr are







|







3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
EscapeToUtfProc(
    void *clientData,		/* EscapeEncodingData that specifies
				 * encoding. */
    const char *src,		/* Source string in specified encoding. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion. Contents of statePtr are
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
EscapeFromUtfProc(
    void *clientData,	/* EscapeEncodingData that specifies
				 * encoding. */
    const char *src,		/* Source string in UTF-8. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion. Contents of statePtr are







|







3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
EscapeFromUtfProc(
    void *clientData,		/* EscapeEncodingData that specifies
				 * encoding. */
    const char *src,		/* Source string in UTF-8. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion. Contents of statePtr are
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
	memcpy(dst, dataPtr->init, dataPtr->initLen);
	dst += dataPtr->initLen;
    } else {
	state = PTR2INT(*statePtr);
    }

    encodingPtr = GetTableEncoding(dataPtr, state);
    tableDataPtr = (const TableEncodingData *)encodingPtr->clientData;
    tablePrefixBytes = tableDataPtr->prefixBytes;
    tableFromUnicode = (const unsigned short *const *)
	    tableDataPtr->fromUnicode;

    for (numChars = 0; src < srcEnd; numChars++) {
	unsigned len;
	int word;







|







3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
	memcpy(dst, dataPtr->init, dataPtr->initLen);
	dst += dataPtr->initLen;
    } else {
	state = PTR2INT(*statePtr);
    }

    encodingPtr = GetTableEncoding(dataPtr, state);
    tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
    tablePrefixBytes = tableDataPtr->prefixBytes;
    tableFromUnicode = (const unsigned short *const *)
	    tableDataPtr->fromUnicode;

    for (numChars = 0; src < srcEnd; numChars++) {
	unsigned len;
	int word;
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
	if ((word == 0) && (ch != 0)) {
	    int oldState;
	    const EscapeSubTable *subTablePtr;

	    oldState = state;
	    for (state = 0; state < dataPtr->numSubTables; state++) {
		encodingPtr = GetTableEncoding(dataPtr, state);
		tableDataPtr = (const TableEncodingData *)encodingPtr->clientData;
		word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xFF];
		if (word != 0) {
		    break;
		}
	    }

	    if (word == 0) {
		state = oldState;
		if (PROFILE_STRICT(flags)) {
		    result = TCL_CONVERT_UNKNOWN;
		    break;
		}
		encodingPtr = GetTableEncoding(dataPtr, state);
		tableDataPtr = (const TableEncodingData *)encodingPtr->clientData;
		word = tableDataPtr->fallback;
	    }

	    tablePrefixBytes = (const char *) tableDataPtr->prefixBytes;
	    tableFromUnicode = (const unsigned short *const *)
		    tableDataPtr->fromUnicode;








|













|







3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
	if ((word == 0) && (ch != 0)) {
	    int oldState;
	    const EscapeSubTable *subTablePtr;

	    oldState = state;
	    for (state = 0; state < dataPtr->numSubTables; state++) {
		encodingPtr = GetTableEncoding(dataPtr, state);
		tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
		word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xFF];
		if (word != 0) {
		    break;
		}
	    }

	    if (word == 0) {
		state = oldState;
		if (PROFILE_STRICT(flags)) {
		    result = TCL_CONVERT_UNKNOWN;
		    break;
		}
		encodingPtr = GetTableEncoding(dataPtr, state);
		tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
		word = tableDataPtr->fallback;
	    }

	    tablePrefixBytes = (const char *) tableDataPtr->prefixBytes;
	    tableFromUnicode = (const unsigned short *const *)
		    tableDataPtr->fromUnicode;

4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
 *	Memory is freed.
 *
 *---------------------------------------------------------------------------
 */

static void
EscapeFreeProc(
    void *clientData)	/* EscapeEncodingData that specifies
				 * encoding. */
{
    EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData;
    EscapeSubTable *subTablePtr;
    int i;

    if (dataPtr == NULL) {







|







4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
 *	Memory is freed.
 *
 *---------------------------------------------------------------------------
 */

static void
EscapeFreeProc(
    void *clientData)		/* EscapeEncodingData that specifies
				 * encoding. */
{
    EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData;
    EscapeSubTable *subTablePtr;
    int i;

    if (dataPtr == NULL) {
4304
4305
4306
4307
4308
4309
4310
4311

4312
4313
4314

4315
4316
4317
4318

4319
4320
4321
4322
4323
4324
4325
    }
    if (interp) {
	/* This code assumes at least two profiles :-) */
	Tcl_Obj *errorObj = Tcl_ObjPrintf("bad profile name \"%s\": must be",
		profileName);
	for (i = 0; i < (numProfiles - 1); ++i) {
	    Tcl_AppendStringsToObj(
		errorObj, " ", encodingProfiles[i].name, ",", (void *)NULL);

	}
	Tcl_AppendStringsToObj(
	    errorObj, " or ", encodingProfiles[numProfiles-1].name, (void *)NULL);


	Tcl_SetObjResult(interp, errorObj);
	Tcl_SetErrorCode(
	    interp, "TCL", "ENCODING", "PROFILE", profileName, (void *)NULL);

    }
    return TCL_ERROR;
}

/*
 *------------------------------------------------------------------------
 *







|
>


|
>



|
>







4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
    }
    if (interp) {
	/* This code assumes at least two profiles :-) */
	Tcl_Obj *errorObj = Tcl_ObjPrintf("bad profile name \"%s\": must be",
		profileName);
	for (i = 0; i < (numProfiles - 1); ++i) {
	    Tcl_AppendStringsToObj(
		    errorObj, " ", encodingProfiles[i].name, ",",
		    (void *)NULL);
	}
	Tcl_AppendStringsToObj(
		errorObj, " or ", encodingProfiles[numProfiles-1].name,
		(void *)NULL);

	Tcl_SetObjResult(interp, errorObj);
	Tcl_SetErrorCode(
		interp, "TCL", "ENCODING", "PROFILE", profileName,
		(void *)NULL);
    }
    return TCL_ERROR;
}

/*
 *------------------------------------------------------------------------
 *
4338
4339
4340
4341
4342
4343
4344
4345

4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
const char *
TclEncodingProfileIdToName(
    Tcl_Interp *interp,		/* For error messages. May be NULL */
    int profileValue)		/* Profile #define value */
{
    size_t i;

    for (i = 0; i < sizeof(encodingProfiles) / sizeof(encodingProfiles[0]); ++i) {

	if (profileValue == encodingProfiles[i].value) {
	    return encodingProfiles[i].name;
	}
    }
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"Internal error. Bad profile id \"%d\".",
		profileValue));
	Tcl_SetErrorCode(
	    interp, "TCL", "ENCODING", "PROFILEID", (void *)NULL);
    }
    return NULL;
}

/*
 *------------------------------------------------------------------------
 *







|
>









|







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
const char *
TclEncodingProfileIdToName(
    Tcl_Interp *interp,		/* For error messages. May be NULL */
    int profileValue)		/* Profile #define value */
{
    size_t i;

    for (i = 0; i < sizeof(encodingProfiles) / sizeof(encodingProfiles[0]);
	    ++i) {
	if (profileValue == encodingProfiles[i].value) {
	    return encodingProfiles[i].name;
	}
    }
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"Internal error. Bad profile id \"%d\".",
		profileValue));
	Tcl_SetErrorCode(
		interp, "TCL", "ENCODING", "PROFILEID", (void *)NULL);
    }
    return NULL;
}

/*
 *------------------------------------------------------------------------
 *
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
    Tcl_Interp *interp)
{
    size_t i, n;
    Tcl_Obj *objPtr;
    n = sizeof(encodingProfiles) / sizeof(encodingProfiles[0]);
    objPtr = Tcl_NewListObj(n, NULL);
    for (i = 0; i < n; ++i) {
	Tcl_ListObjAppendElement(
	    interp, objPtr, Tcl_NewStringObj(encodingProfiles[i].name, TCL_INDEX_NONE));
    }
    Tcl_SetObjResult(interp, objPtr);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







|
|



|







4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
    Tcl_Interp *interp)
{
    size_t i, n;
    Tcl_Obj *objPtr;
    n = sizeof(encodingProfiles) / sizeof(encodingProfiles[0]);
    objPtr = Tcl_NewListObj(n, NULL);
    for (i = 0; i < n; ++i) {
	Tcl_ListObjAppendElement(interp, objPtr,
		Tcl_NewStringObj(encodingProfiles[i].name, TCL_INDEX_NONE));
    }
    Tcl_SetObjResult(interp, objPtr);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclEnsemble.c.

14
15
16
17
18
19
20









21
22
23
24
25
26
27
#include "tclCompile.h"

/*
 * Declarations for functions local to this file:
 */

static inline Tcl_Obj *	NewNsObj(Tcl_Namespace *namespacePtr);









static inline int	EnsembleUnknownCallback(Tcl_Interp *interp,
			    EnsembleConfig *ensemblePtr, Tcl_Size objc,
			    Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr);
static int		NsEnsembleImplementationCmdNR(void *clientData,
			    Tcl_Interp *interp,Tcl_Size objc,Tcl_Obj *const objv[]);
static void		BuildEnsembleConfig(EnsembleConfig *ensemblePtr);
static int		NsEnsembleStringOrder(const void *strPtr1,







>
>
>
>
>
>
>
>
>







14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
#include "tclCompile.h"

/*
 * Declarations for functions local to this file:
 */

static inline Tcl_Obj *	NewNsObj(Tcl_Namespace *namespacePtr);
static Tcl_Command	InitEnsembleFromOptions(Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		ReadOneEnsembleOption(Tcl_Interp *interp,
			    Tcl_Command token, Tcl_Obj *optionObj);
static int		ReadAllEnsembleOptions(Tcl_Interp *interp,
			    Tcl_Command token);
static int		SetEnsembleConfigOptions(Tcl_Interp *interp,
			    Tcl_Command token, int objc,
			    Tcl_Obj *const objv[]);
static inline int	EnsembleUnknownCallback(Tcl_Interp *interp,
			    EnsembleConfig *ensemblePtr, Tcl_Size objc,
			    Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr);
static int		NsEnsembleImplementationCmdNR(void *clientData,
			    Tcl_Interp *interp,Tcl_Size objc,Tcl_Obj *const objv[]);
static void		BuildEnsembleConfig(EnsembleConfig *ensemblePtr);
static int		NsEnsembleStringOrder(const void *strPtr1,
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
125
126
127
128
129
130
131
132
133
134
135
    FreeEnsembleCmdRep,		/* freeIntRepProc */
    DupEnsembleCmdRep,		/* dupIntRepProc */
    NULL,			/* updateStringProc */
    NULL,			/* setFromAnyProc */
    TCL_OBJTYPE_V0
};

#define ECRSetInternalRep(objPtr, ecRepPtr)					\
    do {								\
	Tcl_ObjInternalRep ir;						\
	ir.twoPtrValue.ptr1 = (ecRepPtr);				\
	ir.twoPtrValue.ptr2 = NULL;					\
	Tcl_StoreInternalRep((objPtr), &ensembleCmdType, &ir);		\
    } while (0)

#define ECRGetInternalRep(objPtr, ecRepPtr)					\
    do {								\
	const Tcl_ObjInternalRep *irPtr;					\
	irPtr = TclFetchInternalRep((objPtr), &ensembleCmdType);		\
	(ecRepPtr) = irPtr ? (EnsembleCmdRep *)irPtr->twoPtrValue.ptr1 : NULL;		\

    } while (0)

/*
 * The internal rep for caching ensemble subcommand lookups and spelling
 * corrections.
 */

typedef struct {
    Tcl_Size epoch;               /* Used to confirm when the data in this
                                 * really structure matches up with the
                                 * ensemble. */
    Command *token;             /* Reference to the command for which this
                                 * structure is a cache of the resolution. */
    Tcl_Obj *fix;               /* Corrected spelling, if needed. */
    Tcl_HashEntry *hPtr;        /* Direct link to entry in the subcommand hash
                                 * table. */
} EnsembleCmdRep;













static inline Tcl_Obj *
NewNsObj(
    Tcl_Namespace *namespacePtr)
{
    Namespace *nsPtr = (Namespace *) namespacePtr;

    if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) {
	return Tcl_NewStringObj("::", 2);
    }
    return Tcl_NewStringObj(nsPtr->fullName, -1);
}

/*
 *----------------------------------------------------------------------
 *
 * TclNamespaceEnsembleCmd --
 *







|







|

|
|
|
>








|
|
|
|
|
|
|
|


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









|







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
    FreeEnsembleCmdRep,		/* freeIntRepProc */
    DupEnsembleCmdRep,		/* dupIntRepProc */
    NULL,			/* updateStringProc */
    NULL,			/* setFromAnyProc */
    TCL_OBJTYPE_V0
};

#define ECRSetInternalRep(objPtr, ecRepPtr) \
    do {								\
	Tcl_ObjInternalRep ir;						\
	ir.twoPtrValue.ptr1 = (ecRepPtr);				\
	ir.twoPtrValue.ptr2 = NULL;					\
	Tcl_StoreInternalRep((objPtr), &ensembleCmdType, &ir);		\
    } while (0)

#define ECRGetInternalRep(objPtr, ecRepPtr) \
    do {								\
	const Tcl_ObjInternalRep *irPtr;				\
	irPtr = TclFetchInternalRep((objPtr), &ensembleCmdType);	\
	(ecRepPtr) = irPtr ? (EnsembleCmdRep *)				\
		irPtr->twoPtrValue.ptr1 : NULL;				\
    } while (0)

/*
 * The internal rep for caching ensemble subcommand lookups and spelling
 * corrections.
 */

typedef struct {
    Tcl_Size epoch;		/* Used to confirm when the data in this
				 * really structure matches up with the
				 * ensemble. */
    Command *token;		/* Reference to the command for which this
				 * structure is a cache of the resolution. */
    Tcl_Obj *fix;		/* Corrected spelling, if needed. */
    Tcl_HashEntry *hPtr;	/* Direct link to entry in the subcommand hash
				 * table. */
} EnsembleCmdRep;

/*
 *----------------------------------------------------------------------
 *
 * NewNsObj --
 *
 *	Make an object that contains a namespace's name.
 *
 * TODO:
 * 	This is a candidate for doing something better!
 *
 *----------------------------------------------------------------------
 */
static inline Tcl_Obj *
NewNsObj(
    Tcl_Namespace *namespacePtr)
{
    Namespace *nsPtr = (Namespace *) namespacePtr;

    if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) {
	return Tcl_NewStringObj("::", 2);
    }
    return Tcl_NewStringObj(nsPtr->fullName, TCL_AUTO_LENGTH);
}

/*
 *----------------------------------------------------------------------
 *
 * TclNamespaceEnsembleCmd --
 *
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
int
TclNamespaceEnsembleCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const objv[])
{
    Tcl_Namespace *namespacePtr;
    Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr,
	    *foundNsPtr, *altFoundNsPtr, *actualCxtPtr;
    Tcl_Command token;
    Tcl_DictSearch search;
    Tcl_Obj *listObj;
    const char *simpleName;
    enum EnsSubcmds index;
    int done;

    if (nsPtr == NULL || nsPtr->flags & NS_DEAD) {
	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "tried to manipulate ensemble of deleted namespace",
		    -1));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", (char *)NULL);
	}
	return TCL_ERROR;
    }

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], ensembleSubcommands,
	    "subcommand", 0, &index) != TCL_OK) {
	return TCL_ERROR;
    }

    switch (index) {
    case ENS_CREATE: {
	const char *name;
	Tcl_Size len;
	int allocatedMapFlag = 0;
	/*
	 * Defaults
	 */
	Tcl_Obj *subcmdObj = NULL;
	Tcl_Obj *mapObj = NULL;
	int permitPrefix = 1;
	Tcl_Obj *unknownObj = NULL;
	Tcl_Obj *paramObj = NULL;

	/*
	 * Check that we've got option-value pairs... [Bug 1558654]
	 */

	if (objc & 1) {
	    Tcl_WrongNumArgs(interp, 2, objv, "?option value ...?");
	    return TCL_ERROR;
	}
	objv += 2;
	objc -= 2;

	name = nsPtr->name;
	cxtPtr = (Namespace *) nsPtr->parentPtr;

	/*
	 * Parse the option list, applying type checks as we go. Note that we
	 * are not incrementing any reference counts in the objects at this
	 * stage, so the presence of an option multiple times won't cause any
	 * memory leaks.
	 */

	for (; objc>1 ; objc-=2,objv+=2) {
	    enum EnsCreateOpts idx;
	    if (Tcl_GetIndexFromObj(interp, objv[0], ensembleCreateOptions,
		    "option", 0, &idx) != TCL_OK) {
		if (allocatedMapFlag) {
		    Tcl_DecrRefCount(mapObj);
		}
		return TCL_ERROR;
	    }
	    switch (idx) {
	    case CRT_CMD:
		name = TclGetString(objv[1]);
		cxtPtr = nsPtr;
		continue;
	    case CRT_SUBCMDS:
		if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
		    if (allocatedMapFlag) {
			Tcl_DecrRefCount(mapObj);
		    }
		    return TCL_ERROR;
		}
		subcmdObj = (len > 0 ? objv[1] : NULL);
		continue;
	    case CRT_PARAM:
		if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
		    if (allocatedMapFlag) {
			Tcl_DecrRefCount(mapObj);
		    }
		    return TCL_ERROR;
		}
		paramObj = (len > 0 ? objv[1] : NULL);
		continue;
	    case CRT_MAP: {
		Tcl_Obj *patchedDict = NULL, *subcmdWordsObj;

		/*
		 * Verify that the map is sensible.
		 */

		if (Tcl_DictObjFirst(interp, objv[1], &search,
			&subcmdWordsObj, &listObj, &done) != TCL_OK) {
		    if (allocatedMapFlag) {
			Tcl_DecrRefCount(mapObj);
		    }
		    return TCL_ERROR;
		}
		if (done) {
		    mapObj = NULL;
		    continue;
		}
		do {
		    Tcl_Obj **listv;
		    const char *cmd;

		    if (TclListObjGetElements(interp, listObj, &len,
			    &listv) != TCL_OK) {
			Tcl_DictObjDone(&search);
			if (patchedDict) {
			    Tcl_DecrRefCount(patchedDict);
			}
			if (allocatedMapFlag) {
			    Tcl_DecrRefCount(mapObj);
			}
			return TCL_ERROR;
		    }
		    if (len < 1) {
			Tcl_SetObjResult(interp, Tcl_NewStringObj(
				"ensemble subcommand implementations "
				"must be non-empty lists", -1));
			Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
				"EMPTY_TARGET", (char *)NULL);
			Tcl_DictObjDone(&search);
			if (patchedDict) {
			    Tcl_DecrRefCount(patchedDict);
			}
			if (allocatedMapFlag) {
			    Tcl_DecrRefCount(mapObj);
			}
			return TCL_ERROR;
		    }
		    cmd = TclGetString(listv[0]);
		    if (!(cmd[0] == ':' && cmd[1] == ':')) {
			Tcl_Obj *newList = Tcl_NewListObj(len, listv);
			Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace *) nsPtr);

			if (nsPtr->parentPtr) {
			    Tcl_AppendStringsToObj(newCmd, "::", (char *)NULL);
			}
			Tcl_AppendObjToObj(newCmd, listv[0]);
			Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
			if (patchedDict == NULL) {
			    patchedDict = Tcl_DuplicateObj(objv[1]);
			}
			Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
				newList);
		    }
		    Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj,
			    &done);
		} while (!done);

		if (allocatedMapFlag) {
		    Tcl_DecrRefCount(mapObj);
		}
		mapObj = (patchedDict ? patchedDict : objv[1]);
		if (patchedDict) {
		    allocatedMapFlag = 1;
		}
		continue;
	    }
	    case CRT_PREFIX: {
		if (Tcl_GetBooleanFromObj(interp, objv[1],
			&permitPrefix) != TCL_OK) {
		    if (allocatedMapFlag) {
			Tcl_DecrRefCount(mapObj);
		    }
		    return TCL_ERROR;
		}
		continue;
	    }
	    case CRT_UNKNOWN:
		if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
		    if (allocatedMapFlag) {
			Tcl_DecrRefCount(mapObj);
		    }
		    return TCL_ERROR;
		}
		unknownObj = (len > 0 ? objv[1] : NULL);
		continue;
	    }
	}

	TclGetNamespaceForQualName(interp, name, cxtPtr,
		TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr,
		&actualCxtPtr, &simpleName);

	/*
	 * Create the ensemble. Note that this might delete another ensemble
	 * linked to the same namespace, so we must be careful. However, we
	 * should be OK because we only link the namespace into the list once
	 * we've created it (and after any deletions have occurred.)
	 */

	token = TclCreateEnsembleInNs(interp, simpleName,
		(Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr,
		(permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
	Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
	Tcl_SetEnsembleMappingDict(interp, token, mapObj);
	Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
	Tcl_SetEnsembleParameterList(interp, token, paramObj);

	/*
	 * Tricky! Must ensure that the result is not shared (command delete
	 * traces could have corrupted the pristine object that we started
	 * with). [Snit test rename-1.5]
	 */

	Tcl_ResetResult(interp);
	Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp));
	return TCL_OK;
    }

    case ENS_EXISTS:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "cmdname");
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(







<
|
<
|
<
<
<

<





|








<
|





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








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










<







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
int
TclNamespaceEnsembleCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const objv[])
{

    Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);

    Tcl_Command token;		/* The ensemble command. */



    enum EnsSubcmds index;


    if (nsPtr == NULL || nsPtr->flags & NS_DEAD) {
	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "tried to manipulate ensemble of deleted namespace",
		    TCL_AUTO_LENGTH));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", (char *)NULL);
	}
	return TCL_ERROR;
    }

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
	return TCL_ERROR;

    } else if (Tcl_GetIndexFromObj(interp, objv[1], ensembleSubcommands,
	    "subcommand", 0, &index) != TCL_OK) {
	return TCL_ERROR;
    }

    switch (index) {
    case ENS_CREATE:












	/*
	 * Check that we've got option-value pairs... [Bug 1558654]
	 */

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


	token = InitEnsembleFromOptions(interp, objc - 2, objv + 2);




































































































	if (token == NULL) {
























	    return TCL_ERROR;
	}

































	/*
	 * Tricky! Must ensure that the result is not shared (command delete
	 * traces could have corrupted the pristine object that we started
	 * with). [Snit test rename-1.5]
	 */

	Tcl_ResetResult(interp);
	Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp));
	return TCL_OK;


    case ENS_EXISTS:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "cmdname");
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
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
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
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
	}
	token = Tcl_FindEnsemble(interp, objv[2], TCL_LEAVE_ERR_MSG);
	if (token == NULL) {
	    return TCL_ERROR;
	}

	if (objc == 4) {
	    enum EnsConfigOpts idx;
	    Tcl_Obj *resultObj = NULL;		/* silence gcc 4 warning */

	    if (Tcl_GetIndexFromObj(interp, objv[3], ensembleConfigOptions,
		    "option", 0, &idx) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch (idx) {
	    case CONF_SUBCMDS:
		Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj);
		if (resultObj != NULL) {
		    Tcl_SetObjResult(interp, resultObj);
		}
		break;
	    case CONF_PARAM:
		Tcl_GetEnsembleParameterList(NULL, token, &resultObj);
		if (resultObj != NULL) {
		    Tcl_SetObjResult(interp, resultObj);
		}
		break;
	    case CONF_MAP:
		Tcl_GetEnsembleMappingDict(NULL, token, &resultObj);
		if (resultObj != NULL) {
		    Tcl_SetObjResult(interp, resultObj);
		}
		break;
	    case CONF_NAMESPACE:
		namespacePtr = NULL;		/* silence gcc 4 warning */
		Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
		Tcl_SetObjResult(interp, NewNsObj(namespacePtr));
		break;
	    case CONF_PREFIX: {
		int flags = 0;			/* silence gcc 4 warning */

		Tcl_GetEnsembleFlags(NULL, token, &flags);
		Tcl_SetObjResult(interp,
			Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
		break;
	    }
	    case CONF_UNKNOWN:
		Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj);
		if (resultObj != NULL) {
		    Tcl_SetObjResult(interp, resultObj);
		}
		break;
	    }
	} else if (objc == 3) {
	    /*
	     * Produce list of all information.
	     */

	    Tcl_Obj *resultObj, *tmpObj = NULL;	/* silence gcc 4 warning */
	    int flags = 0;			/* silence gcc 4 warning */

	    TclNewObj(resultObj);

	    /* -map option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(ensembleConfigOptions[CONF_MAP], -1));
	    Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    (tmpObj != NULL) ? tmpObj : Tcl_NewObj());

	    /* -namespace option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(ensembleConfigOptions[CONF_NAMESPACE],
			    -1));
	    namespacePtr = NULL;		/* silence gcc 4 warning */
	    Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
	    Tcl_ListObjAppendElement(NULL, resultObj, NewNsObj(namespacePtr));

	    /* -parameters option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(ensembleConfigOptions[CONF_PARAM], -1));
	    Tcl_GetEnsembleParameterList(NULL, token, &tmpObj);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    (tmpObj != NULL) ? tmpObj : Tcl_NewObj());

	    /* -prefix option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(ensembleConfigOptions[CONF_PREFIX], -1));
	    Tcl_GetEnsembleFlags(NULL, token, &flags);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));

	    /* -subcommands option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(ensembleConfigOptions[CONF_SUBCMDS],-1));
	    Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    (tmpObj != NULL) ? tmpObj : Tcl_NewObj());

	    /* -unknown option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(ensembleConfigOptions[CONF_UNKNOWN],-1));
	    Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    (tmpObj != NULL) ? tmpObj : Tcl_NewObj());

	    Tcl_SetObjResult(interp, resultObj);
	} else {
	    Tcl_Size len;
	    int allocatedMapFlag = 0;
	    Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL,
		    *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */
	    int permitPrefix, flags = 0;	/* silence gcc 4 warning */

	    Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj);
	    Tcl_GetEnsembleMappingDict(NULL, token, &mapObj);
	    Tcl_GetEnsembleParameterList(NULL, token, &paramObj);
	    Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj);
	    Tcl_GetEnsembleFlags(NULL, token, &flags);
	    permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0;

	    objv += 3;
	    objc -= 3;

	    /*
	     * Parse the option list, applying type checks as we go. Note that
	     * we are not incrementing any reference counts in the objects at
	     * this stage, so the presence of an option multiple times won't
	     * cause any memory leaks.
	     */

	    for (; objc>0 ; objc-=2,objv+=2) {
		enum EnsConfigOpts idx;
		if (Tcl_GetIndexFromObj(interp, objv[0],ensembleConfigOptions,
			"option", 0, &idx) != TCL_OK) {
		freeMapAndError:
		    if (allocatedMapFlag) {
			Tcl_DecrRefCount(mapObj);
		    }
		    return TCL_ERROR;
		}
		switch (idx) {
		case CONF_SUBCMDS:
		    if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
			goto freeMapAndError;
		    }
		    subcmdObj = (len > 0 ? objv[1] : NULL);
		    continue;
		case CONF_PARAM:
		    if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
			goto freeMapAndError;
		    }
		    paramObj = (len > 0 ? objv[1] : NULL);
		    continue;
		case CONF_MAP: {
		    Tcl_Obj *patchedDict = NULL, *subcmdWordsObj, **listv;
		    const char *cmd;

		    /*
		     * Verify that the map is sensible.
		     */

		    if (Tcl_DictObjFirst(interp, objv[1], &search,
			    &subcmdWordsObj, &listObj, &done) != TCL_OK) {
			goto freeMapAndError;
		    }
		    if (done) {
			mapObj = NULL;
			continue;
		    }
		    do {
			if (TclListObjLength(interp, listObj, &len) != TCL_OK) {
			    Tcl_DictObjDone(&search);
			    if (patchedDict) {
				Tcl_DecrRefCount(patchedDict);
			    }
			    goto freeMapAndError;
			}
			if (len < 1) {
			    Tcl_SetObjResult(interp, Tcl_NewStringObj(
				    "ensemble subcommand implementations "
				    "must be non-empty lists", -1));
			    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
				    "EMPTY_TARGET", (char *)NULL);
			    Tcl_DictObjDone(&search);
			    if (patchedDict) {
				Tcl_DecrRefCount(patchedDict);
			    }
			    goto freeMapAndError;
			}
			if (TclListObjGetElements(interp, listObj, &len,
				&listv) != TCL_OK) {
			    Tcl_DictObjDone(&search);
			    if (patchedDict) {
				Tcl_DecrRefCount(patchedDict);
			    }
			    goto freeMapAndError;
			}
			cmd = TclGetString(listv[0]);
			if (!(cmd[0] == ':' && cmd[1] == ':')) {
			    Tcl_Obj *newList = Tcl_DuplicateObj(listObj);
			    Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*)nsPtr);

			    if (nsPtr->parentPtr) {
				Tcl_AppendStringsToObj(newCmd, "::", (char *)NULL);
			    }
			    Tcl_AppendObjToObj(newCmd, listv[0]);
			    Tcl_ListObjReplace(NULL, newList, 0, 1, 1,
				    &newCmd);
			    if (patchedDict == NULL) {
				patchedDict = Tcl_DuplicateObj(objv[1]);
			    }
			    Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
				    newList);
			}
			Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj,
				&done);
		    } while (!done);
		    if (allocatedMapFlag) {
			Tcl_DecrRefCount(mapObj);
		    }
		    mapObj = (patchedDict ? patchedDict : objv[1]);
		    if (patchedDict) {
			allocatedMapFlag = 1;
		    }
		    continue;
		}
		case CONF_NAMESPACE:
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "option -namespace is read-only", -1));
		    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY",
			    (char *)NULL);
		    goto freeMapAndError;
		case CONF_PREFIX:
		    if (Tcl_GetBooleanFromObj(interp, objv[1],
			    &permitPrefix) != TCL_OK) {
			goto freeMapAndError;
		    }
		    continue;
		case CONF_UNKNOWN:
		    if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
			goto freeMapAndError;
		    }
		    unknownObj = (len > 0 ? objv[1] : NULL);
		    continue;
		}
	    }

	    /*
	     * Update the namespace now that we've finished the parsing stage.
	     */

	    flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX
		    : flags&~TCL_ENSEMBLE_PREFIX);
	    Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
	    Tcl_SetEnsembleMappingDict(interp, token, mapObj);
	    Tcl_SetEnsembleParameterList(interp, token, paramObj);
	    Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
	    Tcl_SetEnsembleFlags(interp, token, flags);
	}
	return TCL_OK;

    default:
	Tcl_Panic("unexpected ensemble command");
    }
    return TCL_OK;
}






















































































































































































































































































































































































































































































































/*
 *----------------------------------------------------------------------
 *
 * TclCreateEnsembleInNs --
 *
 *	Like Tcl_CreateEnsemble, but additionally accepts as an argument the







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

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

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






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







243
244
245
246
247
248
249


250











































251



252

















































253





254






255












































































































































256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
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
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
	}
	token = Tcl_FindEnsemble(interp, objv[2], TCL_LEAVE_ERR_MSG);
	if (token == NULL) {
	    return TCL_ERROR;
	}

	if (objc == 4) {


	    return ReadOneEnsembleOption(interp, token, objv[3]);











































	} else if (objc == 3) {



	    return ReadAllEnsembleOptions(interp, token);

















































	} else {





	    return SetEnsembleConfigOptions(interp, token, objc - 3, objv + 3);






	}













































































































































    default:
	Tcl_Panic("unexpected ensemble command");
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * InitEnsembleFromOptions --
 *
 *	Core of implementation of "namespace ensemble create".
 *
 * Results:
 *	Returns created ensemble's command token if successful, and NULL if
 *	anything goes wrong.
 *
 * Side effects:
 *	Creates the ensemble for the namespace if one did not previously
 *	exist.
 *
 * Note:
 *	Can't use SetEnsembleConfigOptions() here. Different (but overlapping)
 *	options are supported.
 *
 *----------------------------------------------------------------------
 */
static Tcl_Command
InitEnsembleFromOptions(
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    Namespace *cxtPtr = nsPtr->parentPtr;
    Namespace *altFoundNsPtr, *actualCxtPtr;
    const char *name = nsPtr->name;
    Tcl_Size len;
    int allocatedMapFlag = 0;
    enum EnsCreateOpts index;
    Tcl_Command token;		/* The created ensemble command. */
    Namespace *foundNsPtr;
    const char *simpleName;
    /*
     * Defaults
     */
    Tcl_Obj *subcmdObj = NULL;
    Tcl_Obj *mapObj = NULL;
    int permitPrefix = 1;
    Tcl_Obj *unknownObj = NULL;
    Tcl_Obj *paramObj = NULL;

    /*
     * Parse the option list, applying type checks as we go. Note that we are
     * not incrementing any reference counts in the objects at this stage, so
     * the presence of an option multiple times won't cause any memory leaks.
     */

    for (; objc>1 ; objc-=2,objv+=2) {
	if (Tcl_GetIndexFromObj(interp, objv[0], ensembleCreateOptions,
		"option", 0, &index) != TCL_OK) {
	    goto error;
	}
	switch (index) {
	case CRT_CMD:
	    name = TclGetString(objv[1]);
	    cxtPtr = nsPtr;
	    continue;
	case CRT_SUBCMDS:
	    if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
		goto error;
	    }
	    subcmdObj = (len > 0 ? objv[1] : NULL);
	    continue;
	case CRT_PARAM:
	    if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
		goto error;
	    }
	    paramObj = (len > 0 ? objv[1] : NULL);
	    continue;
	case CRT_MAP: {
	    Tcl_Obj *patchedDict = NULL, *subcmdWordsObj, *listObj;
	    Tcl_DictSearch search;
	    int done;

	    /*
	     * Verify that the map is sensible.
	     */

	    if (Tcl_DictObjFirst(interp, objv[1], &search,
		    &subcmdWordsObj, &listObj, &done) != TCL_OK) {
		goto error;
	    } else if (done) {
		mapObj = NULL;
		continue;
	    }
	    do {
		Tcl_Obj **listv;
		const char *cmd;

		if (TclListObjGetElements(interp, listObj, &len,
			&listv) != TCL_OK) {
		    goto mapError;
		}
		if (len < 1) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "ensemble subcommand implementations "
			    "must be non-empty lists", TCL_AUTO_LENGTH));
		    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
			    "EMPTY_TARGET", (char *)NULL);
		    goto mapError;
		}
		cmd = TclGetString(listv[0]);
		if (!(cmd[0] == ':' && cmd[1] == ':')) {
		    Tcl_Obj *newList = Tcl_NewListObj(len, listv);
		    Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace *) nsPtr);

		    if (nsPtr->parentPtr) {
			Tcl_AppendStringsToObj(newCmd, "::", (char *)NULL);
		    }
		    Tcl_AppendObjToObj(newCmd, listv[0]);
		    Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
		    if (patchedDict == NULL) {
			patchedDict = Tcl_DuplicateObj(objv[1]);
		    }
		    Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj, newList);
		}
		Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj, &done);
	    } while (!done);

	    if (allocatedMapFlag) {
		Tcl_DecrRefCount(mapObj);
	    }
	    mapObj = (patchedDict ? patchedDict : objv[1]);
	    if (patchedDict) {
		allocatedMapFlag = 1;
	    }
	    continue;
	mapError:
	    Tcl_DictObjDone(&search);
	    if (patchedDict) {
		Tcl_DecrRefCount(patchedDict);
	    }
	    goto error;
	}
	case CRT_PREFIX:
	    if (Tcl_GetBooleanFromObj(interp, objv[1],
		    &permitPrefix) != TCL_OK) {
		goto error;
	    }
	    continue;
	case CRT_UNKNOWN:
	    if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
		goto error;
	    }
	    unknownObj = (len > 0 ? objv[1] : NULL);
	    continue;
	}
    }

    TclGetNamespaceForQualName(interp, name, cxtPtr,
	    TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr,
	    &actualCxtPtr, &simpleName);

    /*
     * Create the ensemble. Note that this might delete another ensemble
     * linked to the same namespace, so we must be careful. However, we
     * should be OK because we only link the namespace into the list once
     * we've created it (and after any deletions have occurred.)
     */

    token = TclCreateEnsembleInNs(interp, simpleName,
	    (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr,
	    (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
    Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
    Tcl_SetEnsembleMappingDict(interp, token, mapObj);
    Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
    Tcl_SetEnsembleParameterList(interp, token, paramObj);
    return token;

  error:
    if (allocatedMapFlag) {
	Tcl_DecrRefCount(mapObj);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * ReadOneEnsembleOption --
 *
 *	Core of implementation of "namespace ensemble configure" with just a
 *	single option name.
 *
 * Results:
 *	Tcl result code. Modifies the interpreter result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */
static int
ReadOneEnsembleOption(
    Tcl_Interp *interp,
    Tcl_Command token,		/* The ensemble to read from. */
    Tcl_Obj *optionObj)		/* The name of the option to read. */
{
    Tcl_Obj *resultObj = NULL;			/* silence gcc 4 warning */
    enum EnsConfigOpts index;

    if (Tcl_GetIndexFromObj(interp, optionObj, ensembleConfigOptions,
	    "option", 0, &index) != TCL_OK) {
	return TCL_ERROR;
    }
    switch (index) {
    case CONF_SUBCMDS:
	Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj);
	if (resultObj != NULL) {
	    Tcl_SetObjResult(interp, resultObj);
	}
	break;
    case CONF_PARAM:
	Tcl_GetEnsembleParameterList(NULL, token, &resultObj);
	if (resultObj != NULL) {
	    Tcl_SetObjResult(interp, resultObj);
	}
	break;
    case CONF_MAP:
	Tcl_GetEnsembleMappingDict(NULL, token, &resultObj);
	if (resultObj != NULL) {
	    Tcl_SetObjResult(interp, resultObj);
	}
	break;
    case CONF_NAMESPACE: {
	Tcl_Namespace *namespacePtr = NULL;	/* silence gcc 4 warning */
	Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
	Tcl_SetObjResult(interp, NewNsObj(namespacePtr));
	break;
    }
    case CONF_PREFIX: {
	int flags = 0;				/* silence gcc 4 warning */

	Tcl_GetEnsembleFlags(NULL, token, &flags);
	Tcl_SetObjResult(interp,
		Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
	break;
    }
    case CONF_UNKNOWN:
	Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj);
	if (resultObj != NULL) {
	    Tcl_SetObjResult(interp, resultObj);
	}
	break;
    }
    return TCL_OK;
}
/*
 *----------------------------------------------------------------------
 *
 * ReadAllEnsembleOptions --
 *
 *	Core of implementation of "namespace ensemble configure" without
 *	option names.
 *
 * Results:
 *	Tcl result code. Modifies the interpreter result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */
static int
ReadAllEnsembleOptions(
    Tcl_Interp *interp,
    Tcl_Command token)		/* The ensemble to read from. */
{
    Tcl_Obj *resultObj, *tmpObj = NULL;	/* silence gcc 4 warning */
    int flags = 0;			/* silence gcc 4 warning */
    Tcl_Namespace *namespacePtr = NULL;	/* silence gcc 4 warning */

    TclNewObj(resultObj);

    /* -map option */
    Tcl_ListObjAppendElement(NULL, resultObj,
	    Tcl_NewStringObj(ensembleConfigOptions[CONF_MAP],
		    TCL_AUTO_LENGTH));
    Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj);
    Tcl_ListObjAppendElement(NULL, resultObj,
	    (tmpObj != NULL) ? tmpObj : Tcl_NewObj());

    /* -namespace option */
    Tcl_ListObjAppendElement(NULL, resultObj,
	    Tcl_NewStringObj(ensembleConfigOptions[CONF_NAMESPACE],
		    TCL_AUTO_LENGTH));
    Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
    Tcl_ListObjAppendElement(NULL, resultObj, NewNsObj(namespacePtr));

    /* -parameters option */
    Tcl_ListObjAppendElement(NULL, resultObj,
	    Tcl_NewStringObj(ensembleConfigOptions[CONF_PARAM],
		    TCL_AUTO_LENGTH));
    Tcl_GetEnsembleParameterList(NULL, token, &tmpObj);
    Tcl_ListObjAppendElement(NULL, resultObj,
	    (tmpObj != NULL) ? tmpObj : Tcl_NewObj());

    /* -prefix option */
    Tcl_ListObjAppendElement(NULL, resultObj,
	    Tcl_NewStringObj(ensembleConfigOptions[CONF_PREFIX],
		    TCL_AUTO_LENGTH));
    Tcl_GetEnsembleFlags(NULL, token, &flags);
    Tcl_ListObjAppendElement(NULL, resultObj,
	    Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));

    /* -subcommands option */
    Tcl_ListObjAppendElement(NULL, resultObj,
	    Tcl_NewStringObj(ensembleConfigOptions[CONF_SUBCMDS],
		    TCL_AUTO_LENGTH));
    Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj);
    Tcl_ListObjAppendElement(NULL, resultObj,
	    (tmpObj != NULL) ? tmpObj : Tcl_NewObj());

    /* -unknown option */
    Tcl_ListObjAppendElement(NULL, resultObj,
	    Tcl_NewStringObj(ensembleConfigOptions[CONF_UNKNOWN],
		    TCL_AUTO_LENGTH));
    Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj);
    Tcl_ListObjAppendElement(NULL, resultObj,
	    (tmpObj != NULL) ? tmpObj : Tcl_NewObj());

    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}
/*
 *----------------------------------------------------------------------
 *
 * SetEnsembleConfigOptions --
 *
 *	Core of implementation of "namespace ensemble configure" with even
 *	number of arguments (where there is at least one pair).
 *
 * Results:
 *	Tcl result code. Modifies the interpreter result.
 *
 * Side effects:
 *	Modifies the ensemble's configuration.
 *
 *----------------------------------------------------------------------
 */
static int
SetEnsembleConfigOptions(
    Tcl_Interp *interp,
    Tcl_Command token,		/* The ensemble to configure. */
    int objc,			/* The count of option-related arguments. */
    Tcl_Obj *const objv[])	/* Option-related arguments. */
{
    Tcl_Size len;
    int allocatedMapFlag = 0;
    Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL,
	    *unknownObj = NULL; 	/* Defaults, silence gcc 4 warnings */
    Tcl_Obj *listObj;
    Tcl_DictSearch search;
    int permitPrefix, flags = 0;	/* silence gcc 4 warning */
    enum EnsConfigOpts index;
    int done;

    Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj);
    Tcl_GetEnsembleMappingDict(NULL, token, &mapObj);
    Tcl_GetEnsembleParameterList(NULL, token, &paramObj);
    Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj);
    Tcl_GetEnsembleFlags(NULL, token, &flags);
    permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0;

    /*
     * Parse the option list, applying type checks as we go. Note that
     * we are not incrementing any reference counts in the objects at
     * this stage, so the presence of an option multiple times won't
     * cause any memory leaks.
     */

    for (; objc>0 ; objc-=2,objv+=2) {
	if (Tcl_GetIndexFromObj(interp, objv[0], ensembleConfigOptions,
		"option", 0, &index) != TCL_OK) {
	    goto freeMapAndError;
	}
	switch (index) {
	case CONF_SUBCMDS:
	    if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
		goto freeMapAndError;
	    }
	    subcmdObj = (len > 0 ? objv[1] : NULL);
	    continue;
	case CONF_PARAM:
	    if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
		goto freeMapAndError;
	    }
	    paramObj = (len > 0 ? objv[1] : NULL);
	    continue;
	case CONF_MAP: {
	    Tcl_Obj *patchedDict = NULL, *subcmdWordsObj, **listv;
	    Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
	    const char *cmd;

	    /*
	     * Verify that the map is sensible.
	     */

	    if (Tcl_DictObjFirst(interp, objv[1], &search,
		    &subcmdWordsObj, &listObj, &done) != TCL_OK) {
		goto freeMapAndError;
	    } else if (done) {
		mapObj = NULL;
		continue;
	    }

	    do {
		if (TclListObjLength(interp, listObj, &len) != TCL_OK) {
		    goto finishSearchAndError;
		}
		if (len < 1) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "ensemble subcommand implementations "
			    "must be non-empty lists", TCL_AUTO_LENGTH));
		    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
			    "EMPTY_TARGET", (char *)NULL);
		    goto finishSearchAndError;
		}
		if (TclListObjGetElements(interp, listObj, &len,
			&listv) != TCL_OK) {
		    goto finishSearchAndError;
		}
		cmd = TclGetString(listv[0]);
		if (!(cmd[0] == ':' && cmd[1] == ':')) {
		    Tcl_Obj *newList = Tcl_DuplicateObj(listObj);
		    Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*) nsPtr);

		    if (nsPtr->parentPtr) {
			Tcl_AppendStringsToObj(newCmd, "::", (char *)NULL);
		    }
		    Tcl_AppendObjToObj(newCmd, listv[0]);
		    Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
		    if (patchedDict == NULL) {
			patchedDict = Tcl_DuplicateObj(objv[1]);
		    }
		    Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj, newList);
		}
		Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj, &done);
	    } while (!done);
	    if (allocatedMapFlag) {
		Tcl_DecrRefCount(mapObj);
	    }
	    mapObj = (patchedDict ? patchedDict : objv[1]);
	    if (patchedDict) {
		allocatedMapFlag = 1;
	    }
	    continue;

	finishSearchAndError:
	    Tcl_DictObjDone(&search);
	    if (patchedDict) {
		Tcl_DecrRefCount(patchedDict);
	    }
	    goto freeMapAndError;
	}
	case CONF_NAMESPACE:
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "option -namespace is read-only", TCL_AUTO_LENGTH));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY",
		    (char *)NULL);
	    goto freeMapAndError;
	case CONF_PREFIX:
	    if (Tcl_GetBooleanFromObj(interp, objv[1],
		    &permitPrefix) != TCL_OK) {
		goto freeMapAndError;
	    }
	    continue;
	case CONF_UNKNOWN:
	    if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
		goto freeMapAndError;
	    }
	    unknownObj = (len > 0 ? objv[1] : NULL);
	    continue;
	}
    }

    /*
     * Update the namespace now that we've finished the parsing stage.
     */

    flags = (permitPrefix ? flags | TCL_ENSEMBLE_PREFIX
	    : flags & ~TCL_ENSEMBLE_PREFIX);
    Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
    Tcl_SetEnsembleMappingDict(interp, token, mapObj);
    Tcl_SetEnsembleParameterList(interp, token, paramObj);
    Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
    Tcl_SetEnsembleFlags(interp, token, flags);
    return TCL_OK;

  freeMapAndError:
    if (allocatedMapFlag) {
	Tcl_DecrRefCount(mapObj);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCreateEnsembleInNs --
 *
 *	Like Tcl_CreateEnsemble, but additionally accepts as an argument the
680
681
682
683
684
685
686
687

688
689
690
691
692
693
694
695
696
697
698
699
700
    Tcl_Interp *interp,
    const char *name,		/* Simple name of command to create (no
				 * namespace components). */
    Tcl_Namespace *nameNsPtr,	/* Name of namespace to create the command
				 * in. */
    Tcl_Namespace *ensembleNsPtr,
				/* Name of the namespace for the ensemble. */
    int flags)

{
    Namespace *nsPtr = (Namespace *) ensembleNsPtr;
    EnsembleConfig *ensemblePtr;
    Tcl_Command token;

    ensemblePtr = (EnsembleConfig *)Tcl_Alloc(sizeof(EnsembleConfig));
    token = TclNRCreateCommandInNs(interp, name,
	    (Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd,
	    NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig);
    if (token == NULL) {
	Tcl_Free(ensemblePtr);
	return NULL;
    }







|
>





|







777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
    Tcl_Interp *interp,
    const char *name,		/* Simple name of command to create (no
				 * namespace components). */
    Tcl_Namespace *nameNsPtr,	/* Name of namespace to create the command
				 * in. */
    Tcl_Namespace *ensembleNsPtr,
				/* Name of the namespace for the ensemble. */
    int flags)			/* Whether we need exact matching and whether
				 * we bytecode-compile the ensemble's uses. */
{
    Namespace *nsPtr = (Namespace *) ensembleNsPtr;
    EnsembleConfig *ensemblePtr;
    Tcl_Command token;

    ensemblePtr = (EnsembleConfig *) Tcl_Alloc(sizeof(EnsembleConfig));
    token = TclNRCreateCommandInNs(interp, name,
	    (Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd,
	    NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig);
    if (token == NULL) {
	Tcl_Free(ensemblePtr);
	return NULL;
    }
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
 * Value
 *
 *	The token for the command created.
 *
 * Effect
 *	The ensemble is created and marked for compilation.
 *
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
Tcl_CreateEnsemble(
    Tcl_Interp *interp,
    const char *name,
    Tcl_Namespace *namespacePtr,
    int flags)

{
    Namespace *nsPtr = (Namespace *) namespacePtr, *foundNsPtr, *altNsPtr,
	    *actualNsPtr;
    const char * simpleName;

    if (nsPtr == NULL) {
	nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    }

    TclGetNamespaceForQualName(interp, name, nsPtr, TCL_CREATE_NS_IF_UNKNOWN,
	    &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName);
    return TclCreateEnsembleInNs(interp, simpleName,
	    (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags);
}




































































/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetEnsembleSubcommandList --
 *
 *	Set the subcommand list for a particular ensemble.







<






|
|
|
>














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







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
 * Value
 *
 *	The token for the command created.
 *
 * Effect
 *	The ensemble is created and marked for compilation.
 *

 *----------------------------------------------------------------------
 */

Tcl_Command
Tcl_CreateEnsemble(
    Tcl_Interp *interp,
    const char *name,		/* The ensemble name. */
    Tcl_Namespace *namespacePtr,/* Context namespace. */
    int flags)			/* Whether we need exact matching and whether
				 * we bytecode-compile the ensemble's uses. */
{
    Namespace *nsPtr = (Namespace *) namespacePtr, *foundNsPtr, *altNsPtr,
	    *actualNsPtr;
    const char * simpleName;

    if (nsPtr == NULL) {
	nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    }

    TclGetNamespaceForQualName(interp, name, nsPtr, TCL_CREATE_NS_IF_UNKNOWN,
	    &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName);
    return TclCreateEnsembleInNs(interp, simpleName,
	    (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * GetEnsembleFromCommand --
 *
 *	Standard check to see if a command is an ensemble.
 *
 * Results:
 *	The ensemble implementation if the command is an ensemble. NULL if it
 *	isn't.
 *
 * Side effects:
 *	Reports an error in the interpreter (if non-NULL) if the command is
 *	not an ensemble.
 *
 *----------------------------------------------------------------------
 */
static inline EnsembleConfig *
GetEnsembleFromCommand(
    Tcl_Interp *interp,		/* Where to report an error. May be NULL. */
    Tcl_Command token)		/* What to check for ensemble-ness. */
{
    Command *cmdPtr = (Command *) token;

    if (cmdPtr->objProc2 != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", TCL_AUTO_LENGTH));
	    Tcl_SetErrorCode(interp,
		    "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL);
	}
	return NULL;
    }
    return (EnsembleConfig *)cmdPtr->objClientData2;
}

/*
 *----------------------------------------------------------------------
 *
 * BumpEpochIfNecessary --
 *
 *	Increments the compilation epoch if the (ensemble) command is one where
 *	changes would be seen by the compiler in some cases.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May trigger later bytecode recompilations.
 *
 *----------------------------------------------------------------------
 */
static inline void
BumpEpochIfNecessary(
    Tcl_Interp *interp,
    Tcl_Command token)		/* The ensemble command to check. */
{
    /*
     * Special hack to make compiling of [info exists] work when the
     * dictionary is modified.
     */

    if (((Command *) token)->compileProc != NULL) {
	((Interp *) interp)->compileEpoch++;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetEnsembleSubcommandList --
 *
 *	Set the subcommand list for a particular ensemble.
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
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetEnsembleSubcommandList(
    Tcl_Interp *interp,
    Tcl_Command token,
    Tcl_Obj *subcmdList)
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;
    Tcl_Obj *oldList;

    if (cmdPtr->objProc2 != TclEnsembleImplementationCmd) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"command is not an ensemble", -1));
	Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL);
	return TCL_ERROR;
    }
    if (subcmdList != NULL) {
	Tcl_Size length;

	if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (length < 1) {
	    subcmdList = NULL;
	}
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData2;
    oldList = ensemblePtr->subcmdList;
    ensemblePtr->subcmdList = subcmdList;
    if (subcmdList != NULL) {
	Tcl_IncrRefCount(subcmdList);
    }
    if (oldList != NULL) {
	TclDecrRefCount(oldList);
    }

    /*
     * Trigger an eventual recomputation of the ensemble command set. Note
     * that this is slightly tricky, as it means that we are not actually
     * counting the number of namespace export actions, but it is the simplest
     * way to go!
     */

    ensemblePtr->nsPtr->exportLookupEpoch++;

    /*
     * Special hack to make compiling of [info exists] work when the
     * dictionary is modified.
     */

    if (cmdPtr->compileProc != NULL) {
	((Interp *) interp)->compileEpoch++;
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetEnsembleParameterList --







|


<
|


<
<
|
<













<

















|
<
<
<
<
<
<
<
<
<







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
994









995
996
997
998
999
1000
1001
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetEnsembleSubcommandList(
    Tcl_Interp *interp,
    Tcl_Command token,		/* The ensemble command to write to. */
    Tcl_Obj *subcmdList)
{

    EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);
    Tcl_Obj *oldList;



    if (ensemblePtr == NULL) {

	return TCL_ERROR;
    }
    if (subcmdList != NULL) {
	Tcl_Size length;

	if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (length < 1) {
	    subcmdList = NULL;
	}
    }


    oldList = ensemblePtr->subcmdList;
    ensemblePtr->subcmdList = subcmdList;
    if (subcmdList != NULL) {
	Tcl_IncrRefCount(subcmdList);
    }
    if (oldList != NULL) {
	TclDecrRefCount(oldList);
    }

    /*
     * Trigger an eventual recomputation of the ensemble command set. Note
     * that this is slightly tricky, as it means that we are not actually
     * counting the number of namespace export actions, but it is the simplest
     * way to go!
     */

    ensemblePtr->nsPtr->exportLookupEpoch++;
    BumpEpochIfNecessary(interp, token);









    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetEnsembleParameterList --
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
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetEnsembleParameterList(
    Tcl_Interp *interp,
    Tcl_Command token,
    Tcl_Obj *paramList)
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;
    Tcl_Obj *oldList;
    Tcl_Size length;

    if (cmdPtr->objProc2 != TclEnsembleImplementationCmd) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"command is not an ensemble", -1));
	Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL);
	return TCL_ERROR;
    }
    if (paramList == NULL) {
	length = 0;
    } else {
	if (TclListObjLength(interp, paramList, &length) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (length < 1) {
	    paramList = NULL;
	}
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData2;
    oldList = ensemblePtr->parameterList;
    ensemblePtr->parameterList = paramList;
    if (paramList != NULL) {
	Tcl_IncrRefCount(paramList);
    }
    if (oldList != NULL) {
	TclDecrRefCount(oldList);
    }
    ensemblePtr->numParameters = length;

    /*
     * Trigger an eventual recomputation of the ensemble command set. Note
     * that this is slightly tricky, as it means that we are not actually
     * counting the number of namespace export actions, but it is the simplest
     * way to go!
     */

    ensemblePtr->nsPtr->exportLookupEpoch++;

    /*
     * Special hack to make compiling of [info exists] work when the
     * dictionary is modified.
     */

    if (cmdPtr->compileProc != NULL) {
	((Interp *) interp)->compileEpoch++;
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetEnsembleMappingDict --







|


<
|



<
<
|
<













<


















|
<
<
<
<
<
<
<
<
<







1011
1012
1013
1014
1015
1016
1017
1018
1019
1020

1021
1022
1023
1024


1025

1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038

1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057









1058
1059
1060
1061
1062
1063
1064
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetEnsembleParameterList(
    Tcl_Interp *interp,
    Tcl_Command token,		/* The ensemble command to write to. */
    Tcl_Obj *paramList)
{

    EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);
    Tcl_Obj *oldList;
    Tcl_Size length;



    if (ensemblePtr == NULL) {

	return TCL_ERROR;
    }
    if (paramList == NULL) {
	length = 0;
    } else {
	if (TclListObjLength(interp, paramList, &length) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (length < 1) {
	    paramList = NULL;
	}
    }


    oldList = ensemblePtr->parameterList;
    ensemblePtr->parameterList = paramList;
    if (paramList != NULL) {
	Tcl_IncrRefCount(paramList);
    }
    if (oldList != NULL) {
	TclDecrRefCount(oldList);
    }
    ensemblePtr->numParameters = length;

    /*
     * Trigger an eventual recomputation of the ensemble command set. Note
     * that this is slightly tricky, as it means that we are not actually
     * counting the number of namespace export actions, but it is the simplest
     * way to go!
     */

    ensemblePtr->nsPtr->exportLookupEpoch++;
    BumpEpochIfNecessary(interp, token);









    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetEnsembleMappingDict --
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
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetEnsembleMappingDict(
    Tcl_Interp *interp,
    Tcl_Command token,
    Tcl_Obj *mapDict)
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;
    Tcl_Obj *oldDict;

    if (cmdPtr->objProc2 != TclEnsembleImplementationCmd) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"command is not an ensemble", -1));
	Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL);
	return TCL_ERROR;
    }
    if (mapDict != NULL) {
	Tcl_Size size;
	int done;
	Tcl_DictSearch search;
	Tcl_Obj *valuePtr;







|


<
|


<
<
|
<







1074
1075
1076
1077
1078
1079
1080
1081
1082
1083

1084
1085
1086


1087

1088
1089
1090
1091
1092
1093
1094
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetEnsembleMappingDict(
    Tcl_Interp *interp,
    Tcl_Command token,		/* The ensemble command to write to. */
    Tcl_Obj *mapDict)
{

    EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);
    Tcl_Obj *oldDict;



    if (ensemblePtr == NULL) {

	return TCL_ERROR;
    }
    if (mapDict != NULL) {
	Tcl_Size size;
	int done;
	Tcl_DictSearch search;
	Tcl_Obj *valuePtr;
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
		Tcl_DictObjDone(&search);
		return TCL_ERROR;
	    }
	    bytes = TclGetString(cmdObjPtr);
	    if (bytes[0] != ':' || bytes[1] != ':') {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"ensemble target is not a fully-qualified command",
			-1));
		Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
			"UNQUALIFIED_TARGET", (char *)NULL);
		Tcl_DictObjDone(&search);
		return TCL_ERROR;
	    }
	}

	if (size < 1) {
	    mapDict = NULL;
	}
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData2;
    oldDict = ensemblePtr->subcommandDict;
    ensemblePtr->subcommandDict = mapDict;
    if (mapDict != NULL) {
	Tcl_IncrRefCount(mapDict);
    }
    if (oldDict != NULL) {
	TclDecrRefCount(oldDict);
    }

    /*
     * Trigger an eventual recomputation of the ensemble command set. Note
     * that this is slightly tricky, as it means that we are not actually
     * counting the number of namespace export actions, but it is the simplest
     * way to go!
     */

    ensemblePtr->nsPtr->exportLookupEpoch++;

    /*
     * Special hack to make compiling of [info exists] work when the
     * dictionary is modified.
     */

    if (cmdPtr->compileProc != NULL) {
	((Interp *) interp)->compileEpoch++;
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetEnsembleUnknownHandler --







|












<

















|
<
<
<
<
<
<
<
<
<







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
		Tcl_DictObjDone(&search);
		return TCL_ERROR;
	    }
	    bytes = TclGetString(cmdObjPtr);
	    if (bytes[0] != ':' || bytes[1] != ':') {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"ensemble target is not a fully-qualified command",
			TCL_AUTO_LENGTH));
		Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
			"UNQUALIFIED_TARGET", (char *)NULL);
		Tcl_DictObjDone(&search);
		return TCL_ERROR;
	    }
	}

	if (size < 1) {
	    mapDict = NULL;
	}
    }


    oldDict = ensemblePtr->subcommandDict;
    ensemblePtr->subcommandDict = mapDict;
    if (mapDict != NULL) {
	Tcl_IncrRefCount(mapDict);
    }
    if (oldDict != NULL) {
	TclDecrRefCount(oldDict);
    }

    /*
     * Trigger an eventual recomputation of the ensemble command set. Note
     * that this is slightly tricky, as it means that we are not actually
     * counting the number of namespace export actions, but it is the simplest
     * way to go!
     */

    ensemblePtr->nsPtr->exportLookupEpoch++;
    BumpEpochIfNecessary(interp, token);









    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetEnsembleUnknownHandler --
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetEnsembleUnknownHandler(
    Tcl_Interp *interp,
    Tcl_Command token,
    Tcl_Obj *unknownList)
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;
    Tcl_Obj *oldList;

    if (cmdPtr->objProc2 != TclEnsembleImplementationCmd) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"command is not an ensemble", -1));
	Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL);
	return TCL_ERROR;
    }
    if (unknownList != NULL) {
	Tcl_Size length;

	if (TclListObjLength(interp, unknownList, &length) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (length < 1) {
	    unknownList = NULL;
	}
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData2;
    oldList = ensemblePtr->unknownHandler;
    ensemblePtr->unknownHandler = unknownList;
    if (unknownList != NULL) {
	Tcl_IncrRefCount(unknownList);
    }
    if (oldList != NULL) {
	TclDecrRefCount(oldList);







|


<
|


<
<
|
<













<







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

int
Tcl_SetEnsembleUnknownHandler(
    Tcl_Interp *interp,
    Tcl_Command token,		/* The ensemble command to write to. */
    Tcl_Obj *unknownList)
{

    EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);
    Tcl_Obj *oldList;



    if (ensemblePtr == NULL) {

	return TCL_ERROR;
    }
    if (unknownList != NULL) {
	Tcl_Size length;

	if (TclListObjLength(interp, unknownList, &length) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (length < 1) {
	    unknownList = NULL;
	}
    }


    oldList = ensemblePtr->unknownHandler;
    ensemblePtr->unknownHandler = unknownList;
    if (unknownList != NULL) {
	Tcl_IncrRefCount(unknownList);
    }
    if (oldList != NULL) {
	TclDecrRefCount(oldList);
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
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetEnsembleFlags(
    Tcl_Interp *interp,
    Tcl_Command token,
    int flags)
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;
    int wasCompiled;

    if (cmdPtr->objProc2 != TclEnsembleImplementationCmd) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"command is not an ensemble", -1));
	Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL);
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData2;
    wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE;

    /*
     * This API refuses to set the ENSEMBLE_DEAD flag...
     */

    ensemblePtr->flags &= ENSEMBLE_DEAD;
    ensemblePtr->flags |= flags & ~ENSEMBLE_DEAD;








|


<
|
|

<
<
|
<



<
<
<







1221
1222
1223
1224
1225
1226
1227
1228
1229
1230

1231
1232
1233


1234

1235
1236
1237



1238
1239
1240
1241
1242
1243
1244
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetEnsembleFlags(
    Tcl_Interp *interp,
    Tcl_Command token,		/* The ensemble command to write to. */
    int flags)
{

    EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);
    int changedFlags = flags ^ ensemblePtr->flags;



    if (ensemblePtr == NULL) {

	return TCL_ERROR;
    }




    /*
     * This API refuses to set the ENSEMBLE_DEAD flag...
     */

    ensemblePtr->flags &= ENSEMBLE_DEAD;
    ensemblePtr->flags |= flags & ~ENSEMBLE_DEAD;

1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165

    /*
     * If the ENSEMBLE_COMPILE flag status was changed, install or remove the
     * compiler function and bump the interpreter's compilation epoch so that
     * bytecode gets regenerated.
     */

    if (flags & ENSEMBLE_COMPILE) {
	if (!wasCompiled) {
	    ((Command*) ensemblePtr->token)->compileProc = TclCompileEnsemble;
	    ((Interp *) interp)->compileEpoch++;
	}
    } else {
	if (wasCompiled) {
	    ((Command *) ensemblePtr->token)->compileProc = NULL;
	    ((Interp *) interp)->compileEpoch++;
	}
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------







|
<
|
<
<
<
|
<
|
<







1253
1254
1255
1256
1257
1258
1259
1260

1261



1262

1263

1264
1265
1266
1267
1268
1269
1270

    /*
     * If the ENSEMBLE_COMPILE flag status was changed, install or remove the
     * compiler function and bump the interpreter's compilation epoch so that
     * bytecode gets regenerated.
     */

    if (changedFlags & ENSEMBLE_COMPILE) {

	((Command*) ensemblePtr->token)->compileProc =



		((flags & ENSEMBLE_COMPILE) ? TclCompileEnsemble : NULL);

	((Interp *) interp)->compileEpoch++;

    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
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
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetEnsembleSubcommandList(
    Tcl_Interp *interp,
    Tcl_Command token,
    Tcl_Obj **subcmdListPtr)
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc2 != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData2;
    *subcmdListPtr = ensemblePtr->subcmdList;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|


<
|

<
|
<
<
<
<


<
<







1285
1286
1287
1288
1289
1290
1291
1292
1293
1294

1295
1296

1297




1298
1299


1300
1301
1302
1303
1304
1305
1306
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetEnsembleSubcommandList(
    Tcl_Interp *interp,
    Tcl_Command token,		/* The ensemble command to read from. */
    Tcl_Obj **subcmdListPtr)
{

    EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);


    if (ensemblePtr == NULL) {




	return TCL_ERROR;
    }


    *subcmdListPtr = ensemblePtr->subcmdList;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
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
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetEnsembleParameterList(
    Tcl_Interp *interp,
    Tcl_Command token,
    Tcl_Obj **paramListPtr)
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc2 != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData2;
    *paramListPtr = ensemblePtr->parameterList;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|


<
|

<
|
<
<
<
<


<
<







1319
1320
1321
1322
1323
1324
1325
1326
1327
1328

1329
1330

1331




1332
1333


1334
1335
1336
1337
1338
1339
1340
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetEnsembleParameterList(
    Tcl_Interp *interp,
    Tcl_Command token,		/* The ensemble command to read from. */
    Tcl_Obj **paramListPtr)
{

    EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);


    if (ensemblePtr == NULL) {




	return TCL_ERROR;
    }


    *paramListPtr = ensemblePtr->parameterList;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
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
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetEnsembleMappingDict(
    Tcl_Interp *interp,
    Tcl_Command token,
    Tcl_Obj **mapDictPtr)
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc2 != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData2;
    *mapDictPtr = ensemblePtr->subcommandDict;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|


<
|

<
|
<
<
<
<


<
<







1353
1354
1355
1356
1357
1358
1359
1360
1361
1362

1363
1364

1365




1366
1367


1368
1369
1370
1371
1372
1373
1374
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetEnsembleMappingDict(
    Tcl_Interp *interp,
    Tcl_Command token,		/* The ensemble command to read from. */
    Tcl_Obj **mapDictPtr)
{

    EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);


    if (ensemblePtr == NULL) {




	return TCL_ERROR;
    }


    *mapDictPtr = ensemblePtr->subcommandDict;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
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
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetEnsembleUnknownHandler(
    Tcl_Interp *interp,
    Tcl_Command token,
    Tcl_Obj **unknownListPtr)
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc2 != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData2;
    *unknownListPtr = ensemblePtr->unknownHandler;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|


<
|

<
|
<
<
<
<


<
<







1386
1387
1388
1389
1390
1391
1392
1393
1394
1395

1396
1397

1398




1399
1400


1401
1402
1403
1404
1405
1406
1407
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetEnsembleUnknownHandler(
    Tcl_Interp *interp,
    Tcl_Command token,		/* The ensemble command to read from. */
    Tcl_Obj **unknownListPtr)
{

    EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);


    if (ensemblePtr == NULL) {




	return TCL_ERROR;
    }


    *unknownListPtr = ensemblePtr->unknownHandler;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetEnsembleFlags(
    Tcl_Interp *interp,
    Tcl_Command token,
    int *flagsPtr)
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc2 != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData2;
    *flagsPtr = ensemblePtr->flags;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|


<
|

<
|
<
<
<
<


<
<







1419
1420
1421
1422
1423
1424
1425
1426
1427
1428

1429
1430

1431




1432
1433


1434
1435
1436
1437
1438
1439
1440
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetEnsembleFlags(
    Tcl_Interp *interp,
    Tcl_Command token,		/* The ensemble command to read from. */
    int *flagsPtr)
{

    EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);


    if (ensemblePtr == NULL) {




	return TCL_ERROR;
    }


    *flagsPtr = ensemblePtr->flags;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetEnsembleNamespace(
    Tcl_Interp *interp,
    Tcl_Command token,
    Tcl_Namespace **namespacePtrPtr)
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc2 != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData2;
    *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|


<
|

<
|
<
<
<
<


<
<







1452
1453
1454
1455
1456
1457
1458
1459
1460
1461

1462
1463

1464




1465
1466


1467
1468
1469
1470
1471
1472
1473
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetEnsembleNamespace(
    Tcl_Interp *interp,
    Tcl_Command token,		/* The ensemble command to read from. */
    Tcl_Namespace **namespacePtrPtr)
{

    EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);


    if (ensemblePtr == NULL) {




	return TCL_ERROR;
    }


    *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
    Tcl_Interp *interp,		/* Where to do the lookup, and where to write
				 * the errors if TCL_LEAVE_ERR_MSG is set in
				 * the flags. */
    Tcl_Obj *cmdNameObj,	/* Name of command to look up. */
    int flags)			/* Either 0 or TCL_LEAVE_ERR_MSG; other flags
				 * are probably not useful. */
{
    Command *cmdPtr;

    cmdPtr = (Command *)
	    Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags);
    if (cmdPtr == NULL) {
	return NULL;
    }

    if (cmdPtr->objProc2 != TclEnsembleImplementationCmd) {
	/*
	 * Reuse existing infrastructure for following import link chains
	 * rather than duplicating it.
	 */

	cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);

	if (cmdPtr == NULL
		|| cmdPtr->objProc2 != TclEnsembleImplementationCmd) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"\"%s\" is not an ensemble command",
			TclGetString(cmdNameObj)));
		Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
			TclGetString(cmdNameObj), (char *)NULL);
	    }
	    return NULL;
	}
    }

    return (Tcl_Command) cmdPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_IsEnsemble --
 *







|

<
|
|



|





|

|
|











|







1492
1493
1494
1495
1496
1497
1498
1499
1500

1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
    Tcl_Interp *interp,		/* Where to do the lookup, and where to write
				 * the errors if TCL_LEAVE_ERR_MSG is set in
				 * the flags. */
    Tcl_Obj *cmdNameObj,	/* Name of command to look up. */
    int flags)			/* Either 0 or TCL_LEAVE_ERR_MSG; other flags
				 * are probably not useful. */
{
    Tcl_Command token;


    token = Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags);
    if (token == NULL) {
	return NULL;
    }

    if (((Command *) token)->objProc2 != TclEnsembleImplementationCmd) {
	/*
	 * Reuse existing infrastructure for following import link chains
	 * rather than duplicating it.
	 */

	token = TclGetOriginalCommand(token);

	if (token == NULL ||
		((Command *) token)->objProc2 != TclEnsembleImplementationCmd) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"\"%s\" is not an ensemble command",
			TclGetString(cmdNameObj)));
		Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
			TclGetString(cmdNameObj), (char *)NULL);
	    }
	    return NULL;
	}
    }

    return token;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_IsEnsemble --
 *
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
 *	None
 *
 *----------------------------------------------------------------------
 */

int
Tcl_IsEnsemble(
    Tcl_Command token)
{
    Command *cmdPtr = (Command *) token;

    if (cmdPtr->objProc2 == TclEnsembleImplementationCmd) {
	return 1;
    }
    cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);







|







1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
 *	None
 *
 *----------------------------------------------------------------------
 */

int
Tcl_IsEnsemble(
    Tcl_Command token)		/* The command to check. */
{
    Command *cmdPtr = (Command *) token;

    if (cmdPtr->objProc2 == TclEnsembleImplementationCmd) {
	return 1;
    }
    cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
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
 *
 *	The 'name' parameter may be a single command name or a list if
 *	creating an ensemble subcommand (see the binary implementation).
 *
 *	Currently, the TCL_ENSEMBLE_PREFIX ensemble flag is only used on
 *	top-level ensemble commands.
 *





 * Results:
 *	Handle for the new ensemble, or NULL on failure.
 *
 * Side effects:
 *	May advance the bytecode compilation epoch.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
TclMakeEnsemble(
    Tcl_Interp *interp,
    const char *name,		 /* The ensemble name (as explained above) */
    const EnsembleImplMap map[]) /* The subcommands to create */
{
    Tcl_Command ensemble;
    Tcl_Namespace *ns;
    Tcl_DString buf, hiddenBuf;
    const char **nameParts = NULL;
    const char *cmdName = NULL;
    Tcl_Size i, nameCount = 0;
    int ensembleFlags = 0, hiddenLen;

    /*
     * Construct the path for the ensemble namespace and create it.
     */

    Tcl_DStringInit(&buf);
    Tcl_DStringInit(&hiddenBuf);
    TclDStringAppendLiteral(&hiddenBuf, "tcl:");
    Tcl_DStringAppend(&hiddenBuf, name, -1);
    TclDStringAppendLiteral(&hiddenBuf, ":");
    hiddenLen = Tcl_DStringLength(&hiddenBuf);
    if (name[0] == ':' && name[1] == ':') {
	/*
	 * An absolute name, so use it directly.
	 */

	cmdName = name;
	Tcl_DStringAppend(&buf, name, -1);
	ensembleFlags = TCL_ENSEMBLE_PREFIX;
    } else {
	/*
	 * Not an absolute name, so do munging of it. Note that this treats a
	 * multi-word list differently to a single word.
	 */

	TclDStringAppendLiteral(&buf, "::tcl");

	if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) {
	    Tcl_Panic("invalid ensemble name '%s'", name);
	}

	for (i = 0; i < nameCount; ++i) {
	    TclDStringAppendLiteral(&buf, "::");
	    Tcl_DStringAppend(&buf, nameParts[i], -1);
	}
    }

    ns = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL,
	    TCL_CREATE_NS_IF_UNKNOWN);
    if (!ns) {
	Tcl_Panic("unable to find or create %s namespace!",







>
>
>
>
>












|
|
















|








|















|







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
 *
 *	The 'name' parameter may be a single command name or a list if
 *	creating an ensemble subcommand (see the binary implementation).
 *
 *	Currently, the TCL_ENSEMBLE_PREFIX ensemble flag is only used on
 *	top-level ensemble commands.
 *
 *	This code is not safe to run in Safe interpreter after user code has
 *	executed. That's OK right now because it's just used to set up Tcl,
 *	but it means we mustn't expose it at all, not even to Tk (until we can
 *	hide commands in namespaces directly).
 *
 * Results:
 *	Handle for the new ensemble, or NULL on failure.
 *
 * Side effects:
 *	May advance the bytecode compilation epoch.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
TclMakeEnsemble(
    Tcl_Interp *interp,
    const char *name,		/* The ensemble name (as explained above) */
    const EnsembleImplMap map[])/* The subcommands to create */
{
    Tcl_Command ensemble;
    Tcl_Namespace *ns;
    Tcl_DString buf, hiddenBuf;
    const char **nameParts = NULL;
    const char *cmdName = NULL;
    Tcl_Size i, nameCount = 0;
    int ensembleFlags = 0, hiddenLen;

    /*
     * Construct the path for the ensemble namespace and create it.
     */

    Tcl_DStringInit(&buf);
    Tcl_DStringInit(&hiddenBuf);
    TclDStringAppendLiteral(&hiddenBuf, "tcl:");
    Tcl_DStringAppend(&hiddenBuf, name, TCL_AUTO_LENGTH);
    TclDStringAppendLiteral(&hiddenBuf, ":");
    hiddenLen = Tcl_DStringLength(&hiddenBuf);
    if (name[0] == ':' && name[1] == ':') {
	/*
	 * An absolute name, so use it directly.
	 */

	cmdName = name;
	Tcl_DStringAppend(&buf, name, TCL_AUTO_LENGTH);
	ensembleFlags = TCL_ENSEMBLE_PREFIX;
    } else {
	/*
	 * Not an absolute name, so do munging of it. Note that this treats a
	 * multi-word list differently to a single word.
	 */

	TclDStringAppendLiteral(&buf, "::tcl");

	if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) {
	    Tcl_Panic("invalid ensemble name '%s'", name);
	}

	for (i = 0; i < nameCount; ++i) {
	    TclDStringAppendLiteral(&buf, "::");
	    Tcl_DStringAppend(&buf, nameParts[i], TCL_AUTO_LENGTH);
	}
    }

    ns = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL,
	    TCL_CREATE_NS_IF_UNKNOWN);
    if (!ns) {
	Tcl_Panic("unable to find or create %s namespace!",
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
	Command *cmdPtr;

	TclDStringAppendLiteral(&buf, "::");
	TclNewObj(mapDict);
	for (i=0 ; map[i].name != NULL ; i++) {
	    TclNewStringObj(toObj, Tcl_DStringValue(&buf),
		    Tcl_DStringLength(&buf));
	    Tcl_AppendToObj(toObj, map[i].name, -1);
	    TclDictPut(NULL, mapDict, map[i].name, toObj);

	    if (map[i].proc2 || map[i].nreProc2) {
		/*
		 * If the command is unsafe, hide it when we're in a safe
		 * interpreter. The code to do this is really hokey! It also
		 * doesn't work properly yet; this function is always
		 * currently called before the safe-interp flag is set so the
		 * Tcl_IsSafe check fails.
		 */

		if (map[i].unsafe && Tcl_IsSafe(interp)) {
		    cmdPtr = (Command *)
			    Tcl_NRCreateCommand2(interp, "___tmp", map[i].proc2,
			    map[i].nreProc2, map[i].clientData, NULL);
		    Tcl_DStringSetLength(&hiddenBuf, hiddenLen);
		    if (Tcl_HideCommand(interp, "___tmp",
			    Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) {

			Tcl_Panic("%s", Tcl_GetStringResult(interp));
		    }


		} else {
		    /*
		     * Not hidden, so just create it. Yay!
		     */

		    cmdPtr = (Command *)
			    Tcl_NRCreateCommand2(interp, TclGetString(toObj),
			    map[i].proc2, map[i].nreProc2, map[i].clientData,
			    NULL);
		}
		cmdPtr->compileProc = map[i].compileProc;

	    }
	}
	Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
    }

    Tcl_DStringFree(&buf);
    Tcl_DStringFree(&hiddenBuf);







|

















|
>


>
>









<
|
>







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
	Command *cmdPtr;

	TclDStringAppendLiteral(&buf, "::");
	TclNewObj(mapDict);
	for (i=0 ; map[i].name != NULL ; i++) {
	    TclNewStringObj(toObj, Tcl_DStringValue(&buf),
		    Tcl_DStringLength(&buf));
	    Tcl_AppendToObj(toObj, map[i].name, TCL_AUTO_LENGTH);
	    TclDictPut(NULL, mapDict, map[i].name, toObj);

	    if (map[i].proc2 || map[i].nreProc2) {
		/*
		 * If the command is unsafe, hide it when we're in a safe
		 * interpreter. The code to do this is really hokey! It also
		 * doesn't work properly yet; this function is always
		 * currently called before the safe-interp flag is set so the
		 * Tcl_IsSafe check fails.
		 */

		if (map[i].unsafe && Tcl_IsSafe(interp)) {
		    cmdPtr = (Command *)
			    Tcl_NRCreateCommand2(interp, "___tmp", map[i].proc2,
			    map[i].nreProc2, map[i].clientData, NULL);
		    Tcl_DStringSetLength(&hiddenBuf, hiddenLen);
		    if (Tcl_HideCommand(interp, "___tmp",
			    Tcl_DStringAppend(&hiddenBuf, map[i].name,
				    TCL_AUTO_LENGTH))) {
			Tcl_Panic("%s", Tcl_GetStringResult(interp));
		    }
		    /* don't compile unsafe subcommands in safe interp */
		    cmdPtr->compileProc = NULL;
		} else {
		    /*
		     * Not hidden, so just create it. Yay!
		     */

		    cmdPtr = (Command *)
			    Tcl_NRCreateCommand2(interp, TclGetString(toObj),
			    map[i].proc2, map[i].nreProc2, map[i].clientData,
			    NULL);

		    cmdPtr->compileProc = map[i].compileProc;
		}
	    }
	}
	Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
    }

    Tcl_DStringFree(&buf);
    Tcl_DStringFree(&hiddenBuf);
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
{
    return Tcl_NRCallObjProc2(interp, NsEnsembleImplementationCmdNR,
	    clientData, objc, objv);
}

static int
NsEnsembleImplementationCmdNR(
    void *clientData,
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const objv[])
{
    EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
				/* The ensemble itself. */
    Tcl_Obj *prefixObj;		/* An object containing the prefix words of
				 * the command that implements the
				 * subcommand. */
    Tcl_HashEntry *hPtr;	/* Used for efficient lookup of fully
				 * specified but not yet cached command
				 * names. */







|




|







1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
{
    return Tcl_NRCallObjProc2(interp, NsEnsembleImplementationCmdNR,
	    clientData, objc, objv);
}

static int
NsEnsembleImplementationCmdNR(
    void *clientData,		/* The ensemble this is the impl. of. */
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const objv[])
{
    EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData;
				/* The ensemble itself. */
    Tcl_Obj *prefixObj;		/* An object containing the prefix words of
				 * the command that implements the
				 * subcommand. */
    Tcl_HashEntry *hPtr;	/* Used for efficient lookup of fully
				 * specified but not yet cached command
				 * names. */
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
	 * No subcommand argument. Make error message.
	 */

	Tcl_DString buf;	/* Message being built */

	Tcl_DStringInit(&buf);
	if (ensemblePtr->parameterList) {
	    Tcl_DStringAppend(&buf,
		    TclGetString(ensemblePtr->parameterList), -1);
	    TclDStringAppendLiteral(&buf, " ");
	}
	TclDStringAppendLiteral(&buf, "subcommand ?arg ...?");
	Tcl_WrongNumArgs(interp, 1, objv, Tcl_DStringValue(&buf));
	Tcl_DStringFree(&buf);

	return TCL_ERROR;
    }

    if (ensemblePtr->nsPtr->flags & NS_DEAD) {
	/*
	 * Don't know how we got here, but make things give up quickly.
	 */

	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "ensemble activated for deleted namespace", -1));

	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", (char *)NULL);
	}
	return TCL_ERROR;
    }

    /*
     * If the table of subcommands is valid just lookup up the command there







<
|
















|
>







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
	 * No subcommand argument. Make error message.
	 */

	Tcl_DString buf;	/* Message being built */

	Tcl_DStringInit(&buf);
	if (ensemblePtr->parameterList) {

	    TclDStringAppendObj(&buf, ensemblePtr->parameterList);
	    TclDStringAppendLiteral(&buf, " ");
	}
	TclDStringAppendLiteral(&buf, "subcommand ?arg ...?");
	Tcl_WrongNumArgs(interp, 1, objv, Tcl_DStringValue(&buf));
	Tcl_DStringFree(&buf);

	return TCL_ERROR;
    }

    if (ensemblePtr->nsPtr->flags & NS_DEAD) {
	/*
	 * Don't know how we got here, but make things give up quickly.
	 */

	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "ensemble activated for deleted namespace",
		    TCL_AUTO_LENGTH));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", (char *)NULL);
	}
	return TCL_ERROR;
    }

    /*
     * If the table of subcommands is valid just lookup up the command there
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
	 * is an ensembleCmd, just call it.
	 */
	EnsembleCmdRep *ensembleCmd;

	ECRGetInternalRep(subObj, ensembleCmd);
	if (ensembleCmd) {
	    if (ensembleCmd->epoch == ensemblePtr->epoch &&
		    ensembleCmd->token == (Command *)ensemblePtr->token) {
		prefixObj = (Tcl_Obj *)Tcl_GetHashValue(ensembleCmd->hPtr);
		Tcl_IncrRefCount(prefixObj);
		if (ensembleCmd->fix) {
		    TclSpellFix(interp, objv, objc, subIdx, subObj, ensembleCmd->fix);
		}
		goto runResultingSubcommand;
	    }
	}
    } else {
	BuildEnsembleConfig(ensemblePtr);
	ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch;
    }

    /*
     * Look in the hashtable for the named subcommand.  This is the fastest
     * path if there is no cache in operation.
     */

    hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
	    TclGetString(subObj));
    if (hPtr != NULL) {

	/*
	 * Cache ensemble in the subcommand object for later.
	 */

	MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL);
    } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) {
	/*







|
|




















<







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
	 * is an ensembleCmd, just call it.
	 */
	EnsembleCmdRep *ensembleCmd;

	ECRGetInternalRep(subObj, ensembleCmd);
	if (ensembleCmd) {
	    if (ensembleCmd->epoch == ensemblePtr->epoch &&
		    ensembleCmd->token == (Command *) ensemblePtr->token) {
		prefixObj = (Tcl_Obj *) Tcl_GetHashValue(ensembleCmd->hPtr);
		Tcl_IncrRefCount(prefixObj);
		if (ensembleCmd->fix) {
		    TclSpellFix(interp, objv, objc, subIdx, subObj, ensembleCmd->fix);
		}
		goto runResultingSubcommand;
	    }
	}
    } else {
	BuildEnsembleConfig(ensemblePtr);
	ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch;
    }

    /*
     * Look in the hashtable for the named subcommand.  This is the fastest
     * path if there is no cache in operation.
     */

    hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
	    TclGetString(subObj));
    if (hPtr != NULL) {

	/*
	 * Cache ensemble in the subcommand object for later.
	 */

	MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL);
    } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) {
	/*
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
		    fullName);
	}

	/*
	 * Record the spelling correction for usage message.
	 */

	fix = Tcl_NewStringObj(fullName, -1);

	/*
	 * Cache for later in the subcommand object.
	 */

	MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, fix);
	TclSpellFix(interp, objv, objc, subIdx, subObj, fix);
    }

    prefixObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
    Tcl_IncrRefCount(prefixObj);
  runResultingSubcommand:

    /*
     * Execute the subcommand by populating an array of objects, which might
     * not be the same length as the number of arguments to this ensemble
     * command, and then handing it to the main command-lookup engine. In







|









|







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

	/*
	 * Record the spelling correction for usage message.
	 */

	fix = Tcl_NewStringObj(fullName, TCL_AUTO_LENGTH);

	/*
	 * Cache for later in the subcommand object.
	 */

	MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, fix);
	TclSpellFix(interp, objv, objc, subIdx, subObj, fix);
    }

    prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
    Tcl_IncrRefCount(prefixObj);
  runResultingSubcommand:

    /*
     * Execute the subcommand by populating an array of objects, which might
     * not be the same length as the number of arguments to this ensemble
     * command, and then handing it to the main command-lookup engine. In
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944

	/*
	 * Hand off to the target command.
	 */

	TclSkipTailcall(interp);
	TclListObjGetElements(NULL, copyPtr, &copyObjc, &copyObjv);
	((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr;
	return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL);
    }

  unknownOrAmbiguousSubcommand:
    /*
     * The named subcommand did not match any exported command. If there is a
     * handler registered unknown subcommands, call it, but not more than once







|







1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007

	/*
	 * Hand off to the target command.
	 */

	TclSkipTailcall(interp);
	TclListObjGetElements(NULL, copyPtr, &copyObjc, &copyObjv);
	((Interp *) interp)->lookupNsPtr = ensemblePtr->nsPtr;
	return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL);
    }

  unknownOrAmbiguousSubcommand:
    /*
     * The named subcommand did not match any exported command. If there is a
     * handler registered unknown subcommands, call it, but not more than once
1974
1975
1976
1977
1978
1979
1980
1981

1982
1983
1984
1985
1986

1987
1988
1989
1990
1991
1992
1993
		ensemblePtr->nsPtr->fullName));
	return TCL_ERROR;
    }
    errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ",
	    (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""),
	    TclGetString(subObj));
    if (ensemblePtr->subcommandTable.numEntries == 1) {
	Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1);

    } else {
	Tcl_Size i;

	for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
	    Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], -1);

	    Tcl_AppendToObj(errorObj, ", ", 2);
	}
	Tcl_AppendPrintfToObj(errorObj, "or %s",
		ensemblePtr->subcommandArrayPtr[i]);
    }
    Tcl_SetObjResult(interp, errorObj);
    return TCL_ERROR;







|
>




|
>







2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
		ensemblePtr->nsPtr->fullName));
	return TCL_ERROR;
    }
    errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ",
	    (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""),
	    TclGetString(subObj));
    if (ensemblePtr->subcommandTable.numEntries == 1) {
	Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0],
		TCL_AUTO_LENGTH);
    } else {
	Tcl_Size i;

	for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
	    Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i],
		    TCL_AUTO_LENGTH);
	    Tcl_AppendToObj(errorObj, ", ", 2);
	}
	Tcl_AppendPrintfToObj(errorObj, "or %s",
		ensemblePtr->subcommandArrayPtr[i]);
    }
    Tcl_SetObjResult(interp, errorObj);
    return TCL_ERROR;
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
	}
    }

    search = iPtr->ensembleRewrite.sourceObjs;
    if (search[0] == NULL) {
	store = (Tcl_Obj **) search[2];
    }  else {
	Tcl_Obj **tmp = (Tcl_Obj **)Tcl_Alloc(3 * sizeof(Tcl_Obj *));

	store = (Tcl_Obj **)Tcl_Alloc(size * sizeof(Tcl_Obj *));
	memcpy(store, iPtr->ensembleRewrite.sourceObjs,
		size * sizeof(Tcl_Obj *));

	/*
	 * Awful casting abuse here! Note that the NULL in the first element
	 * indicates that the initial objects are a raw array in the second
	 * element and the rewritten ones are a raw array in the third.







|

|







2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
	}
    }

    search = iPtr->ensembleRewrite.sourceObjs;
    if (search[0] == NULL) {
	store = (Tcl_Obj **) search[2];
    }  else {
	Tcl_Obj **tmp = (Tcl_Obj **) Tcl_Alloc(3 * sizeof(Tcl_Obj *));

	store = (Tcl_Obj **) Tcl_Alloc(size * sizeof(Tcl_Obj *));
	memcpy(store, iPtr->ensembleRewrite.sourceObjs,
		size * sizeof(Tcl_Obj *));

	/*
	 * Awful casting abuse here! Note that the NULL in the first element
	 * indicates that the initial objects are a raw array in the second
	 * element and the rewritten ones are a raw array in the third.
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
    }

    store[idx] = fix;
    Tcl_IncrRefCount(fix);
    TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL);
}











Tcl_Obj *const *
TclEnsembleGetRewriteValues(
    Tcl_Interp *interp)		/* Current interpreter. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs;

    if (origObjv[0] == NULL) {
	origObjv = (Tcl_Obj *const *)origObjv[2];
    }
    return origObjv;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFetchEnsembleRoot --
 *
 *	Returns the root of ensemble rewriting, if any.
 *	If no root exists, returns objv instead.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *const *
TclFetchEnsembleRoot(
    Tcl_Interp *interp,
    Tcl_Obj *const *objv,
    Tcl_Size objc,
    Tcl_Size *objcPtr)
{
    Tcl_Obj *const *sourceObjs;
    Interp *iPtr = (Interp *) interp;

    if (iPtr->ensembleRewrite.sourceObjs) {
	*objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs
		- iPtr->ensembleRewrite.numInsertedObjs;
	if (iPtr->ensembleRewrite.sourceObjs[0] == NULL) {
	    sourceObjs = (Tcl_Obj *const *)iPtr->ensembleRewrite.sourceObjs[1];
	} else {
	    sourceObjs = iPtr->ensembleRewrite.sourceObjs;
	}
	return sourceObjs;
    }
    *objcPtr = objc;
    return objv;







>
>
>
>
>
>
>
>
>
>






>

|




















<














|







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
    }

    store[idx] = fix;
    Tcl_IncrRefCount(fix);
    TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TclEnsembleGetRewriteValues --
 *
 *	Get the original arguments to the current command before any rewrite
 *	rules (from aliases, ensembles, and method forwards) were applied.
 *
 *----------------------------------------------------------------------
 */
Tcl_Obj *const *
TclEnsembleGetRewriteValues(
    Tcl_Interp *interp)		/* Current interpreter. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs;

    if (origObjv[0] == NULL) {
	origObjv = (Tcl_Obj *const *) origObjv[2];
    }
    return origObjv;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFetchEnsembleRoot --
 *
 *	Returns the root of ensemble rewriting, if any.
 *	If no root exists, returns objv instead.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *const *
TclFetchEnsembleRoot(
    Tcl_Interp *interp,
    Tcl_Obj *const *objv,
    Tcl_Size objc,
    Tcl_Size *objcPtr)
{
    Tcl_Obj *const *sourceObjs;
    Interp *iPtr = (Interp *) interp;

    if (iPtr->ensembleRewrite.sourceObjs) {
	*objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs
		- iPtr->ensembleRewrite.numInsertedObjs;
	if (iPtr->ensembleRewrite.sourceObjs[0] == NULL) {
	    sourceObjs = (Tcl_Obj *const *) iPtr->ensembleRewrite.sourceObjs[1];
	} else {
	    sourceObjs = iPtr->ensembleRewrite.sourceObjs;
	}
	return sourceObjs;
    }
    *objcPtr = objc;
    return objv;
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294


2295
2296
2297
2298
2299
2300
2301
 *
 * ----------------------------------------------------------------------
 */

static inline int
EnsembleUnknownCallback(
    Tcl_Interp *interp,
    EnsembleConfig *ensemblePtr,
    Tcl_Size objc,
    Tcl_Obj *const objv[],
    Tcl_Obj **prefixObjPtr)


{
    Tcl_Size paramc;
    int result;
    Tcl_Size i, prefixObjc;
    Tcl_Obj **paramv, *unknownCmd, *ensObj;

    /*







|
|
|
|
>
>







2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
 *
 * ----------------------------------------------------------------------
 */

static inline int
EnsembleUnknownCallback(
    Tcl_Interp *interp,
    EnsembleConfig *ensemblePtr,/* The ensemble structure. */
    Tcl_Size objc,			/* Number of arguments. */
    Tcl_Obj *const objv[],	/* Actual arguments. */
    Tcl_Obj **prefixObjPtr)	/* Where to write the prefix suggested by the
				 * unknown callback. Must not be NULL. Only has
				 * a meaningful value on TCL_OK. */
{
    Tcl_Size paramc;
    int result;
    Tcl_Size i, prefixObjc;
    Tcl_Obj **paramv, *unknownCmd, *ensObj;

    /*
2320
2321
2322
2323
2324
2325
2326
2327

2328
2329
2330
2331
2332
2333
2334

    Tcl_Preserve(ensemblePtr);
    TclSkipTailcall(interp);
    result = Tcl_EvalObjv(interp, paramc, paramv, 0);
    if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) {
	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "unknown subcommand handler deleted its ensemble", -1));

	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED",
		    (char *)NULL);
	}
	result = TCL_ERROR;
    }
    Tcl_Release(ensemblePtr);








|
>







2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412

    Tcl_Preserve(ensemblePtr);
    TclSkipTailcall(interp);
    result = Tcl_EvalObjv(interp, paramc, paramv, 0);
    if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) {
	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "unknown subcommand handler deleted its ensemble",
		    TCL_AUTO_LENGTH));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED",
		    (char *)NULL);
	}
	result = TCL_ERROR;
    }
    Tcl_Release(ensemblePtr);

2368
2369
2370
2371
2372
2373
2374
2375

2376
2377
2378

2379
2380
2381

2382
2383
2384

2385
2386
2387
2388
2389
2390
2391
     * Convert exceptional result to an error.
     */

    if (!Tcl_InterpDeleted(interp)) {
	if (result != TCL_ERROR) {
	    Tcl_ResetResult(interp);
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "unknown subcommand handler returned bad code: ", -1));

	    switch (result) {
	    case TCL_RETURN:
		Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", -1);

		break;
	    case TCL_BREAK:
		Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", -1);

		break;
	    case TCL_CONTINUE:
		Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", -1);

		break;
	    default:
		Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result);
	    }
	    Tcl_AddErrorInfo(interp, "\n    result of "
		    "ensemble unknown subcommand handler: ");
	    Tcl_AppendObjToErrorInfo(interp, unknownCmd);







|
>


|
>


|
>


|
>







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
     * Convert exceptional result to an error.
     */

    if (!Tcl_InterpDeleted(interp)) {
	if (result != TCL_ERROR) {
	    Tcl_ResetResult(interp);
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "unknown subcommand handler returned bad code: ",
		    TCL_AUTO_LENGTH));
	    switch (result) {
	    case TCL_RETURN:
		Tcl_AppendToObj(Tcl_GetObjResult(interp), "return",
			TCL_AUTO_LENGTH);
		break;
	    case TCL_BREAK:
		Tcl_AppendToObj(Tcl_GetObjResult(interp), "break",
			TCL_AUTO_LENGTH);
		break;
	    case TCL_CONTINUE:
		Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue",
			TCL_AUTO_LENGTH);
		break;
	    default:
		Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result);
	    }
	    Tcl_AddErrorInfo(interp, "\n    result of "
		    "ensemble unknown subcommand handler: ");
	    Tcl_AppendObjToErrorInfo(interp, unknownCmd);
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
 *	ensembleCmd.
 *
 *----------------------------------------------------------------------
 */

static void
MakeCachedEnsembleCommand(
    Tcl_Obj *objPtr,
    EnsembleConfig *ensemblePtr,
    Tcl_HashEntry *hPtr,
    Tcl_Obj *fix)

{
    EnsembleCmdRep *ensembleCmd;

    ECRGetInternalRep(objPtr, ensembleCmd);
    if (ensembleCmd) {
	TclCleanupCommandMacro(ensembleCmd->token);
	if (ensembleCmd->fix) {
	    Tcl_DecrRefCount(ensembleCmd->fix);
	}
    } else {
	/*
	 * Replace any old internal representation with a new one.
	 */

	ensembleCmd = (EnsembleCmdRep *)Tcl_Alloc(sizeof(EnsembleCmdRep));
	ECRSetInternalRep(objPtr, ensembleCmd);
    }

    /*
     * Populate the internal rep.
     */








|
|
|
|
>














|







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

static void
MakeCachedEnsembleCommand(
    Tcl_Obj *objPtr,		/* Object to cache in. */
    EnsembleConfig *ensemblePtr,/* Ensemble implementation. */
    Tcl_HashEntry *hPtr,	/* What to cache; what the object maps to. */
    Tcl_Obj *fix)		/* Spelling correction for later error, or NULL
				 * if no correction. */
{
    EnsembleCmdRep *ensembleCmd;

    ECRGetInternalRep(objPtr, ensembleCmd);
    if (ensembleCmd) {
	TclCleanupCommandMacro(ensembleCmd->token);
	if (ensembleCmd->fix) {
	    Tcl_DecrRefCount(ensembleCmd->fix);
	}
    } else {
	/*
	 * Replace any old internal representation with a new one.
	 */

	ensembleCmd = (EnsembleCmdRep *) Tcl_Alloc(sizeof(EnsembleCmdRep));
	ECRSetInternalRep(objPtr, ensembleCmd);
    }

    /*
     * Populate the internal rep.
     */

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
 *	Memory is eventually deallocated.
 *
 *----------------------------------------------------------------------
 */

static void
ClearTable(
    EnsembleConfig *ensemblePtr)
{
    Tcl_HashTable *hash = &ensemblePtr->subcommandTable;

    if (hash->numEntries != 0) {
        Tcl_HashSearch search;
        Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search);

        while (hPtr != NULL) {
            Tcl_Obj *prefixObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
            Tcl_DecrRefCount(prefixObj);
            hPtr = Tcl_NextHashEntry(&search);
        }
        Tcl_Free(ensemblePtr->subcommandArrayPtr);
    }
    Tcl_DeleteHashTable(hash);
}

static void
DeleteEnsembleConfig(
    void *clientData)
{
    EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
    Namespace *nsPtr = ensemblePtr->nsPtr;

    /* Unlink from the ensemble chain if it not already marked as unlinked. */

    if (ensemblePtr->next != ensemblePtr) {
	EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles;








|




|
|

|
|
|
|
|
|






|

|







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
 *	Memory is eventually deallocated.
 *
 *----------------------------------------------------------------------
 */

static void
ClearTable(
    EnsembleConfig *ensemblePtr)/* Ensemble to clear table of. */
{
    Tcl_HashTable *hash = &ensemblePtr->subcommandTable;

    if (hash->numEntries != 0) {
	Tcl_HashSearch search;
	Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search);

	while (hPtr != NULL) {
	    Tcl_Obj *prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
	    Tcl_DecrRefCount(prefixObj);
	    hPtr = Tcl_NextHashEntry(&search);
	}
	Tcl_Free(ensemblePtr->subcommandArrayPtr);
    }
    Tcl_DeleteHashTable(hash);
}

static void
DeleteEnsembleConfig(
    void *clientData)		/* Ensemble to delete. */
{
    EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData;
    Namespace *nsPtr = ensemblePtr->nsPtr;

    /* Unlink from the ensemble chain if it not already marked as unlinked. */

    if (ensemblePtr->next != ensemblePtr) {
	EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles;

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
 *	may be an expensive operation.
 *
 *----------------------------------------------------------------------
 */

static void
BuildEnsembleConfig(
    EnsembleConfig *ensemblePtr)
{
    Tcl_HashSearch search;	/* Used for scanning the commands in
				 * the namespace for this ensemble. */
    Tcl_Size i, j;
    int isNew;
    Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
    Tcl_HashEntry *hPtr;
    Tcl_Obj *mapDict = ensemblePtr->subcommandDict;
    Tcl_Obj *subList = ensemblePtr->subcmdList;

    ClearTable(ensemblePtr);
    Tcl_InitHashTable(hash, TCL_STRING_KEYS);

    if (subList) {
        Tcl_Size subc;
        Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj;
        const char *name;

        /*
         * There is a list of exactly what subcommands go in the table.
         * Determine the target for each.
         */

        TclListObjGetElements(NULL, subList, &subc, &subv);
        if (subList == mapDict) {
            /*
             * Unusual case where explicit list of subcommands is same value
             * as the dict mapping to targets.
             */

            for (i = 0; i < subc; i += 2) {
                name = TclGetString(subv[i]);
                hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
                if (!isNew) {
                    cmdObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
                    Tcl_DecrRefCount(cmdObj);
                }
                Tcl_SetHashValue(hPtr, subv[i+1]);
                Tcl_IncrRefCount(subv[i+1]);

                name = TclGetString(subv[i+1]);
                hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
                if (isNew) {
                    cmdObj = Tcl_NewStringObj(name, -1);
                    cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
                    Tcl_SetHashValue(hPtr, cmdPrefixObj);
                    Tcl_IncrRefCount(cmdPrefixObj);
                }
            }
        } else {
            /*
	     * Usual case where we can freely act on the list and dict.
	     */

            for (i = 0; i < subc; i++) {
                name = TclGetString(subv[i]);
                hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
                if (!isNew) {
                    continue;
                }

                /*
		 * Lookup target in the dictionary.
		 */

                if (mapDict) {
                    Tcl_DictObjGet(NULL, mapDict, subv[i], &target);
                    if (target) {
                        Tcl_SetHashValue(hPtr, target);
                        Tcl_IncrRefCount(target);
                        continue;
                    }
                }

                /*
                 * Target was not in the dictionary.  Map onto the namespace.
                 * In this case there is no guarantee that the command
                 * is actually there.  It is the responsibility of the
		 * programmer (or [::unknown] of course) to provide the procedure.
                 */

                cmdObj = Tcl_NewStringObj(name, -1);
                cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
                Tcl_SetHashValue(hPtr, cmdPrefixObj);
                Tcl_IncrRefCount(cmdPrefixObj);
            }
        }
    } else if (mapDict) {
        /*
         * No subcmd list, but there is a mapping dictionary, so
         * use the keys of that. Convert the contents of the dictionary into the
         * form required for the internal hashtable of the ensemble.
         */

        Tcl_DictSearch dictSearch;
        Tcl_Obj *keyObj, *valueObj;
        int done;

        Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
                &keyObj, &valueObj, &done);
        while (!done) {
            const char *name = TclGetString(keyObj);

            hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
            Tcl_SetHashValue(hPtr, valueObj);
            Tcl_IncrRefCount(valueObj);
            Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done);
        }
    } else {
	/*
	 * Use the array of patterns and the hash table whose keys are the
	 * commands exported by the namespace.  The corresponding values do not
	 * matter here.  Filter the commands in the namespace against the
	 * patterns in the export list to find out what commands are actually
	 * exported. Use an intermediate hash table to make memory management
	 * easier and to make exact matching much easier.
	 *
	 * Suggestion for future enhancement: Compute the unique prefixes and
	 * place them in the hash too for even faster matching.
	 */

	hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
	for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
	    char *nsCmdName =		/* Name of command in namespace. */
		    (char *)Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);

	    for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
		if (Tcl_StringMatch(nsCmdName,
			ensemblePtr->nsPtr->exportArrayPtr[i])) {
		    hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew);

		    /*







|














|
|
|

|
|
|
|

|
|
|
|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|



|
|
|
|
|
|

|



|
|
|
|
|
|
|
|

|
|
|
|
|
|

|
|
|
|
|
|

|
|
|
|
|

|
|
|

|
|
|
|

|
|
|
|
|















|
|







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
 *	may be an expensive operation.
 *
 *----------------------------------------------------------------------
 */

static void
BuildEnsembleConfig(
    EnsembleConfig *ensemblePtr)/* Ensemble to set up. */
{
    Tcl_HashSearch search;	/* Used for scanning the commands in
				 * the namespace for this ensemble. */
    Tcl_Size i, j;
    int isNew;
    Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
    Tcl_HashEntry *hPtr;
    Tcl_Obj *mapDict = ensemblePtr->subcommandDict;
    Tcl_Obj *subList = ensemblePtr->subcmdList;

    ClearTable(ensemblePtr);
    Tcl_InitHashTable(hash, TCL_STRING_KEYS);

    if (subList) {
	Tcl_Size subc;
	Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj;
	const char *name;

	/*
	 * There is a list of exactly what subcommands go in the table.
	 * Determine the target for each.
	 */

	TclListObjGetElements(NULL, subList, &subc, &subv);
	if (subList == mapDict) {
	    /*
	     * Unusual case where explicit list of subcommands is same value
	     * as the dict mapping to targets.
	     */

	    for (i = 0; i < subc; i += 2) {
		name = TclGetString(subv[i]);
		hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
		if (!isNew) {
		    cmdObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
		    Tcl_DecrRefCount(cmdObj);
		}
		Tcl_SetHashValue(hPtr, subv[i + 1]);
		Tcl_IncrRefCount(subv[i + 1]);

		name = TclGetString(subv[i + 1]);
		hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
		if (isNew) {
		    cmdObj = Tcl_NewStringObj(name, TCL_AUTO_LENGTH);
		    cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
		    Tcl_SetHashValue(hPtr, cmdPrefixObj);
		    Tcl_IncrRefCount(cmdPrefixObj);
		}
	    }
	} else {
	    /*
	     * Usual case where we can freely act on the list and dict.
	     */

	    for (i = 0; i < subc; i++) {
		name = TclGetString(subv[i]);
		hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
		if (!isNew) {
		    continue;
		}

		/*
		 * Lookup target in the dictionary.
		 */

		if (mapDict) {
		    Tcl_DictObjGet(NULL, mapDict, subv[i], &target);
		    if (target) {
			Tcl_SetHashValue(hPtr, target);
			Tcl_IncrRefCount(target);
			continue;
		    }
		}

		/*
		 * Target was not in the dictionary.  Map onto the namespace.
		 * In this case there is no guarantee that the command is
		 * actually there.  It is the responsibility of the programmer
		 * (or [::unknown] of course) to provide the procedure.
		 */

		cmdObj = Tcl_NewStringObj(name, TCL_AUTO_LENGTH);
		cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
		Tcl_SetHashValue(hPtr, cmdPrefixObj);
		Tcl_IncrRefCount(cmdPrefixObj);
	    }
	}
    } else if (mapDict) {
	/*
	 * No subcmd list, but there is a mapping dictionary, so use
	 * the keys of that. Convert the contents of the dictionary into the
	 * form required for the internal hashtable of the ensemble.
	 */

	Tcl_DictSearch dictSearch;
	Tcl_Obj *keyObj, *valueObj;
	int done;

	Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
		&keyObj, &valueObj, &done);
	while (!done) {
	    const char *name = TclGetString(keyObj);

	    hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
	    Tcl_SetHashValue(hPtr, valueObj);
	    Tcl_IncrRefCount(valueObj);
	    Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done);
	}
    } else {
	/*
	 * Use the array of patterns and the hash table whose keys are the
	 * commands exported by the namespace.  The corresponding values do not
	 * matter here.  Filter the commands in the namespace against the
	 * patterns in the export list to find out what commands are actually
	 * exported. Use an intermediate hash table to make memory management
	 * easier and to make exact matching much easier.
	 *
	 * Suggestion for future enhancement: Compute the unique prefixes and
	 * place them in the hash too for even faster matching.
	 */

	hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
	for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
	    char *nsCmdName = (char *)	/* Name of command in namespace. */
		    Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);

	    for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
		if (Tcl_StringMatch(nsCmdName,
			ensemblePtr->nsPtr->exportArrayPtr[i])) {
		    hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew);

		    /*
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
     * the error message either.
     *
     * Do this by filling an array with the names:  Use the hash keys
     * directly to save a copy since any time we change the array we change
     * the hash too, and vice versa, and run quicksort over the array.
     */

    ensemblePtr->subcommandArrayPtr =
	    (char **)Tcl_Alloc(sizeof(char *) * hash->numEntries);

    /*
     * Fill the array from both ends as this reduces the likelihood of
     * performance problems in qsort(). This makes this code much more opaque,
     * but the naive alternatve:
     *
     * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ;







|
|







2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
     * the error message either.
     *
     * Do this by filling an array with the names:  Use the hash keys
     * directly to save a copy since any time we change the array we change
     * the hash too, and vice versa, and run quicksort over the array.
     */

    ensemblePtr->subcommandArrayPtr = (char **)
	    Tcl_Alloc(sizeof(char *) * hash->numEntries);

    /*
     * Fill the array from both ends as this reduces the likelihood of
     * performance problems in qsort(). This makes this code much more opaque,
     * but the naive alternatve:
     *
     * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ;
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
     * to have awful runtime behaviour.
     */

    i = 0;
    j = hash->numEntries;
    hPtr = Tcl_FirstHashEntry(hash, &search);
    while (hPtr != NULL) {
	ensemblePtr->subcommandArrayPtr[i++] = (char *)Tcl_GetHashKey(hash, hPtr);

	hPtr = Tcl_NextHashEntry(&search);
	if (hPtr == NULL) {
	    break;
	}
	ensemblePtr->subcommandArrayPtr[--j] = (char *)Tcl_GetHashKey(hash, hPtr);

	hPtr = Tcl_NextHashEntry(&search);
    }
    if (hash->numEntries > 1) {
	qsort(ensemblePtr->subcommandArrayPtr, hash->numEntries,
		sizeof(char *), NsEnsembleStringOrder);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * NsEnsembleStringOrder --
 *

 *	Helper to for uset with sort() that compares two string pointers.
 *
 * Results:
 *	-1 if the first string is smaller, 1 if the second string is smaller,
 *	and 0 if they are equal.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
NsEnsembleStringOrder(
    const void *strPtr1,
    const void *strPtr2)
{
    return strcmp(*(const char **)strPtr1, *(const char **)strPtr2);
}

/*
 *----------------------------------------------------------------------
 *







|
>




|
>













>
|













|
|







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
     * to have awful runtime behaviour.
     */

    i = 0;
    j = hash->numEntries;
    hPtr = Tcl_FirstHashEntry(hash, &search);
    while (hPtr != NULL) {
	ensemblePtr->subcommandArrayPtr[i++] = (char *)
		Tcl_GetHashKey(hash, hPtr);
	hPtr = Tcl_NextHashEntry(&search);
	if (hPtr == NULL) {
	    break;
	}
	ensemblePtr->subcommandArrayPtr[--j] = (char *)
		Tcl_GetHashKey(hash, hPtr);
	hPtr = Tcl_NextHashEntry(&search);
    }
    if (hash->numEntries > 1) {
	qsort(ensemblePtr->subcommandArrayPtr, hash->numEntries,
		sizeof(char *), NsEnsembleStringOrder);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * NsEnsembleStringOrder --
 *
 *	Helper to for use with qsort() that compares two array entries that
 *	contain string pointers.
 *
 * Results:
 *	-1 if the first string is smaller, 1 if the second string is smaller,
 *	and 0 if they are equal.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
NsEnsembleStringOrder(
    const void *strPtr1,	/* Points to first array entry */
    const void *strPtr2)	/* Points to second array entry */
{
    return strcmp(*(const char **)strPtr1, *(const char **)strPtr2);
}

/*
 *----------------------------------------------------------------------
 *
2869
2870
2871
2872
2873
2874
2875
2876

2877
2878
2879
2880
2881
2882
2883

static void
DupEnsembleCmdRep(
    Tcl_Obj *objPtr,
    Tcl_Obj *copyPtr)
{
    EnsembleCmdRep *ensembleCmd;
    EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)Tcl_Alloc(sizeof(EnsembleCmdRep));


    ECRGetInternalRep(objPtr, ensembleCmd);
    ECRSetInternalRep(copyPtr, ensembleCopy);

    ensembleCopy->epoch = ensembleCmd->epoch;
    ensembleCopy->token = ensembleCmd->token;
    ensembleCopy->token->refCount++;







|
>







2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970

static void
DupEnsembleCmdRep(
    Tcl_Obj *objPtr,
    Tcl_Obj *copyPtr)
{
    EnsembleCmdRep *ensembleCmd;
    EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)
	    Tcl_Alloc(sizeof(EnsembleCmdRep));

    ECRGetInternalRep(objPtr, ensembleCmd);
    ECRSetInternalRep(copyPtr, ensembleCopy);

    ensembleCopy->epoch = ensembleCmd->epoch;
    ensembleCopy->token = ensembleCmd->token;
    ensembleCopy->token->refCount++;
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
    }
    targetCmdObj = elems[0];

    oldCmdPtr = cmdPtr;
    Tcl_IncrRefCount(targetCmdObj);
    newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
    TclDecrRefCount(targetCmdObj);
    if (newCmdPtr == NULL || Tcl_IsSafe(interp)
	    || newCmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION
	    || newCmdPtr->flags & CMD_HAS_EXEC_TRACES
	    || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) {
	/*
	 * Maps to an undefined command or a command without a compiler.
	 * Cannot compile.
	 */

	goto cleanup;
    }
    cmdPtr = newCmdPtr;
    depth++;

    /*
     * See whether we have a nested ensemble. If we do, we can go round the







|


|




<







3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234

3235
3236
3237
3238
3239
3240
3241
    }
    targetCmdObj = elems[0];

    oldCmdPtr = cmdPtr;
    Tcl_IncrRefCount(targetCmdObj);
    newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
    TclDecrRefCount(targetCmdObj);
    if (newCmdPtr == NULL || (Tcl_IsSafe(interp) && !cmdPtr->compileProc)
	    || newCmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION
	    || newCmdPtr->flags & CMD_HAS_EXEC_TRACES
	    || ((Interp *) interp)->flags & DONT_COMPILE_CMDS_INLINE) {
	/*
	 * Maps to an undefined command or a command without a compiler.
	 * Cannot compile.
	 */

	goto cleanup;
    }
    cmdPtr = newCmdPtr;
    depth++;

    /*
     * See whether we have a nested ensemble. If we do, we can go round the
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
    }

    /*
     * Throw out any line information generated by the failed compile attempt.
     */

    while (mapPtr->nuloc > eclIndex + 1) {
        mapPtr->nuloc--;
        Tcl_Free(mapPtr->loc[mapPtr->nuloc].line);
        mapPtr->loc[mapPtr->nuloc].line = NULL;
    }

    /*
     * Reset the index of next command.  Toss out any from failed nested
     * partial compiles.
     */








|
|
|







3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
    }

    /*
     * Throw out any line information generated by the failed compile attempt.
     */

    while (mapPtr->nuloc > eclIndex + 1) {
	mapPtr->nuloc--;
	Tcl_Free(mapPtr->loc[mapPtr->nuloc].line);
	mapPtr->loc[mapPtr->nuloc].line = NULL;
    }

    /*
     * Reset the index of next command.  Toss out any from failed nested
     * partial compiles.
     */

3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
     * difference. Hence the call to TclContinuationsEnterDerived...
     */

    TclListObjGetElements(NULL, replacements, &numWords, &words);
    for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords;
	    i++, tokPtr = TokenAfter(tokPtr)) {
	if (i > 0 && i <= numWords) {
	    bytes = TclGetStringFromObj(words[i-1], &length);
	    PushLiteral(envPtr, bytes, length);
	    continue;
	}

	SetLineInformation(i);
	if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    int literal = TclRegisterLiteral(envPtr,







|







3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
     * difference. Hence the call to TclContinuationsEnterDerived...
     */

    TclListObjGetElements(NULL, replacements, &numWords, &words);
    for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords;
	    i++, tokPtr = TokenAfter(tokPtr)) {
	if (i > 0 && i <= numWords) {
	    bytes = TclGetStringFromObj(words[i - 1], &length);
	    PushLiteral(envPtr, bytes, length);
	    continue;
	}

	SetLineInformation(i);
	if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    int literal = TclRegisterLiteral(envPtr,
3446
3447
3448
3449
3450
3451
3452
3453

3454
3455
3456
3457
3458
3459
3460
    TclEmitPush(cmdLit, envPtr);
    TclDecrRefCount(objPtr);

    /*
     * Do the replacing dispatch.
     */

    TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,numWords+1);

}

/*
 * Helpers that do issuing of instructions for commands that "don't have
 * compilers" (well, they do; these). They all work by just generating base
 * code to invoke the command; they're intended for ensemble subcommands so
 * that the costs of INST_INVOKE_REPLACE can be avoided where we can work out







|
>







3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
    TclEmitPush(cmdLit, envPtr);
    TclDecrRefCount(objPtr);

    /*
     * Do the replacing dispatch.
     */

    TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,
	    numWords + 1);
}

/*
 * Helpers that do issuing of instructions for commands that "don't have
 * compilers" (well, they do; these). They all work by just generating base
 * code to invoke the command; they're intended for ensemble subcommands so
 * that the costs of INST_INVOKE_REPLACE can be avoided where we can work out

Changes to generic/tclExecute.c.

655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
static Tcl_NRPostProc   TEBCresume;

/*
 * The structure below defines a bytecode Tcl object type to hold the
 * compiled bytecode for Tcl expressions.
 */

static const Tcl_ObjType exprCodeType = {
    "exprcode",
    FreeExprCodeInternalRep,	/* freeIntRepProc */
    DupExprCodeInternalRep,	/* dupIntRepProc */
    NULL,			/* updateStringProc */
    NULL,			/* setFromAnyProc */
    TCL_OBJTYPE_V0
};







|







655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
static Tcl_NRPostProc   TEBCresume;

/*
 * The structure below defines a bytecode Tcl object type to hold the
 * compiled bytecode for Tcl expressions.
 */

const Tcl_ObjType tclExprCodeType = {
    "exprcode",
    FreeExprCodeInternalRep,	/* freeIntRepProc */
    DupExprCodeInternalRep,	/* dupIntRepProc */
    NULL,			/* updateStringProc */
    NULL,			/* setFromAnyProc */
    TCL_OBJTYPE_V0
};
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
				 * to avoid compiler warning. */

    /*
     * Get the expression ByteCode from the object. If it exists, make sure it
     * is valid in the current context.
     */

    ByteCodeGetInternalRep(objPtr, &exprCodeType, codePtr);

    if (codePtr != NULL) {
	Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;

	if (((Interp *) *codePtr->interpHandle != iPtr)
		|| (codePtr->compileEpoch != iPtr->compileEpoch)
		|| (codePtr->nsPtr != namespacePtr)
		|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)
		|| (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) {
	    Tcl_StoreInternalRep(objPtr, &exprCodeType, NULL);
	    codePtr = NULL;
	}
    }

    if (codePtr == NULL) {
	/*
	 * TIP #280: No invoker (yet) - Expression compilation.







|









|







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
				 * to avoid compiler warning. */

    /*
     * Get the expression ByteCode from the object. If it exists, make sure it
     * is valid in the current context.
     */

    ByteCodeGetInternalRep(objPtr, &tclExprCodeType, codePtr);

    if (codePtr != NULL) {
	Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;

	if (((Interp *) *codePtr->interpHandle != iPtr)
		|| (codePtr->compileEpoch != iPtr->compileEpoch)
		|| (codePtr->nsPtr != namespacePtr)
		|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)
		|| (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) {
	    Tcl_StoreInternalRep(objPtr, &tclExprCodeType, NULL);
	    codePtr = NULL;
	}
    }

    if (codePtr == NULL) {
	/*
	 * TIP #280: No invoker (yet) - Expression compilation.
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
	/*
	 * Add a "done" instruction as the last instruction and change the
	 * object into a ByteCode object. Ownership of the literal objects and
	 * aux data items is given to the ByteCode object.
	 */

	TclEmitOpcode(INST_DONE, &compEnv);
	codePtr = TclInitByteCodeObj(objPtr, &exprCodeType, &compEnv);
	TclFreeCompileEnv(&compEnv);
	if (iPtr->varFramePtr->localCachePtr) {
	    codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
	    codePtr->localCachePtr->refCount++;
	}
	TclDebugPrintByteCodeObj(objPtr);
    }







|







1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
	/*
	 * Add a "done" instruction as the last instruction and change the
	 * object into a ByteCode object. Ownership of the literal objects and
	 * aux data items is given to the ByteCode object.
	 */

	TclEmitOpcode(INST_DONE, &compEnv);
	codePtr = TclInitByteCodeObj(objPtr, &tclExprCodeType, &compEnv);
	TclFreeCompileEnv(&compEnv);
	if (iPtr->varFramePtr->localCachePtr) {
	    codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
	    codePtr->localCachePtr->refCount++;
	}
	TclDebugPrintByteCodeObj(objPtr);
    }
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
 */

static void
FreeExprCodeInternalRep(
    Tcl_Obj *objPtr)
{
    ByteCode *codePtr;
    ByteCodeGetInternalRep(objPtr, &exprCodeType, codePtr);
    assert(codePtr != NULL);

    TclReleaseByteCode(codePtr);
}

/*
 *----------------------------------------------------------------------







|







1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
 */

static void
FreeExprCodeInternalRep(
    Tcl_Obj *objPtr)
{
    ByteCode *codePtr;
    ByteCodeGetInternalRep(objPtr, &tclExprCodeType, codePtr);
    assert(codePtr != NULL);

    TclReleaseByteCode(codePtr);
}

/*
 *----------------------------------------------------------------------

Changes to generic/tclIO.c.

9191
9192
9193
9194
9195
9196
9197
9198
9199
9200
9201
9202
9203
9204
9205
    const char *chanName;
    int modeIndex;		/* Index of mode argument. */
    int mask;
    static const char *const modeOptions[] = {"readable", "writable", NULL};
    static const int maskArray[] = {TCL_READABLE, TCL_WRITABLE};

    if ((objc != 3) && (objc != 4)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId event ?script?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[2], modeOptions, "event name", 0,
	    &modeIndex) != TCL_OK) {
	return TCL_ERROR;
    }
    mask = maskArray[modeIndex];







|







9191
9192
9193
9194
9195
9196
9197
9198
9199
9200
9201
9202
9203
9204
9205
    const char *chanName;
    int modeIndex;		/* Index of mode argument. */
    int mask;
    static const char *const modeOptions[] = {"readable", "writable", NULL};
    static const int maskArray[] = {TCL_READABLE, TCL_WRITABLE};

    if ((objc != 3) && (objc != 4)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channel event ?script?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[2], modeOptions, "event name", 0,
	    &modeIndex) != TCL_OK) {
	return TCL_ERROR;
    }
    mask = maskArray[modeIndex];

Changes to generic/tclIOCmd.c.

134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
	    chanObjPtr = objv[2];
	    string = objv[3];
	    break;
	}
	/* Fall through */
    default:			/* [puts] or
				 * [puts some bad number of arguments...] */
	Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
	return TCL_ERROR;
    }

    if (chanObjPtr == NULL) {
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

	if (!tsdPtr->initialized) {







|







134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
	    chanObjPtr = objv[2];
	    string = objv[3];
	    break;
	}
	/* Fall through */
    default:			/* [puts] or
				 * [puts some bad number of arguments...] */
	Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channel? string");
	return TCL_ERROR;
    }

    if (chanObjPtr == NULL) {
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

	if (!tsdPtr->initialized) {
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *chanObjPtr;
    Tcl_Channel chan;		/* The channel to flush on. */
    int mode;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
	return TCL_ERROR;
    }
    chanObjPtr = objv[1];
    if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
	return TCL_ERROR;
    }
    if (!(mode & TCL_WRITABLE)) {







|







218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *chanObjPtr;
    Tcl_Channel chan;		/* The channel to flush on. */
    int mode;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channel");
	return TCL_ERROR;
    }
    chanObjPtr = objv[1];
    if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
	return TCL_ERROR;
    }
    if (!(mode & TCL_WRITABLE)) {
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
    Tcl_Channel chan;		/* The channel to read from. */
    Tcl_Size lineLen;		/* Length of line just read. */
    int mode;			/* Mode in which channel is opened. */
    Tcl_Obj *linePtr, *chanObjPtr;
    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)) {







|







284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
    Tcl_Channel chan;		/* The channel to read from. */
    Tcl_Size lineLen;		/* Length of line just read. */
    int mode;			/* Mode in which channel is opened. */
    Tcl_Obj *linePtr, *chanObjPtr;
    int code = TCL_OK;

    if ((objc != 2) && (objc != 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channel ?varName?");
	return TCL_ERROR;
    }
    chanObjPtr = objv[1];
    if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
	return TCL_ERROR;
    }
    if (!(mode & TCL_READABLE)) {
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
    Tcl_Obj *resultPtr, *chanObjPtr;

    if ((objc != 2) && (objc != 3)) {
	Interp *iPtr;

    argerror:
	iPtr = (Interp *) interp;
	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?");

	/*
	 * Do not append directly; that makes ensembles using this command as
	 * a subcommand produce the wrong message.
	 */

	iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS;
	Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channelId");
	return TCL_ERROR;
    }

    i = 1;
    newline = 0;
    if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
	newline = 1;







|







|







376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
    Tcl_Obj *resultPtr, *chanObjPtr;

    if ((objc != 2) && (objc != 3)) {
	Interp *iPtr;

    argerror:
	iPtr = (Interp *) interp;
	Tcl_WrongNumArgs(interp, 1, objv, "channel ?numChars?");

	/*
	 * Do not append directly; that makes ensembles using this command as
	 * a subcommand produce the wrong message.
	 */

	iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS;
	Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channel");
	return TCL_ERROR;
    }

    i = 1;
    newline = 0;
    if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
	newline = 1;
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
    int optionIndex;
    static const char *const originOptions[] = {
	"start", "current", "end", NULL
    };
    static const int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END};

    if ((objc != 3) && (objc != 4)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?");
	return TCL_ERROR;
    }
    if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
	return TCL_ERROR;
    }
    if (TclGetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) {
	return TCL_ERROR;







|







512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
    int optionIndex;
    static const char *const originOptions[] = {
	"start", "current", "end", NULL
    };
    static const int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END};

    if ((objc != 3) && (objc != 4)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channel offset ?origin?");
	return TCL_ERROR;
    }
    if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
	return TCL_ERROR;
    }
    if (TclGetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) {
	return TCL_ERROR;
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
    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.
     */







|







581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
    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, "channel");
	return TCL_ERROR;
    }

    /*
     * Try to find a channel with the right name and permissions in the IO
     * channel table of this interpreter.
     */
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
    Tcl_Channel chan;		/* The channel to close. */
    static const char *const dirOptions[] = {
	"read", "write", NULL
    };
    static const int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE};

    if ((objc != 2) && (objc != 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?direction?");
	return TCL_ERROR;
    }

    if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
	return TCL_ERROR;
    }








|







644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
    Tcl_Channel chan;		/* The channel to close. */
    static const char *const dirOptions[] = {
	"read", "write", NULL
    };
    static const int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE};

    if ((objc != 2) && (objc != 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channel ?direction?");
	return TCL_ERROR;
    }

    if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
	return TCL_ERROR;
    }

750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *optionName, *valueName;
    Tcl_Channel chan;		/* The channel to set a mode on. */
    Tcl_Size i;			/* Iterate over arg-value pairs. */

    if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?-option value ...?");
	return TCL_ERROR;
    }

    if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
	return TCL_ERROR;
    }








|







750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *optionName, *valueName;
    Tcl_Channel chan;		/* The channel to set a mode on. */
    Tcl_Size i;			/* Iterate over arg-value pairs. */

    if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) {
	Tcl_WrongNumArgs(interp, 1, objv, "channel ?-option value ...?");
	return TCL_ERROR;
    }

    if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
	return TCL_ERROR;
    }

823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Size objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;

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

    if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
	return TCL_ERROR;
    }








|







823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Size objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;

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

    if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
	return TCL_ERROR;
    }

1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
    Tcl_Size objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;
    int mode;

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

    if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) {
	return TCL_ERROR;
    }
    if (!(mode & TCL_READABLE)) {







|







1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
    Tcl_Size objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;
    int mode;

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

    if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) {
	return TCL_ERROR;
    }
    if (!(mode & TCL_READABLE)) {
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
{
    Tcl_Channel chan;
    static const char *const options[] = {"input", "output", NULL};
    enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT} index;
    int mode;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "mode channelId");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], options, "mode", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }







|







1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
{
    Tcl_Channel chan;
    static const char *const options[] = {"input", "output", NULL};
    enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT} index;
    int mode;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "mode channel");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], options, "mode", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
    Tcl_Size objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;
    Tcl_WideInt length;

    if ((objc < 2) || (objc > 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?length?");
	return TCL_ERROR;
    }
    if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
	return TCL_ERROR;
    }

    if (objc == 3) {







|







1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
    Tcl_Size objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;
    Tcl_WideInt length;

    if ((objc < 2) || (objc > 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channel ?length?");
	return TCL_ERROR;
    }
    if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
	return TCL_ERROR;
    }

    if (objc == 3) {

Changes to generic/tclInt.h.

2123
2124
2125
2126
2127
2128
2129
2130

2131
2132
2133
2134
2135
2136
2137
	Tcl_Obj *const *sourceObjs;
				/* What arguments were actually input into the
				 * *root* ensemble command? (Nested ensembles
				 * don't rewrite this.) NULL if we're not
				 * processing an ensemble. */
	Tcl_Size numRemovedObjs;/* How many arguments have been stripped off
				 * because of ensemble processing. */
	Tcl_Size numInsertedObjs;/* How many of the current arguments were

				 * inserted by an ensemble. */
    } ensembleRewrite;

    /*
     * TIP #219: Global info for the I/O system.
     */








|
>







2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
	Tcl_Obj *const *sourceObjs;
				/* What arguments were actually input into the
				 * *root* ensemble command? (Nested ensembles
				 * don't rewrite this.) NULL if we're not
				 * processing an ensemble. */
	Tcl_Size numRemovedObjs;/* How many arguments have been stripped off
				 * because of ensemble processing. */
	Tcl_Size numInsertedObjs;
				/* How many of the current arguments were
				 * inserted by an ensemble. */
    } ensembleRewrite;

    /*
     * TIP #219: Global info for the I/O system.
     */

3057
3058
3059
3060
3061
3062
3063

3064
3065
3066
3067
3068
3069
3070
 * Variables denoting the Tcl object types defined in the core.
 */

MODULE_SCOPE const Tcl_ObjType tclBignumType;
MODULE_SCOPE const Tcl_ObjType tclBooleanType;
MODULE_SCOPE const Tcl_ObjType tclByteCodeType;
MODULE_SCOPE const Tcl_ObjType tclDoubleType;

MODULE_SCOPE const Tcl_ObjType tclIntType;
MODULE_SCOPE const Tcl_ObjType tclIndexType;
MODULE_SCOPE const Tcl_ObjType tclListType;
MODULE_SCOPE const Tcl_ObjType tclDictType;
MODULE_SCOPE const Tcl_ObjType tclProcBodyType;
MODULE_SCOPE const Tcl_ObjType tclStringType;
MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType;







>







3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
 * Variables denoting the Tcl object types defined in the core.
 */

MODULE_SCOPE const Tcl_ObjType tclBignumType;
MODULE_SCOPE const Tcl_ObjType tclBooleanType;
MODULE_SCOPE const Tcl_ObjType tclByteCodeType;
MODULE_SCOPE const Tcl_ObjType tclDoubleType;
MODULE_SCOPE const Tcl_ObjType tclExprCodeType;
MODULE_SCOPE const Tcl_ObjType tclIntType;
MODULE_SCOPE const Tcl_ObjType tclIndexType;
MODULE_SCOPE const Tcl_ObjType tclListType;
MODULE_SCOPE const Tcl_ObjType tclDictType;
MODULE_SCOPE const Tcl_ObjType tclProcBodyType;
MODULE_SCOPE const Tcl_ObjType tclStringType;
MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType;
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
MODULE_SCOPE int	TclProcessReturn(Tcl_Interp *interp,
			    int code, int level, Tcl_Obj *returnOpts);
MODULE_SCOPE void	TclUndoRefCount(Tcl_Obj *objPtr);
MODULE_SCOPE int	TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
MODULE_SCOPE Tcl_Obj *	TclpTempFileName(void);
MODULE_SCOPE Tcl_Obj *	TclpTempFileNameForLibrary(Tcl_Interp *interp,
			    Tcl_Obj* pathPtr);
MODULE_SCOPE int	TclNewArithSeriesObj(Tcl_Interp *interp,
			    Tcl_Obj **arithSeriesPtr,
			    int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj,
			    Tcl_Obj *stepObj, Tcl_Obj *lenObj);
MODULE_SCOPE Tcl_Obj *	TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep,
			    Tcl_Size len);
MODULE_SCOPE void	TclpAlertNotifier(void *clientData);
MODULE_SCOPE void *	TclpNotifierData(void);
MODULE_SCOPE void	TclpServiceModeHook(int mode);







|
<







3448
3449
3450
3451
3452
3453
3454
3455

3456
3457
3458
3459
3460
3461
3462
MODULE_SCOPE int	TclProcessReturn(Tcl_Interp *interp,
			    int code, int level, Tcl_Obj *returnOpts);
MODULE_SCOPE void	TclUndoRefCount(Tcl_Obj *objPtr);
MODULE_SCOPE int	TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
MODULE_SCOPE Tcl_Obj *	TclpTempFileName(void);
MODULE_SCOPE Tcl_Obj *	TclpTempFileNameForLibrary(Tcl_Interp *interp,
			    Tcl_Obj* pathPtr);
MODULE_SCOPE Tcl_Obj *	TclNewArithSeriesObj(Tcl_Interp *interp,

			    int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj,
			    Tcl_Obj *stepObj, Tcl_Obj *lenObj);
MODULE_SCOPE Tcl_Obj *	TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep,
			    Tcl_Size len);
MODULE_SCOPE void	TclpAlertNotifier(void *clientData);
MODULE_SCOPE void *	TclpNotifierData(void);
MODULE_SCOPE void	TclpServiceModeHook(int mode);

Changes to generic/tclInterp.c.

1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
    }
    case OPT_TRANSFER:
    case OPT_SHARE: {
	Tcl_Interp *parentInterp;	/* The parent of the child. */
	Tcl_Channel chan;

	if (objc != 5) {
	    Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");
	    return TCL_ERROR;
	}
	parentInterp = GetInterp(interp, objv[2]);
	if (parentInterp == NULL) {
	    return TCL_ERROR;
	}
	chan = Tcl_GetChannel(parentInterp, TclGetString(objv[3]), NULL);







|







1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
    }
    case OPT_TRANSFER:
    case OPT_SHARE: {
	Tcl_Interp *parentInterp;	/* The parent of the child. */
	Tcl_Channel chan;

	if (objc != 5) {
	    Tcl_WrongNumArgs(interp, 2, objv, "srcPath channel destPath");
	    return TCL_ERROR;
	}
	parentInterp = GetInterp(interp, objv[2]);
	if (parentInterp == NULL) {
	    return TCL_ERROR;
	}
	chan = Tcl_GetChannel(parentInterp, TclGetString(objv[3]), NULL);

Changes to generic/tclListObj.c.

494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
 *------------------------------------------------------------------------
 */
static int
ListLimitExceededError(
    Tcl_Interp *interp)
{
    if (interp != NULL) {
	Tcl_SetObjResult(
	    interp,
	    Tcl_NewStringObj("max length of a Tcl list exceeded", -1));
	Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
    }
    return TCL_ERROR;
}

/*
 *------------------------------------------------------------------------







|
<
|







494
495
496
497
498
499
500
501

502
503
504
505
506
507
508
509
 *------------------------------------------------------------------------
 */
static int
ListLimitExceededError(
    Tcl_Interp *interp)
{
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(

		"max length of a Tcl list exceeded", -1));
	Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
    }
    return TCL_ERROR;
}

/*
 *------------------------------------------------------------------------

Changes to generic/tclScan.c.

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
	 * Parse any width specifier.
	 */

	if ((ch < 0x80) && isdigit(UCHAR(ch))) {	/* INTL: "C" locale. */
	    /* Note ull >= 0 because of isdigit check above */
	    unsigned long long ull;
	    ull = strtoull(
		format - 1, (char **)&format, 10); /* INTL: "C" locale. */
	    /* Note >=, not >, to leave room for a nul */
	    if (ull >= TCL_SIZE_MAX) {
		Tcl_SetObjResult(
		    interp,
		    Tcl_ObjPrintf("specified field width %" TCL_LL_MODIFIER
				  "u exceeds limit %" TCL_SIZE_MODIFIER "d.",
				  ull,
				  (Tcl_Size)TCL_SIZE_MAX-1));
		Tcl_SetErrorCode(
		    interp, "TCL", "FORMAT", "WIDTHLIMIT", (char *)NULL);
		goto error;
	    }
	    flags |= SCAN_WIDTH;
	    format += TclUtfToUniChar(format, &ch);
	}

	/*
	 * Handle any size specifier.
	 */

	switch (ch) {











	case 'l':
	    if (*format == 'l') {
		flags |= SCAN_BIG;
		format += 1;
		format += TclUtfToUniChar(format, &ch);
		break;
	    }
	    /* FALLTHRU */
	case 'L':

	    flags |= SCAN_LONGER;
	    /* FALLTHRU */
	case 'h':
	    format += TclUtfToUniChar(format, &ch);
	}

	if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) {







|


|
<
|
|
<
|

|











>
>
>
>
>
>
>
>
>
>
>








|
>







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
	 * Parse any width specifier.
	 */

	if ((ch < 0x80) && isdigit(UCHAR(ch))) {	/* INTL: "C" locale. */
	    /* Note ull >= 0 because of isdigit check above */
	    unsigned long long ull;
	    ull = strtoull(
		    format - 1, (char **)&format, 10);	/* INTL: "C" locale. */
	    /* Note >=, not >, to leave room for a nul */
	    if (ull >= TCL_SIZE_MAX) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(

			"specified field width %" TCL_LL_MODIFIER
			"u exceeds limit %" TCL_SIZE_MODIFIER "d.",

			ull, (Tcl_Size)TCL_SIZE_MAX-1));
		Tcl_SetErrorCode(
			interp, "TCL", "FORMAT", "WIDTHLIMIT", (char *)NULL);
		goto error;
	    }
	    flags |= SCAN_WIDTH;
	    format += TclUtfToUniChar(format, &ch);
	}

	/*
	 * Handle any size specifier.
	 */

	switch (ch) {
	case 'z':
	case 't':
	    if (sizeof(void *) > sizeof(int)) {
		flags |= SCAN_LONGER;
	    }
	    format += TclUtfToUniChar(format, &ch);
	    break;
	case 'L':
	    flags |= SCAN_BIG;
	    format += TclUtfToUniChar(format, &ch);
	    break;
	case 'l':
	    if (*format == 'l') {
		flags |= SCAN_BIG;
		format += 1;
		format += TclUtfToUniChar(format, &ch);
		break;
	    }
	    /* FALLTHRU */
	case 'j':
	case 'q':
	    flags |= SCAN_LONGER;
	    /* FALLTHRU */
	case 'h':
	    format += TclUtfToUniChar(format, &ch);
	}

	if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) {
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Size objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *format;
    int numVars, nconversions, totalVars = -1;
    int objIndex, offset, i, result, code;
    long value;
    const char *string, *end, *baseString;
    char op = 0;
    int underflow = 0;
    Tcl_Size width;
    Tcl_WideInt wideValue;
    Tcl_UniChar ch = 0, sch = 0;
    Tcl_Obj **objs = NULL, *objPtr = NULL;







|







600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Size objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *format;
    int numVars, nconversions, totalVars = -1;
    int objIndex, offset, i, result, code;
    int value;
    const char *string, *end, *baseString;
    char op = 0;
    int underflow = 0;
    Tcl_Size width;
    Tcl_WideInt wideValue;
    Tcl_UniChar ch = 0, sch = 0;
    Tcl_Obj **objs = NULL, *objPtr = NULL;
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
				"unsigned bignum scans are invalid", -1));
			Tcl_SetErrorCode(interp, "TCL", "FORMAT",
				"BADUNSIGNED", (char *)NULL);
			return TCL_ERROR;
		    }
		}
	    } else {
		if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
		    if (TclGetString(objPtr)[0] == '-') {
			value = LONG_MIN;
		    } else {
			value = LONG_MAX;
		    }
		}
		if ((flags & SCAN_UNSIGNED) && (value < 0)) {
#ifdef TCL_WIDE_INT_IS_LONG
		    mp_int big;
		    if (mp_init_u64(&big, (unsigned long)value) != MP_OKAY) {
			Tcl_SetObjResult(interp, Tcl_NewStringObj(







|

|

|







993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
				"unsigned bignum scans are invalid", -1));
			Tcl_SetErrorCode(interp, "TCL", "FORMAT",
				"BADUNSIGNED", (char *)NULL);
			return TCL_ERROR;
		    }
		}
	    } else {
		if (TclGetIntFromObj(NULL, objPtr, &value) != TCL_OK) {
		    if (TclGetString(objPtr)[0] == '-') {
			value = INT_MIN;
		    } else {
			value = INT_MAX;
		    }
		}
		if ((flags & SCAN_UNSIGNED) && (value < 0)) {
#ifdef TCL_WIDE_INT_IS_LONG
		    mp_int big;
		    if (mp_init_u64(&big, (unsigned long)value) != MP_OKAY) {
			Tcl_SetObjResult(interp, Tcl_NewStringObj(
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
	}
    } else {
	/*
	 * Here no vars were specified, we want a list returned (inline scan)
	 * We create an empty Tcl_Obj to fill missing values rather than
	 * allocating a new Tcl_Obj every time. See test scan-bigdata-XX.
	 */
	Tcl_Obj *emptyObj;
	TclNewObj(emptyObj);
	Tcl_IncrRefCount(emptyObj);
	TclNewObj(objPtr);
	for (i = 0; code == TCL_OK && i < totalVars; i++) {
	    if (objs[i] != NULL) {
		code = Tcl_ListObjAppendElement(interp, objPtr, objs[i]);
		Tcl_DecrRefCount(objs[i]);
	    } else {
		/*
		 * More %-specifiers than matching chars, so we just spit out
		 * empty strings for these.
		 */



		code = Tcl_ListObjAppendElement(interp, objPtr, emptyObj);
	    }
	}
	Tcl_DecrRefCount(emptyObj);
	if (code != TCL_OK) {
	    /* If error'ed out, free up remaining. i contains last index freed */
	    while (++i < totalVars) {
		if (objs[i] != NULL) {
		    Tcl_DecrRefCount(objs[i]);
		}
	    }







|
<
<










>
>
|



<







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
	}
    } else {
	/*
	 * Here no vars were specified, we want a list returned (inline scan)
	 * We create an empty Tcl_Obj to fill missing values rather than
	 * allocating a new Tcl_Obj every time. See test scan-bigdata-XX.
	 */
	Tcl_Obj *emptyObj = NULL;


	TclNewObj(objPtr);
	for (i = 0; code == TCL_OK && i < totalVars; i++) {
	    if (objs[i] != NULL) {
		code = Tcl_ListObjAppendElement(interp, objPtr, objs[i]);
		Tcl_DecrRefCount(objs[i]);
	    } else {
		/*
		 * More %-specifiers than matching chars, so we just spit out
		 * empty strings for these.
		 */
		if (!emptyObj) {
		    TclNewObj(emptyObj);
		}
		code = Tcl_ListObjAppendElement(interp, objPtr, emptyObj);
	    }
	}

	if (code != TCL_OK) {
	    /* If error'ed out, free up remaining. i contains last index freed */
	    while (++i < totalVars) {
		if (objs[i] != NULL) {
		    Tcl_DecrRefCount(objs[i]);
		}
	    }

Changes to generic/tclStringObj.c.

1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
     */

    while (*format != '\0') {
	char *end;
	int gotMinus = 0, gotHash = 0, gotZero = 0, gotSpace = 0, gotPlus = 0;
	int gotPrecision, sawFlag, useShort = 0, useBig = 0;
	Tcl_WideInt width, precision;
#ifndef TCL_WIDE_INT_IS_LONG
	int useWide = 0;
#endif
	int newXpg, allocSegment = 0;
	Tcl_Size numChars, segmentLimit, segmentNumBytes;
	Tcl_Obj *segment;
	int step = TclUtfToUniChar(format, &ch);

	format += step;
	if (ch != '%') {







<

<







1871
1872
1873
1874
1875
1876
1877

1878

1879
1880
1881
1882
1883
1884
1885
     */

    while (*format != '\0') {
	char *end;
	int gotMinus = 0, gotHash = 0, gotZero = 0, gotSpace = 0, gotPlus = 0;
	int gotPrecision, sawFlag, useShort = 0, useBig = 0;
	Tcl_WideInt width, precision;

	int useWide = 0;

	int newXpg, allocSegment = 0;
	Tcl_Size numChars, segmentLimit, segmentNumBytes;
	Tcl_Obj *segment;
	int step = TclUtfToUniChar(format, &ch);

	format += step;
	if (ch != '%') {
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
	} else if (ch == 'l') {
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	    if (ch == 'l') {
		useBig = 1;
		format += step;
		step = TclUtfToUniChar(format, &ch);
#ifndef TCL_WIDE_INT_IS_LONG
	    } else {
		useWide = 1;
#endif
	    }
	} else if (ch == 'I') {
	    if ((format[1] == '6') && (format[2] == '4')) {
		format += (step + 2);
		step = TclUtfToUniChar(format, &ch);
#ifndef TCL_WIDE_INT_IS_LONG
		useWide = 1;
#endif
	    } else if ((format[1] == '3') && (format[2] == '2')) {
		format += (step + 2);
		step = TclUtfToUniChar(format, &ch);
	    } else {
		format += step;
		step = TclUtfToUniChar(format, &ch);
	    }
	} else if ((ch == 'q') || (ch == 'j')) {
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
#ifndef TCL_WIDE_INT_IS_LONG
	    useWide = 1;
#endif
	} else if ((ch == 't') || (ch == 'z')) {
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
#ifndef TCL_WIDE_INT_IS_LONG
	    if (sizeof(void *) > sizeof(int)) {
		useWide = 1;
	    }
#endif
	} else if (ch == 'L') {
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	    useBig = 1;
	}

	format += step;







<


<





<

<










<

<



<



<







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
	} else if (ch == 'l') {
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	    if (ch == 'l') {
		useBig = 1;
		format += step;
		step = TclUtfToUniChar(format, &ch);

	    } else {
		useWide = 1;

	    }
	} else if (ch == 'I') {
	    if ((format[1] == '6') && (format[2] == '4')) {
		format += (step + 2);
		step = TclUtfToUniChar(format, &ch);

		useWide = 1;

	    } else if ((format[1] == '3') && (format[2] == '2')) {
		format += (step + 2);
		step = TclUtfToUniChar(format, &ch);
	    } else {
		format += step;
		step = TclUtfToUniChar(format, &ch);
	    }
	} else if ((ch == 'q') || (ch == 'j')) {
	    format += step;
	    step = TclUtfToUniChar(format, &ch);

	    useWide = 1;

	} else if ((ch == 't') || (ch == 'z')) {
	    format += step;
	    step = TclUtfToUniChar(format, &ch);

	    if (sizeof(void *) > sizeof(int)) {
		useWide = 1;
	    }

	} else if (ch == 'L') {
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	    useBig = 1;
	}

	format += step;
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
	case 'o':
	case 'p':
	case 'x':
	case 'X':
	case 'b': {
	    short s = 0;	/* Silence compiler warning; only defined and
				 * used when useShort is true. */
	    long l;
	    Tcl_WideInt w;
	    mp_int big;
	    int isNegative = 0;
	    Tcl_Size toAppend;

#ifndef TCL_WIDE_INT_IS_LONG
	    if ((ch == 'p') && (sizeof(void *) > sizeof(int))) {
		useWide = 1;
	    }
#endif
	    if (useBig) {
		int cmpResult;
		if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) {
		    goto error;
		}
		cmpResult = mp_cmp_d(&big, 0);
		isNegative = (cmpResult == MP_LT);
		if (cmpResult == MP_EQ) {
		    gotHash = 0;
		}
		if (ch == 'u') {
		    if (isNegative) {
			mp_clear(&big);
			msg = "unsigned bignum format is invalid";
			errCode = "BADUNSIGNED";
			goto errorMsg;
		    } else {
			ch = 'd';
		    }
		}
#ifndef TCL_WIDE_INT_IS_LONG
	    } else if (useWide) {
		if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
		    goto error;
		}
		isNegative = (w < (Tcl_WideInt) 0);
		if (w == (Tcl_WideInt) 0) {
		    gotHash = 0;
		}
#endif
	    } else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) {
		if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
		    goto error;
		} else {
		    l = (long) w;
		}
		if (useShort) {
		    s = (short) l;
		    isNegative = (s < (short) 0);
		    if (s == (short) 0) {
			gotHash = 0;
		    }
		} else {
		    isNegative = (l < (long) 0);
		    if (l == (long) 0) {
			gotHash = 0;
		    }
		}
	    } else if (useShort) {
		s = (short) l;
		isNegative = (s < (short) 0);
		if (s == (short) 0) {
		    gotHash = 0;
		}
	    } else {
		isNegative = (l < (long) 0);
		if (l == (long) 0) {
		    gotHash = 0;
		}
	    }

	    TclNewObj(segment);
	    allocSegment = 1;
	    segmentLimit = TCL_SIZE_MAX;







|





<



<




















<








<
|



|








|
|










|
|







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
	case 'o':
	case 'p':
	case 'x':
	case 'X':
	case 'b': {
	    short s = 0;	/* Silence compiler warning; only defined and
				 * used when useShort is true. */
	    int l;
	    Tcl_WideInt w;
	    mp_int big;
	    int isNegative = 0;
	    Tcl_Size toAppend;


	    if ((ch == 'p') && (sizeof(void *) > sizeof(int))) {
		useWide = 1;
	    }

	    if (useBig) {
		int cmpResult;
		if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) {
		    goto error;
		}
		cmpResult = mp_cmp_d(&big, 0);
		isNegative = (cmpResult == MP_LT);
		if (cmpResult == MP_EQ) {
		    gotHash = 0;
		}
		if (ch == 'u') {
		    if (isNegative) {
			mp_clear(&big);
			msg = "unsigned bignum format is invalid";
			errCode = "BADUNSIGNED";
			goto errorMsg;
		    } else {
			ch = 'd';
		    }
		}

	    } else if (useWide) {
		if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
		    goto error;
		}
		isNegative = (w < (Tcl_WideInt) 0);
		if (w == (Tcl_WideInt) 0) {
		    gotHash = 0;
		}

	    } else if (TclGetIntFromObj(NULL, segment, &l) != TCL_OK) {
		if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
		    goto error;
		} else {
		    l = (int) w;
		}
		if (useShort) {
		    s = (short) l;
		    isNegative = (s < (short) 0);
		    if (s == (short) 0) {
			gotHash = 0;
		    }
		} else {
		    isNegative = (l < (int) 0);
		    if (l == (int) 0) {
			gotHash = 0;
		    }
		}
	    } else if (useShort) {
		s = (short) l;
		isNegative = (s < (short) 0);
		if (s == (short) 0) {
		    gotHash = 0;
		}
	    } else {
		isNegative = (l < (int) 0);
		if (l == (int) 0) {
		    gotHash = 0;
		}
	    }

	    TclNewObj(segment);
	    allocSegment = 1;
	    segmentLimit = TCL_SIZE_MAX;
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
	    case 'd': {
		Tcl_Size length;
		Tcl_Obj *pure;
		const char *bytes;

		if (useShort) {
		    TclNewIntObj(pure, s);
#ifndef TCL_WIDE_INT_IS_LONG
		} else if (useWide) {
		    TclNewIntObj(pure, w);
#endif
		} else if (useBig) {
		    pure = Tcl_NewBignumObj(&big);
		} else {
		    TclNewIntObj(pure, l);
		}
		Tcl_IncrRefCount(pure);
		bytes = TclGetStringFromObj(pure, &length);







<


<







2276
2277
2278
2279
2280
2281
2282

2283
2284

2285
2286
2287
2288
2289
2290
2291
	    case 'd': {
		Tcl_Size length;
		Tcl_Obj *pure;
		const char *bytes;

		if (useShort) {
		    TclNewIntObj(pure, s);

		} else if (useWide) {
		    TclNewIntObj(pure, w);

		} else if (useBig) {
		    pure = Tcl_NewBignumObj(&big);
		} else {
		    TclNewIntObj(pure, l);
		}
		Tcl_IncrRefCount(pure);
		bytes = TclGetStringFromObj(pure, &length);
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
		    unsigned short us = (unsigned short) s;

		    bits = (Tcl_WideUInt) us;
		    while (us) {
			numDigits++;
			us /= base;
		    }
#ifndef TCL_WIDE_INT_IS_LONG
		} else if (useWide) {
		    Tcl_WideUInt uw = (Tcl_WideUInt) w;

		    bits = uw;
		    while (uw) {
			numDigits++;
			uw /= base;
		    }
#endif
		} else if (useBig && !mp_iszero(&big)) {
		    int leftover = (big.used * MP_DIGIT_BIT) % numBits;
		    mp_digit mask = (~(mp_digit)0) << (MP_DIGIT_BIT-leftover);

		    numDigits = 1 +
			    (((Tcl_WideInt) big.used * MP_DIGIT_BIT) / numBits);
		    while ((mask & big.dp[big.used-1]) == 0) {
			numDigits--;
			mask >>= numBits;
		    }
		    if (numDigits > INT_MAX) {
			msg = overflow;
			errCode = "OVERFLOW";
			goto errorMsg;
		    }
		} else if (!useBig) {
		    unsigned long ul = (unsigned long) l;

		    bits = (Tcl_WideUInt) ul;
		    while (ul) {
			numDigits++;
			ul /= base;
		    }
		}







<








<
















|







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
		    unsigned short us = (unsigned short) s;

		    bits = (Tcl_WideUInt) us;
		    while (us) {
			numDigits++;
			us /= base;
		    }

		} else if (useWide) {
		    Tcl_WideUInt uw = (Tcl_WideUInt) w;

		    bits = uw;
		    while (uw) {
			numDigits++;
			uw /= base;
		    }

		} else if (useBig && !mp_iszero(&big)) {
		    int leftover = (big.used * MP_DIGIT_BIT) % numBits;
		    mp_digit mask = (~(mp_digit)0) << (MP_DIGIT_BIT-leftover);

		    numDigits = 1 +
			    (((Tcl_WideInt) big.used * MP_DIGIT_BIT) / numBits);
		    while ((mask & big.dp[big.used-1]) == 0) {
			numDigits--;
			mask >>= numBits;
		    }
		    if (numDigits > INT_MAX) {
			msg = overflow;
			errCode = "OVERFLOW";
			goto errorMsg;
		    }
		} else if (!useBig) {
		    unsigned ul = (unsigned) l;

		    bits = (Tcl_WideUInt) ul;
		    while (ul) {
			numDigits++;
			ul /= base;
		    }
		}

Changes to generic/tclTest.c.

6392
6393
6394
6395
6396
6397
6398
6399
6400
6401
6402
6403
6404
6405
6406
    if ((cmdName[0] == 't') && (strncmp(cmdName, "transform", len) == 0)) {
	/*
	 * Syntax: transform channel -command command
	 */

	if (argc != 5) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " transform channelId -command cmd\"", (char *)NULL);
	    return TCL_ERROR;
	}
	if (strcmp(argv[3], "-command") != 0) {
	    Tcl_AppendResult(interp, "bad argument \"", argv[3],
		    "\": should be \"-command\"", (char *)NULL);
	    return TCL_ERROR;
	}







|







6392
6393
6394
6395
6396
6397
6398
6399
6400
6401
6402
6403
6404
6405
6406
    if ((cmdName[0] == 't') && (strncmp(cmdName, "transform", len) == 0)) {
	/*
	 * Syntax: transform channel -command command
	 */

	if (argc != 5) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " transform channel -command cmd\"", (char *)NULL);
	    return TCL_ERROR;
	}
	if (strcmp(argv[3], "-command") != 0) {
	    Tcl_AppendResult(interp, "bad argument \"", argv[3],
		    "\": should be \"-command\"", (char *)NULL);
	    return TCL_ERROR;
	}

Changes to library/history.tcl.

193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
    set result {}
    set newline ""
    for {set i [expr {$history(nextid) - $count + 1}]} \
	    {$i <= $history(nextid)} {incr i} {
	if {![info exists history($i)]} {
	    continue
	}
        set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]]
	append result $newline[format "%6d  %s" $i $cmd]
	set newline \n
    }
    return $result
}

# tcl::HistRedo --







|







193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
    set result {}
    set newline ""
    for {set i [expr {$history(nextid) - $count + 1}]} \
	    {$i <= $history(nextid)} {incr i} {
	if {![info exists history($i)]} {
	    continue
	}
	set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]]
	append result $newline[format "%6d  %s" $i $cmd]
	set newline \n
    }
    return $result
}

# tcl::HistRedo --

Changes to library/http/http.tcl.

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
	)?
    }

    variable TmpSockCounter 0
    variable ThreadCounter  0

    variable reasonDict [dict create {*}{
        100 Continue
        101 {Switching Protocols}
        102 Processing
        103 {Early Hints}
        200 OK
        201 Created
        202 Accepted
        203 {Non-Authoritative Information}
        204 {No Content}
        205 {Reset Content}
        206 {Partial Content}
        207 Multi-Status
        208 {Already Reported}
        226 {IM Used}
        300 {Multiple Choices}
        301 {Moved Permanently}
        302 Found
        303 {See Other}
        304 {Not Modified}
        305 {Use Proxy}
        306 (Unused)
        307 {Temporary Redirect}
        308 {Permanent Redirect}
        400 {Bad Request}
        401 Unauthorized
        402 {Payment Required}
        403 Forbidden
        404 {Not Found}
        405 {Method Not Allowed}
        406 {Not Acceptable}
        407 {Proxy Authentication Required}
        408 {Request Timeout}
        409 Conflict
        410 Gone
        411 {Length Required}
        412 {Precondition Failed}
        413 {Content Too Large}
        414 {URI Too Long}
        415 {Unsupported Media Type}
        416 {Range Not Satisfiable}
        417 {Expectation Failed}
        418 (Unused)
        421 {Misdirected Request}
        422 {Unprocessable Content}
        423 Locked
        424 {Failed Dependency}
        425 {Too Early}
        426 {Upgrade Required}
        428 {Precondition Required}
        429 {Too Many Requests}
        431 {Request Header Fields Too Large}
        451 {Unavailable For Legal Reasons}
        500 {Internal Server Error}
        501 {Not Implemented}
        502 {Bad Gateway}
        503 {Service Unavailable}
        504 {Gateway Timeout}
        505 {HTTP Version Not Supported}
        506 {Variant Also Negotiates}
        507 {Insufficient Storage}
        508 {Loop Detected}
        510 {Not Extended (OBSOLETED)}
        511 {Network Authentication Required}
    }]

    variable failedProxyValues {
	binary
	body
	charset
	coding







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







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
	)?
    }

    variable TmpSockCounter 0
    variable ThreadCounter  0

    variable reasonDict [dict create {*}{
	100 Continue
	101 {Switching Protocols}
	102 Processing
	103 {Early Hints}
	200 OK
	201 Created
	202 Accepted
	203 {Non-Authoritative Information}
	204 {No Content}
	205 {Reset Content}
	206 {Partial Content}
	207 Multi-Status
	208 {Already Reported}
	226 {IM Used}
	300 {Multiple Choices}
	301 {Moved Permanently}
	302 Found
	303 {See Other}
	304 {Not Modified}
	305 {Use Proxy}
	306 (Unused)
	307 {Temporary Redirect}
	308 {Permanent Redirect}
	400 {Bad Request}
	401 Unauthorized
	402 {Payment Required}
	403 Forbidden
	404 {Not Found}
	405 {Method Not Allowed}
	406 {Not Acceptable}
	407 {Proxy Authentication Required}
	408 {Request Timeout}
	409 Conflict
	410 Gone
	411 {Length Required}
	412 {Precondition Failed}
	413 {Content Too Large}
	414 {URI Too Long}
	415 {Unsupported Media Type}
	416 {Range Not Satisfiable}
	417 {Expectation Failed}
	418 (Unused)
	421 {Misdirected Request}
	422 {Unprocessable Content}
	423 Locked
	424 {Failed Dependency}
	425 {Too Early}
	426 {Upgrade Required}
	428 {Precondition Required}
	429 {Too Many Requests}
	431 {Request Header Fields Too Large}
	451 {Unavailable For Legal Reasons}
	500 {Internal Server Error}
	501 {Not Implemented}
	502 {Bad Gateway}
	503 {Service Unavailable}
	504 {Gateway Timeout}
	505 {HTTP Version Not Supported}
	506 {Variant Also Negotiates}
	507 {Insufficient Storage}
	508 {Loop Detected}
	510 {Not Extended (OBSOLETED)}
	511 {Network Authentication Required}
    }]

    variable failedProxyValues {
	binary
	body
	charset
	coding
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
#     list of port, command, variable name, (boolean) threadability,
#     and (boolean) endToEndProxy that was registered.

proc http::register {proto port command {socketCmdVarName {}} {useSockThread 0} {endToEndProxy 0}} {
    variable urlTypes
    set lower [string tolower $proto]
    if {[info exists urlTypes($lower)]} {
        unregister $lower
    }
    set urlTypes($lower) [list $port $command $socketCmdVarName $useSockThread $endToEndProxy]

    # If the external handler for protocol $proto has given $socketCmdVarName the expected
    # value "::socket", overwrite it with the new value.
    if {($socketCmdVarName ne {}) && ([set $socketCmdVarName] eq {::socket})} {
	set $socketCmdVarName ::http::socketAsCallback







|







295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
#     list of port, command, variable name, (boolean) threadability,
#     and (boolean) endToEndProxy that was registered.

proc http::register {proto port command {socketCmdVarName {}} {useSockThread 0} {endToEndProxy 0}} {
    variable urlTypes
    set lower [string tolower $proto]
    if {[info exists urlTypes($lower)]} {
	unregister $lower
    }
    set urlTypes($lower) [list $port $command $socketCmdVarName $useSockThread $endToEndProxy]

    # If the external handler for protocol $proto has given $socketCmdVarName the expected
    # value "::socket", overwrite it with the new value.
    if {($socketCmdVarName ne {}) && ([set $socketCmdVarName] eq {::socket})} {
	set $socketCmdVarName ::http::socketAsCallback
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
# http::config --
#
#	See documentation for details.
#
# Arguments:
#	args		Options parsed by the procedure.
# Results:
#        TODO

proc http::config {args} {
    variable http
    set options [lsort [array names http -*]]
    set usage [join $options ", "]
    if {[llength $args] == 0} {
	set result {}







|







343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
# http::config --
#
#	See documentation for details.
#
# Arguments:
#	args		Options parsed by the procedure.
# Results:
#	TODO

proc http::config {args} {
    variable http
    set options [lsort [array names http -*]]
    set usage [join $options ", "]
    if {[llength $args] == 0} {
	set result {}
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
#
# Return Value: the reason phrase
# ------------------------------------------------------------------------------

proc http::reasonPhrase {code} {
    variable reasonDict
    if {![regexp -- {^[1-5][0-9][0-9]$} $code]} {
        set msg {argument must be a three-digit integer from 100 to 599}
        return -code error $msg
    }
    if {[dict exists $reasonDict $code]} {
        set reason [dict get $reasonDict $code]
    } else {
        set reason Unassigned
    }
    return $reason
}

# http::Finish --
#
#	Clean up the socket and eval close time callbacks
#
# Arguments:
#	token	    Connection token.
#	errormsg    (optional) If set, forces status to error.
#	skipCB      (optional) If set, don't call the -command callback. This
#		    is useful when geturl wants to throw an exception instead
#		    of calling the callback. That way, the same error isn't
#		    reported to two places.
#
# Side Effects:
#        May close the socket.

proc http::Finish {token {errormsg ""} {skipCB 0}} {
    variable socketMapping
    variable socketRdState
    variable socketWrState
    variable socketRdQueue
    variable socketWrQueue







|
|


|

|

















|







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
#
# Return Value: the reason phrase
# ------------------------------------------------------------------------------

proc http::reasonPhrase {code} {
    variable reasonDict
    if {![regexp -- {^[1-5][0-9][0-9]$} $code]} {
	set msg {argument must be a three-digit integer from 100 to 599}
	return -code error $msg
    }
    if {[dict exists $reasonDict $code]} {
	set reason [dict get $reasonDict $code]
    } else {
	set reason Unassigned
    }
    return $reason
}

# http::Finish --
#
#	Clean up the socket and eval close time callbacks
#
# Arguments:
#	token	    Connection token.
#	errormsg    (optional) If set, forces status to error.
#	skipCB      (optional) If set, don't call the -command callback. This
#		    is useful when geturl wants to throw an exception instead
#		    of calling the callback. That way, the same error isn't
#		    reported to two places.
#
# Side Effects:
#	May close the socket.

proc http::Finish {token {errormsg ""} {skipCB 0}} {
    variable socketMapping
    variable socketRdState
    variable socketWrState
    variable socketRdQueue
    variable socketWrQueue
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
    if {[info commands ${token}--EventCoroutine] ne {}} {
	rename ${token}--EventCoroutine {}
    }
    if {[info commands ${token}--SocketCoroutine] ne {}} {
	rename ${token}--SocketCoroutine {}
    }
    if {[info exists state(socketcoro)]} {
        Log $token Cancel socket after-idle event (Finish)
        after cancel $state(socketcoro)
        unset state(socketcoro)
    }

    # Is this an upgrade request/response?
    set upgradeResponse \
	[expr {    [info exists state(upgradeRequest)]
		&& $state(upgradeRequest)
		&& [info exists state(http)]







|
|
|







450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
    if {[info commands ${token}--EventCoroutine] ne {}} {
	rename ${token}--EventCoroutine {}
    }
    if {[info commands ${token}--SocketCoroutine] ne {}} {
	rename ${token}--SocketCoroutine {}
    }
    if {[info exists state(socketcoro)]} {
	Log $token Cancel socket after-idle event (Finish)
	after cancel $state(socketcoro)
	unset state(socketcoro)
    }

    # Is this an upgrade request/response?
    set upgradeResponse \
	[expr {    [info exists state(upgradeRequest)]
		&& $state(upgradeRequest)
		&& [info exists state(http)]
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
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
    } {
	set closeQueue 1
	set connId $state(socketinfo)
	if {[info exists state(sock)]} {
	    set sock $state(sock)
	    CloseSocket $state(sock) $token
	} else {
            # When opening the socket and calling http::reset
            # immediately, the socket may not yet exist.
            # Test http-4.11 may come here.
	}
	if {$state(tid) ne {}} {
            # When opening the socket in a thread, and calling http::reset
            # immediately, the thread may still exist.
            # Test http-4.11 may come here.
	    thread::release $state(tid)
	    set state(tid) {}
	} else {
	}
    } elseif {$upgradeResponse} {
	# Special handling for an upgrade request/response.
	# - geturl ensures that this is not a "persistent" socket used for
	#   multiple HTTP requests, so a call to KeepSocket is not needed.
	# - Leave socket open, so a call to CloseSocket is not needed either.
	# - Remove fileevent bindings.  The caller will set its own bindings.
	# - THE CALLER MUST PROCESS THE UPGRADED SOCKET IN THE CALLBACK COMMAND
	#   PASSED TO http::geturl AS -command callback.
	catch {fileevent $state(sock) readable {}}
	catch {fileevent $state(sock) writable {}}
    } elseif {
          ([info exists state(-keepalive)] && !$state(-keepalive))
       || ([info exists state(connection)] && ("close" in $state(connection)))
    } {
	set closeQueue 1
	set connId $state(socketinfo)
	if {[info exists state(sock)]} {
	    set sock $state(sock)
	    CloseSocket $state(sock) $token
	} else {
            # When opening the socket and calling http::reset
            # immediately, the socket may not yet exist.
            # Test http-4.11 may come here.
	}
    } elseif {
	  ([info exists state(-keepalive)] && $state(-keepalive))
       && ([info exists state(connection)] && ("close" ni $state(connection)))
    } {
	KeepSocket $token
    }







|
|
|


|
|
|














<
|
|







|
|
|







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
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
    } {
	set closeQueue 1
	set connId $state(socketinfo)
	if {[info exists state(sock)]} {
	    set sock $state(sock)
	    CloseSocket $state(sock) $token
	} else {
	    # When opening the socket and calling http::reset
	    # immediately, the socket may not yet exist.
	    # Test http-4.11 may come here.
	}
	if {$state(tid) ne {}} {
	    # When opening the socket in a thread, and calling http::reset
	    # immediately, the thread may still exist.
	    # Test http-4.11 may come here.
	    thread::release $state(tid)
	    set state(tid) {}
	} else {
	}
    } elseif {$upgradeResponse} {
	# Special handling for an upgrade request/response.
	# - geturl ensures that this is not a "persistent" socket used for
	#   multiple HTTP requests, so a call to KeepSocket is not needed.
	# - Leave socket open, so a call to CloseSocket is not needed either.
	# - Remove fileevent bindings.  The caller will set its own bindings.
	# - THE CALLER MUST PROCESS THE UPGRADED SOCKET IN THE CALLBACK COMMAND
	#   PASSED TO http::geturl AS -command callback.
	catch {fileevent $state(sock) readable {}}
	catch {fileevent $state(sock) writable {}}

    } elseif {([info exists state(-keepalive)] && !$state(-keepalive))
	    || ([info exists state(connection)] && ("close" in $state(connection)))
    } {
	set closeQueue 1
	set connId $state(socketinfo)
	if {[info exists state(sock)]} {
	    set sock $state(sock)
	    CloseSocket $state(sock) $token
	} else {
	    # When opening the socket and calling http::reset
	    # immediately, the socket may not yet exist.
	    # Test http-4.11 may come here.
	}
    } elseif {
	  ([info exists state(-keepalive)] && $state(-keepalive))
       && ([info exists state(connection)] && ("close" ni $state(connection)))
    } {
	KeepSocket $token
    }
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
#	See documentation for details.
#
# Arguments:
#	token	Connection token.
#	why	Status info.
#
# Side Effects:
#        See Finish

proc http::reset {token {why reset}} {
    variable $token
    upvar 0 $token state
    set state(status) $why
    catch {fileevent $state(sock) readable {}}
    catch {fileevent $state(sock) writable {}}







|







916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
#	See documentation for details.
#
# Arguments:
#	token	Connection token.
#	why	Status info.
#
# Side Effects:
#	See Finish

proc http::reset {token {why reset}} {
    variable $token
    upvar 0 $token state
    set state(status) $why
    catch {fileevent $state(sock) readable {}}
    catch {fileevent $state(sock) writable {}}
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
    set usage [join [lsort $options] ", "]
    set options [string map {- ""} $options]
    set pat ^-(?:[join $options |])$
    foreach {flag value} $args {
	if {[regexp -- $pat $flag]} {
	    # Validate numbers
	    if {    [info exists type($flag)]
	        && (![string is $type($flag) -strict $value])
	    } {
		unset $token
		return -code error \
		    "Bad value for $flag ($value), must be $type($flag)"
	    }
	    if {($flag eq "-headers") && ([llength $value] % 2 != 0)} {
		unset $token







|







1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
    set usage [join [lsort $options] ", "]
    set options [string map {- ""} $options]
    set pat ^-(?:[join $options |])$
    foreach {flag value} $args {
	if {[regexp -- $pat $flag]} {
	    # Validate numbers
	    if {    [info exists type($flag)]
		    && (![string is $type($flag) -strict $value])
	    } {
		unset $token
		return -code error \
		    "Bad value for $flag ($value), must be $type($flag)"
	    }
	    if {($flag eq "-headers") && ([llength $value] % 2 != 0)} {
		unset $token
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416

    # Pass -myaddr directly to the socket command
    if {[info exists state(-myaddr)]} {
	lappend sockopts -myaddr $state(-myaddr)
    }

    if {$useSockThread} {
        set targs [list -type $token]
    } else {
        set targs {}
    }
    set state(connArgs) [list $proto $phost $srvurl]
    set state(openCmd) [list {*}$defcmd {*}$sockopts {*}$targs {*}$targetAddr]

    # See if we are supposed to use a previously opened channel.
    # - In principle, ANY call to http::geturl could use a previously opened
    #   channel if it is available - the "Connection: keep-alive" header is a







|

|







1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415

    # Pass -myaddr directly to the socket command
    if {[info exists state(-myaddr)]} {
	lappend sockopts -myaddr $state(-myaddr)
    }

    if {$useSockThread} {
	set targs [list -type $token]
    } else {
	set targs {}
    }
    set state(connArgs) [list $proto $phost $srvurl]
    set state(openCmd) [list {*}$defcmd {*}$sockopts {*}$targs {*}$targetAddr]

    # See if we are supposed to use a previously opened channel.
    # - In principle, ANY call to http::geturl could use a previously opened
    #   channel if it is available - the "Connection: keep-alive" header is a
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
	}
    }

    set state(reusing) $reusing
    unset reusing

    if {![info exists sock]} {
        # N.B. At this point ([info exists sock] == $state(reusing)).
        # This will no longer be true after we set a value of sock here.
	# Give the socket a placeholder name.
	set sock HTTP_PLACEHOLDER_[incr TmpSockCounter]
    }
    set state(sock) $sock

    if {$state(reusing)} {
	# Define these for use (only) by http::ReplayIfDead if the persistent







|
|







1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
	}
    }

    set state(reusing) $reusing
    unset reusing

    if {![info exists sock]} {
	# N.B. At this point ([info exists sock] == $state(reusing)).
	# This will no longer be true after we set a value of sock here.
	# Give the socket a placeholder name.
	set sock HTTP_PLACEHOLDER_[incr TmpSockCounter]
    }
    set state(sock) $sock

    if {$state(reusing)} {
	# Define these for use (only) by http::ReplayIfDead if the persistent
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

    if {    $state(-keepalive)
	 && (![info exists socketMapping($state(socketinfo))])
    } {
	# This code is executed only for the first -keepalive request on a
	# socket.  It makes the socket persistent.
	##Log "  PreparePersistentConnection" $token -- $sock -- DO
        set DoLater [PreparePersistentConnection $token]
    } else {
        ##Log "  PreparePersistentConnection" $token -- $sock -- SKIP
        set DoLater {-traceread 0 -tracewrite 0}
    }

    if {$state(ReusingPlaceholder)} {
        # - This request was added to the socketPhQueue of a persistent
        #   connection.
        # - But the connection has not yet been created and is a placeholder;
        # - And the placeholder was created by an earlier request.
        # - When that earlier request calls OpenSocket, its placeholder is
        #   replaced with a true socket, and it then executes the equivalent of
        #   OpenSocket for any subsequent requests that have
        #   $state(ReusingPlaceholder).
        Log >J$tk after idle coro NO - ReusingPlaceholder
    } elseif {$state(alreadyQueued)} {
        # - This request was added to the socketWrQueue and socketPlayCmd
        #   of a persistent connection that will close at the end of its current
        #   read operation.
        Log >J$tk after idle coro NO - alreadyQueued
    } else {
        Log >J$tk after idle coro YES
        set CoroName ${token}--SocketCoroutine
        set cancel [after idle [list coroutine $CoroName ::http::OpenSocket \
                $token $DoLater]]
        dict set socketCoEvent($state(socketinfo)) $token $cancel
        set state(socketcoro) $cancel
    }

    return
}


# ------------------------------------------------------------------------------







|

|
|



|
|
|
|
|
|
|
|
|

|
|
|
|

|
|
|
|
|
|







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

    if {    $state(-keepalive)
	 && (![info exists socketMapping($state(socketinfo))])
    } {
	# This code is executed only for the first -keepalive request on a
	# socket.  It makes the socket persistent.
	##Log "  PreparePersistentConnection" $token -- $sock -- DO
	set DoLater [PreparePersistentConnection $token]
    } else {
	##Log "  PreparePersistentConnection" $token -- $sock -- SKIP
	set DoLater {-traceread 0 -tracewrite 0}
    }

    if {$state(ReusingPlaceholder)} {
	# - This request was added to the socketPhQueue of a persistent
	#   connection.
	# - But the connection has not yet been created and is a placeholder;
	# - And the placeholder was created by an earlier request.
	# - When that earlier request calls OpenSocket, its placeholder is
	#   replaced with a true socket, and it then executes the equivalent of
	#   OpenSocket for any subsequent requests that have
	#   $state(ReusingPlaceholder).
	Log >J$tk after idle coro NO - ReusingPlaceholder
    } elseif {$state(alreadyQueued)} {
	# - This request was added to the socketWrQueue and socketPlayCmd
	#   of a persistent connection that will close at the end of its current
	#   read operation.
	Log >J$tk after idle coro NO - alreadyQueued
    } else {
	Log >J$tk after idle coro YES
	set CoroName ${token}--SocketCoroutine
	set cancel [after idle [list coroutine $CoroName ::http::OpenSocket \
		$token $DoLater]]
	dict set socketCoEvent($state(socketinfo)) $token $cancel
	set state(socketcoro) $cancel
    }

    return
}


# ------------------------------------------------------------------------------
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
    set socketProxyId($state(socketinfo)) $state(proxyUsed)
    # - The value of state(proxyUsed) was set in http::CreateToken to either
    #   "none" or "HttpProxy".
    # - $token is the first transaction to use this placeholder, so there are
    #   no other tokens whose (proxyUsed) must be modified.

    if {![info exists socketRdState($state(socketinfo))]} {
        set socketRdState($state(socketinfo)) {}
        # set varName ::http::socketRdState($state(socketinfo))
        # trace add variable $varName unset ::http::CancelReadPipeline
        dict set DoLater -traceread 1
    }
    if {![info exists socketWrState($state(socketinfo))]} {
        set socketWrState($state(socketinfo)) {}
        # set varName ::http::socketWrState($state(socketinfo))
        # trace add variable $varName unset ::http::CancelWritePipeline
        dict set DoLater -tracewrite 1
    }

    if {$state(-pipeline)} {
        #Log new, init for pipelined, GRANT write access to $token in geturl
        # Also grant premature read access to the socket. This is OK.
        set socketRdState($state(socketinfo)) $token
        set socketWrState($state(socketinfo)) $token
    } else {
        # socketWrState is not used by this non-pipelined transaction.
        # We cannot leave it as "Wready" because the next call to
        # http::geturl with a pipelined transaction would conclude that the
        # socket is available for writing.
        #Log new, init for nonpipeline, GRANT r/w access to $token in geturl
        set socketRdState($state(socketinfo)) $token
        set socketWrState($state(socketinfo)) $token
    }

    # Value of socketPhQueue() may have already been set by ReplayCore.
    if {![info exists socketPhQueue($state(sock))]} {
        set socketPhQueue($state(sock))   {}
    }
    set socketRdQueue($state(socketinfo)) {}
    set socketWrQueue($state(socketinfo)) {}
    set socketClosing($state(socketinfo)) 0
    set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}}
    set socketCoEvent($state(socketinfo)) {}
    set socketProxyId($state(socketinfo)) {}







|
|
|
|


|
|
|
|



|
|
|
|

|
|
|
|
|
|
|




|







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
    set socketProxyId($state(socketinfo)) $state(proxyUsed)
    # - The value of state(proxyUsed) was set in http::CreateToken to either
    #   "none" or "HttpProxy".
    # - $token is the first transaction to use this placeholder, so there are
    #   no other tokens whose (proxyUsed) must be modified.

    if {![info exists socketRdState($state(socketinfo))]} {
	set socketRdState($state(socketinfo)) {}
	# set varName ::http::socketRdState($state(socketinfo))
	# trace add variable $varName unset ::http::CancelReadPipeline
	dict set DoLater -traceread 1
    }
    if {![info exists socketWrState($state(socketinfo))]} {
	set socketWrState($state(socketinfo)) {}
	# set varName ::http::socketWrState($state(socketinfo))
	# trace add variable $varName unset ::http::CancelWritePipeline
	dict set DoLater -tracewrite 1
    }

    if {$state(-pipeline)} {
	#Log new, init for pipelined, GRANT write access to $token in geturl
	# Also grant premature read access to the socket. This is OK.
	set socketRdState($state(socketinfo)) $token
	set socketWrState($state(socketinfo)) $token
    } else {
	# socketWrState is not used by this non-pipelined transaction.
	# We cannot leave it as "Wready" because the next call to
	# http::geturl with a pipelined transaction would conclude that the
	# socket is available for writing.
	#Log new, init for nonpipeline, GRANT r/w access to $token in geturl
	set socketRdState($state(socketinfo)) $token
	set socketWrState($state(socketinfo)) $token
    }

    # Value of socketPhQueue() may have already been set by ReplayCore.
    if {![info exists socketPhQueue($state(sock))]} {
	set socketPhQueue($state(sock))   {}
    }
    set socketRdQueue($state(socketinfo)) {}
    set socketWrQueue($state(socketinfo)) {}
    set socketClosing($state(socketinfo)) 0
    set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}}
    set socketCoEvent($state(socketinfo)) {}
    set socketProxyId($state(socketinfo)) {}
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
    variable socketPlayCmd
    variable socketCoEvent
    variable socketProxyId

    Log >K$tk Start OpenSocket coroutine

    if {![info exists state(-keepalive)]} {
        # The request has already been cancelled by the calling script.
        return
    }

    set sockOld $state(sock)

    dict unset socketCoEvent($state(socketinfo)) $token
    unset -nocomplain state(socketcoro)

    if {[catch {
        if {$state(reusing)} {
	    # If ($state(reusing)) is true, then we do not need to create a new
	    # socket, even if $sockOld is only a placeholder for a socket.
            set sock $sockOld
        } else {
	    # set sock in the [catch] below.
	    set pre [clock milliseconds]
	    ##Log pre socket opened, - token $token
	    ##Log $state(openCmd) - token $token
	    set sock [namespace eval :: $state(openCmd)]
	    set state(sock) $sock
	    # Normal return from $state(openCmd) always returns a valid socket.







|
|








|


|
|







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
    variable socketPlayCmd
    variable socketCoEvent
    variable socketProxyId

    Log >K$tk Start OpenSocket coroutine

    if {![info exists state(-keepalive)]} {
	# The request has already been cancelled by the calling script.
	return
    }

    set sockOld $state(sock)

    dict unset socketCoEvent($state(socketinfo)) $token
    unset -nocomplain state(socketcoro)

    if {[catch {
	if {$state(reusing)} {
	    # If ($state(reusing)) is true, then we do not need to create a new
	    # socket, even if $sockOld is only a placeholder for a socket.
	    set sock $sockOld
	} else {
	    # set sock in the [catch] below.
	    set pre [clock milliseconds]
	    ##Log pre socket opened, - token $token
	    ##Log $state(openCmd) - token $token
	    set sock [namespace eval :: $state(openCmd)]
	    set state(sock) $sock
	    # Normal return from $state(openCmd) always returns a valid socket.
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
	    }
	    fconfigure $sock -translation {auto crlf} \
			     -buffersize $state(-blocksize)
	    if {[package vsatisfies [package provide Tcl] 9.0-]} {
		fconfigure $sock -profile replace
	    }
	    ##Log socket opened, DONE fconfigure - token $token
        }

        Log "Using $sock for $state(socketinfo) - token $token" \
	    [expr {$state(-keepalive)?"keepalive":""}]

        # Code above has set state(sock) $sock
        ConfigureNewSocket $token $sockOld $DoLater
        ##Log OpenSocket success $sock - token $token
    } result errdict]} {
	##Log OpenSocket failed $result - token $token
	# There may be other requests in the socketPhQueue.
	# Prepare socketPlayCmd so that Finish will replay them.
	if {    ($state(-keepalive)) && (!$state(reusing))
	     && [info exists socketPhQueue($sockOld)]
	     && ($socketPhQueue($sockOld) ne {})
	} {
	    if {$socketMapping($state(socketinfo)) ne $sockOld} {
		Log "WARNING: this code should not be reached.\
			{$socketMapping($state(socketinfo)) ne $sockOld}"
	    }
	    set socketPlayCmd($state(socketinfo)) [list ReplayIfClose Wready {} $socketPhQueue($sockOld)]
	    set socketPhQueue($sockOld) {}
	}
        if {[string range $result 0 20] eq {proxy connect failed:}} {
	    # - The HTTPS proxy did not create a socket.  The pre-existing value
	    #   (a "placeholder socket") is unchanged.
	    # - The proxy returned a valid HTTP response to the failed CONNECT
	    #   request, and http::SecureProxyConnect copied this to $token,
	    #   and also set ${token}(connection) set to "close".
	    # - Remove the error message $result so that Finish delivers this
	    #   HTTP response to the caller.







|

|


|
|
|















|







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
	    }
	    fconfigure $sock -translation {auto crlf} \
			     -buffersize $state(-blocksize)
	    if {[package vsatisfies [package provide Tcl] 9.0-]} {
		fconfigure $sock -profile replace
	    }
	    ##Log socket opened, DONE fconfigure - token $token
	}

	Log "Using $sock for $state(socketinfo) - token $token" \
	    [expr {$state(-keepalive)?"keepalive":""}]

	# Code above has set state(sock) $sock
	ConfigureNewSocket $token $sockOld $DoLater
	##Log OpenSocket success $sock - token $token
    } result errdict]} {
	##Log OpenSocket failed $result - token $token
	# There may be other requests in the socketPhQueue.
	# Prepare socketPlayCmd so that Finish will replay them.
	if {    ($state(-keepalive)) && (!$state(reusing))
	     && [info exists socketPhQueue($sockOld)]
	     && ($socketPhQueue($sockOld) ne {})
	} {
	    if {$socketMapping($state(socketinfo)) ne $sockOld} {
		Log "WARNING: this code should not be reached.\
			{$socketMapping($state(socketinfo)) ne $sockOld}"
	    }
	    set socketPlayCmd($state(socketinfo)) [list ReplayIfClose Wready {} $socketPhQueue($sockOld)]
	    set socketPhQueue($sockOld) {}
	}
	if {[string range $result 0 20] eq {proxy connect failed:}} {
	    # - The HTTPS proxy did not create a socket.  The pre-existing value
	    #   (a "placeholder socket") is unchanged.
	    # - The proxy returned a valid HTTP response to the failed CONNECT
	    #   request, and http::SecureProxyConnect copied this to $token,
	    #   and also set ${token}(connection) set to "close".
	    # - Remove the error message $result so that Finish delivers this
	    #   HTTP response to the caller.
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

    set reusing $state(reusing)
    set sock $state(sock)
    set proxyUsed $state(proxyUsed)
    ##Log "  ConfigureNewSocket" $token $sockOld ... -- $reusing $sock $proxyUsed

    if {(!$reusing) && ($sock ne $sockOld)} {
        # Replace the placeholder value sockOld with sock.

        if {    [info exists socketMapping($state(socketinfo))]
             && ($socketMapping($state(socketinfo)) eq $sockOld)
        } {
            set socketMapping($state(socketinfo)) $sock
            set socketProxyId($state(socketinfo)) $proxyUsed
            # tokens that use the placeholder $sockOld are updated below.
            ##Log set socketMapping($state(socketinfo)) $sock
        }

        # Now finish any tasks left over from PreparePersistentConnection on
        # the connection.
        #
        # The "unset" traces are fired by init (clears entire arrays), and
        # by http::Unset.
        # Unset is called by CloseQueuedQueries and (possibly never) by geturl.
        #
        # CancelReadPipeline, CancelWritePipeline call http::Finish for each
        # token.
        #
        # FIXME If Finish is placeholder-aware, these traces can be set earlier,
        # in PreparePersistentConnection.

        if {[dict get $DoLater -traceread]} {
	    set varName ::http::socketRdState($state(socketinfo))
	    trace add variable $varName unset ::http::CancelReadPipeline
        }
        if {[dict get $DoLater -tracewrite]} {
	    set varName ::http::socketWrState($state(socketinfo))
	    trace add variable $varName unset ::http::CancelWritePipeline
        }
    }

    # Do this in all cases.
    ScheduleRequest $token

    # Now look at all other tokens that use the placeholder $sockOld.
    if {    (!$reusing)
         && ($sock ne $sockOld)
         && [info exists socketPhQueue($sockOld)]
    } {
        ##Log "  ConfigureNewSocket" $token scheduled, now do $socketPhQueue($sockOld)
        foreach tok $socketPhQueue($sockOld) {
	    # 1. Amend the token's (sock).
	    ##Log set ${tok}(sock) $sock
	    set ${tok}(sock) $sock
	    set ${tok}(proxyUsed) $proxyUsed

	    # 2. Schedule the token's HTTP request.
	    # Every token in socketPhQueue(*) has reusing 1 alreadyQueued 0.







|

|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|

|


|
|


|







|
|

|
|







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

    set reusing $state(reusing)
    set sock $state(sock)
    set proxyUsed $state(proxyUsed)
    ##Log "  ConfigureNewSocket" $token $sockOld ... -- $reusing $sock $proxyUsed

    if {(!$reusing) && ($sock ne $sockOld)} {
	# Replace the placeholder value sockOld with sock.

	if {    [info exists socketMapping($state(socketinfo))]
	     && ($socketMapping($state(socketinfo)) eq $sockOld)
	} {
	    set socketMapping($state(socketinfo)) $sock
	    set socketProxyId($state(socketinfo)) $proxyUsed
	    # tokens that use the placeholder $sockOld are updated below.
	    ##Log set socketMapping($state(socketinfo)) $sock
	}

	# Now finish any tasks left over from PreparePersistentConnection on
	# the connection.
	#
	# The "unset" traces are fired by init (clears entire arrays), and
	# by http::Unset.
	# Unset is called by CloseQueuedQueries and (possibly never) by geturl.
	#
	# CancelReadPipeline, CancelWritePipeline call http::Finish for each
	# token.
	#
	# FIXME If Finish is placeholder-aware, these traces can be set earlier,
	# in PreparePersistentConnection.

	if {[dict get $DoLater -traceread]} {
	    set varName ::http::socketRdState($state(socketinfo))
	    trace add variable $varName unset ::http::CancelReadPipeline
	}
	if {[dict get $DoLater -tracewrite]} {
	    set varName ::http::socketWrState($state(socketinfo))
	    trace add variable $varName unset ::http::CancelWritePipeline
	}
    }

    # Do this in all cases.
    ScheduleRequest $token

    # Now look at all other tokens that use the placeholder $sockOld.
    if {    (!$reusing)
	 && ($sock ne $sockOld)
	 && [info exists socketPhQueue($sockOld)]
    } {
	##Log "  ConfigureNewSocket" $token scheduled, now do $socketPhQueue($sockOld)
	foreach tok $socketPhQueue($sockOld) {
	    # 1. Amend the token's (sock).
	    ##Log set ${tok}(sock) $sock
	    set ${tok}(sock) $sock
	    set ${tok}(proxyUsed) $proxyUsed

	    # 2. Schedule the token's HTTP request.
	    # Every token in socketPhQueue(*) has reusing 1 alreadyQueued 0.
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
	# pipelined request jumping the queue.
	##Log "HTTP request for token $token is queued for nonpipeline use"
	#Log re-use nonpipeline, GRANT delayed write access to $token in geturl
	set socketWrState($state(socketinfo)) peNding
	lappend socketWrQueue($state(socketinfo)) $token

    } else {
        if {$reusing && $state(-pipeline)} {
	    #Log new, init for pipelined, GRANT write access to $token in geturl
	    # DO NOT grant premature read access to the socket.
            # set socketRdState($state(socketinfo)) $token
            set socketWrState($state(socketinfo)) $token
        } elseif {$reusing} {
	    # socketWrState is not used by this non-pipelined transaction.
	    # We cannot leave it as "Wready" because the next call to
	    # http::geturl with a pipelined transaction would conclude that the
	    # socket is available for writing.
	    #Log new, init for nonpipeline, GRANT r/w access to $token in geturl
            set socketRdState($state(socketinfo)) $token
            set socketWrState($state(socketinfo)) $token
        } else {
        }

	# Process the request now.
	# - Command is not called unless $state(sock) is a real socket handle
	#   and not a placeholder.
	# - All (!$reusing) cases come here.
	# - Some $reusing cases come here too if the connection is
	#   marked as ready.  Those $reusing cases are:
	#   $reusing && ($socketWrState($state(socketinfo)) eq "Wready") &&
	#   EITHER !$pipeline && ($socketRdState($state(socketinfo)) eq "Rready")
	#   OR      $pipeline
	#
	#Log ---- $state(socketinfo) << conn to $token for HTTP request (a)
	##Log "  ScheduleRequest" $token -- fileevent $state(sock) writable for $token
	# Connect does its own fconfigure.

        lassign $state(connArgs) proto phost srvurl

	if {[catch {
		fileevent $state(sock) writable \
			[list http::Connect $token $proto $phost $srvurl]
	} res opts]} {
	    # The socket no longer exists.
	    ##Log bug -- socket gone -- $res -- $opts







|


|
|
|





|
|
|
|















|







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
	# pipelined request jumping the queue.
	##Log "HTTP request for token $token is queued for nonpipeline use"
	#Log re-use nonpipeline, GRANT delayed write access to $token in geturl
	set socketWrState($state(socketinfo)) peNding
	lappend socketWrQueue($state(socketinfo)) $token

    } else {
	if {$reusing && $state(-pipeline)} {
	    #Log new, init for pipelined, GRANT write access to $token in geturl
	    # DO NOT grant premature read access to the socket.
	    # set socketRdState($state(socketinfo)) $token
	    set socketWrState($state(socketinfo)) $token
	} elseif {$reusing} {
	    # socketWrState is not used by this non-pipelined transaction.
	    # We cannot leave it as "Wready" because the next call to
	    # http::geturl with a pipelined transaction would conclude that the
	    # socket is available for writing.
	    #Log new, init for nonpipeline, GRANT r/w access to $token in geturl
	    set socketRdState($state(socketinfo)) $token
	    set socketWrState($state(socketinfo)) $token
	} else {
	}

	# Process the request now.
	# - Command is not called unless $state(sock) is a real socket handle
	#   and not a placeholder.
	# - All (!$reusing) cases come here.
	# - Some $reusing cases come here too if the connection is
	#   marked as ready.  Those $reusing cases are:
	#   $reusing && ($socketWrState($state(socketinfo)) eq "Wready") &&
	#   EITHER !$pipeline && ($socketRdState($state(socketinfo)) eq "Rready")
	#   OR      $pipeline
	#
	#Log ---- $state(socketinfo) << conn to $token for HTTP request (a)
	##Log "  ScheduleRequest" $token -- fileevent $state(sock) writable for $token
	# Connect does its own fconfigure.

	lassign $state(connArgs) proto phost srvurl

	if {[catch {
		fileevent $state(sock) writable \
			[list http::Connect $token $proto $phost $srvurl]
	} res opts]} {
	    # The socket no longer exists.
	    ##Log bug -- socket gone -- $res -- $opts
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
	    # Some server implementations of HTTP/1.0 have a faulty
	    # implementation of RFC 2068 Keep-Alive.
	    # Don't leave this to chance.
	    # For HTTP/1.0 we have already "set state(connection) close"
	    # and "state(-keepalive) 0".
	    set ConnVal close
	}
        # Proxy authorisation (cf. mod by Anders Ramdahl to autoproxy by
        # Pat Thoyts).
        if {($http(-proxyauth) ne {}) && ($state(proxyUsed) eq {HttpProxy})} {
	    SendHeader $token Proxy-Authorization $http(-proxyauth)
        }
	# RFC7230 A.1 - "clients are encouraged not to send the
	# Proxy-Connection header field in any requests"
	set accept_encoding_seen 0
	set content_type_seen 0
	set connection_seen 0
	foreach {key value} $state(-headers) {
	    set value [string map [list \n "" \r ""] $value]







|
|
|

|







2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
	    # Some server implementations of HTTP/1.0 have a faulty
	    # implementation of RFC 2068 Keep-Alive.
	    # Don't leave this to chance.
	    # For HTTP/1.0 we have already "set state(connection) close"
	    # and "state(-keepalive) 0".
	    set ConnVal close
	}
	# Proxy authorisation (cf. mod by Anders Ramdahl to autoproxy by
	# Pat Thoyts).
	if {($http(-proxyauth) ne {}) && ($state(proxyUsed) eq {HttpProxy})} {
	    SendHeader $token Proxy-Authorization $http(-proxyauth)
	}
	# RFC7230 A.1 - "clients are encouraged not to send the
	# Proxy-Connection header field in any requests"
	set accept_encoding_seen 0
	set content_type_seen 0
	set connection_seen 0
	foreach {key value} $state(-headers) {
	    set value [string map [list \n "" \r ""] $value]
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
		set content_type_seen 1
	    }
	    if {[string equal -nocase $key "content-length"]} {
		set contDone 1
		set state(querylength) $value
	    }
	    if {    [string equal -nocase $key "connection"]
	         && [info exists state(bypass)]
	    } {
		# Value supplied in -headers overrides $ConnVal.
		set connection_seen 1
	    } elseif {[string equal -nocase $key "connection"]} {
		# Remove "close" or "keep-alive" and use our own value.
		# In an upgrade request, the upgrade is not guaranteed.
		# Value "close" or "keep-alive" tells the server what to do







|







2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
		set content_type_seen 1
	    }
	    if {[string equal -nocase $key "content-length"]} {
		set contDone 1
		set state(querylength) $value
	    }
	    if {    [string equal -nocase $key "connection"]
		    && [info exists state(bypass)]
	    } {
		# Value supplied in -headers overrides $ConnVal.
		set connection_seen 1
	    } elseif {[string equal -nocase $key "connection"]} {
		# Remove "close" or "keep-alive" and use our own value.
		# In an upgrade request, the upgrade is not guaranteed.
		# Value "close" or "keep-alive" tells the server what to do
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
    if {[package vsatisfies [package provide Tcl] 9.0-]} {
	fconfigure $sock -profile replace
    }
    Log ^D$tk begin receiving response - token $token

    coroutine ${token}--EventCoroutine http::Event $sock $token
    if {[info exists state(-handler)] || [info exists state(-progress)]} {
        fileevent $sock readable [list http::EventGateway $sock $token]
    } else {
        fileevent $sock readable ${token}--EventCoroutine
    }
    return
}


# http::EventGateway
#







|

|







2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
    if {[package vsatisfies [package provide Tcl] 9.0-]} {
	fconfigure $sock -profile replace
    }
    Log ^D$tk begin receiving response - token $token

    coroutine ${token}--EventCoroutine http::Event $sock $token
    if {[info exists state(-handler)] || [info exists state(-progress)]} {
	fileevent $sock readable [list http::EventGateway $sock $token]
    } else {
	fileevent $sock readable ${token}--EventCoroutine
    }
    return
}


# http::EventGateway
#
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652

proc http::EventGateway {sock token} {
    variable $token
    upvar 0 $token state
    fileevent $sock readable {}
    catch {${token}--EventCoroutine} res opts
    if {[info commands ${token}--EventCoroutine] ne {}} {
        # The coroutine can be deleted by completion (a non-yield return), by
        # http::Finish (when there is a premature end to the transaction), by
        # http::reset or http::cleanup, or if the caller set option -channel
        # but not option -handler: in the last case reading from the socket is
        # now managed by commands ::http::Copy*, http::ReceiveChunked, and
        # http::MakeTransformationChunked.
        #
        # Catch in case the coroutine has closed the socket.
        catch {fileevent $sock readable [list http::EventGateway $sock $token]}
    }

    # If there was an error, re-throw it.
    return -options $opts $res
}









|
|
|
|
|
|
|
|
|







2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651

proc http::EventGateway {sock token} {
    variable $token
    upvar 0 $token state
    fileevent $sock readable {}
    catch {${token}--EventCoroutine} res opts
    if {[info commands ${token}--EventCoroutine] ne {}} {
	# The coroutine can be deleted by completion (a non-yield return), by
	# http::Finish (when there is a premature end to the transaction), by
	# http::reset or http::cleanup, or if the caller set option -channel
	# but not option -handler: in the last case reading from the socket is
	# now managed by commands ::http::Copy*, http::ReceiveChunked, and
	# http::MakeTransformationChunked.
	#
	# Catch in case the coroutine has closed the socket.
	catch {fileevent $sock readable [list http::EventGateway $sock $token]}
    }

    # If there was an error, re-throw it.
    return -options $opts $res
}


3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
    }

    if {[info exists state(after)]} {
	after cancel $state(after)
	unset state(after)
    }
    if {[info exists state(socketcoro)]} {
        Log $token Cancel socket after-idle event (ReInit)
        after cancel $state(socketcoro)
        unset state(socketcoro)
    }

    # Don't alter state(status) - this would trigger http::wait if it is in use.
    set tmpState    $state(tmpState)
    set tmpOpenCmd  $state(tmpOpenCmd)
    set tmpConnArgs $state(tmpConnArgs)
    foreach name [array names state] {







|
|
|







3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
    }

    if {[info exists state(after)]} {
	after cancel $state(after)
	unset state(after)
    }
    if {[info exists state(socketcoro)]} {
	Log $token Cancel socket after-idle event (ReInit)
	after cancel $state(socketcoro)
	unset state(socketcoro)
    }

    # Don't alter state(status) - this would trigger http::wait if it is in use.
    set tmpState    $state(tmpState)
    set tmpOpenCmd  $state(tmpOpenCmd)
    set tmpConnArgs $state(tmpConnArgs)
    foreach name [array names state] {
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
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
    variable $token
    upvar 0 $token state
    return $state(currentsize)
}
proc http::requestHeaders {token args} {
    set lenny  [llength $args]
    if {$lenny > 1} {
        return -code error {usage: ::http::requestHeaders token ?headerName?}
    } else {
        return [Meta $token request {*}$args]
    }
}
proc http::responseHeaders {token args} {
    set lenny  [llength $args]
    if {$lenny > 1} {
        return -code error {usage: ::http::responseHeaders token ?headerName?}
    } else {
        return [Meta $token response {*}$args]
    }
}
proc http::requestHeaderValue {token header} {
    Meta $token request $header VALUE
}
proc http::responseHeaderValue {token header} {
    Meta $token response $header VALUE
}
proc http::Meta {token who args} {
    variable $token
    upvar 0 $token state

    if {$who eq {request}} {
        set whom requestHeaders
    } elseif {$who eq {response}} {
        set whom meta
    } else {
        return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??}
    }

    set header [string tolower [lindex $args 0]]
    set how    [string tolower [lindex $args 1]]
    set lenny  [llength $args]
    if {$lenny == 0} {
        return $state($whom)
    } elseif {($lenny > 2) || (($lenny == 2) && ($how ne {value}))} {
        return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??}
    } else {
        set result {}
        set combined {}
        foreach {key value} $state($whom) {
            if {$key eq $header} {
                lappend result $key $value
                append combined $value {, }
            }
        }
        if {$lenny == 1} {
            return $result
        } else {
            return [string range $combined 0 end-2]
        }
    }
}


# ------------------------------------------------------------------------------
#  Proc http::responseInfo
# ------------------------------------------------------------------------------







|

|





|

|













|

|

|






|

|

|
|
|
|
|
|
|
|
|
|
|
|
|







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
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
    variable $token
    upvar 0 $token state
    return $state(currentsize)
}
proc http::requestHeaders {token args} {
    set lenny  [llength $args]
    if {$lenny > 1} {
	return -code error {usage: ::http::requestHeaders token ?headerName?}
    } else {
	return [Meta $token request {*}$args]
    }
}
proc http::responseHeaders {token args} {
    set lenny  [llength $args]
    if {$lenny > 1} {
	return -code error {usage: ::http::responseHeaders token ?headerName?}
    } else {
	return [Meta $token response {*}$args]
    }
}
proc http::requestHeaderValue {token header} {
    Meta $token request $header VALUE
}
proc http::responseHeaderValue {token header} {
    Meta $token response $header VALUE
}
proc http::Meta {token who args} {
    variable $token
    upvar 0 $token state

    if {$who eq {request}} {
	set whom requestHeaders
    } elseif {$who eq {response}} {
	set whom meta
    } else {
	return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??}
    }

    set header [string tolower [lindex $args 0]]
    set how    [string tolower [lindex $args 1]]
    set lenny  [llength $args]
    if {$lenny == 0} {
	return $state($whom)
    } elseif {($lenny > 2) || (($lenny == 2) && ($how ne {value}))} {
	return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??}
    } else {
	set result {}
	set combined {}
	foreach {key value} $state($whom) {
	    if {$key eq $header} {
		lappend result $key $value
		append combined $value {, }
	    }
	}
	if {$lenny == 1} {
	    return $result
	} else {
	    return [string range $combined 0 end-2]
	}
    }
}


# ------------------------------------------------------------------------------
#  Proc http::responseInfo
# ------------------------------------------------------------------------------
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
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
# ------------------------------------------------------------------------------

proc http::responseInfo {token} {
    variable $token
    upvar 0 $token state
    set result {}
    foreach {key origin name} {
        stage                 STATE  state
        status                STATE  status
        responseCode          STATE  responseCode
        reasonPhrase          STATE  reasonPhrase
        contentType           STATE  type
        binary                STATE  binary
        redirection           RESP   location
        upgrade               STATE  upgrade
        error                 ERROR  -
        postError             STATE  posterror
        method                STATE  method
        charset               STATE  charset
        compression           STATE  coding
        httpRequest           STATE  -protocol
        httpResponse          STATE  httpResponse
        url                   STATE  url
        connectionRequest     REQ    connection
        connectionResponse    RESP   connection
        connectionActual      STATE  connection
        transferEncoding      STATE  transfer
        totalPost             STATE  querylength
        currentPost           STATE  queryoffset
        totalSize             STATE  totalsize
        currentSize           STATE  currentsize
        proxyUsed             STATE  proxyUsed
    } {
        if {$origin eq {STATE}} {
            if {[info exists state($name)]} {
                dict set result $key $state($name)
            } else {
                # Should never come here
                dict set result $key {}
            }
        } elseif {$origin eq {REQ}} {
            dict set result $key [requestHeaderValue $token $name]
        } elseif {$origin eq {RESP}} {
            dict set result $key [responseHeaderValue $token $name]
        } elseif {$origin eq {ERROR}} {
            # Don't flood the dict with data.  The command ::http::error is
            # available.
            if {[info exists state(error)]} {
                set msg [lindex $state(error) 0]
            } else {
                set msg {}
            }
            dict set result $key $msg
        } else {
            # Should never come here
            dict set result $key {}
        }
    }
    return $result
}
proc http::error {token} {
    variable $token
    upvar 0 $token state
    if {[info exists state(error)]} {







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







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
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
# ------------------------------------------------------------------------------

proc http::responseInfo {token} {
    variable $token
    upvar 0 $token state
    set result {}
    foreach {key origin name} {
	stage                 STATE  state
	status                STATE  status
	responseCode          STATE  responseCode
	reasonPhrase          STATE  reasonPhrase
	contentType           STATE  type
	binary                STATE  binary
	redirection           RESP   location
	upgrade               STATE  upgrade
	error                 ERROR  -
	postError             STATE  posterror
	method                STATE  method
	charset               STATE  charset
	compression           STATE  coding
	httpRequest           STATE  -protocol
	httpResponse          STATE  httpResponse
	url                   STATE  url
	connectionRequest     REQ    connection
	connectionResponse    RESP   connection
	connectionActual      STATE  connection
	transferEncoding      STATE  transfer
	totalPost             STATE  querylength
	currentPost           STATE  queryoffset
	totalSize             STATE  totalsize
	currentSize           STATE  currentsize
	proxyUsed             STATE  proxyUsed
    } {
	if {$origin eq {STATE}} {
	    if {[info exists state($name)]} {
		dict set result $key $state($name)
	    } else {
		# Should never come here
		dict set result $key {}
	    }
	} elseif {$origin eq {REQ}} {
	    dict set result $key [requestHeaderValue $token $name]
	} elseif {$origin eq {RESP}} {
	    dict set result $key [responseHeaderValue $token $name]
	} elseif {$origin eq {ERROR}} {
	    # Don't flood the dict with data.  The command ::http::error is
	    # available.
	    if {[info exists state(error)]} {
		set msg [lindex $state(error) 0]
	    } else {
		set msg {}
	    }
	    dict set result $key $msg
	} else {
	    # Should never come here
	    dict set result $key {}
	}
    }
    return $result
}
proc http::error {token} {
    variable $token
    upvar 0 $token state
    if {[info exists state(error)]} {
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
	rename ${token}--SocketCoroutine {}
    }
    if {[info exists state(after)]} {
	after cancel $state(after)
	unset state(after)
    }
    if {[info exists state(socketcoro)]} {
        Log $token Cancel socket after-idle event (cleanup)
        after cancel $state(socketcoro)
        unset state(socketcoro)
    }
    if {[info exists state]} {
	unset state
    }
    return
}








|
|
|







3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
	rename ${token}--SocketCoroutine {}
    }
    if {[info exists state(after)]} {
	after cancel $state(after)
	unset state(after)
    }
    if {[info exists state(socketcoro)]} {
	Log $token Cancel socket after-idle event (cleanup)
	after cancel $state(socketcoro)
	unset state(socketcoro)
    }
    if {[info exists state]} {
	unset state
    }
    return
}

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

proc http::Connect {token proto phost srvurl} {
    variable $token
    upvar 0 $token state
    set tk [namespace tail $token]

    if {[catch {eof $state(sock)} tmp] || $tmp} {
        set err "due to unexpected EOF"
    } elseif {[set err [fconfigure $state(sock) -error]] ne ""} {
        # set err is done in test
    } else {
        # All OK
	set state(state) connecting
	fileevent $state(sock) writable {}
	::http::Connected $token $proto $phost $srvurl
	return
    }

    # Error cases.







|

|

|







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

proc http::Connect {token proto phost srvurl} {
    variable $token
    upvar 0 $token state
    set tk [namespace tail $token]

    if {[catch {eof $state(sock)} tmp] || $tmp} {
	set err "due to unexpected EOF"
    } elseif {[set err [fconfigure $state(sock) -error]] ne ""} {
	# set err is done in test
    } else {
	# All OK
	set state(state) connecting
	fileevent $state(sock) writable {}
	::http::Connected $token $proto $phost $srvurl
	return
    }

    # Error cases.
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
		    if {[info commands ${token}--EventCoroutine] ne {}} {
			rename ${token}--EventCoroutine {}
		    }
		    if {[info commands ${token}--SocketCoroutine] ne {}} {
			rename ${token}--SocketCoroutine {}
		    }
		    if {[info exists state(socketcoro)]} {
		        Log $token Cancel socket after-idle event (Finish)
		        after cancel $state(socketcoro)
		        unset state(socketcoro)
		    }
		    if {[info exists state(after)]} {
			after cancel $state(after)
			unset state(after)
		    }
		    if {    [info exists state(-command)]
			 && (![info exists state(done-command-cb)])







|
|
|







3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
		    if {[info commands ${token}--EventCoroutine] ne {}} {
			rename ${token}--EventCoroutine {}
		    }
		    if {[info commands ${token}--SocketCoroutine] ne {}} {
			rename ${token}--SocketCoroutine {}
		    }
		    if {[info exists state(socketcoro)]} {
			Log $token Cancel socket after-idle event (Finish)
			after cancel $state(socketcoro)
			unset state(socketcoro)
		    }
		    if {[info exists state(after)]} {
			after cancel $state(after)
			unset state(after)
		    }
		    if {    [info exists state(-command)]
			 && (![info exists state(done-command-cb)])
4643
4644
4645
4646
4647
4648
4649
4650
4651
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
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
# ------------------------------------------------------------------------------

proc http::GuessType {token} {
    variable $token
    upvar 0 $token state

    if {$state(type) ne {application/octet-stream}} {
        return 0
    }

    set body $state(body)
    # e.g. {<?xml version="1.0" encoding="utf-8"?> ...}

    if {![regexp -nocase -- {^<[?]xml[[:space:]][^>?]*[?]>} $body match]} {
        return 0
    }
    # e.g. {<?xml version="1.0" encoding="utf-8"?>}

    set contents [regsub -- {[[:space:]]+} $match { }]
    set contents [string range [string tolower $contents] 6 end-2]
    # e.g. {version="1.0" encoding="utf-8"}
    # without excess whitespace or upper-case letters

    if {![regexp -- {^([^=" ]+="[^"]+" )+$} "$contents "]} {
        return 0
    }
    # The application/xml default encoding:
    set res utf-8

    set tagList [regexp -all -inline -- {[^=" ]+="[^"]+"} $contents]
    foreach tag $tagList {
        regexp -- {([^=" ]+)="([^"]+)"} $tag -> name value
        if {$name eq {encoding}} {
            set res $value
        }
    }
    set enc [CharsetToEncoding $res]
    if {$enc eq "binary"} {
        return 0
    }
    if {[package vsatisfies [package provide Tcl] 9.0-]} {
	set state(body) [encoding convertfrom -profile replace $enc $state(body)]
    } else {
	set state(body) [encoding convertfrom $enc $state(body)]
    }
    set state(body) [string map {\r\n \n \r \n} $state(body)]







|






|









|






|
|
|
|



|







4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
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
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
# ------------------------------------------------------------------------------

proc http::GuessType {token} {
    variable $token
    upvar 0 $token state

    if {$state(type) ne {application/octet-stream}} {
	return 0
    }

    set body $state(body)
    # e.g. {<?xml version="1.0" encoding="utf-8"?> ...}

    if {![regexp -nocase -- {^<[?]xml[[:space:]][^>?]*[?]>} $body match]} {
	return 0
    }
    # e.g. {<?xml version="1.0" encoding="utf-8"?>}

    set contents [regsub -- {[[:space:]]+} $match { }]
    set contents [string range [string tolower $contents] 6 end-2]
    # e.g. {version="1.0" encoding="utf-8"}
    # without excess whitespace or upper-case letters

    if {![regexp -- {^([^=" ]+="[^"]+" )+$} "$contents "]} {
	return 0
    }
    # The application/xml default encoding:
    set res utf-8

    set tagList [regexp -all -inline -- {[^=" ]+="[^"]+"} $contents]
    foreach tag $tagList {
	regexp -- {([^=" ]+)="([^"]+)"} $tag -> name value
	if {$name eq {encoding}} {
	    set res $value
	}
    }
    set enc [CharsetToEncoding $res]
    if {$enc eq "binary"} {
	return 0
    }
    if {[package vsatisfies [package provide Tcl] 9.0-]} {
	set state(body) [encoding convertfrom -profile replace $enc $state(body)]
    } else {
	set state(body) [encoding convertfrom $enc $state(body)]
    }
    set state(body) [string map {\r\n \n \r \n} $state(body)]
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
#	args	A list of name-value pairs.
#
# Results:
#	TODO

proc http::formatQuery {args} {
    if {[llength $args] % 2} {
        return \
            -code error \
            -errorcode [list HTTP BADARGCNT $args] \
            {Incorrect number of arguments, must be an even number.}
    }
    set result ""
    set sep ""
    foreach i $args {
	append result $sep [quoteString $i]
	if {$sep eq "="} {
	    set sep &







|
|
|
|







4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
#	args	A list of name-value pairs.
#
# Results:
#	TODO

proc http::formatQuery {args} {
    if {[llength $args] % 2} {
	return \
	    -code error \
	    -errorcode [list HTTP BADARGCNT $args] \
	    {Incorrect number of arguments, must be an even number.}
    }
    set result ""
    set sep ""
    foreach i $args {
	append result $sep [quoteString $i]
	if {$sep eq "="} {
	    set sep &
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
#
# Results:
#       The current proxy settings

proc http::ProxyRequired {host} {
    variable http
    if {(![info exists http(-proxyhost)]) || ($http(-proxyhost) eq {})} {
        return
    }
    if {![info exists http(-proxyport)] || ($http(-proxyport) eq {})} {
	set port 8080
    } else {
	set port $http(-proxyport)
    }

    # Simple test (cf. autoproxy) for hosts that must be accessed directly,
    # not through the proxy server.
    foreach domain $http(-proxynot) {
        if {[string match -nocase $domain $host]} {
            return {}
        }
    }
    return [list $http(-proxyhost) $port]
}

# http::CharsetToEncoding --
#
#	Tries to map a given IANA charset to a tcl encoding.  If no encoding







|










|
|
|







4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
#
# Results:
#       The current proxy settings

proc http::ProxyRequired {host} {
    variable http
    if {(![info exists http(-proxyhost)]) || ($http(-proxyhost) eq {})} {
	return
    }
    if {![info exists http(-proxyport)] || ($http(-proxyport) eq {})} {
	set port 8080
    } else {
	set port $http(-proxyport)
    }

    # Simple test (cf. autoproxy) for hosts that must be accessed directly,
    # not through the proxy server.
    foreach domain $http(-proxynot) {
	if {[string match -nocase $domain $host]} {
	    return {}
	}
    }
    return [list $http(-proxyhost) $port]
}

# http::CharsetToEncoding --
#
#	Tries to map a given IANA charset to a tcl encoding.  If no encoding
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
# ------------------------------------------------------------------------------

proc http::socketAsCallback {args} {
    variable http

    set targ [lsearch -exact $args -type]
    if {$targ != -1} {
        set token [lindex $args $targ+1]
        upvar 0 ${token} state
        set protoProxyConn $state(protoProxyConn)
    } else {
        set protoProxyConn 0
    }

    set host [lindex $args end-1]
    set port [lindex $args end]
    if {    ($http(-proxyfilter) ne {})
         && (![catch {$http(-proxyfilter) $host} proxy])
         && $protoProxyConn
    } {
        set phost [lindex $proxy 0]
        set pport [lindex $proxy 1]
    } else {
        set phost {}
        set pport {}
    }
    if {$phost eq ""} {
        set sock [::http::AltSocket {*}$args]
    } else {
        set sock [::http::SecureProxyConnect {*}$args $phost $pport]
    }
    return $sock
}


# ------------------------------------------------------------------------------
#  Proc http::SecureProxyConnect







|
|
|

|





|
|

|
|

|
|


|

|







5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
# ------------------------------------------------------------------------------

proc http::socketAsCallback {args} {
    variable http

    set targ [lsearch -exact $args -type]
    if {$targ != -1} {
	set token [lindex $args $targ+1]
	upvar 0 ${token} state
	set protoProxyConn $state(protoProxyConn)
    } else {
	set protoProxyConn 0
    }

    set host [lindex $args end-1]
    set port [lindex $args end]
    if {    ($http(-proxyfilter) ne {})
	 && (![catch {$http(-proxyfilter) $host} proxy])
	 && $protoProxyConn
    } {
	set phost [lindex $proxy 0]
	set pport [lindex $proxy 1]
    } else {
	set phost {}
	set pport {}
    }
    if {$phost eq ""} {
	set sock [::http::AltSocket {*}$args]
    } else {
	set sock [::http::SecureProxyConnect {*}$args $phost $pport]
    }
    return $sock
}


# ------------------------------------------------------------------------------
#  Proc http::SecureProxyConnect
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
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
    set args [lreplace $args end-3 end-2]

    # Proxy server URL for connection.
    # This determines where the socket is opened.
    set phost [lindex $args end-1]
    set pport [lindex $args end]
    if {[string first : $phost] != -1} {
        # IPv6 address, wrap it in [] so we can append :pport
        set phost "\[${phost}\]"
    }
    set url http://${phost}:${pport}
    # Elements of args other than host and port are not used when
    # AsyncTransaction opens a socket.  Those elements are -async and the
    # -type $tokenName for the https transaction.  Option -async is used by
    # AsyncTransaction anyway, and -type $tokenName should not be
    # propagated: the proxy request adds its own -type value.

    set targ [lsearch -exact $args -type]
    if {$targ != -1} {
        # Record in the token that this is a proxy call.
        set token [lindex $args $targ+1]
        upvar 0 ${token} state
        set tim $state(-timeout)
        set state(proxyUsed) SecureProxyFailed
        # This value is overwritten with "SecureProxy" below if the CONNECT is
        # successful.  If it is unsuccessful, the socket will be closed
        # below, and so in this unsuccessful case there are no other transactions
        # whose (proxyUsed) must be updated.
    } else {
        set tim 0
    }
    if {$tim == 0} {
        # Do not use infinite timeout for the proxy.
        set tim 30000
    }

    # Prepare and send a CONNECT request to the proxy, using
    # code similar to http::geturl.
    set requestHeaders [list Host $host]
    lappend requestHeaders Connection keep-alive
    if {$http(-proxyauth) != {}} {
        lappend requestHeaders Proxy-Authorization $http(-proxyauth)
    }

    set token2 [CreateToken $url -keepalive 0 -timeout $tim \
            -headers $requestHeaders -command [list http::AllDone $varName]]
    variable $token2
    upvar 0 $token2 state2

    # Kludges:
    # Setting this variable overrides the HTTP request line and also allows
    # -headers to override the Connection: header set by -keepalive.
    # The arguments "-keepalive 0" ensure that when Finish is called for an
    # unsuccessful request, the socket is always closed.
    set state2(bypass) "CONNECT $host:$port HTTP/1.1"

    AsyncTransaction $token2

    if {[info coroutine] ne {}} {
        # All callers in the http package are coroutines launched by
        # the event loop.
        # The cwait command requires a coroutine because it yields
        # to the caller; $varName is traced and the coroutine resumes
        # when the variable is written.
        cwait $varName
    } else {
        return -code error {code must run in a coroutine}
        # For testing with a non-coroutine caller outside the http package.
        # vwait $varName
    }
    unset $varName

    if {    ($state2(state) ne "complete")
         || ($state2(status) ne "ok")
         || (![string is integer -strict $state2(responseCode)])
    } {
        set msg {the HTTP request to the proxy server did not return a valid\
                and complete response}
        if {[info exists state2(error)]} {
            append msg ": " [lindex $state2(error) 0]
        }
        cleanup $token2
        return -code error $msg
    }

    set code $state2(responseCode)

    if {($code >= 200) && ($code < 300)} {
        # All OK.  The caller in package tls will now call "tls::import $sock".
        # The cleanup command does not close $sock.
        # Other tidying was done in http::Event.

        # If this is a persistent socket, any other transactions that are
        # already marked to use the socket will have their (proxyUsed) updated
        # when http::OpenSocket calls http::ConfigureNewSocket.
        set state(proxyUsed) SecureProxy
        set sock $state2(sock)
        cleanup $token2
        return $sock
    }

    if {$targ != -1} {
        # Non-OK HTTP status code; token is known because option -type
        # (cf. targ) was passed through tcltls, and so the useful
        # parts of the proxy's response can be copied to state(*).
        # Do not copy state2(sock).
        # Return the proxy response to the caller of geturl.
        foreach name $failedProxyValues {
            if {[info exists state2($name)]} {
                set state($name) $state2($name)
            }
        }
        set state(connection) close
        set msg "proxy connect failed: $code"
	# - This error message will be detected by http::OpenSocket and will
	#   cause it to present the proxy's HTTP response as that of the
	#   original $token transaction, identified only by state(proxyUsed)
	#   as the response of the proxy.
	# - The cases where this would mislead the caller of http::geturl are
	#   given a different value of msg (below) so that http::OpenSocket will
	#   treat them as errors, but will preserve the $token array for







|
|










|
|
|
|
|
|
|
|
|

|


|
|







|



|













|
|
|
|
|
|

|
|
|




|
|

|
|
|
|
|
|
|





|
|
|

|
|
|
|
|
|
|



|
|
|
|
|
|
|
|
|
|
|
|







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
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
    set args [lreplace $args end-3 end-2]

    # Proxy server URL for connection.
    # This determines where the socket is opened.
    set phost [lindex $args end-1]
    set pport [lindex $args end]
    if {[string first : $phost] != -1} {
	# IPv6 address, wrap it in [] so we can append :pport
	set phost "\[${phost}\]"
    }
    set url http://${phost}:${pport}
    # Elements of args other than host and port are not used when
    # AsyncTransaction opens a socket.  Those elements are -async and the
    # -type $tokenName for the https transaction.  Option -async is used by
    # AsyncTransaction anyway, and -type $tokenName should not be
    # propagated: the proxy request adds its own -type value.

    set targ [lsearch -exact $args -type]
    if {$targ != -1} {
	# Record in the token that this is a proxy call.
	set token [lindex $args $targ+1]
	upvar 0 ${token} state
	set tim $state(-timeout)
	set state(proxyUsed) SecureProxyFailed
	# This value is overwritten with "SecureProxy" below if the CONNECT is
	# successful.  If it is unsuccessful, the socket will be closed
	# below, and so in this unsuccessful case there are no other transactions
	# whose (proxyUsed) must be updated.
    } else {
	set tim 0
    }
    if {$tim == 0} {
	# Do not use infinite timeout for the proxy.
	set tim 30000
    }

    # Prepare and send a CONNECT request to the proxy, using
    # code similar to http::geturl.
    set requestHeaders [list Host $host]
    lappend requestHeaders Connection keep-alive
    if {$http(-proxyauth) != {}} {
	lappend requestHeaders Proxy-Authorization $http(-proxyauth)
    }

    set token2 [CreateToken $url -keepalive 0 -timeout $tim \
	    -headers $requestHeaders -command [list http::AllDone $varName]]
    variable $token2
    upvar 0 $token2 state2

    # Kludges:
    # Setting this variable overrides the HTTP request line and also allows
    # -headers to override the Connection: header set by -keepalive.
    # The arguments "-keepalive 0" ensure that when Finish is called for an
    # unsuccessful request, the socket is always closed.
    set state2(bypass) "CONNECT $host:$port HTTP/1.1"

    AsyncTransaction $token2

    if {[info coroutine] ne {}} {
	# All callers in the http package are coroutines launched by
	# the event loop.
	# The cwait command requires a coroutine because it yields
	# to the caller; $varName is traced and the coroutine resumes
	# when the variable is written.
	cwait $varName
    } else {
	return -code error {code must run in a coroutine}
	# For testing with a non-coroutine caller outside the http package.
	# vwait $varName
    }
    unset $varName

    if {    ($state2(state) ne "complete")
	 || ($state2(status) ne "ok")
	 || (![string is integer -strict $state2(responseCode)])
    } {
	set msg {the HTTP request to the proxy server did not return a valid\
		and complete response}
	if {[info exists state2(error)]} {
	    append msg ": " [lindex $state2(error) 0]
	}
	cleanup $token2
	return -code error $msg
    }

    set code $state2(responseCode)

    if {($code >= 200) && ($code < 300)} {
	# All OK.  The caller in package tls will now call "tls::import $sock".
	# The cleanup command does not close $sock.
	# Other tidying was done in http::Event.

	# If this is a persistent socket, any other transactions that are
	# already marked to use the socket will have their (proxyUsed) updated
	# when http::OpenSocket calls http::ConfigureNewSocket.
	set state(proxyUsed) SecureProxy
	set sock $state2(sock)
	cleanup $token2
	return $sock
    }

    if {$targ != -1} {
	# Non-OK HTTP status code; token is known because option -type
	# (cf. targ) was passed through tcltls, and so the useful
	# parts of the proxy's response can be copied to state(*).
	# Do not copy state2(sock).
	# Return the proxy response to the caller of geturl.
	foreach name $failedProxyValues {
	    if {[info exists state2($name)]} {
		set state($name) $state2($name)
	    }
	}
	set state(connection) close
	set msg "proxy connect failed: $code"
	# - This error message will be detected by http::OpenSocket and will
	#   cause it to present the proxy's HTTP response as that of the
	#   original $token transaction, identified only by state(proxyUsed)
	#   as the response of the proxy.
	# - The cases where this would mislead the caller of http::geturl are
	#   given a different value of msg (below) so that http::OpenSocket will
	#   treat them as errors, but will preserve the $token array for
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
    variable ThreadCounter
    variable http

    LoadThreadIfNeeded

    set targ [lsearch -exact $args -type]
    if {$targ != -1} {
        set token [lindex $args $targ+1]
        set args [lreplace $args $targ $targ+1]
        upvar 0 $token state
    }

    if {$http(usingThread) && [info exists state] && $state(protoSockThread)} {
    } else {
        # Use plain "::socket".  This is the default.
        return [eval ::socket $args]
    }

    set defcmd ::socket
    set sockargs $args
    set script "
        set code \[catch {
            [list proc ::SockInThread {caller defcmd sockargs} [info body ::http::SockInThread]]
            [list ::SockInThread [thread::id] $defcmd $sockargs]
        } result opts\]
        list \$code \$opts \$result
    "

    set state(tid) [thread::create]
    set varName ::http::ThreadVar([incr ThreadCounter])
    thread::send -async $state(tid) $script $varName
    Log >T Thread Start Wait $args -- coro [info coroutine] $varName
    if {[info coroutine] ne {}} {
        # All callers in the http package are coroutines launched by
        # the event loop.
        # The cwait command requires a coroutine because it yields
        # to the caller; $varName is traced and the coroutine resumes
        # when the variable is written.
        cwait $varName
    } else {
        return -code error {code must run in a coroutine}
        # For testing with a non-coroutine caller outside the http package.
        # vwait $varName
    }
    Log >U Thread End Wait $args -- coro [info coroutine] $varName [set $varName]
    thread::release $state(tid)
    set state(tid) {}
    set result [set $varName]
    unset $varName
    if {(![string is list $result]) || ([llength $result] != 3)} {
        return -code error "result from peer thread is not a list of\
                length 3: it is \n$result"
    }
    lassign $result threadCode threadDict threadResult
    if {($threadCode != 0)} {
        # This is an error in thread::send.  Return the lot.
        return -options $threadDict -code error $threadResult
    }

    # Now the results of the catch in the peer thread.
    lassign $threadResult catchCode errdict sock

    if {($catchCode == 0) && ($sock ni [chan names])} {
        return -code error {Transfer of socket from peer thread failed.\
		Check that this script is not running in a child interpreter.}
    }
    return -options $errdict -code $catchCode $sock
}

# The commands below are dependencies of http::AltSocket and
# http::SecureProxyConnect and are not used elsewhere.







|
|
|




|
|





|
|
|
|
|







|
|
|
|
|
|

|
|
|







|
|



|
|






|







5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
    variable ThreadCounter
    variable http

    LoadThreadIfNeeded

    set targ [lsearch -exact $args -type]
    if {$targ != -1} {
	set token [lindex $args $targ+1]
	set args [lreplace $args $targ $targ+1]
	upvar 0 $token state
    }

    if {$http(usingThread) && [info exists state] && $state(protoSockThread)} {
    } else {
	# Use plain "::socket".  This is the default.
	return [eval ::socket $args]
    }

    set defcmd ::socket
    set sockargs $args
    set script "
	set code \[catch {
	    [list proc ::SockInThread {caller defcmd sockargs} [info body ::http::SockInThread]]
	    [list ::SockInThread [thread::id] $defcmd $sockargs]
	} result opts\]
	list \$code \$opts \$result
    "

    set state(tid) [thread::create]
    set varName ::http::ThreadVar([incr ThreadCounter])
    thread::send -async $state(tid) $script $varName
    Log >T Thread Start Wait $args -- coro [info coroutine] $varName
    if {[info coroutine] ne {}} {
	# All callers in the http package are coroutines launched by
	# the event loop.
	# The cwait command requires a coroutine because it yields
	# to the caller; $varName is traced and the coroutine resumes
	# when the variable is written.
	cwait $varName
    } else {
	return -code error {code must run in a coroutine}
	# For testing with a non-coroutine caller outside the http package.
	# vwait $varName
    }
    Log >U Thread End Wait $args -- coro [info coroutine] $varName [set $varName]
    thread::release $state(tid)
    set state(tid) {}
    set result [set $varName]
    unset $varName
    if {(![string is list $result]) || ([llength $result] != 3)} {
	return -code error "result from peer thread is not a list of\
		length 3: it is \n$result"
    }
    lassign $result threadCode threadDict threadResult
    if {($threadCode != 0)} {
	# This is an error in thread::send.  Return the lot.
	return -options $threadDict -code error $threadResult
    }

    # Now the results of the catch in the peer thread.
    lassign $threadResult catchCode errdict sock

    if {($catchCode == 0) && ($sock ni [chan names])} {
	return -code error {Transfer of socket from peer thread failed.\
		Check that this script is not running in a child interpreter.}
    }
    return -options $errdict -code $catchCode $sock
}

# The commands below are dependencies of http::AltSocket and
# http::SecureProxyConnect and are not used elsewhere.
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
# Arguments: none
# Return Value: none
# ------------------------------------------------------------------------------

proc http::LoadThreadIfNeeded {} {
    variable http
    if {$http(-threadlevel) == 0} {
        set http(usingThread) 0
        return
    }
    if {[catch {package require Thread}]} {
        if {$http(-threadlevel) == 2} {
            set msg {[http::config -threadlevel] has value 2,\
                     but the Thread package is not available}
            return -code error $msg
        }
        set http(usingThread) 0
        return
    }
    set http(usingThread) 1
    return
}


# ------------------------------------------------------------------------------







|
|


|
|
|
|
|
|
|







5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
# Arguments: none
# Return Value: none
# ------------------------------------------------------------------------------

proc http::LoadThreadIfNeeded {} {
    variable http
    if {$http(-threadlevel) == 0} {
	set http(usingThread) 0
	return
    }
    if {[catch {package require Thread}]} {
	if {$http(-threadlevel) == 2} {
	    set msg {[http::config -threadlevel] has value 2,\
		     but the Thread package is not available}
	    return -code error $msg
	}
	set http(usingThread) 0
	return
    }
    set http(usingThread) 1
    return
}


# ------------------------------------------------------------------------------
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
# ------------------------------------------------------------------------------

proc http::SockInThread {caller defcmd sockargs} {
    package require Thread

    set catchCode [catch {eval $defcmd $sockargs} sock errdict]
    if {$catchCode == 0} {
        set catchCode [catch {thread::transfer $caller $sock; set sock} sock errdict]
    }
    return [list $catchCode $errdict $sock]
}


# ------------------------------------------------------------------------------
#  Proc http::cwaiter::cwait







|







5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
# ------------------------------------------------------------------------------

proc http::SockInThread {caller defcmd sockargs} {
    package require Thread

    set catchCode [catch {eval $defcmd $sockargs} sock errdict]
    if {$catchCode == 0} {
	set catchCode [catch {thread::transfer $caller $sock; set sock} sock errdict]
    }
    return [list $catchCode $errdict $sock]
}


# ------------------------------------------------------------------------------
#  Proc http::cwaiter::cwait
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
}

proc http::cwaiter::cwait {
    varName {coroName {}} {timeout {}} {timeoutValue {}}
} {
    set thisCoro [info coroutine]
    if {$thisCoro eq {}} {
        return -code error {cwait cannot be called outside a coroutine}
    }
    if {$coroName eq {}} {
        set coroName $thisCoro
    }
    if {[string range $varName 0 1] ne {::}} {
        return -code error {argument varName must be fully qualified}
    }
    if {$timeout eq {}} {
        set toe {}
    } elseif {[string is integer -strict $timeout] && ($timeout > 0)} {
        set toe [after $timeout [list set $varName $timeoutValue]]
    } else {
        return -code error {if timeout is supplied it must be a positive integer}
    }

    set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe]
    trace add variable $varName write $cmd
    CoLog "Yield $varName $coroName"
    yield
    CoLog "Resume $varName $coroName"







|


|


|


|

|

|







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
}

proc http::cwaiter::cwait {
    varName {coroName {}} {timeout {}} {timeoutValue {}}
} {
    set thisCoro [info coroutine]
    if {$thisCoro eq {}} {
	return -code error {cwait cannot be called outside a coroutine}
    }
    if {$coroName eq {}} {
	set coroName $thisCoro
    }
    if {[string range $varName 0 1] ne {::}} {
	return -code error {argument varName must be fully qualified}
    }
    if {$timeout eq {}} {
	set toe {}
    } elseif {[string is integer -strict $timeout] && ($timeout > 0)} {
	set toe [after $timeout [list set $varName $timeoutValue]]
    } else {
	return -code error {if timeout is supplied it must be a positive integer}
    }

    set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe]
    trace add variable $varName write $cmd
    CoLog "Yield $varName $coroName"
    yield
    CoLog "Resume $varName $coroName"
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
    return $log
}

proc http::cwaiter::CoLog {msg} {
    variable log
    variable logOn
    if {$logOn} {
        append log $msg \n
    }
    return
}

namespace eval http {
    namespace import ::http::cwaiter::*
}

# Local variables:
# indent-tabs-mode: t
# End:







|











5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
    return $log
}

proc http::cwaiter::CoLog {msg} {
    variable log
    variable logOn
    if {$logOn} {
	append log $msg \n
    }
    return
}

namespace eval http {
    namespace import ::http::cwaiter::*
}

# Local variables:
# indent-tabs-mode: t
# End:

Changes to library/init.tcl.

550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569

    set ns [uplevel 1 [list ::namespace current]]
    set patternList [auto_qualify $pattern $ns]

    auto_load_index

    foreach pattern $patternList {
        foreach name [array names auto_index $pattern] {
            if {([namespace which -command $name] eq "")
		    && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} {
                namespace inscope :: $auto_index($name)
            }
        }
    }
}

# auto_execok --
#
# Returns string that indicates name of program to execute if
# name corresponds to a shell builtin or an executable in the







|
|

|
|
|







550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569

    set ns [uplevel 1 [list ::namespace current]]
    set patternList [auto_qualify $pattern $ns]

    auto_load_index

    foreach pattern $patternList {
	foreach name [array names auto_index $pattern] {
	    if {([namespace which -command $name] eq "")
		    && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} {
		namespace inscope :: $auto_index($name)
	    }
	}
    }
}

# auto_execok --
#
# Returns string that indicates name of program to execute if
# name corresponds to a shell builtin or an executable in the

Changes to library/msgcat/msgcat.tcl.

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the installation directory in the Makefiles.
package provide msgcat 1.7.1

namespace eval msgcat {
    namespace export mc mcn mcexists mcload mclocale mcmax\
	    mcmset mcpreferences mcset\
            mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\
	    mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil

    # Records the list of locales to search
    variable Loclist {}

    # List of currently loaded locales
    variable LoadedLocales {}







|







16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the installation directory in the Makefiles.
package provide msgcat 1.7.1

namespace eval msgcat {
    namespace export mc mcn mcexists mcload mclocale mcmax\
	    mcmset mcpreferences mcset\
	    mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\
	    mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil

    # Records the list of locales to search
    variable Loclist {}

    # List of currently loaded locales
    variable LoadedLocales {}
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
    if {[llength [info level 0]] == 4 } {
	# value provided
	if {$subcommand in {"get" "isset" "unset"}} {
	    return -code error "wrong # args: should be\
		    \"[lrange [info level 0] 0 2] value\""
	}
    } elseif {$subcommand eq "set"} {
        return -code error\
		"wrong # args: should be \"[lrange [info level 0] 0 2]\""
    }

    # Execute subcommands
    switch -exact -- $subcommand {
	get {	# Operation get return current value
	    if {![dict exists $PackageConfig $option $ns]} {







|







734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
    if {[llength [info level 0]] == 4 } {
	# value provided
	if {$subcommand in {"get" "isset" "unset"}} {
	    return -code error "wrong # args: should be\
		    \"[lrange [info level 0] 0 2] value\""
	}
    } elseif {$subcommand eq "set"} {
	return -code error\
		"wrong # args: should be \"[lrange [info level 0] 0 2]\""
    }

    # Execute subcommands
    switch -exact -- $subcommand {
	get {	# Operation get return current value
	    if {![dict exists $PackageConfig $option $ns]} {

Changes to library/opt/optparse.tcl.

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
# and the install directory in the Makefiles.
package provide opt 0.4.9

namespace eval ::tcl {

    # Exported APIs
    namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
             OptProc OptProcArgGiven OptParse \
	     Lempty Lget \
             Lassign Lvarpop Lvarpop1 Lvarset Lvarincr \
             SetMax SetMin


#################  Example of use / 'user documentation'  ###################

    proc OptCreateTestProc {} {

	# Defines ::tcl::OptParseTest as a test proc with parsed arguments
	# (can't be defined before the code below is loaded (before "OptProc"))

	# Every OptProc give usage information on "procname -help".
	# Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and
	# then other arguments.
	#
	# example of 'valid' call:
	# ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\
	#		-nostatics false ch1
	OptProc OptParseTest {
            {subcommand -choice {save print} "sub command"}
            {arg1 3 "some number"}
            {-aflag}
            {-intflag      7}
            {-weirdflag                    "help string"}
            {-noStatics                    "Not ok to load static packages"}
            {-nestedloading1 true           "OK to load into nested children"}
            {-nestedloading2 -boolean true "OK to load into nested children"}
            {-libsOK        -choice {Tk SybTcl}
		                      "List of packages that can be loaded"}
            {-precision     -int 12        "Number of digits of precision"}
            {-intval        7               "An integer"}
            {-scale         -float 1.0     "Scale factor"}
            {-zoom          1.0             "Zoom factor"}
            {-arbitrary     foobar          "Arbitrary string"}
            {-random        -string 12   "Random string"}
            {-listval       -list {}       "List value"}
            {-blahflag       -blah abc       "Funny type"}
	    {arg2 -boolean "a boolean"}
	    {arg3 -choice "ch1 ch2"}
	    {?optarg? -list {} "optional argument"}
        } {
	    foreach v [info locals] {
		puts stderr [format "%14s : %s" $v [set $v]]
	    }
	}
    }

###################  No User serviceable part below ! ###############







|
|
|
|

















|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|



|







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
# and the install directory in the Makefiles.
package provide opt 0.4.9

namespace eval ::tcl {

    # Exported APIs
    namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
	    OptProc OptProcArgGiven OptParse \
	    Lempty Lget \
	    Lassign Lvarpop Lvarpop1 Lvarset Lvarincr \
	    SetMax SetMin


#################  Example of use / 'user documentation'  ###################

    proc OptCreateTestProc {} {

	# Defines ::tcl::OptParseTest as a test proc with parsed arguments
	# (can't be defined before the code below is loaded (before "OptProc"))

	# Every OptProc give usage information on "procname -help".
	# Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and
	# then other arguments.
	#
	# example of 'valid' call:
	# ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\
	#		-nostatics false ch1
	OptProc OptParseTest {
	    {subcommand -choice {save print} "sub command"}
	    {arg1 3 "some number"}
	    {-aflag}
	    {-intflag      7}
	    {-weirdflag                    "help string"}
	    {-noStatics                    "Not ok to load static packages"}
	    {-nestedloading1 true          "OK to load into nested children"}
	    {-nestedloading2 -boolean true "OK to load into nested children"}
	    {-libsOK        -choice {Tk SybTcl}
					   "List of packages that can be loaded"}
	    {-precision     -int 12        "Number of digits of precision"}
	    {-intval        7              "An integer"}
	    {-scale         -float 1.0     "Scale factor"}
	    {-zoom          1.0            "Zoom factor"}
	    {-arbitrary     foobar         "Arbitrary string"}
	    {-random        -string 12     "Random string"}
	    {-listval       -list {}       "List value"}
	    {-blahflag       -blah abc     "Funny type"}
	    {arg2 -boolean "a boolean"}
	    {arg3 -choice "ch1 ch2"}
	    {?optarg? -list {} "optional argument"}
	} {
	    foreach v [info locals] {
		puts stderr [format "%14s : %s" $v [set $v]]
	    }
	}
    }

###################  No User serviceable part below ! ###############
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
# Parse a given description and saves it here under the given key
# generate a unused keyid if not given
#
proc ::tcl::OptKeyRegister {desc {key ""}} {
    variable OptDesc
    variable OptDescN
    if {[string equal $key ""]} {
        # in case a key given to us as a parameter was a number
        while {[info exists OptDesc($OptDescN)]} {incr OptDescN}
        set key $OptDescN
        incr OptDescN
    }
    # program counter
    set program [list [list "P" 1]]

    # are we processing flags (which makes a single program step)
    set inflags 0

    set state {}

    # flag used to detect that we just have a single (flags set) subprogram.
    set empty 1

    foreach item $desc {
	if {$state == "args"} {
	    # more items after 'args'...
	    return -code error "'args' special argument must be the last one"
	}
        set res [OptNormalizeOne $item]
        set state [lindex $res 0]
        if {$inflags} {
            if {$state == "flags"} {
		# add to 'subprogram'
                lappend flagsprg $res
            } else {
                # put in the flags
                # structure for flag programs items is a list of
                # {subprgcounter {prg flag 1} {prg flag 2} {...}}
                lappend program $flagsprg
                # put the other regular stuff
                lappend program $res
		set inflags 0
		set empty 0
            }
        } else {
           if {$state == "flags"} {
               set inflags 1
               # sub program counter + first sub program
               set flagsprg [list [list "P" 1] $res]
           } else {
               lappend program $res
               set empty 0
           }
       }
   }
   if {$inflags} {
       if {$empty} {
	   # We just have the subprogram, optimize and remove
	   # unneeded level:
	   set program $flagsprg







|
|
|
|

















|
|
|
|

|
|
|
|
|
|
|
|


|
|
|
|
|
|
|
|
|
|







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
# Parse a given description and saves it here under the given key
# generate a unused keyid if not given
#
proc ::tcl::OptKeyRegister {desc {key ""}} {
    variable OptDesc
    variable OptDescN
    if {[string equal $key ""]} {
	# in case a key given to us as a parameter was a number
	while {[info exists OptDesc($OptDescN)]} {incr OptDescN}
	set key $OptDescN
	incr OptDescN
    }
    # program counter
    set program [list [list "P" 1]]

    # are we processing flags (which makes a single program step)
    set inflags 0

    set state {}

    # flag used to detect that we just have a single (flags set) subprogram.
    set empty 1

    foreach item $desc {
	if {$state == "args"} {
	    # more items after 'args'...
	    return -code error "'args' special argument must be the last one"
	}
	set res [OptNormalizeOne $item]
	set state [lindex $res 0]
	if {$inflags} {
	    if {$state == "flags"} {
		# add to 'subprogram'
		lappend flagsprg $res
	    } else {
		# put in the flags
		# structure for flag programs items is a list of
		# {subprgcounter {prg flag 1} {prg flag 2} {...}}
		lappend program $flagsprg
		# put the other regular stuff
		lappend program $res
		set inflags 0
		set empty 0
	    }
	} else {
	   if {$state == "flags"} {
	       set inflags 1
	       # sub program counter + first sub program
	       set flagsprg [list [list "P" 1] $res]
	   } else {
	       lappend program $res
	       set empty 0
	   }
       }
   }
   if {$inflags} {
       if {$empty} {
	   # We just have the subprogram, optimize and remove
	   # unneeded level:
	   set program $flagsprg
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
proc ::tcl::OptKeyDelete {key} {
    variable OptDesc
    unset OptDesc($key)
}

    # Get the parsed description stored under the given key.
    proc OptKeyGetDesc {descKey} {
        variable OptDesc
        if {![info exists OptDesc($descKey)]} {
            return -code error "Unknown option description key \"$descKey\""
        }
        set OptDesc($descKey)
    }

# Parse entry point for people who don't want to register with a key,
# for instance because the description changes dynamically.
#  (otherwise one should really use OptKeyRegister once + OptKeyParse
#   as it is way faster or simply OptProc which does it all)
# Assign a temporary key, call OptKeyParse and then free the storage







|
|
|
|
|







215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
proc ::tcl::OptKeyDelete {key} {
    variable OptDesc
    unset OptDesc($key)
}

    # Get the parsed description stored under the given key.
    proc OptKeyGetDesc {descKey} {
	variable OptDesc
	if {![info exists OptDesc($descKey)]} {
	    return -code error "Unknown option description key \"$descKey\""
	}
	set OptDesc($descKey)
    }

# Parse entry point for people who don't want to register with a key,
# for instance because the description changes dynamically.
#  (otherwise one should really use OptKeyRegister once + OptKeyParse
#   as it is way faster or simply OptProc which does it all)
# Assign a temporary key, call OptKeyParse and then free the storage
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
# and add a first line to the code to call the OptKeyParse proc
# Stores the list of variables that have been actually given by the user
# (the other will be sets to their default value)
# into local variable named "Args".
proc ::tcl::OptProc {name desc body} {
    set namespace [uplevel 1 [list ::namespace current]]
    if {[string match "::*" $name] || [string equal $namespace "::"]} {
        # absolute name or global namespace, name is the key
        set key $name
    } else {
        # we are relative to some non top level namespace:
        set key "${namespace}::${name}"
    }
    OptKeyRegister $desc $key
    uplevel 1 [list ::proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"]
    return $key
}
# Check that a argument has been given
# assumes that "OptProc" has been used as it will check in "Args" list







|
|

|
|







244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
# and add a first line to the code to call the OptKeyParse proc
# Stores the list of variables that have been actually given by the user
# (the other will be sets to their default value)
# into local variable named "Args".
proc ::tcl::OptProc {name desc body} {
    set namespace [uplevel 1 [list ::namespace current]]
    if {[string match "::*" $name] || [string equal $namespace "::"]} {
	# absolute name or global namespace, name is the key
	set key $name
    } else {
	# we are relative to some non top level namespace:
	set key "${namespace}::${name}"
    }
    OptKeyRegister $desc $key
    uplevel 1 [list ::proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"]
    return $key
}
# Check that a argument has been given
# assumes that "OptProc" has been used as it will check in "Args" list
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
	    lappend res [Lget $lst $idx]
	}
	return $res
    }

    # Advance to next description
    proc OptNextDesc {descName} {
        uplevel 1 [list Lvarincr $descName {0 1}]
    }

    # Get the current description, eventually descend
    proc OptCurDesc {descriptions} {
        lindex $descriptions [OptGetPrgCounter $descriptions]
    }
    # get the current description, eventually descend
    # through sub programs as needed.
    proc OptCurDescFinal {descriptions} {
        set item [OptCurDesc $descriptions]
	# Descend untill we get the actual item and not a sub program
        while {[OptIsPrg $item]} {
            set item [OptCurDesc $item]
        }
	return $item
    }
    # Current final instruction adress
    proc OptCurAddr {descriptions {start {}}} {
	set adress [OptGetPrgCounter $descriptions]
	lappend start $adress
	set item [lindex $descriptions $adress]
	if {[OptIsPrg $item]} {
	    return [OptCurAddr $item $start]
	} else {
	    return $start
	}
    }
    # Set the value field of the current instruction.
    proc OptCurSetValue {descriptionsName value} {
	upvar $descriptionsName descriptions
	# Get the current item full address.
        set adress [OptCurAddr $descriptions]
	# Use the 3rd field of the item  (see OptValue / OptNewInst).
	lappend adress 2
	Lvarset descriptions $adress [list 1 $value]
	#                                  ^hasBeenSet flag
    }

    # Empty state means done/paste the end of the program.
    proc OptState {item} {
        lindex $item 0
    }

    # current state
    proc OptCurState {descriptions} {
        OptState [OptCurDesc $descriptions]
    }

    #######
    # Arguments manipulation

    # Returns the argument that has to be processed now.
    proc OptCurrentArg {lst} {
        lindex $lst 0
    }
    # Advance to next argument.
    proc OptNextArg {argsName} {
        uplevel 1 [list Lvarpop1 $argsName]
    }
    #######





    # Loop over all descriptions, calling OptDoOne which will
    # eventually eat all the arguments.
    proc OptDoAll {descriptionsName argumentsName} {
	upvar $descriptionsName descriptions
	upvar $argumentsName arguments
#	puts "entered DoAll"
	# Nb: the places where "state" can be set are tricky to figure
	#     because DoOne sets the state to flagsValue and return -continue
	#     when needed...
	set state [OptCurState $descriptions]
	# We'll exit the loop in "OptDoOne" or when state is empty.
        while 1 {
	    set curitem [OptCurDesc $descriptions]
	    # Do subprograms if needed, call ourselves on the sub branch
	    while {[OptIsPrg $curitem]} {
		OptDoAll curitem arguments
#		puts "done DoAll sub"
		# Insert back the results in current tree
		Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\
			$curitem
		OptNextDesc descriptions
		set curitem [OptCurDesc $descriptions]
                set state [OptCurState $descriptions]
	    }
#           puts "state = \"$state\" - arguments=($arguments)"
	    if {[Lempty $state]} {
		# Nothing left to do, we are done in this branch:
		break
	    }
	    # The following statement can make us terminate/continue
	    # as it use return -code {break, continue, return and error}
	    # codes
            OptDoOne descriptions state arguments
	    # If we are here, no special return code where issued,
	    # we'll step to next instruction :
#           puts "new state  = \"$state\""
	    OptNextDesc descriptions
	    set state [OptCurState $descriptions]
        }
    }

    # Process one step for the state machine,
    # eventually consuming the current argument.
    proc OptDoOne {descriptionsName stateName argumentsName} {
        upvar $argumentsName arguments
        upvar $descriptionsName descriptions
	upvar $stateName state

	# the special state/instruction "args" eats all
	# the remaining args (if any)
	if {($state == "args")} {
	    if {![Lempty $arguments]} {
		# If there is no additional arguments, leave the default value







|




|




|

|
|
|

















|








|




|







|



|


















|










|









|





|





|
|







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
	    lappend res [Lget $lst $idx]
	}
	return $res
    }

    # Advance to next description
    proc OptNextDesc {descName} {
	uplevel 1 [list Lvarincr $descName {0 1}]
    }

    # Get the current description, eventually descend
    proc OptCurDesc {descriptions} {
	lindex $descriptions [OptGetPrgCounter $descriptions]
    }
    # get the current description, eventually descend
    # through sub programs as needed.
    proc OptCurDescFinal {descriptions} {
	set item [OptCurDesc $descriptions]
	# Descend untill we get the actual item and not a sub program
	while {[OptIsPrg $item]} {
	    set item [OptCurDesc $item]
	}
	return $item
    }
    # Current final instruction adress
    proc OptCurAddr {descriptions {start {}}} {
	set adress [OptGetPrgCounter $descriptions]
	lappend start $adress
	set item [lindex $descriptions $adress]
	if {[OptIsPrg $item]} {
	    return [OptCurAddr $item $start]
	} else {
	    return $start
	}
    }
    # Set the value field of the current instruction.
    proc OptCurSetValue {descriptionsName value} {
	upvar $descriptionsName descriptions
	# Get the current item full address.
	set adress [OptCurAddr $descriptions]
	# Use the 3rd field of the item  (see OptValue / OptNewInst).
	lappend adress 2
	Lvarset descriptions $adress [list 1 $value]
	#                                  ^hasBeenSet flag
    }

    # Empty state means done/paste the end of the program.
    proc OptState {item} {
	lindex $item 0
    }

    # current state
    proc OptCurState {descriptions} {
	OptState [OptCurDesc $descriptions]
    }

    #######
    # Arguments manipulation

    # Returns the argument that has to be processed now.
    proc OptCurrentArg {lst} {
	lindex $lst 0
    }
    # Advance to next argument.
    proc OptNextArg {argsName} {
	uplevel 1 [list Lvarpop1 $argsName]
    }
    #######





    # Loop over all descriptions, calling OptDoOne which will
    # eventually eat all the arguments.
    proc OptDoAll {descriptionsName argumentsName} {
	upvar $descriptionsName descriptions
	upvar $argumentsName arguments
#	puts "entered DoAll"
	# Nb: the places where "state" can be set are tricky to figure
	#     because DoOne sets the state to flagsValue and return -continue
	#     when needed...
	set state [OptCurState $descriptions]
	# We'll exit the loop in "OptDoOne" or when state is empty.
	while 1 {
	    set curitem [OptCurDesc $descriptions]
	    # Do subprograms if needed, call ourselves on the sub branch
	    while {[OptIsPrg $curitem]} {
		OptDoAll curitem arguments
#		puts "done DoAll sub"
		# Insert back the results in current tree
		Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\
			$curitem
		OptNextDesc descriptions
		set curitem [OptCurDesc $descriptions]
		set state [OptCurState $descriptions]
	    }
#           puts "state = \"$state\" - arguments=($arguments)"
	    if {[Lempty $state]} {
		# Nothing left to do, we are done in this branch:
		break
	    }
	    # The following statement can make us terminate/continue
	    # as it use return -code {break, continue, return and error}
	    # codes
	    OptDoOne descriptions state arguments
	    # If we are here, no special return code where issued,
	    # we'll step to next instruction :
#           puts "new state  = \"$state\""
	    OptNextDesc descriptions
	    set state [OptCurState $descriptions]
	}
    }

    # Process one step for the state machine,
    # eventually consuming the current argument.
    proc OptDoOne {descriptionsName stateName argumentsName} {
	upvar $argumentsName arguments
	upvar $descriptionsName descriptions
	upvar $stateName state

	# the special state/instruction "args" eats all
	# the remaining args (if any)
	if {($state == "args")} {
	    if {![Lempty $arguments]} {
		# If there is no additional arguments, leave the default value
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
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
	    } else {
		return -code error [OptMissingValue $descriptions]
	    }
	} else {
	    set arg [OptCurrentArg $arguments]
	}

        switch $state {
            flags {
                # A non-dash argument terminates the options, as does --

                # Still a flag ?
                if {![OptIsFlag $arg]} {
                    # don't consume the argument, return to previous prg
                    return -code return
                }
                # consume the flag
                OptNextArg arguments
                if {[string equal "--" $arg]} {
                    # return from 'flags' state
                    return -code return
                }

                set hits [OptHits descriptions $arg]
                if {$hits > 1} {
                    return -code error [OptAmbigous $descriptions $arg]
                } elseif {$hits == 0} {
                    return -code error [OptFlagUsage $descriptions $arg]
                }
		set item [OptCurDesc $descriptions]
                if {[OptNeedValue $item]} {
		    # we need a value, next state is
		    set state flagValue
                } else {
                    OptCurSetValue descriptions 1
                }
		# continue
		return -code continue
            }
	    flagValue -
	    value {
		set item [OptCurDesc $descriptions]
                # Test the values against their required type
		if {[catch {OptCheckType $arg\
			[OptType $item] [OptTypeArgs $item]} val]} {
		    return -code error [OptBadValue $item $arg $val]
		}
                # consume the value
                OptNextArg arguments
		# set the value
		OptCurSetValue descriptions $val
		# go to next state
		if {$state == "flagValue"} {
		    set state flags
		    return -code continue
		} else {
		    set state next; # not used, for debug only
		    return ; # will go on next step
		}
	    }
	    optValue {
		set item [OptCurDesc $descriptions]
                # Test the values against their required type
		if {![catch {OptCheckType $arg\
			[OptType $item] [OptTypeArgs $item]} val]} {
		    # right type, so :
		    # consume the value
		    OptNextArg arguments
		    # set the value
		    OptCurSetValue descriptions $val
		}
		# go to next state
		set state next; # not used, for debug only
		return ; # will go on next step
	    }
        }
	# If we reach this point: an unknown
	# state as been entered !
	return -code error "Bug! unknown state in DoOne \"$state\"\
		(prg counter [OptGetPrgCounter $descriptions]:\
			[OptCurDesc $descriptions])"
    }








|
|
|

|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|

|


|
|
|


|



|




|
|













|












|







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
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
	    } else {
		return -code error [OptMissingValue $descriptions]
	    }
	} else {
	    set arg [OptCurrentArg $arguments]
	}

	switch $state {
	    flags {
		# A non-dash argument terminates the options, as does --

		# Still a flag ?
		if {![OptIsFlag $arg]} {
		    # don't consume the argument, return to previous prg
		    return -code return
		}
		# consume the flag
		OptNextArg arguments
		if {[string equal "--" $arg]} {
		    # return from 'flags' state
		    return -code return
		}

		set hits [OptHits descriptions $arg]
		if {$hits > 1} {
		    return -code error [OptAmbigous $descriptions $arg]
		} elseif {$hits == 0} {
		    return -code error [OptFlagUsage $descriptions $arg]
		}
		set item [OptCurDesc $descriptions]
		if {[OptNeedValue $item]} {
		    # we need a value, next state is
		    set state flagValue
		} else {
		    OptCurSetValue descriptions 1
		}
		# continue
		return -code continue
	    }
	    flagValue -
	    value {
		set item [OptCurDesc $descriptions]
		# Test the values against their required type
		if {[catch {OptCheckType $arg\
			[OptType $item] [OptTypeArgs $item]} val]} {
		    return -code error [OptBadValue $item $arg $val]
		}
		# consume the value
		OptNextArg arguments
		# set the value
		OptCurSetValue descriptions $val
		# go to next state
		if {$state == "flagValue"} {
		    set state flags
		    return -code continue
		} else {
		    set state next; # not used, for debug only
		    return ; # will go on next step
		}
	    }
	    optValue {
		set item [OptCurDesc $descriptions]
		# Test the values against their required type
		if {![catch {OptCheckType $arg\
			[OptType $item] [OptTypeArgs $item]} val]} {
		    # right type, so :
		    # consume the value
		    OptNextArg arguments
		    # set the value
		    OptCurSetValue descriptions $val
		}
		# go to next state
		set state next; # not used, for debug only
		return ; # will go on next step
	    }
	}
	# If we reach this point: an unknown
	# state as been entered !
	return -code error "Bug! unknown state in DoOne \"$state\"\
		(prg counter [OptGetPrgCounter $descriptions]:\
			[OptCurDesc $descriptions])"
    }

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
# otherwise returns the canonical value of that arg (ie 0/1 for booleans)
proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
#    puts "checking '$arg' against '$type' ($typeArgs)"

    # only types "any", "choice", and numbers can have leading "-"

    switch -exact -- $type {
        int {
            if {![string is integer -strict $arg]} {
                error "not an integer"
            }
	    return $arg
        }
        float {
            return [expr {double($arg)}]
        }
	script -
        list {
	    # if llength fail : malformed list
            if {[llength $arg]==0 && [OptIsFlag $arg]} {
		error "no values with leading -"
	    }
	    return $arg
        }
        boolean {
	    if {![string is boolean -strict $arg]} {
		error "non canonic boolean"
            }
	    # convert true/false because expr/if is broken with "!,...
	    return [expr {$arg ? 1 : 0}]
        }
        choice {
            if {$arg ni $typeArgs} {
                error "invalid choice"
            }
	    return $arg
        }
	any {
	    return $arg
	}
	string -
	default {
            if {[OptIsFlag $arg]} {
                error "no values with leading -"
            }
	    return $arg
        }
    }
    return neverReached
}

    # internal utilities

    # returns the number of flags matching the given arg
    # sets the (local) prg counter to the list of matches
    proc OptHits {descName arg} {
        upvar $descName desc
        set hits 0
        set hitems {}
	set i 1

	set larg [string tolower $arg]
	set len  [string length $larg]
	set last [expr {$len-1}]

        foreach item [lrange $desc 1 end] {
            set flag [OptName $item]
	    # lets try to match case insensitively
	    # (string length ought to be cheap)
	    set lflag [string tolower $flag]
	    if {$len == [string length $lflag]} {
		if {[string equal $larg $lflag]} {
		    # Exact match case
		    OptSetPrgCounter desc $i
		    return 1
		}
	    } elseif {[string equal $larg [string range $lflag 0 $last]]} {
		lappend hitems $i
		incr hits
            }
	    incr i
        }
	if {$hits} {
	    OptSetPrgCounter desc $hitems
	}
        return $hits
    }

    # Extract fields from the list structure:

    proc OptName {item} {
        lindex $item 1
    }
    proc OptHasBeenSet {item} {
	Lget $item {2 0}
    }
    proc OptValue {item} {
	Lget $item {2 1}
    }

    proc OptIsFlag {name} {
        string match "-*" $name
    }
    proc OptIsOpt {name} {
        string match {\?*} $name
    }
    proc OptVarName {item} {
        set name [OptName $item]
        if {[OptIsFlag $name]} {
            return [string range $name 1 end]
        } elseif {[OptIsOpt $name]} {
	    return [string trim $name "?"]
	} else {
            return $name
        }
    }
    proc OptType {item} {
        lindex $item 3
    }
    proc OptTypeArgs {item} {
        lindex $item 4
    }
    proc OptHelp {item} {
        lindex $item 5
    }
    proc OptNeedValue {item} {
        expr {![string equal [OptType $item] boolflag]}
    }
    proc OptDefaultValue {item} {
        set val [OptTypeArgs $item]
        switch -exact -- [OptType $item] {
            choice {return [lindex $val 0]}
	    boolean -
	    boolflag {
		# convert back false/true to 0/1 because expr !$bool
		# is broken..
		if {$val} {
		    return 1
		} else {
		    return 0
		}
	    }
        }
        return $val
    }

    # Description format error helper
    proc OptOptUsage {item {what ""}} {
        return -code error "invalid description format$what: $item\n\
                should be a list of {varname|-flagname ?-type? ?defaultvalue?\
                ?helpstring?}"
    }


    # Generate a canonical form single instruction
    proc OptNewInst {state varname type typeArgs help} {
	list $state $varname [list 0 {}] $type $typeArgs $help
	#                          ^  ^
	#                          |  |
	#               hasBeenSet=+  +=currentValue
    }

    # Translate one item to canonical form
    proc OptNormalizeOne {item} {
        set lg [Lassign $item varname arg1 arg2 arg3]
#       puts "called optnormalizeone '$item' v=($varname), lg=$lg"
        set isflag [OptIsFlag $varname]
	set isopt  [OptIsOpt  $varname]
        if {$isflag} {
            set state "flags"
        } elseif {$isopt} {
	    set state "optValue"
	} elseif {![string equal $varname "args"]} {
	    set state "value"
	} else {
	    set state "args"
	}

	# apply 'smart' 'fuzzy' logic to try to make
	# description writer's life easy, and our's difficult :
	# let's guess the missing arguments :-)

        switch $lg {
            1 {
                if {$isflag} {
                    return [OptNewInst $state $varname boolflag false ""]
                } else {
                    return [OptNewInst $state $varname any "" ""]
                }
            }
            2 {
                # varname default
                # varname help
                set type [OptGuessType $arg1]
                if {[string equal $type "string"]} {
                    if {$isflag} {
			set type boolflag
			set def false
		    } else {
			set type any
			set def ""
		    }
		    set help $arg1
                } else {
                    set help ""
                    set def $arg1
                }
                return [OptNewInst $state $varname $type $def $help]
            }
            3 {
                # varname type value
                # varname value comment

                if {[regexp {^-(.+)$} $arg1 x type]} {
		    # flags/optValue as they are optional, need a "value",
		    # on the contrary, for a variable (non optional),
	            # default value is pointless, 'cept for choices :
		    if {$isflag || $isopt || ($type == "choice")} {
			return [OptNewInst $state $varname $type $arg2 ""]
		    } else {
			return [OptNewInst $state $varname $type "" $arg2]
		    }
                } else {
                    return [OptNewInst $state $varname\
			    [OptGuessType $arg1] $arg1 $arg2]
                }
            }
            4 {
                if {[regexp {^-(.+)$} $arg1 x type]} {
		    return [OptNewInst $state $varname $type $arg2 $arg3]
                } else {
                    return -code error [OptOptUsage $item]
                }
            }
            default {
                return -code error [OptOptUsage $item]
            }
        }
    }

    # Auto magic lazy type determination
    proc OptGuessType {arg} {
	if { $arg == "true" || $arg == "false" } {
            return boolean
        }
        if {[string is integer -strict $arg]} {
            return int
        }
        if {[string is double -strict $arg]} {
            return float
        }
        return string
    }

    # Error messages front ends

    proc OptAmbigous {desc arg} {
        OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc]
    }
    proc OptFlagUsage {desc arg} {
        OptError "bad flag \"$arg\", must be one of" $desc
    }
    proc OptTooManyArgs {desc arguments} {
        OptError "too many arguments (unexpected argument(s): $arguments),\
		usage:"\
		$desc 1
    }
    proc OptParamType {item} {
	if {[OptIsFlag $item]} {
	    return "flag"
	} else {
	    return "parameter"
	}
    }
    proc OptBadValue {item arg {err {}}} {
#       puts "bad val err = \"$err\""
        OptError "bad value \"$arg\" for [OptParamType $item]"\
		[list $item]
    }
    proc OptMissingValue {descriptions} {
#        set item [OptCurDescFinal $descriptions]
        set item [OptCurDesc $descriptions]
        OptError "no value given for [OptParamType $item] \"[OptName $item]\"\
		(use -help for full usage) :"\
		[list $item]
    }

proc ::tcl::OptKeyError {prefix descKey {header 0}} {
    OptError $prefix [OptKeyGetDesc $descKey] $header
}







|
|
|
|

|
|
|
|

|

|



|
|


|


|
|
|
|
|

|





|
|
|

|









|
|
|






|
|












|

|



|





|









|


|


|
|
|
|


|
|


|


|


|


|


|
|
|










|
|




|
|
|













|

|

|
|
|











|
|
|
|
|
|
|
|
|
|
|
|
|
|







|
|
|
|
|
|
|
|
|

|


|





|
|

|
|
|
|

|
|
|
|
|
|
|
|





|
|
|
|
|
|
|
|
|





|


|


|












|




|
|







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
# otherwise returns the canonical value of that arg (ie 0/1 for booleans)
proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
#    puts "checking '$arg' against '$type' ($typeArgs)"

    # only types "any", "choice", and numbers can have leading "-"

    switch -exact -- $type {
	int {
	    if {![string is integer -strict $arg]} {
		error "not an integer"
	    }
	    return $arg
	}
	float {
	    return [expr {double($arg)}]
	}
	script -
	list {
	    # if llength fail : malformed list
	    if {[llength $arg]==0 && [OptIsFlag $arg]} {
		error "no values with leading -"
	    }
	    return $arg
	}
	boolean {
	    if {![string is boolean -strict $arg]} {
		error "non canonic boolean"
	    }
	    # convert true/false because expr/if is broken with "!,...
	    return [expr {$arg ? 1 : 0}]
	}
	choice {
	    if {$arg ni $typeArgs} {
		error "invalid choice"
	    }
	    return $arg
	}
	any {
	    return $arg
	}
	string -
	default {
	    if {[OptIsFlag $arg]} {
		error "no values with leading -"
	    }
	    return $arg
	}
    }
    return neverReached
}

    # internal utilities

    # returns the number of flags matching the given arg
    # sets the (local) prg counter to the list of matches
    proc OptHits {descName arg} {
	upvar $descName desc
	set hits 0
	set hitems {}
	set i 1

	set larg [string tolower $arg]
	set len  [string length $larg]
	set last [expr {$len-1}]

	foreach item [lrange $desc 1 end] {
	    set flag [OptName $item]
	    # lets try to match case insensitively
	    # (string length ought to be cheap)
	    set lflag [string tolower $flag]
	    if {$len == [string length $lflag]} {
		if {[string equal $larg $lflag]} {
		    # Exact match case
		    OptSetPrgCounter desc $i
		    return 1
		}
	    } elseif {[string equal $larg [string range $lflag 0 $last]]} {
		lappend hitems $i
		incr hits
	    }
	    incr i
	}
	if {$hits} {
	    OptSetPrgCounter desc $hitems
	}
	return $hits
    }

    # Extract fields from the list structure:

    proc OptName {item} {
	lindex $item 1
    }
    proc OptHasBeenSet {item} {
	Lget $item {2 0}
    }
    proc OptValue {item} {
	Lget $item {2 1}
    }

    proc OptIsFlag {name} {
	string match "-*" $name
    }
    proc OptIsOpt {name} {
	string match {\?*} $name
    }
    proc OptVarName {item} {
	set name [OptName $item]
	if {[OptIsFlag $name]} {
	    return [string range $name 1 end]
	} elseif {[OptIsOpt $name]} {
	    return [string trim $name "?"]
	} else {
	    return $name
	}
    }
    proc OptType {item} {
	lindex $item 3
    }
    proc OptTypeArgs {item} {
	lindex $item 4
    }
    proc OptHelp {item} {
	lindex $item 5
    }
    proc OptNeedValue {item} {
	expr {![string equal [OptType $item] boolflag]}
    }
    proc OptDefaultValue {item} {
	set val [OptTypeArgs $item]
	switch -exact -- [OptType $item] {
	    choice {return [lindex $val 0]}
	    boolean -
	    boolflag {
		# convert back false/true to 0/1 because expr !$bool
		# is broken..
		if {$val} {
		    return 1
		} else {
		    return 0
		}
	    }
	}
	return $val
    }

    # Description format error helper
    proc OptOptUsage {item {what ""}} {
	return -code error "invalid description format$what: $item\n\
		should be a list of {varname|-flagname ?-type? ?defaultvalue?\
		?helpstring?}"
    }


    # Generate a canonical form single instruction
    proc OptNewInst {state varname type typeArgs help} {
	list $state $varname [list 0 {}] $type $typeArgs $help
	#                          ^  ^
	#                          |  |
	#               hasBeenSet=+  +=currentValue
    }

    # Translate one item to canonical form
    proc OptNormalizeOne {item} {
	set lg [Lassign $item varname arg1 arg2 arg3]
#       puts "called optnormalizeone '$item' v=($varname), lg=$lg"
	set isflag [OptIsFlag $varname]
	set isopt  [OptIsOpt  $varname]
	if {$isflag} {
	    set state "flags"
	} elseif {$isopt} {
	    set state "optValue"
	} elseif {![string equal $varname "args"]} {
	    set state "value"
	} else {
	    set state "args"
	}

	# apply 'smart' 'fuzzy' logic to try to make
	# description writer's life easy, and our's difficult :
	# let's guess the missing arguments :-)

	switch $lg {
	    1 {
		if {$isflag} {
		    return [OptNewInst $state $varname boolflag false ""]
		} else {
		    return [OptNewInst $state $varname any "" ""]
		}
	    }
	    2 {
		# varname default
		# varname help
		set type [OptGuessType $arg1]
		if {[string equal $type "string"]} {
		    if {$isflag} {
			set type boolflag
			set def false
		    } else {
			set type any
			set def ""
		    }
		    set help $arg1
		} else {
		    set help ""
		    set def $arg1
		}
		return [OptNewInst $state $varname $type $def $help]
	    }
	    3 {
		# varname type value
		# varname value comment

		if {[regexp {^-(.+)$} $arg1 x type]} {
		    # flags/optValue as they are optional, need a "value",
		    # on the contrary, for a variable (non optional),
		    # default value is pointless, 'cept for choices :
		    if {$isflag || $isopt || ($type == "choice")} {
			return [OptNewInst $state $varname $type $arg2 ""]
		    } else {
			return [OptNewInst $state $varname $type "" $arg2]
		    }
		} else {
		    return [OptNewInst $state $varname\
			    [OptGuessType $arg1] $arg1 $arg2]
		}
	    }
	    4 {
		if {[regexp {^-(.+)$} $arg1 x type]} {
		    return [OptNewInst $state $varname $type $arg2 $arg3]
		} else {
		    return -code error [OptOptUsage $item]
		}
	    }
	    default {
		return -code error [OptOptUsage $item]
	    }
	}
    }

    # Auto magic lazy type determination
    proc OptGuessType {arg} {
	if { $arg == "true" || $arg == "false" } {
	    return boolean
	}
	if {[string is integer -strict $arg]} {
	    return int
	}
	if {[string is double -strict $arg]} {
	    return float
	}
	return string
    }

    # Error messages front ends

    proc OptAmbigous {desc arg} {
	OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc]
    }
    proc OptFlagUsage {desc arg} {
	OptError "bad flag \"$arg\", must be one of" $desc
    }
    proc OptTooManyArgs {desc arguments} {
	OptError "too many arguments (unexpected argument(s): $arguments),\
		usage:"\
		$desc 1
    }
    proc OptParamType {item} {
	if {[OptIsFlag $item]} {
	    return "flag"
	} else {
	    return "parameter"
	}
    }
    proc OptBadValue {item arg {err {}}} {
#       puts "bad val err = \"$err\""
	OptError "bad value \"$arg\" for [OptParamType $item]"\
		[list $item]
    }
    proc OptMissingValue {descriptions} {
#        set item [OptCurDescFinal $descriptions]
	set item [OptCurDesc $descriptions]
	OptError "no value given for [OptParamType $item] \"[OptName $item]\"\
		(use -help for full usage) :"\
		[list $item]
    }

proc ::tcl::OptKeyError {prefix descKey {header 0}} {
    OptError $prefix [OptKeyGetDesc $descKey] $header
}
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
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
proc ::tcl::Lempty {list} {
    expr {[llength $list]==0}
}

# Gets the value of one leaf of a lists tree
proc ::tcl::Lget {list indexLst} {
    if {[llength $indexLst] <= 1} {
        return [lindex $list $indexLst]
    }
    Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end]
}
# Sets the value of one leaf of a lists tree
# (we use the version that does not create the elements because
#  it would be even slower... needs to be written in C !)
# (nb: there is a non trivial recursive problem with indexes 0,
#  which appear because there is no difference between a list
#  of 1 element and 1 element alone : [list "a"] == "a" while
#  it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1
#  and [listp "a b"] maybe 0. listp does not exist either...)
proc ::tcl::Lvarset {listName indexLst newValue} {
    upvar $listName list
    if {[llength $indexLst] <= 1} {
        Lvarset1nc list $indexLst $newValue
    } else {
        set idx [lindex $indexLst 0]
        set targetList [lindex $list $idx]
        # reduce refcount on targetList (not really usefull now,
	# could be with optimizing compiler)
#        Lvarset1 list $idx {}
        # recursively replace in targetList
        Lvarset targetList [lrange $indexLst 1 end] $newValue
        # put updated sub list back in the tree
        Lvarset1nc list $idx $targetList
    }
}
# Set one cell to a value, eventually create all the needed elements
# (on level-1 of lists)
variable emptyList {}
proc ::tcl::Lvarset1 {listName index newValue} {
    upvar $listName list
    if {$index < 0} {return -code error "invalid negative index"}
    set lg [llength $list]
    if {$index >= $lg} {
        variable emptyList
        for {set i $lg} {$i<$index} {incr i} {
            lappend list $emptyList
        }
        lappend list $newValue
    } else {
        set list [lreplace $list $index $index $newValue]
    }
}
# same as Lvarset1 but no bound checking / creation
proc ::tcl::Lvarset1nc {listName index newValue} {
    upvar $listName list
    set list [lreplace $list $index $index $newValue]
}
# Increments the value of one leaf of a lists tree
# (which must exists)
proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} {
    upvar $listName list
    if {[llength $indexLst] <= 1} {
        Lvarincr1 list $indexLst $howMuch
    } else {
        set idx [lindex $indexLst 0]
        set targetList [lindex $list $idx]
        # reduce refcount on targetList
        Lvarset1nc list $idx {}
        # recursively replace in targetList
        Lvarincr targetList [lrange $indexLst 1 end] $howMuch
        # put updated sub list back in the tree
        Lvarset1nc list $idx $targetList
    }
}
# Increments the value of one cell of a list
proc ::tcl::Lvarincr1 {listName index {howMuch 1}} {
    upvar $listName list
    set newValue [expr {[lindex $list $index]+$howMuch}]
    set list [lreplace $list $index $index $newValue]







|














|

|
|
|


|
|
|
|










|
|
|
|
|

|












|

|
|
|
|
|
|
|
|







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
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
proc ::tcl::Lempty {list} {
    expr {[llength $list]==0}
}

# Gets the value of one leaf of a lists tree
proc ::tcl::Lget {list indexLst} {
    if {[llength $indexLst] <= 1} {
	return [lindex $list $indexLst]
    }
    Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end]
}
# Sets the value of one leaf of a lists tree
# (we use the version that does not create the elements because
#  it would be even slower... needs to be written in C !)
# (nb: there is a non trivial recursive problem with indexes 0,
#  which appear because there is no difference between a list
#  of 1 element and 1 element alone : [list "a"] == "a" while
#  it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1
#  and [listp "a b"] maybe 0. listp does not exist either...)
proc ::tcl::Lvarset {listName indexLst newValue} {
    upvar $listName list
    if {[llength $indexLst] <= 1} {
	Lvarset1nc list $indexLst $newValue
    } else {
	set idx [lindex $indexLst 0]
	set targetList [lindex $list $idx]
	# reduce refcount on targetList (not really usefull now,
	# could be with optimizing compiler)
#        Lvarset1 list $idx {}
	# recursively replace in targetList
	Lvarset targetList [lrange $indexLst 1 end] $newValue
	# put updated sub list back in the tree
	Lvarset1nc list $idx $targetList
    }
}
# Set one cell to a value, eventually create all the needed elements
# (on level-1 of lists)
variable emptyList {}
proc ::tcl::Lvarset1 {listName index newValue} {
    upvar $listName list
    if {$index < 0} {return -code error "invalid negative index"}
    set lg [llength $list]
    if {$index >= $lg} {
	variable emptyList
	for {set i $lg} {$i<$index} {incr i} {
	    lappend list $emptyList
	}
	lappend list $newValue
    } else {
	set list [lreplace $list $index $index $newValue]
    }
}
# same as Lvarset1 but no bound checking / creation
proc ::tcl::Lvarset1nc {listName index newValue} {
    upvar $listName list
    set list [lreplace $list $index $index $newValue]
}
# Increments the value of one leaf of a lists tree
# (which must exists)
proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} {
    upvar $listName list
    if {[llength $indexLst] <= 1} {
	Lvarincr1 list $indexLst $howMuch
    } else {
	set idx [lindex $indexLst 0]
	set targetList [lindex $list $idx]
	# reduce refcount on targetList
	Lvarset1nc list $idx {}
	# recursively replace in targetList
	Lvarincr targetList [lrange $indexLst 1 end] $howMuch
	# put updated sub list back in the tree
	Lvarset1nc list $idx $targetList
    }
}
# Increments the value of one cell of a list
proc ::tcl::Lvarincr1 {listName index {howMuch 1}} {
    upvar $listName list
    set newValue [expr {[lindex $list $index]+$howMuch}]
    set list [lreplace $list $index $index $newValue]
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
}
# Assign list elements to variables and return the length of the list
proc ::tcl::Lassign {list args} {
    # faster than direct blown foreach (which does not byte compile)
    set i 0
    set lg [llength $list]
    foreach vname $args {
        if {$i>=$lg} break
        uplevel 1 [list ::set $vname [lindex $list $i]]
        incr i
    }
    return $lg
}

# Misc utilities

# Set the varname to value if value is greater than varname's current value
# or if varname is undefined
proc ::tcl::SetMax {varname value} {
    upvar 1 $varname var
    if {![info exists var] || $value > $var} {
        set var $value
    }
}

# Set the varname to value if value is smaller than varname's current value
# or if varname is undefined
proc ::tcl::SetMin {varname value} {
    upvar 1 $varname var
    if {![info exists var] || $value < $var} {
        set var $value
    }
}


    # everything loaded fine, lets create the test proc:
 #    OptCreateTestProc
    # Don't need the create temp proc anymore:
 #    rename OptCreateTestProc {}
}







|
|
|











|








|









1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
}
# Assign list elements to variables and return the length of the list
proc ::tcl::Lassign {list args} {
    # faster than direct blown foreach (which does not byte compile)
    set i 0
    set lg [llength $list]
    foreach vname $args {
	if {$i>=$lg} break
	uplevel 1 [list ::set $vname [lindex $list $i]]
	incr i
    }
    return $lg
}

# Misc utilities

# Set the varname to value if value is greater than varname's current value
# or if varname is undefined
proc ::tcl::SetMax {varname value} {
    upvar 1 $varname var
    if {![info exists var] || $value > $var} {
	set var $value
    }
}

# Set the varname to value if value is smaller than varname's current value
# or if varname is undefined
proc ::tcl::SetMin {varname value} {
    upvar 1 $varname var
    if {![info exists var] || $value < $var} {
	set var $value
    }
}


    # everything loaded fine, lets create the test proc:
 #    OptCreateTestProc
    # Don't need the create temp proc anymore:
 #    rename OptCreateTestProc {}
}

Changes to library/package.tcl.

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
# Results:
#  Returns 1 if the extension matches, 0 otherwise

proc tcl::Pkg::CompareExtension {fileName {ext {}}} {
    global tcl_platform
    if {$ext eq ""} {set ext [info sharedlibextension]}
    if {$tcl_platform(platform) eq "windows"} {
        return [string equal -nocase [file extension $fileName] $ext]
    } else {
        # Some unices add trailing numbers after the .so, so
        # we could have something like '.so.1.2'.
        set root $fileName
        while {1} {
            set currExt [file extension $root]
            if {$currExt eq $ext} {
                return 1
            }

	    # The current extension does not match; if it is not a numeric
	    # value, quit, as we are only looking to ignore version number
	    # extensions.  Otherwise we might return 1 in this case:
	    #		tcl::Pkg::CompareExtension foo.so.bar .so
	    # which should not match.

	    if {![string is integer -strict [string range $currExt 1 end]]} {
		return 0
	    }
            set root [file rootname $root]
	}
    }
}

# pkg_mkIndex --
# This procedure creates a package index in a given directory.  The package
# index consists of a "pkgIndex.tcl" file whose contents are a Tcl script that







|

|
|
|
|
|
|
|
|










|







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
# Results:
#  Returns 1 if the extension matches, 0 otherwise

proc tcl::Pkg::CompareExtension {fileName {ext {}}} {
    global tcl_platform
    if {$ext eq ""} {set ext [info sharedlibextension]}
    if {$tcl_platform(platform) eq "windows"} {
	return [string equal -nocase [file extension $fileName] $ext]
    } else {
	# Some unices add trailing numbers after the .so, so
	# we could have something like '.so.1.2'.
	set root $fileName
	while {1} {
	    set currExt [file extension $root]
	    if {$currExt eq $ext} {
		return 1
	    }

	    # The current extension does not match; if it is not a numeric
	    # value, quit, as we are only looking to ignore version number
	    # extensions.  Otherwise we might return 1 in this case:
	    #		tcl::Pkg::CompareExtension foo.so.bar .so
	    # which should not match.

	    if {![string is integer -strict [string range $currExt 1 end]]} {
		return 0
	    }
	    set root [file rootname $root]
	}
    }
}

# pkg_mkIndex --
# This procedure creates a package index in a given directory.  The package
# index consists of a "pkgIndex.tcl" file whose contents are a Tcl script that

Changes to library/platform/shell.tcl.

127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
    set    cc [open $c w]
    puts  $cc $code
    close $cc

    set e [TEMP]

    set code [catch {
        exec $shell $c 2> $e
    } res]

    file delete $c

    if {$code} {
	append res \n[read [set chan [open $e r]]][close $chan]
	file delete $e







|







127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
    set    cc [open $c w]
    puts  $cc $code
    close $cc

    set e [TEMP]

    set code [catch {
	exec $shell $c 2> $e
    } res]

    file delete $c

    if {$code} {
	append res \n[read [set chan [open $e r]]][close $chan]
	file delete $e

Changes to library/safe.tcl.

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

# Interface/entry point function and front end for "Create"
proc ::safe::interpCreate {args} {
    variable AutoPathSync
    if {$AutoPathSync} {
        set autoPath {}
    }
    set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
    RejectExcessColons $child

    set withAutoPath [::tcl::OptProcArgGiven -autoPath]
    InterpCreate $child $accessPath \
	[InterpStatics] [InterpNested] $deleteHook $autoPath $withAutoPath
}

proc ::safe::interpInit {args} {
    variable AutoPathSync
    if {$AutoPathSync} {
        set autoPath {}
    }
    set Args [::tcl::OptKeyParse ::safe::interpIC $args]
    if {![::interp exists $child]} {
	return -code error "\"$child\" is not an interpreter"
    }
    RejectExcessColons $child








|












|







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

# Interface/entry point function and front end for "Create"
proc ::safe::interpCreate {args} {
    variable AutoPathSync
    if {$AutoPathSync} {
	set autoPath {}
    }
    set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
    RejectExcessColons $child

    set withAutoPath [::tcl::OptProcArgGiven -autoPath]
    InterpCreate $child $accessPath \
	[InterpStatics] [InterpNested] $deleteHook $autoPath $withAutoPath
}

proc ::safe::interpInit {args} {
    variable AutoPathSync
    if {$AutoPathSync} {
	set autoPath {}
    }
    set Args [::tcl::OptKeyParse ::safe::interpIC $args]
    if {![::interp exists $child]} {
	return -code error "\"$child\" is not an interpreter"
    }
    RejectExcessColons $child

140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
	    CheckInterp $child
	    namespace upvar ::safe [VarName $child] state

	    set TMP [list \
		[list -accessPath $state(access_path)] \
		[list -statics    $state(staticsok)]   \
		[list -nested     $state(nestedok)]    \
	        [list -deleteHook $state(cleanupHook)] \
	    ]
	    if {!$AutoPathSync} {
	        lappend TMP [list -autoPath $state(auto_path)]
	    }
	    return [join $TMP]
	}
	2 {
	    # If we have exactly 2 arguments the semantic is a "configure
	    # get"
	    lassign $args child arg







|


|







140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
	    CheckInterp $child
	    namespace upvar ::safe [VarName $child] state

	    set TMP [list \
		[list -accessPath $state(access_path)] \
		[list -statics    $state(staticsok)]   \
		[list -nested     $state(nestedok)]    \
		[list -deleteHook $state(cleanupHook)] \
	    ]
	    if {!$AutoPathSync} {
		lappend TMP [list -autoPath $state(auto_path)]
	    }
	    return [join $TMP]
	}
	2 {
	    # If we have exactly 2 arguments the semantic is a "configure
	    # get"
	    lassign $args child arg
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
	    set name [::tcl::OptName $item]
	    switch -exact -- $name {
		-accessPath {
		    return [list -accessPath $state(access_path)]
		}
		-autoPath {
		    if {$AutoPathSync} {
		        return -code error "unknown flag $name (bug)"
		    } else {
		        return [list -autoPath $state(auto_path)]
		    }
		}
		-statics    {
		    return [list -statics $state(staticsok)]
		}
		-nested     {
		    return [list -nested $state(nestedok)]







|

|







172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
	    set name [::tcl::OptName $item]
	    switch -exact -- $name {
		-accessPath {
		    return [list -accessPath $state(access_path)]
		}
		-autoPath {
		    if {$AutoPathSync} {
			return -code error "unknown flag $name (bug)"
		    } else {
			return [list -autoPath $state(auto_path)]
		    }
		}
		-statics    {
		    return [list -statics $state(staticsok)]
		}
		-nested     {
		    return [list -nested $state(nestedok)]
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
	set raw_auto_path $access_path

	# Add 1st level subdirs (will searched by auto loading from tcl
	# code in the child using glob and thus fail, so we add them here
	# so by default it works the same).
	set access_path [AddSubDirs $access_path]
    } else {
        set raw_auto_path $autoPath
    }

    if {$withAutoPath} {
        set raw_auto_path $autoPath
    }

    Log $child "Setting accessPath=($access_path) staticsok=$staticsok\
		nestedok=$nestedok deletehook=($deletehook)" NOTICE
    if {!$AutoPathSync} {
        Log $child "Setting auto_path=($raw_auto_path)" NOTICE
    }

    namespace upvar ::safe [VarName $child] state

    # clear old autopath if it existed
    # build new one
    # Extend the access list with the paths used to look for Tcl Modules.







|



|





|







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
	set raw_auto_path $access_path

	# Add 1st level subdirs (will searched by auto loading from tcl
	# code in the child using glob and thus fail, so we add them here
	# so by default it works the same).
	set access_path [AddSubDirs $access_path]
    } else {
	set raw_auto_path $autoPath
    }

    if {$withAutoPath} {
	set raw_auto_path $autoPath
    }

    Log $child "Setting accessPath=($access_path) staticsok=$staticsok\
		nestedok=$nestedok deletehook=($deletehook)" NOTICE
    if {!$AutoPathSync} {
	Log $child "Setting auto_path=($raw_auto_path)" NOTICE
    }

    namespace upvar ::safe [VarName $child] state

    # clear old autopath if it existed
    # build new one
    # Extend the access list with the paths used to look for Tcl Modules.
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
	set addpaths $morepaths
	set morepaths {}

	foreach dir $addpaths {
	    # Prevent the addition of dirs on the tm list to the
	    # result if they are already known.
	    if {[dict exists $remap_access_path $dir]} {
	        if {$firstpass} {
		    # $dir is in [::tcl::tm::list] and belongs in the child_tm_path.
		    # Later passes handle subdirectories, which belong in the
		    # access path but not in the module path.
		    lappend child_tm_path  [dict get $remap_access_path $dir]
		}
		continue
	    }







|







437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
	set addpaths $morepaths
	set morepaths {}

	foreach dir $addpaths {
	    # Prevent the addition of dirs on the tm list to the
	    # result if they are already known.
	    if {[dict exists $remap_access_path $dir]} {
		if {$firstpass} {
		    # $dir is in [::tcl::tm::list] and belongs in the child_tm_path.
		    # Later passes handle subdirectories, which belong in the
		    # access path but not in the module path.
		    lappend child_tm_path  [dict get $remap_access_path $dir]
		}
		continue
	    }
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
    set state(access_path,child) $child_access_path
    set state(tm_path_child)     $child_tm_path
    set state(staticsok)         $staticsok
    set state(nestedok)          $nestedok
    set state(cleanupHook)       $deletehook

    if {!$AutoPathSync} {
        set state(auto_path)     $raw_auto_path
    }

    SyncAccessPath $child
    return
}









|







482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
    set state(access_path,child) $child_access_path
    set state(tm_path_child)     $child_tm_path
    set state(staticsok)         $staticsok
    set state(nestedok)          $nestedok
    set state(cleanupHook)       $deletehook

    if {!$AutoPathSync} {
	set state(auto_path)     $raw_auto_path
    }

    SyncAccessPath $child
    return
}


683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699

    # When an interpreter is deleted with [interp delete], any sub-interpreters
    # are deleted automatically, but this leaves behind their data in the Safe
    # Base. To clean up properly, we call safe::interpDelete recursively on each
    # Safe Base sub-interpreter, so each one is deleted cleanly and not by
    # the automatic mechanism built into [interp delete].
    foreach sub [interp children $child] {
        if {[info exists ::safe::[VarName [list $child $sub]]]} {
            ::safe::interpDelete [list $child $sub]
        }
    }

    # If the child has a cleanup hook registered, call it.  Check the
    # existence because we might be called to delete an interp which has
    # not been registered with us at all

    if {[info exists state(cleanupHook)]} {







|
|
|







683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699

    # When an interpreter is deleted with [interp delete], any sub-interpreters
    # are deleted automatically, but this leaves behind their data in the Safe
    # Base. To clean up properly, we call safe::interpDelete recursively on each
    # Safe Base sub-interpreter, so each one is deleted cleanly and not by
    # the automatic mechanism built into [interp delete].
    foreach sub [interp children $child] {
	if {[info exists ::safe::[VarName [list $child $sub]]]} {
	    ::safe::interpDelete [list $child $sub]
	}
    }

    # If the child has a cleanup hook registered, call it.  Check the
    # existence because we might be called to delete an interp which has
    # not been registered with us at all

    if {[info exists state(cleanupHook)]} {
1078
1079
1080
1081
1082
1083
1084




1085
1086
1087
1088
1089
1090
1091
	set f [open $realfile]
	fconfigure $f -encoding $encoding -eofchar \x1A
	set contents [read $f]
	close $f
	::interp eval $child [list info script $file]
    } msg opt]
    if {$code == 0} {




	set code [catch {::interp eval $child $contents} msg opt]
	set replacementMsg $msg
    }
    catch {interp eval $child [list info script $old]}
    # Note that all non-errors are fine result codes from [source], so we must
    # take a little care to do it properly. [Bug 2923613]
    if {$code == 1} {







>
>
>
>







1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
	set f [open $realfile]
	fconfigure $f -encoding $encoding -eofchar \x1A
	set contents [read $f]
	close $f
	::interp eval $child [list info script $file]
    } msg opt]
    if {$code == 0} {
	# See [Bug 1d26e580cf]
	if {[string index $contents 0] eq "\uFEFF"} {
	    set contents [string range $contents 1 end]
	}
	set code [catch {::interp eval $child $contents} msg opt]
	set replacementMsg $msg
    }
    catch {interp eval $child [list info script $old]}
    # Note that all non-errors are fine result codes from [source], so we must
    # take a little care to do it properly. [Bug 2923613]
    if {$code == 1} {
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
#     becomes
#         namespace upvar ::safe [VarName $child] state
# ------------------------------------------------------------------------------

proc ::safe::RejectExcessColons {child} {
    set stripped [regsub -all -- {:::*} $child ::]
    if {[string range $stripped end-1 end] eq {::}} {
        return -code error {interpreter name must not end in "::"}
    }
    if {$stripped ne $child} {
        set msg {interpreter name has excess colons in namespace separators}
        return -code error $msg
    }
    if {[string range $stripped 0 1] eq {::}} {
        return -code error {interpreter name must not begin "::"}
    }
    return
}

proc ::safe::VarName {child} {
    # return S$child
    return S[string map {:: @N @ @A} $child]







|


|
|


|







1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
#     becomes
#         namespace upvar ::safe [VarName $child] state
# ------------------------------------------------------------------------------

proc ::safe::RejectExcessColons {child} {
    set stripped [regsub -all -- {:::*} $child ::]
    if {[string range $stripped end-1 end] eq {::}} {
	return -code error {interpreter name must not end in "::"}
    }
    if {$stripped ne $child} {
	set msg {interpreter name has excess colons in namespace separators}
	return -code error $msg
    }
    if {[string range $stripped 0 1] eq {::}} {
	return -code error {interpreter name must not begin "::"}
    }
    return
}

proc ::safe::VarName {child} {
    # return S$child
    return S[string map {:: @N @ @A} $child]
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
	{-noStatics "prevent loading of statically linked pkgs"}
	{-statics true "loading of statically linked pkgs"}
	{-nestedLoadOk "allow nested loading"}
	{-nested false "nested loading"}
	{-deleteHook -script {} "delete hook"}
    }
    if {!$AutoPathSync} {
        lappend OptList {-autoPath -list {} "::auto_path for the child"}
    }
    set temp [::tcl::OptKeyRegister $OptList]

    # create case (child is optional)
    ::tcl::OptKeyRegister {
	{?child? -name {} "name of the child (optional)"}
    } ::safe::interpCreate







|







1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
	{-noStatics "prevent loading of statically linked pkgs"}
	{-statics true "loading of statically linked pkgs"}
	{-nestedLoadOk "allow nested loading"}
	{-nested false "nested loading"}
	{-deleteHook -script {} "delete hook"}
    }
    if {!$AutoPathSync} {
	lappend OptList {-autoPath -list {} "::auto_path for the child"}
    }
    set temp [::tcl::OptKeyRegister $OptList]

    # create case (child is optional)
    ::tcl::OptKeyRegister {
	{?child? -name {} "name of the child (optional)"}
    } ::safe::interpCreate
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
#  because Setup has not yet been called.)

proc ::safe::setSyncMode {args} {
    variable AutoPathSync

    if {[llength $args] == 0} {
    } elseif {[llength $args] == 1} {
        set newValue [lindex $args 0]
        if {![string is boolean -strict $newValue]} {
            return -code error "new value must be a valid boolean"
        }
        set args [expr {$newValue && $newValue}]
        if {([info vars ::safe::S*] ne {}) && ($args != $AutoPathSync)} {
            return -code error \
                    "cannot set new value while Safe Base child interpreters exist"
        }
        if {($args != $AutoPathSync)} {
            set AutoPathSync {*}$args
            ::tcl::OptKeyDelete ::safe::interpCreate
            ::tcl::OptKeyDelete ::safe::interpIC
            set TmpLog [setLogCmd]
            Setup
            setLogCmd $TmpLog
        }
    } else {
        set msg {wrong # args: should be "safe::setSyncMode ?newValue?"}
        return -code error $msg
    }

    return $AutoPathSync
}

namespace eval ::safe {
    # internal variables (must not begin with "S")







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|







1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
#  because Setup has not yet been called.)

proc ::safe::setSyncMode {args} {
    variable AutoPathSync

    if {[llength $args] == 0} {
    } elseif {[llength $args] == 1} {
	set newValue [lindex $args 0]
	if {![string is boolean -strict $newValue]} {
	    return -code error "new value must be a valid boolean"
	}
	set args [expr {$newValue && $newValue}]
	if {([info vars ::safe::S*] ne {}) && ($args != $AutoPathSync)} {
	    return -code error \
		    "cannot set new value while Safe Base child interpreters exist"
	}
	if {($args != $AutoPathSync)} {
	    set AutoPathSync {*}$args
	    ::tcl::OptKeyDelete ::safe::interpCreate
	    ::tcl::OptKeyDelete ::safe::interpIC
	    set TmpLog [setLogCmd]
	    Setup
	    setLogCmd $TmpLog
	}
    } else {
	set msg {wrong # args: should be "safe::setSyncMode ?newValue?"}
	return -code error $msg
    }

    return $AutoPathSync
}

namespace eval ::safe {
    # internal variables (must not begin with "S")

Changes to library/tcltest/tcltest.tcl.

1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
#
# Side effects:
#       None.

proc tcltest::Asciify {s} {
    set print ""
    foreach c [split $s ""] {
        if {(($c < "\x7F") && [string is print $c]) || ($c eq "\n")} {
            append print $c
        } elseif {$c < "\u0100"} {
            append print \\x[format %02X [scan $c %c]]
        } elseif {$c > "\uFFFF"} {
            append print \\U[format %08X [scan $c %c]]
        } else {
            append print \\u[format %04X [scan $c %c]]
        }
    }
    return $print
}

# tcltest::ConstraintInitializer --
#
#	Get or set a script that when evaluated in the tcltest namespace







|
|
|
|
|
|
|
|
|







1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
#
# Side effects:
#       None.

proc tcltest::Asciify {s} {
    set print ""
    foreach c [split $s ""] {
	if {(($c < "\x7F") && [string is print $c]) || ($c eq "\n")} {
	    append print $c
	} elseif {$c < "\u0100"} {
	    append print \\x[format %02X [scan $c %c]]
	} elseif {$c > "\uFFFF"} {
	    append print \\U[format %08X [scan $c %c]]
	} else {
	    append print \\u[format %04X [scan $c %c]]
	}
    }
    return $print
}

# tcltest::ConstraintInitializer --
#
#	Get or set a script that when evaluated in the tcltest namespace
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
    ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}

    # Test to see if execed commands such as cat, echo, rm and so forth
    # are present on this machine.

    ConstraintInitializer unixExecs {
	set code 1
        if {$::tcl_platform(platform) eq "macintosh"} {
	    set code 0
        }
        if {$::tcl_platform(platform) eq "windows"} {
	    if {[catch {
	        set file _tcl_test_remove_me.txt
	        makeFile {hello} $file
	    }]} {
	        set code 0
	    } elseif {
	        [catch {exec cat $file}] ||
	        [catch {exec echo hello}] ||
	        [catch {exec sh -c echo hello}] ||
	        [catch {exec wc $file}] ||
	        [catch {exec sleep 1}] ||
	        [catch {exec echo abc > $file}] ||
	        [catch {exec chmod 644 $file}] ||
	        [catch {exec rm $file}] ||
	        [llength [auto_execok mkdir]] == 0 ||
	        [llength [auto_execok fgrep]] == 0 ||
	        [llength [auto_execok grep]] == 0 ||
	        [llength [auto_execok ps]] == 0
	    } {
	        set code 0
	    }
	    removeFile $file
        }
	set code
    }

    ConstraintInitializer stdio {
	variable fullutf

	set code 0







|

|
|

|
|

|

|
|
|
|
|
|
|
|
|
|
|
|

|


|







1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
    ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}

    # Test to see if execed commands such as cat, echo, rm and so forth
    # are present on this machine.

    ConstraintInitializer unixExecs {
	set code 1
	if {$::tcl_platform(platform) eq "macintosh"} {
	    set code 0
	}
	if {$::tcl_platform(platform) eq "windows"} {
	    if {[catch {
		set file _tcl_test_remove_me.txt
		makeFile {hello} $file
	    }]} {
		set code 0
	    } elseif {
		[catch {exec cat $file}] ||
		[catch {exec echo hello}] ||
		[catch {exec sh -c echo hello}] ||
		[catch {exec wc $file}] ||
		[catch {exec sleep 1}] ||
		[catch {exec echo abc > $file}] ||
		[catch {exec chmod 644 $file}] ||
		[catch {exec rm $file}] ||
		[llength [auto_execok mkdir]] == 0 ||
		[llength [auto_execok fgrep]] == 0 ||
		[llength [auto_execok grep]] == 0 ||
		[llength [auto_execok ps]] == 0
	    } {
		set code 0
	    }
	    removeFile $file
	}
	set code
    }

    ConstraintInitializer stdio {
	variable fullutf

	set code 0
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
		    "missing value for option [lindex $args 0]"
	    exit 1
	}
    }

    # Call the hook
    catch {
        array set flag $flagArray
        processCmdLineArgsHook [array get flag]
    }
    return
}

# tcltest::ProcessCmdLineArgs --
#
#       This procedure must be run after constraint initialization is







|
|







1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
		    "missing value for option [lindex $args 0]"
	    exit 1
	}
    }

    # Call the hook
    catch {
	array set flag $flagArray
	processCmdLineArgsHook [array get flag]
    }
    return
}

# tcltest::ProcessCmdLineArgs --
#
#       This procedure must be run after constraint initialization is
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
	1 {
	    # Only the string to be printed is specified
	    append outData [lindex $args 0]\n
	    return
	    # return [Puts [lindex $args 0]]
	}
	2 {
	    # Either -nonewline or channelId has been specified
	    if {[lindex $args 0] eq "-nonewline"} {
		append outData [lindex $args end]
		return
		# return [Puts -nonewline [lindex $args end]]
	    } else {
		set channel [lindex $args 0]
		set newline \n
	    }
	}
	3 {
	    if {[lindex $args 0] eq "-nonewline"} {
		# Both -nonewline and channelId are specified, unless
		# it's an error.  -nonewline is supposed to be argv[0].
		set channel [lindex $args 1]
		set newline ""
	    }
	}
    }








|











|







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
	1 {
	    # Only the string to be printed is specified
	    append outData [lindex $args 0]\n
	    return
	    # return [Puts [lindex $args 0]]
	}
	2 {
	    # Either -nonewline or channel has been specified
	    if {[lindex $args 0] eq "-nonewline"} {
		append outData [lindex $args end]
		return
		# return [Puts -nonewline [lindex $args end]]
	    } else {
		set channel [lindex $args 0]
		set newline \n
	    }
	}
	3 {
	    if {[lindex $args 0] eq "-nonewline"} {
		# Both -nonewline and channel are specified, unless
		# it's an error.  -nonewline is supposed to be argv[0].
		set channel [lindex $args 1]
		set newline ""
	    }
	}
    }

1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
#
# Side effects:
#	None.

proc tcltest::CompareStrings {actual expected mode} {
    variable CustomMatch
    if {![info exists CustomMatch($mode)]} {
        return -code error "No matching command registered for `-match $mode'"
    }
    set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]]
    if {[catch {expr {$match && $match}} result]} {
	return -code error "Invalid result from `-match $mode' command: $result"
    }
    return $match
}







|







1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
#
# Side effects:
#	None.

proc tcltest::CompareStrings {actual expected mode} {
    variable CustomMatch
    if {![info exists CustomMatch($mode)]} {
	return -code error "No matching command registered for `-match $mode'"
    }
    set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]]
    if {[catch {expr {$match && $match}} result]} {
	return -code error "Invalid result from `-match $mode' command: $result"
    }
    return $match
}
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
    # separated strings as it throws away the whitespace which maybe
    # important so we have to do it all by hand.

    set result {}
    set token ""

    while {[string length $argList]} {
        # Look for the next word containing a quote: " { }
        if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
		$argList all]} {
            # Get the text leading up to this word, but not including
	    # this word, from the argList.
            set text [string range $argList 0 \
		    [expr {[lindex $all 0] - 1}]]
            # Get the word with the quote
            set word [string range $argList \
                    [lindex $all 0] [lindex $all 1]]

            # Remove all text up to and including the word from the
            # argList.
            set argList [string range $argList \
                    [expr {[lindex $all 1] + 1}] end]
        } else {
            # Take everything up to the end of the argList.
            set text $argList
            set word {}
            set argList {}
        }

        if {$token ne {}} {
            # If we saw a word with quote before, then there is a
            # multi-word token starting with that word.  In this case,
            # add the text and the current word to this token.
            append token $text $word
        } else {
            # Add the text to the result.  There is no need to parse
            # the text because it couldn't be a part of any multi-word
            # token.  Then start a new multi-word token with the word
            # because we need to pass this token to the Tcl parser to
            # check for balancing quotes
            append result $text
            set token $word
        }

        if { [catch {llength $token} length] == 0 && $length == 1} {
            # The token is a valid list so add it to the result.
            # lappend result [string trim $token]
            append result \{$token\}
            set token {}
        }
    }

    # If the last token has not been added to the list then there
    # is a problem.
    if { [string length $token] } {
        error "incomplete token \"$token\""
    }

    return $result
}


# tcltest::test --







|
|

|

|

|
|
|

|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|





|







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
    # separated strings as it throws away the whitespace which maybe
    # important so we have to do it all by hand.

    set result {}
    set token ""

    while {[string length $argList]} {
	# Look for the next word containing a quote: " { }
	if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
		$argList all]} {
	    # Get the text leading up to this word, but not including
	    # this word, from the argList.
	    set text [string range $argList 0 \
		    [expr {[lindex $all 0] - 1}]]
	    # Get the word with the quote
	    set word [string range $argList \
		    [lindex $all 0] [lindex $all 1]]

	    # Remove all text up to and including the word from the
	    # argList.
	    set argList [string range $argList \
		    [expr {[lindex $all 1] + 1}] end]
	} else {
	    # Take everything up to the end of the argList.
	    set text $argList
	    set word {}
	    set argList {}
	}

	if {$token ne {}} {
	    # If we saw a word with quote before, then there is a
	    # multi-word token starting with that word.  In this case,
	    # add the text and the current word to this token.
	    append token $text $word
	} else {
	    # Add the text to the result.  There is no need to parse
	    # the text because it couldn't be a part of any multi-word
	    # token.  Then start a new multi-word token with the word
	    # because we need to pass this token to the Tcl parser to
	    # check for balancing quotes
	    append result $text
	    set token $word
	}

	if { [catch {llength $token} length] == 0 && $length == 1} {
	    # The token is a valid list so add it to the result.
	    # lappend result [string trim $token]
	    append result \{$token\}
	    set token {}
	}
    }

    # If the last token has not been added to the list then there
    # is a problem.
    if { [string length $token] } {
	error "incomplete token \"$token\""
    }

    return $result
}


# tcltest::test --
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
		    must be $values"
	}

	# Replace symbolic valies supplied for -returnCodes
	foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
	    set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
	}
        # errorCode without returnCode 1 is meaningless
        if {$errorCode ne "*" && 1 ni $returnCodes} {
            set returnCodes 1
        }
    } else {
	# This is parsing for the old test command format; it is here
	# for backward compatibility.
	set result [lindex $args end]
	if {[llength $args] == 2} {
	    set body [lindex $args 0]
	} elseif {[llength $args] == 3} {







|
|
|
|







2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
		    must be $values"
	}

	# Replace symbolic valies supplied for -returnCodes
	foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
	    set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
	}
	# errorCode without returnCode 1 is meaningless
	if {$errorCode ne "*" && 1 ni $returnCodes} {
	    set returnCodes 1
	}
    } else {
	# This is parsing for the old test command format; it is here
	# for backward compatibility.
	set result [lindex $args end]
	if {[llength $args] == 2} {
	    set body [lindex $args 0]
	} elseif {[llength $args] == 3} {
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
    # check if the return code matched the expected return code
    set codeFailure 0
    if {$processTest && !$setupFailure && ($returnCode ni $returnCodes)} {
	set codeFailure 1
    }
    set errorCodeFailure 0
    if {$processTest && !$setupFailure && !$codeFailure && $returnCode == 1 && \
                ![string match $errorCode $errorCodeRes(body)]} {
	set errorCodeFailure 1
    }

    # If expected output/error strings exist, we have to compare
    # them.  If the comparison fails, then so did the test.
    set outputFailure 0
    variable outData







|







2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
    # check if the return code matched the expected return code
    set codeFailure 0
    if {$processTest && !$setupFailure && ($returnCode ni $returnCodes)} {
	set codeFailure 1
    }
    set errorCodeFailure 0
    if {$processTest && !$setupFailure && !$codeFailure && $returnCode == 1 && \
	    ![string match $errorCode $errorCodeRes(body)]} {
	set errorCodeFailure 1
    }

    # If expected output/error strings exist, we have to compare
    # them.  If the comparison fails, then so did the test.
    set outputFailure 0
    variable outData
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
	    return 1
	}
    } else {
	# "constraints" argument exists;
	# make sure that the constraints are satisfied.

	set doTest 0
        set constraints [string trim $constraints]
	if {[string match {*[$\[]*} $constraints] != 0} {
	    # full expression, e.g. {$foo > [info tclversion]}
	    catch {set doTest [uplevel #0 [list expr $constraints]]}
	} elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
	    # something like {a || b} should be turned into
	    # $testConstraints(a) || $testConstraints(b).
	    regsub -all {[.\w]+} $constraints {$testConstraints(&)} c







|







2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
	    return 1
	}
    } else {
	# "constraints" argument exists;
	# make sure that the constraints are satisfied.

	set doTest 0
	set constraints [string trim $constraints]
	if {[string match {*[$\[]*} $constraints] != 0} {
	    # full expression, e.g. {$foo > [info tclversion]}
	    catch {set doTest [uplevel #0 [list expr $constraints]]}
	} elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
	    # something like {a || b} should be turned into
	    # $testConstraints(a) || $testConstraints(b).
	    regsub -all {[.\w]+} $constraints {$testConstraints(&)} c

Changes to tests-perf/list.perf.tcl.

90
91
92
93
94
95
96

































97
98
99
100
101
102
103



104
105
106
107
108
109
110
    { lsearch -glob $l $sNF }

    { lsearch -nocase $l $sNF }
    { lsearch -nocase -glob $l $sNF }

  }
}


































proc test {{reptime 1000}} {
  test-lsearch-regress $reptime
  test-lsearch-nf-regress $reptime
  test-lsearch-nf-non-opti-fast $reptime
  test-lsearch-nf-non-opti-slow $reptime




  puts \n**OK**
}

}; # end of ::tclTestPerf-List

# ------------------------------------------------------------------------








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







>
>
>







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
    { lsearch -glob $l $sNF }

    { lsearch -nocase $l $sNF }
    { lsearch -nocase -glob $l $sNF }

  }
}

proc test-lseq {{reptime 1000}} {
  _test_run $reptime {
    setup   { set i 0 }
    { lseq 10 }
    { lseq 0 count 10 }
    { lseq 0 count 10 by 1 }
    { lseq 0 9 }
    { lseq 0 to 9 }
    { lseq 0 9 1 }
    { lseq 0 to 9 by 1 }
  }
}

proc test-lseq-expr {{reptime 1000}} {
  _test_run $reptime {
    setup   { set i 0 }
    { lseq [expr {$i+10}] }
    { lseq {$i+10} }
    { lseq [expr {$i+0}] count [expr {$i+10}] }
    { lseq {$i+0} count {$i+10} }
    { lseq [expr {$i+0}] count [expr {$i+10}] by [expr {$i+1}] }
    { lseq {$i+0} count {$i+10} by {$i+1} }
    { lseq [expr {$i+0}] [expr {$i+9}] }
    { lseq {$i+0} {$i+9} }
    { lseq [expr {$i+0}] to [expr {$i+9}] }
    { lseq {$i+0} to {$i+9} }
    { lseq [expr {$i+0}] [expr {$i+9}] [expr {$i+1}] }
    { lseq {$i+0} {$i+9} {$i+1} }
    { lseq [expr {$i+0}] to [expr {$i+9}] by [expr {$i+1}] }
    { lseq {$i+0} to {$i+9} by {$i+1} }
  }
}

proc test {{reptime 1000}} {
  test-lsearch-regress $reptime
  test-lsearch-nf-regress $reptime
  test-lsearch-nf-non-opti-fast $reptime
  test-lsearch-nf-non-opti-slow $reptime

  test-lseq [expr {$reptime/2}]
  test-lseq-expr [expr {$reptime/2}]

  puts \n**OK**
}

}; # end of ::tclTestPerf-List

# ------------------------------------------------------------------------

Changes to tests/chan.test.

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
} -returnCodes error -result "wrong # args: should be \"chan subcommand ?arg ...?\""
test chan-1.2 {chan command general syntax} -body {
    chan FOOBAR
} -returnCodes error -match glob -result "unknown or ambiguous subcommand \"FOOBAR\": must be *"

test chan-2.1 {chan command: blocked subcommand} -body {
    chan blocked foo bar
} -returnCodes error -result "wrong # args: should be \"chan blocked channelId\""
test chan-3.1 {chan command: close subcommand} -body {
    chan close foo bar zet
} -returnCodes error -result "wrong # args: should be \"chan close channelId ?direction?\""
test chan-3.2 {chan command: close subcommand} -setup {
    set chan [open [info script] r]
} -body {
    chan close $chan bar
} -cleanup {
    close $chan
} -returnCodes error -result "bad direction \"bar\": must be read or write"
test chan-3.3 {chan command: close subcommand} -setup {
    set chan [open [info script] r]
} -body {
    chan close $chan write
} -cleanup {
    close $chan
} -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed"
test chan-4.1 {chan command: configure subcommand} -body {
    chan configure
} -returnCodes error -result "wrong # args: should be \"chan configure channelId ?-option value ...?\""
test chan-4.2 {chan command: [Bug 800753]} -body {
    chan configure stdout -eofchar Ā
} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character}
test chan-4.3 {chan command: [Bug 800753]} -body {
    chan configure stdout -eofchar \x00
} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character}
test chan-4.4 {chan command: check valid inValue, no outValue} -constraints deprecated -body {







|


|
















|







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
} -returnCodes error -result "wrong # args: should be \"chan subcommand ?arg ...?\""
test chan-1.2 {chan command general syntax} -body {
    chan FOOBAR
} -returnCodes error -match glob -result "unknown or ambiguous subcommand \"FOOBAR\": must be *"

test chan-2.1 {chan command: blocked subcommand} -body {
    chan blocked foo bar
} -returnCodes error -result "wrong # args: should be \"chan blocked channel\""
test chan-3.1 {chan command: close subcommand} -body {
    chan close foo bar zet
} -returnCodes error -result "wrong # args: should be \"chan close channel ?direction?\""
test chan-3.2 {chan command: close subcommand} -setup {
    set chan [open [info script] r]
} -body {
    chan close $chan bar
} -cleanup {
    close $chan
} -returnCodes error -result "bad direction \"bar\": must be read or write"
test chan-3.3 {chan command: close subcommand} -setup {
    set chan [open [info script] r]
} -body {
    chan close $chan write
} -cleanup {
    close $chan
} -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed"
test chan-4.1 {chan command: configure subcommand} -body {
    chan configure
} -returnCodes error -result "wrong # args: should be \"chan configure channel ?-option value ...?\""
test chan-4.2 {chan command: [Bug 800753]} -body {
    chan configure stdout -eofchar Ā
} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character}
test chan-4.3 {chan command: [Bug 800753]} -body {
    chan configure stdout -eofchar \x00
} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character}
test chan-4.4 {chan command: check valid inValue, no outValue} -constraints deprecated -body {
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
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143

test chan-5.1 {chan command: copy subcommand} -body {
    chan copy foo
} -returnCodes error -result "wrong # args: should be \"chan copy input output ?-size size? ?-command callback?\""

test chan-6.1 {chan command: eof subcommand} -body {
    chan eof foo bar
} -returnCodes error -result "wrong # args: should be \"chan eof channelId\""

test chan-7.1 {chan command: event subcommand} -body {
    chan event foo
} -returnCodes error -result "wrong # args: should be \"chan event channelId event ?script?\""

test chan-8.1 {chan command: flush subcommand} -body {
    chan flush foo bar
} -returnCodes error -result "wrong # args: should be \"chan flush channelId\""

test chan-9.1 {chan command: gets subcommand} -body {
    chan gets
} -returnCodes error -result "wrong # args: should be \"chan gets channelId ?varName?\""

test chan-10.1 {chan command: names subcommand} -body {
    chan names foo bar
} -returnCodes error -result "wrong # args: should be \"chan names ?pattern?\""

test chan-11.1 {chan command: puts subcommand} -body {
    chan puts foo bar foo bar
} -returnCodes error -result "wrong # args: should be \"chan puts ?-nonewline? ?channelId? string\""

test chan-12.1 {chan command: read subcommand} -body {
    chan read
} -returnCodes error -result "wrong # args: should be \"chan read channelId ?numChars?\" or \"chan read ?-nonewline? channelId\""

test chan-13.1 {chan command: seek subcommand} -body {
    chan seek foo bar foo bar
} -returnCodes error -result "wrong # args: should be \"chan seek channelId offset ?origin?\""

test chan-14.1 {chan command: tell subcommand} -body {
    chan tell foo bar
} -returnCodes error -result "wrong # args: should be \"chan tell channelId\""

test chan-15.1 {chan command: truncate subcommand} -body {
    chan truncate foo bar foo bar
} -returnCodes error -result "wrong \# args: should be \"chan truncate channelId ?length?\""
test chan-15.2 {chan command: truncate subcommand} -setup {
    set file [makeFile {} testTruncate]
    set f [open $file w+]
    fconfigure $f -translation binary
} -body {
    seek $f 0
    puts -nonewline $f 12345
    seek $f 0
    chan truncate $f 2
    read $f
} -result 12 -cleanup {
    catch {close $f}
    catch {removeFile $file}
}

# TIP 287: chan pending
test chan-16.1 {chan command: pending subcommand} -body {
    chan pending
} -returnCodes error -result "wrong # args: should be \"chan pending mode channelId\""
test chan-16.2 {chan command: pending subcommand} -body {
    chan pending stdin
} -returnCodes error -result "wrong # args: should be \"chan pending mode channelId\""
test chan-16.3 {chan command: pending subcommand} -body {
    chan pending stdin stdout stderr
} -returnCodes error -result "wrong # args: should be \"chan pending mode channelId\""
test chan-16.4 {chan command: pending subcommand} -body {
    chan pending {input output} stdout
} -returnCodes error -result "bad mode \"input output\": must be input or output"
test chan-16.5 {chan command: pending input subcommand} -body {
    chan pending input stdout
} -result -1
test chan-16.6 {chan command: pending input subcommand} -body {







|



|



|



|







|



|



|



|



|


















|


|


|







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
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143

test chan-5.1 {chan command: copy subcommand} -body {
    chan copy foo
} -returnCodes error -result "wrong # args: should be \"chan copy input output ?-size size? ?-command callback?\""

test chan-6.1 {chan command: eof subcommand} -body {
    chan eof foo bar
} -returnCodes error -result "wrong # args: should be \"chan eof channel\""

test chan-7.1 {chan command: event subcommand} -body {
    chan event foo
} -returnCodes error -result "wrong # args: should be \"chan event channel event ?script?\""

test chan-8.1 {chan command: flush subcommand} -body {
    chan flush foo bar
} -returnCodes error -result "wrong # args: should be \"chan flush channel\""

test chan-9.1 {chan command: gets subcommand} -body {
    chan gets
} -returnCodes error -result "wrong # args: should be \"chan gets channel ?varName?\""

test chan-10.1 {chan command: names subcommand} -body {
    chan names foo bar
} -returnCodes error -result "wrong # args: should be \"chan names ?pattern?\""

test chan-11.1 {chan command: puts subcommand} -body {
    chan puts foo bar foo bar
} -returnCodes error -result "wrong # args: should be \"chan puts ?-nonewline? ?channel? string\""

test chan-12.1 {chan command: read subcommand} -body {
    chan read
} -returnCodes error -result "wrong # args: should be \"chan read channel ?numChars?\" or \"chan read ?-nonewline? channel\""

test chan-13.1 {chan command: seek subcommand} -body {
    chan seek foo bar foo bar
} -returnCodes error -result "wrong # args: should be \"chan seek channel offset ?origin?\""

test chan-14.1 {chan command: tell subcommand} -body {
    chan tell foo bar
} -returnCodes error -result "wrong # args: should be \"chan tell channel\""

test chan-15.1 {chan command: truncate subcommand} -body {
    chan truncate foo bar foo bar
} -returnCodes error -result "wrong \# args: should be \"chan truncate channel ?length?\""
test chan-15.2 {chan command: truncate subcommand} -setup {
    set file [makeFile {} testTruncate]
    set f [open $file w+]
    fconfigure $f -translation binary
} -body {
    seek $f 0
    puts -nonewline $f 12345
    seek $f 0
    chan truncate $f 2
    read $f
} -result 12 -cleanup {
    catch {close $f}
    catch {removeFile $file}
}

# TIP 287: chan pending
test chan-16.1 {chan command: pending subcommand} -body {
    chan pending
} -returnCodes error -result "wrong # args: should be \"chan pending mode channel\""
test chan-16.2 {chan command: pending subcommand} -body {
    chan pending stdin
} -returnCodes error -result "wrong # args: should be \"chan pending mode channel\""
test chan-16.3 {chan command: pending subcommand} -body {
    chan pending stdin stdout stderr
} -returnCodes error -result "wrong # args: should be \"chan pending mode channel\""
test chan-16.4 {chan command: pending subcommand} -body {
    chan pending {input output} stdout
} -returnCodes error -result "bad mode \"input output\": must be input or output"
test chan-16.5 {chan command: pending input subcommand} -body {
    chan pending input stdout
} -result -1
test chan-16.6 {chan command: pending input subcommand} -body {

Changes to tests/chanio.test.

5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
} -cleanup {
    file delete ./~ ;# ./ because don't want to delete home in case of bugs!
    cd $curdir
} -result 1

test chan-io-41.1 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
    chan event foo
} -returnCodes error -result {wrong # args: should be "chan event channelId event ?script?"}
test chan-io-41.2 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
    chan event foo bar baz q
} -returnCodes error -result {wrong # args: should be "chan event channelId event ?script?"}
test chan-io-41.3 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
    chan event gorp readable
} -returnCodes error -result {can not find channel named "gorp"}
test chan-io-41.4 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
    chan event gorp writable
} -returnCodes error -result {can not find channel named "gorp"}
test chan-io-41.5 {Tcl_FileeventCmd: errors} -constraints fileevent -body {







|


|







5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
} -cleanup {
    file delete ./~ ;# ./ because don't want to delete home in case of bugs!
    cd $curdir
} -result 1

test chan-io-41.1 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
    chan event foo
} -returnCodes error -result {wrong # args: should be "chan event channel event ?script?"}
test chan-io-41.2 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
    chan event foo bar baz q
} -returnCodes error -result {wrong # args: should be "chan event channel event ?script?"}
test chan-io-41.3 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
    chan event gorp readable
} -returnCodes error -result {can not find channel named "gorp"}
test chan-io-41.4 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
    chan event gorp writable
} -returnCodes error -result {can not find channel named "gorp"}
test chan-io-41.5 {Tcl_FileeventCmd: errors} -constraints fileevent -body {

Changes to tests/coroutine.test.

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
		# c1.  After the fix, that doesn't happen, so if c1 still exists call it
		# one final time to allow it to finish and clean up
		rename c1 {}
	}
	return [list $done0 $done1]
} -result {failure failure}


test coroutine-8.0.0 {coro inject executed} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    demo
    set ::result none
    tcl::unsupported::inject demo set ::result inject-executed
    demo
    set ::result
} -result {inject-executed}
test coroutine-8.0.1 {coro inject after error} -body {
    coroutine demo apply {{} { foreach i {1 2} yield; error test }}
    demo
    set ::result none
    tcl::unsupported::inject demo set ::result inject-executed
    lappend ::result [catch {demo} err] $err
} -result {inject-executed 1 test}
test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body {
    interp create child
    child eval {
	coroutine demo apply {{} { while {1} yield }}
	demo
	tcl::unsupported::inject demo set ::result inject-executed
    }
    interp delete child
} -result {}
test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body {
    interp create child
    child eval {
	coroutine demo apply {{} { while {1} yield }}
	demo
	tcl::unsupported::inject demo set ::result inject-executed
    }
    child eval demo
    set result [child eval {set ::result}]

    interp delete child
    set result
} -result {inject-executed}


test coroutine-9.1 {coroprobe with yield} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    list [coroprobe demo set i] [demo] [coroprobe demo set i] [demo]
} -cleanup {
    catch {rename demo {}}
} -result {1 {} 2 {}}







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





|








|






|
>







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
		# c1.  After the fix, that doesn't happen, so if c1 still exists call it
		# one final time to allow it to finish and clean up
		rename c1 {}
	}
	return [list $done0 $done1]
} -result {failure failure}

















test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body {
    interp create child
    child eval {
	coroutine demo apply {{} { while {1} yield }}
	demo
	coroinject demo set ::result inject-executed
    }
    interp delete child
} -result {}
test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body {
    interp create child
    child eval {
	coroutine demo apply {{} { while {1} yield }}
	demo
	coroinject demo lappend ::result inject-executed
    }
    child eval demo
    set result [child eval {set ::result}]

    interp delete child
    set result
} -result {inject-executed yield {}}


test coroutine-9.1 {coroprobe with yield} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    list [coroprobe demo set i] [demo] [coroprobe demo set i] [demo]
} -cleanup {
    catch {rename demo {}}
} -result {1 {} 2 {}}
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

test coroutine-12.1 {coroutine general introspection} -setup {
    set i [interp create]
} -body {
    $i eval {
	# Make the introspection code
	namespace path tcl::unsupported
	proc probe {type var} {
	    upvar 1 $var v
	    set f [info frame]
	    incr f -1
	    set result [list $v [dict get [info frame $f] proc]]
	    if {$type eq "yield"} {
		tailcall yield $result
	    } else {
		tailcall yieldto string cat $result
	    }
	}
	proc pokecoro {c var} {
	    inject $c probe [corotype $c] $var
	    $c
	}

	# Coroutine implementations
	proc cbody1 {} {
	    set val [info coroutine]
	    set accum {}







|











|







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

test coroutine-12.1 {coroutine general introspection} -setup {
    set i [interp create]
} -body {
    $i eval {
	# Make the introspection code
	namespace path tcl::unsupported
	proc probe {var type args} {
	    upvar 1 $var v
	    set f [info frame]
	    incr f -1
	    set result [list $v [dict get [info frame $f] proc]]
	    if {$type eq "yield"} {
		tailcall yield $result
	    } else {
		tailcall yieldto string cat $result
	    }
	}
	proc pokecoro {c var} {
	    coroinject $c probe $var
	    $c
	}

	# Coroutine implementations
	proc cbody1 {} {
	    set val [info coroutine]
	    set accum {}

Changes to tests/expr.test.

5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
        [expr {$max_long_str + 0}] \
        [expr {$max_long + 0}] \
        [expr {2147483647 + 0}] \
        [expr {$max_long == $max_long_hex}] \
        [expr {int(2147483647 + 1) > 0}] \

} {2147483647 2147483647 2147483647 2147483647 1 1}
test expr-33.2 {parse smallest long value} longIs32bit {
    set min_long_str -2147483648
    set min_long_hex "-0x80000000 "

    set min_long -2147483648
    # This will convert to integer (not wide) internal rep
    string is integer $min_long








|







5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
        [expr {$max_long_str + 0}] \
        [expr {$max_long + 0}] \
        [expr {2147483647 + 0}] \
        [expr {$max_long == $max_long_hex}] \
        [expr {int(2147483647 + 1) > 0}] \

} {2147483647 2147483647 2147483647 2147483647 1 1}
test expr-33.2 {parse smallest long value} {
    set min_long_str -2147483648
    set min_long_hex "-0x80000000 "

    set min_long -2147483648
    # This will convert to integer (not wide) internal rep
    string is integer $min_long

Changes to tests/format.test.

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
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {"::tcltest" ni [namespace children]} {
    package require tcltest 2.5
    namespace import -force ::tcltest::*
}

# %u output depends on word length, so this test is not portable.
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}]
# MSVC uses a broken libc that gets sprintf("%g") wrong. This is a pain
# particularly in Continuous Integration, and there isn't anything much we can
# do about it.
testConstraint knownMsvcBug [expr {![string match msvc-* [tcl::build-info compiler]]}]

test format-1.1 {integer formatting} {
    format "%*d %d %d %d" 6 34 16923 -12 -1
} {    34 16923 -12 -1}
test format-1.2 {integer formatting} {
    format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12
} {   6   34 16923  -12 -1 0xe 0xC}
test format-1.3 {integer formatting} longIs32bit {
    format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0
} {   6   34 16923 4294967284 -1 0}
test format-1.3.1 {integer formatting} longIs64bit {
    format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0
} {   6   34 16923 18446744073709551604 -1 0}
test format-1.4 {integer formatting} {
    format "%-4d %-4i %-4d %-4ld" 6 34 16923 -12 -1
} {6    34   16923 -12 }
test format-1.5 {integer formatting} {
    format "%04d %04d %04d %04i" 6 34 16923 -12 -1
} {0006 0034 16923 -012}
test format-1.6 {integer formatting} {
    format "%00*d" 6 34
} {000034}
# Printing negative numbers in hex or octal format depends on word
# length, so these tests are not portable.
test format-1.7 {integer formatting} longIs32bit {
    format "%4x %4x %4x %4x" 6 34 16923 -12 -1
} {   6   22 421b fffffff4}
test format-1.7.1 {integer formatting} longIs64bit {
    format "%4x %4x %4x %4x" 6 34 16923 -12 -1
} {   6   22 421b fffffffffffffff4}
test format-1.8 {integer formatting} longIs32bit {
    format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1
} {0 0x6 0x22 0x421B 0xfffffff4}
test format-1.8.1 {integer formatting} longIs64bit {
    format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1
} {0 0x6 0x22 0x421B 0xfffffffffffffff4}
test format-1.9 {integer formatting} longIs32bit {
    format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1
} {    0                  0x6                 0x22               0x421b           0xfffffff4}
test format-1.9.1 {integer formatting} longIs64bit {
    format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1
} {    0                  0x6                 0x22               0x421b   0xfffffffffffffff4}
test format-1.10 {integer formatting} longIs32bit {
    format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1
} {0     0x6                  0x22                 0x421b               0xfffffff4          }
test format-1.10.1 {integer formatting} longIs64bit {
    format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1
} {0     0x6                  0x22                 0x421b               0xfffffffffffffff4  }
test format-1.11 {integer formatting} longIs32bit {
    format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1
} {0     0o6                  0o42                 0o41033              0o37777777764       }
test format-1.11.1 {integer formatting} longIs64bit {
    format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1
} {0     0o6                  0o42                 0o41033              0o1777777777777777777764}
test format-1.12 {integer formatting} {
    format "%b %#b %#b %llb" 5 0 5 [expr {2**100}]
} {101 0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}
test format-1.13 {integer formatting} {
    format "%#0d %#0d %#0d %#0d %#0d" 0 6 34 16923 -12 -1
} {0 0d6 0d34 0d16923 -0d12}
test format-1.14 {integer formatting} {







|
<
<
<












|


<
<
<











|


<
<
<
|


<
<
<
|


<
<
<
|


<
<
<
|


<
<
<







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
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {"::tcltest" ni [namespace children]} {
    package require tcltest 2.5
    namespace import -force ::tcltest::*
}

# %z/%t/%p output depends on pointerSize, so some tests are not portable.



testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}]
# MSVC uses a broken libc that gets sprintf("%g") wrong. This is a pain
# particularly in Continuous Integration, and there isn't anything much we can
# do about it.
testConstraint knownMsvcBug [expr {![string match msvc-* [tcl::build-info compiler]]}]

test format-1.1 {integer formatting} {
    format "%*d %d %d %d" 6 34 16923 -12 -1
} {    34 16923 -12 -1}
test format-1.2 {integer formatting} {
    format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12
} {   6   34 16923  -12 -1 0xe 0xC}
test format-1.3 {integer formatting} {
    format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0
} {   6   34 16923 4294967284 -1 0}



test format-1.4 {integer formatting} {
    format "%-4d %-4i %-4d %-4ld" 6 34 16923 -12 -1
} {6    34   16923 -12 }
test format-1.5 {integer formatting} {
    format "%04d %04d %04d %04i" 6 34 16923 -12 -1
} {0006 0034 16923 -012}
test format-1.6 {integer formatting} {
    format "%00*d" 6 34
} {000034}
# Printing negative numbers in hex or octal format depends on word
# length, so these tests are not portable.
test format-1.7 {integer formatting} {
    format "%4x %4x %4x %4x" 6 34 16923 -12 -1
} {   6   22 421b fffffff4}



test format-1.8 {integer formatting} {
    format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1
} {0 0x6 0x22 0x421B 0xfffffff4}



test format-1.9 {integer formatting} {
    format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1
} {    0                  0x6                 0x22               0x421b           0xfffffff4}



test format-1.10 {integer formatting} {
    format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1
} {0     0x6                  0x22                 0x421b               0xfffffff4          }



test format-1.11 {integer formatting} {
    format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1
} {0     0o6                  0o42                 0o41033              0o37777777764       }



test format-1.12 {integer formatting} {
    format "%b %#b %#b %llb" 5 0 5 [expr {2**100}]
} {101 0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}
test format-1.13 {integer formatting} {
    format "%#0d %#0d %#0d %#0d %#0d" 0 6 34 16923 -12 -1
} {0 0d6 0d34 0d16923 -0d12}
test format-1.14 {integer formatting} {
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
for {set i 290} {$i < 400} {incr i} {
    test format-16.[expr {$i -289}] {testing MAX_FLOAT_SIZE} {
        format {%s} $b
    } $b
    append b "x"
}

test format-17.1 {testing %d with wide} {longIs32bit wideIs64bit} {
    format %d 7810179016327718216
} 1819043144
test format-17.2 {testing %ld with wide} {wideIs64bit} {
    format %ld 7810179016327718216
} 7810179016327718216
test format-17.3 {testing %ld with non-wide} {wideIs64bit} {
    format %ld 42
} 42
test format-17.4 {testing %l with non-integer} {
    format %lf 1
} 1.000000
test format-17.5 {testing %llu with positive bignum} -body {
    format %llu 0xabcdef0123456789abcdef







|


|


|







531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
for {set i 290} {$i < 400} {incr i} {
    test format-16.[expr {$i -289}] {testing MAX_FLOAT_SIZE} {
        format {%s} $b
    } $b
    append b "x"
}

test format-17.1 {testing %d with wide} {
    format %d 7810179016327718216
} 1819043144
test format-17.2 {testing %ld with wide} {
    format %ld 7810179016327718216
} 7810179016327718216
test format-17.3 {testing %ld with non-wide} {
    format %ld 42
} 42
test format-17.4 {testing %l with non-integer} {
    format %lf 1
} 1.000000
test format-17.5 {testing %llu with positive bignum} -body {
    format %llu 0xabcdef0123456789abcdef
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
    lappend result [expr {$a == $b}]
    set b 0xaaaa
    append b aaaa
    lappend result [expr {$a == $b}]
    format %08x $b
    lappend result [expr {$a == $b}]
} {1 1 1 1}
test format-18.2 {do not demote existing numeric values} {longIs32bit wideIs64bit} {
    set a [expr {0xaaaaaaaaaa + 1}]
    set b 0xaaaaaaaaab
    list [format %08x $a] [expr {$a == $b}]
} {aaaaaaab 1}

test format-19.1 {regression test - tcl-core message by Brian Griffin on 26 0ctober 2004} -body {
    set x 0x8fedc654
    list [expr { ~ $x }] [format %08x [expr { ~$x }]]
} -match regexp -result {-2414724693 f*701239ab}
test format-19.2 {Bug 1867855} {
    format %llx 0
} 0
test format-19.3 {Bug 2830354} {
    string length [format %340f 0]
} 340

test format-19.4.1 {Bug d498578df4: width overflow should cause limit exceeded} \
-constraints {longIs32bit} -body {
    # in case of overflow into negative, it produces width -2 (and limit exceeded),
    # in case of width will be unsigned, it will be outside limit (2GB for 32bit)...
    # and it don't throw an error in case the bug is not fixed (and probably no segfault).
    format %[expr {0xffffffff - 1}]g 0
} -returnCodes error -result "max size for a Tcl value exceeded"

test format-19.4.2 {Bug d498578df4: width overflow should cause limit exceeded} -body {







|
















|
<







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
    lappend result [expr {$a == $b}]
    set b 0xaaaa
    append b aaaa
    lappend result [expr {$a == $b}]
    format %08x $b
    lappend result [expr {$a == $b}]
} {1 1 1 1}
test format-18.2 {do not demote existing numeric values} {
    set a [expr {0xaaaaaaaaaa + 1}]
    set b 0xaaaaaaaaab
    list [format %08x $a] [expr {$a == $b}]
} {aaaaaaab 1}

test format-19.1 {regression test - tcl-core message by Brian Griffin on 26 0ctober 2004} -body {
    set x 0x8fedc654
    list [expr { ~ $x }] [format %08x [expr { ~$x }]]
} -match regexp -result {-2414724693 f*701239ab}
test format-19.2 {Bug 1867855} {
    format %llx 0
} 0
test format-19.3 {Bug 2830354} {
    string length [format %340f 0]
} 340

test format-19.4.1 {Bug d498578df4: width overflow should cause limit exceeded} -body {

    # in case of overflow into negative, it produces width -2 (and limit exceeded),
    # in case of width will be unsigned, it will be outside limit (2GB for 32bit)...
    # and it don't throw an error in case the bug is not fixed (and probably no segfault).
    format %[expr {0xffffffff - 1}]g 0
} -returnCodes error -result "max size for a Tcl value exceeded"

test format-19.4.2 {Bug d498578df4: width overflow should cause limit exceeded} -body {

Changes to tests/io.test.

6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
6086
6087
    set x [list [catch {open ~/foo} msg] $msg]
    set ::env(HOME) $home
    set x
} {1 {couldn't open "~/foo": no such file or directory}}

test io-41.1 {Tcl_FileeventCmd: errors} {fileevent} {
    list [catch {fileevent foo} msg] $msg
} {1 {wrong # args: should be "fileevent channelId event ?script?"}}
test io-41.2 {Tcl_FileeventCmd: errors} {fileevent} {
    list [catch {fileevent foo bar baz q} msg] $msg
} {1 {wrong # args: should be "fileevent channelId event ?script?"}}
test io-41.3 {Tcl_FileeventCmd: errors} {fileevent} {
    list [catch {fileevent gorp readable} msg] $msg
} {1 {can not find channel named "gorp"}}
test io-41.4 {Tcl_FileeventCmd: errors} {fileevent} {
    list [catch {fileevent gorp writable} msg] $msg
} {1 {can not find channel named "gorp"}}
test io-41.5 {Tcl_FileeventCmd: errors} {fileevent} {







|


|







6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
6086
6087
    set x [list [catch {open ~/foo} msg] $msg]
    set ::env(HOME) $home
    set x
} {1 {couldn't open "~/foo": no such file or directory}}

test io-41.1 {Tcl_FileeventCmd: errors} {fileevent} {
    list [catch {fileevent foo} msg] $msg
} {1 {wrong # args: should be "fileevent channel event ?script?"}}
test io-41.2 {Tcl_FileeventCmd: errors} {fileevent} {
    list [catch {fileevent foo bar baz q} msg] $msg
} {1 {wrong # args: should be "fileevent channel event ?script?"}}
test io-41.3 {Tcl_FileeventCmd: errors} {fileevent} {
    list [catch {fileevent gorp readable} msg] $msg
} {1 {can not find channel named "gorp"}}
test io-41.4 {Tcl_FileeventCmd: errors} {fileevent} {
    list [catch {fileevent gorp writable} msg] $msg
} {1 {can not find channel named "gorp"}}
test io-41.5 {Tcl_FileeventCmd: errors} {fileevent} {

Changes to tests/ioCmd.test.

26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
# Custom constraints used in this file
testConstraint testchannel	[llength [info commands testchannel]]

#----------------------------------------------------------------------

test iocmd-1.1 {puts command} {
   list [catch {puts} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.2 {puts command} {
   list [catch {puts a b c d e f g} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.3 {puts command} {
   list [catch {puts froboz -nonewline kablooie} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.4 {puts command} {
   list [catch {puts froboz hello} msg] $msg
} {1 {can not find channel named "froboz"}}
test iocmd-1.5 {puts command} {
   list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}








|


|


|







26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
# Custom constraints used in this file
testConstraint testchannel	[llength [info commands testchannel]]

#----------------------------------------------------------------------

test iocmd-1.1 {puts command} {
   list [catch {puts} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channel? string"}}
test iocmd-1.2 {puts command} {
   list [catch {puts a b c d e f g} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channel? string"}}
test iocmd-1.3 {puts command} {
   list [catch {puts froboz -nonewline kablooie} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channel? string"}}
test iocmd-1.4 {puts command} {
   list [catch {puts froboz hello} msg] $msg
} {1 {can not find channel named "froboz"}}
test iocmd-1.5 {puts command} {
   list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}

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
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
    puts -nonewline $f [binary format a4a5 foo bar]
    close $f
    file size $path(test1)
} 9

test iocmd-2.1 {flush command} {
   list [catch {flush} msg] $msg
} {1 {wrong # args: should be "flush channelId"}}
test iocmd-2.2 {flush command} {
   list [catch {flush a b c d e} msg] $msg
} {1 {wrong # args: should be "flush channelId"}}
test iocmd-2.3 {flush command} {
   list [catch {flush foo} msg] $msg
} {1 {can not find channel named "foo"}}
test iocmd-2.4 {flush command} {
   list [catch {flush stdin} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}

test iocmd-3.1 {gets command} {
   list [catch {gets} msg] $msg
} {1 {wrong # args: should be "gets channelId ?varName?"}}
test iocmd-3.2 {gets command} {
   list [catch {gets a b c d e f g} msg] $msg
} {1 {wrong # args: should be "gets channelId ?varName?"}}
test iocmd-3.3 {gets command} {
   list [catch {gets aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-3.4 {gets command} {
   list [catch {gets stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-3.5 {gets command} {
    set f [open $path(test1) w]
    puts $f [binary format a4a5 foo bar]
    close $f
    set f [open $path(test1) r]
    set result [gets $f]
    close $f
    set x foo\x00
    set x "${x}bar\x00\x00"
    string compare $x $result
} 0

test iocmd-4.1 {read command} {
   list [catch {read} msg] $msg
} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"}}
test iocmd-4.2 {read command} {
   list [catch {read a b c d e f g h} msg] $msg
} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"}}
test iocmd-4.3 {read command} {
   list [catch {read aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-4.4 {read command} {
   list [catch {read -nonewline} msg] $msg
} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"}}
test iocmd-4.5 {read command} {
   list [catch {read -nonew file4} msg] $msg $::errorCode
} {1 {can not find channel named "-nonew"} {TCL LOOKUP CHANNEL -nonew}}
test iocmd-4.6 {read command} {
   list [catch {read stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.7 {read command} {
   list [catch {read -nonewline stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.8 {read command with incorrect combination of arguments} {
    file delete $path(test1)
    set f [open $path(test1) w]
    puts $f "Two lines: this one"
    puts $f "and this one"
    close $f
    set f [open $path(test1)]
    set x [list [catch {read -nonewline $f 20 z} msg] $msg $::errorCode]
    close $f
    set x
} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"} {TCL WRONGARGS}}
test iocmd-4.9 {read command} {
    list [catch {read stdin foo} msg] $msg $::errorCode
} {1 {expected non-negative integer but got "foo"} {TCL VALUE NUMBER}}
test iocmd-4.10 {read command} {
    list [catch {read file107} msg] $msg $::errorCode
} {1 {can not find channel named "file107"} {TCL LOOKUP CHANNEL file107}}
set path(test3) [makeFile {} test3]







|


|









|


|




















|


|





|



















|







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
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
    puts -nonewline $f [binary format a4a5 foo bar]
    close $f
    file size $path(test1)
} 9

test iocmd-2.1 {flush command} {
   list [catch {flush} msg] $msg
} {1 {wrong # args: should be "flush channel"}}
test iocmd-2.2 {flush command} {
   list [catch {flush a b c d e} msg] $msg
} {1 {wrong # args: should be "flush channel"}}
test iocmd-2.3 {flush command} {
   list [catch {flush foo} msg] $msg
} {1 {can not find channel named "foo"}}
test iocmd-2.4 {flush command} {
   list [catch {flush stdin} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}

test iocmd-3.1 {gets command} {
   list [catch {gets} msg] $msg
} {1 {wrong # args: should be "gets channel ?varName?"}}
test iocmd-3.2 {gets command} {
   list [catch {gets a b c d e f g} msg] $msg
} {1 {wrong # args: should be "gets channel ?varName?"}}
test iocmd-3.3 {gets command} {
   list [catch {gets aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-3.4 {gets command} {
   list [catch {gets stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-3.5 {gets command} {
    set f [open $path(test1) w]
    puts $f [binary format a4a5 foo bar]
    close $f
    set f [open $path(test1) r]
    set result [gets $f]
    close $f
    set x foo\x00
    set x "${x}bar\x00\x00"
    string compare $x $result
} 0

test iocmd-4.1 {read command} {
   list [catch {read} msg] $msg
} {1 {wrong # args: should be "read channel ?numChars?" or "read ?-nonewline? channel"}}
test iocmd-4.2 {read command} {
   list [catch {read a b c d e f g h} msg] $msg
} {1 {wrong # args: should be "read channel ?numChars?" or "read ?-nonewline? channel"}}
test iocmd-4.3 {read command} {
   list [catch {read aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-4.4 {read command} {
   list [catch {read -nonewline} msg] $msg
} {1 {wrong # args: should be "read channel ?numChars?" or "read ?-nonewline? channel"}}
test iocmd-4.5 {read command} {
   list [catch {read -nonew file4} msg] $msg $::errorCode
} {1 {can not find channel named "-nonew"} {TCL LOOKUP CHANNEL -nonew}}
test iocmd-4.6 {read command} {
   list [catch {read stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.7 {read command} {
   list [catch {read -nonewline stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.8 {read command with incorrect combination of arguments} {
    file delete $path(test1)
    set f [open $path(test1) w]
    puts $f "Two lines: this one"
    puts $f "and this one"
    close $f
    set f [open $path(test1)]
    set x [list [catch {read -nonewline $f 20 z} msg] $msg $::errorCode]
    close $f
    set x
} {1 {wrong # args: should be "read channel ?numChars?" or "read ?-nonewline? channel"} {TCL WRONGARGS}}
test iocmd-4.9 {read command} {
    list [catch {read stdin foo} msg] $msg $::errorCode
} {1 {expected non-negative integer but got "foo"} {TCL VALUE NUMBER}}
test iocmd-4.10 {read command} {
    list [catch {read file107} msg] $msg $::errorCode
} {1 {can not find channel named "file107"} {TCL LOOKUP CHANNEL file107}}
set path(test3) [makeFile {} test3]
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
    read $f 12z
} -cleanup {
    close $f
} -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER}

test iocmd-5.1 {seek command} -returnCodes error -body {
    seek
} -result {wrong # args: should be "seek channelId offset ?origin?"}
test iocmd-5.2 {seek command} -returnCodes error -body {
    seek a b c d e f g
} -result {wrong # args: should be "seek channelId offset ?origin?"}
test iocmd-5.3 {seek command} -returnCodes error -body {
    seek stdin gugu
} -result {expected integer but got "gugu"}
test iocmd-5.4 {seek command} -returnCodes error -body {
    seek stdin 100 gugu
} -result {bad origin "gugu": must be start, current, or end}

test iocmd-6.1 {tell command} {
    list [catch {tell} msg] $msg
} {1 {wrong # args: should be "tell channelId"}}
test iocmd-6.2 {tell command} {
    list [catch {tell a b c d e} msg] $msg
} {1 {wrong # args: should be "tell channelId"}}
test iocmd-6.3 {tell command} {
    list [catch {tell aaa} msg] $msg
} {1 {can not find channel named "aaa"}}

test iocmd-7.1 {close command} {
    list [catch {close} msg] $msg
} {1 {wrong # args: should be "close channelId ?direction?"}}
test iocmd-7.2 {close command} {
    list [catch {close a b c d e} msg] $msg
} {1 {wrong # args: should be "close channelId ?direction?"}}
test iocmd-7.3 {close command} {
    list [catch {close aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-7.4 {close command} -setup {
    set chan [open [info script] r]
} -body {
    chan close $chan bar







|


|









|


|






|


|







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
    read $f 12z
} -cleanup {
    close $f
} -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER}

test iocmd-5.1 {seek command} -returnCodes error -body {
    seek
} -result {wrong # args: should be "seek channel offset ?origin?"}
test iocmd-5.2 {seek command} -returnCodes error -body {
    seek a b c d e f g
} -result {wrong # args: should be "seek channel offset ?origin?"}
test iocmd-5.3 {seek command} -returnCodes error -body {
    seek stdin gugu
} -result {expected integer but got "gugu"}
test iocmd-5.4 {seek command} -returnCodes error -body {
    seek stdin 100 gugu
} -result {bad origin "gugu": must be start, current, or end}

test iocmd-6.1 {tell command} {
    list [catch {tell} msg] $msg
} {1 {wrong # args: should be "tell channel"}}
test iocmd-6.2 {tell command} {
    list [catch {tell a b c d e} msg] $msg
} {1 {wrong # args: should be "tell channel"}}
test iocmd-6.3 {tell command} {
    list [catch {tell aaa} msg] $msg
} {1 {can not find channel named "aaa"}}

test iocmd-7.1 {close command} {
    list [catch {close} msg] $msg
} {1 {wrong # args: should be "close channel ?direction?"}}
test iocmd-7.2 {close command} {
    list [catch {close a b c d e} msg] $msg
} {1 {wrong # args: should be "close channel ?direction?"}}
test iocmd-7.3 {close command} {
    list [catch {close aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-7.4 {close command} -setup {
    set chan [open [info script] r]
} -body {
    chan close $chan bar
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
    }
    set opts [list {*}$basicOpts {*}$extra]
    lset opts end [string cat "or " [lindex $opts end]]
    return [format {bad option "%s": should be one of %s} $got [join $opts ", "]]
}
test iocmd-8.1 {fconfigure command} -returnCodes error -body {
    fconfigure
} -result {wrong # args: should be "fconfigure channelId ?-option value ...?"}
test iocmd-8.2 {fconfigure command} -returnCodes error -body {
    fconfigure a b c d e f
} -result {wrong # args: should be "fconfigure channelId ?-option value ...?"}
test iocmd-8.3 {fconfigure command} -returnCodes error -body {
    fconfigure a b
} -result {can not find channel named "a"}
test iocmd-8.4 {fconfigure command} -setup {
    file delete $path(test1)
    set f1 [open $path(test1) w]
} -body {







|


|







212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
    }
    set opts [list {*}$basicOpts {*}$extra]
    lset opts end [string cat "or " [lindex $opts end]]
    return [format {bad option "%s": should be one of %s} $got [join $opts ", "]]
}
test iocmd-8.1 {fconfigure command} -returnCodes error -body {
    fconfigure
} -result {wrong # args: should be "fconfigure channel ?-option value ...?"}
test iocmd-8.2 {fconfigure command} -returnCodes error -body {
    fconfigure a b c d e f
} -result {wrong # args: should be "fconfigure channel ?-option value ...?"}
test iocmd-8.3 {fconfigure command} -returnCodes error -body {
    fconfigure a b
} -result {can not find channel named "a"}
test iocmd-8.4 {fconfigure command} -setup {
    file delete $path(test1)
    set f1 [open $path(test1) w]
} -body {
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

test iocmd-8.23 {fconfigure -profile badprofile} -body {
    fconfigure stdin -profile froboz
} -returnCodes error -result {bad profile name "froboz": must be replace, strict, or tcl8}

test iocmd-9.1 {eof command} {
    list [catch {eof} msg] $msg $::errorCode
} {1 {wrong # args: should be "eof channelId"} {TCL WRONGARGS}}
test iocmd-9.2 {eof command} {
    list [catch {eof a b} msg] $msg $::errorCode
} {1 {wrong # args: should be "eof channelId"} {TCL WRONGARGS}}
test iocmd-9.3 {eof command} {
    catch {close file100}
    list [catch {eof file100} msg] $msg $::errorCode
} {1 {can not find channel named "file100"} {TCL LOOKUP CHANNEL file100}}

# The tests for Tcl_ExecObjCmd are in exec.test

test iocmd-10.1 {fblocked command} {
    list [catch {fblocked} msg] $msg
} {1 {wrong # args: should be "fblocked channelId"}}
test iocmd-10.2 {fblocked command} {
    list [catch {fblocked a b c d e f g} msg] $msg
} {1 {wrong # args: should be "fblocked channelId"}}
test iocmd-10.3 {fblocked command} {
    list [catch {fblocked file1000} msg] $msg
} {1 {can not find channel named "file1000"}}
test iocmd-10.4 {fblocked command} {
    list [catch {fblocked stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-10.5 {fblocked command} {







|


|









|


|







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

test iocmd-8.23 {fconfigure -profile badprofile} -body {
    fconfigure stdin -profile froboz
} -returnCodes error -result {bad profile name "froboz": must be replace, strict, or tcl8}

test iocmd-9.1 {eof command} {
    list [catch {eof} msg] $msg $::errorCode
} {1 {wrong # args: should be "eof channel"} {TCL WRONGARGS}}
test iocmd-9.2 {eof command} {
    list [catch {eof a b} msg] $msg $::errorCode
} {1 {wrong # args: should be "eof channel"} {TCL WRONGARGS}}
test iocmd-9.3 {eof command} {
    catch {close file100}
    list [catch {eof file100} msg] $msg $::errorCode
} {1 {can not find channel named "file100"} {TCL LOOKUP CHANNEL file100}}

# The tests for Tcl_ExecObjCmd are in exec.test

test iocmd-10.1 {fblocked command} {
    list [catch {fblocked} msg] $msg
} {1 {wrong # args: should be "fblocked channel"}}
test iocmd-10.2 {fblocked command} {
    list [catch {fblocked a b c d e f g} msg] $msg
} {1 {wrong # args: should be "fblocked channel"}}
test iocmd-10.3 {fblocked command} {
    list [catch {fblocked file1000} msg] $msg
} {1 {can not find channel named "file1000"}}
test iocmd-10.4 {fblocked command} {
    list [catch {fblocked stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-10.5 {fblocked command} {

Changes to tests/lseq.test.

105
106
107
108
109
110
111
112
113
114
115
116
117




118
119
120
121
122
123
124
test lseq-1.15 {count with decreasing step} {
    -body {
	lseq 5 count 5 by -2
    }
    -result {5 3 1 -1 -3}
}

test lseq-1.16 {large numbers} {
    -body {
	lseq [expr {int(1e6)}] [expr {int(2e6)}] [expr {int(1e5)}]
    }
    -result {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000}
}





test lseq-1.17 {too many arguments} -body {
    lseq 12 to 24 by 2 with feeling
} -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"}

test lseq-1.18 {too many arguments extra valid keyword} -body {
    lseq 12 to 24 by 2 count







|





>
>
>
>







105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
test lseq-1.15 {count with decreasing step} {
    -body {
	lseq 5 count 5 by -2
    }
    -result {5 3 1 -1 -3}
}

test lseq-1.16 {large doubles} {
    -body {
	lseq [expr {int(1e6)}] [expr {int(2e6)}] [expr {int(1e5)}]
    }
    -result {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000}
}

test lseq-1.16.2 {large numbers (bigints are not supported yet)} -body {
    lseq 0xfffffffffffffffe 0xffffffffffffffff
} -returnCodes 1 -result {integer value too large to represent}

test lseq-1.17 {too many arguments} -body {
    lseq 12 to 24 by 2 with feeling
} -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"}

test lseq-1.18 {too many arguments extra valid keyword} -body {
    lseq 12 to 24 by 2 count
135
136
137
138
139
140
141





























142
143
144
145
146
147
148
test lseq-1.21 {n n by n} {
    lseq 66 84 by 3
} {66 69 72 75 78 81 84}

test lseq-1.22 {n n by -n} {
    lseq 84 66 by -3
} {84 81 78 75 72 69 66}






























#
# Short-hand use cases
#
test lseq-2.2 {step magnitude} {
    lseq 10 1 2 ;# this is an empty case since step has wrong sign
} {}







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







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
test lseq-1.21 {n n by n} {
    lseq 66 84 by 3
} {66 69 72 75 78 81 84}

test lseq-1.22 {n n by -n} {
    lseq 84 66 by -3
} {84 81 78 75 72 69 66}

test lseq-1.23 {consistence, accept double count representable as integer (but use double in series)} {
    list [lseq 0.0 2.0] [lseq 3.0] [lseq 0 count 3.0] \
	 [lseq 0.0 count 3.0] [lseq 0 count 3.0 by 1.0]
} [lrepeat 5 {0.0 1.0 2.0}]
test lseq-1.24 {consistence, use double (even if representable as integer) in all variants, if contains a double somewhere} {
    list [lseq 0.0 2] [lseq 0 2.0] [lseq 0.0 count 3] \
	 [lseq 0 count 3 by 1.0] [lseq 0 .. 2.0] [lseq 0 to 2 by 1.0]
} [lrepeat 6 {0.0 1.0 2.0}]
test lseq-1.25 {consistence, use double (even if representable as integer) in all variants, if contains a double somewhere} {
    list [lseq double(0) 2] [lseq 0 double(2)] [lseq double(0) count 3] \
	 [lseq 0 count 3 by double(1)] [lseq 0 .. double(2)] [lseq 0 to 2 by double(1)]
} [lrepeat 6 {0.0 1.0 2.0}]
test lseq-1.26 {consistence, double always remains double} {
    list [lseq        1              3.0      ] \
	 [lseq        1       [expr {3.0+0}]  ] \
	 [lseq        1             {3.0+0}   ] \
	 [lseq        1.0            3.0     1] \
	 [lseq [expr {1.0+0}] [expr {3.0+0}] 1] \
	 [lseq       {1.0+0}        {3.0+0}  1]
} [lrepeat 6 {1.0 2.0 3.0}]
test lseq-1.27 {consistence, double always remains double} {
    list [lseq        1e50     [expr {1e50+1}]  ] \
	 [lseq        1e50           {1e50+1}   ] \
	 [lseq [expr {1e50+0}] [expr {1e50+1}] 1] \
	 [lseq       {1e50+0}        {1e50+1}  1] \
	 [lseq [expr {1e50+0}] count 1 1] \
	 [lseq       {1e50+0}  count 1 1]
} [lrepeat 6 [expr {1e50}]]

#
# Short-hand use cases
#
test lseq-2.2 {step magnitude} {
    lseq 10 1 2 ;# this is an empty case since step has wrong sign
} {}
217
218
219
220
221
222
223

















224
225
226
227
228
229
230
	[lseq -10 1 -3] \
	[lseq 10 -1 -4] \
	[lseq -10 -1 3] \
	[lseq 10 1 -5]

} {{-10 -8 -6 -4 -2} {} {} {10 6 2} {-10 -7 -4 -1} {10 5}}


















test lseq-3.1 {experiement} -body {
    set ans {}
    foreach factor [lseq 2.0 10.0] {
	set start 1
	set end 10
	for {set step 1} {$step < 1e8} {} {
	    set l [lseq $start to $end by $step]







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







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
	[lseq -10 1 -3] \
	[lseq 10 -1 -4] \
	[lseq -10 -1 3] \
	[lseq 10 1 -5]

} {{-10 -8 -6 -4 -2} {} {} {10 6 2} {-10 -7 -4 -1} {10 5}}

test lseq-2.19 {expressions as indices} {
    list [lseq {1+1}] \
	 [lseq {1+1} {2+2}] \
	 [lseq {1+1} count {2+2}] \
	 [lseq {1+1} {5+5} {2+2}] \
	 [lseq {1+1} count {2+2} by {2+2}]
} {{0 1} {2 3 4} {2 3 4 5} {2 6 10} {2 6 10 14}}

test lseq-2.20 {expressions as indices, no duplicative eval of expr} {
    set i 1
    list [lseq {[incr i]}] $i [lseq {0 + [incr i]}] $i [lseq {0.0 + [incr i]}] $i
} {{0 1} 2 {0 1 2} 3 {0.0 1.0 2.0 3.0} 4}

test lseq-3.0 {expr error: don't swalow expr error (here: divide by zero)} -body {
    set i 0; lseq {3/$i}
} -returnCodes [catch {expr {3/0}} res] -result $res

test lseq-3.1 {experiement} -body {
    set ans {}
    foreach factor [lseq 2.0 10.0] {
	set start 1
	set end 10
	for {set step 1} {$step < 1e8} {} {
	    set l [lseq $start to $end by $step]
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
    set ans
} -cleanup {
    unset ans step end start factor l
} -result {OK}

test lseq-3.2 {error case} -body {
    lseq foo
} -returnCodes 1 -result {bad operation "foo": must be .., to, count, or by}

test lseq-3.3 {error case} -body {
    lseq 10 foo
} -returnCodes 1 -result {bad operation "foo": must be .., to, count, or by}

test lseq-3.4 {error case} -body {
    lseq 25 or 6
} -returnCodes 1 -result {bad operation "or": must be .., to, count, or by}

test lseq-3.5 {simple count and step arguments} -body {
    set s [lseq 25 by 6]
    list $s length=[llength $s]
} -cleanup {
    unset s
} -result {{0 6 12 18 24 30 36 42 48 54 60 66 72 78 84 90 96 102 108 114 120 126 132 138 144} length=25}

test lseq-3.6 {error case} -body {
    lseq 1 7 or 3



} -returnCodes 1  -result {bad operation "or": must be .., to, count, or by}

test lseq-3.7 {lmap lseq} -body {
    lmap x [lseq 5] { expr {$x * $x} }
} -cleanup {unset x} -result {0 1 4 9 16}

test lseq-3.8 {lrange lseq} -body {







|



|



|










>
>
>







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
    set ans
} -cleanup {
    unset ans step end start factor l
} -result {OK}

test lseq-3.2 {error case} -body {
    lseq foo
} -returnCodes 1 -match glob -result {invalid bareword "foo"*}

test lseq-3.3 {error case} -body {
    lseq 10 foo
} -returnCodes 1 -match glob -result {invalid bareword "foo"*}

test lseq-3.4 {error case} -body {
    lseq 25 or 6
} -returnCodes 1 -match glob -result {invalid bareword "or"*}

test lseq-3.5 {simple count and step arguments} -body {
    set s [lseq 25 by 6]
    list $s length=[llength $s]
} -cleanup {
    unset s
} -result {{0 6 12 18 24 30 36 42 48 54 60 66 72 78 84 90 96 102 108 114 120 126 132 138 144} length=25}

test lseq-3.6 {error case} -body {
    lseq 1 7 or 3
} -returnCodes 1  -result {bad operation "or": must be .., to, count, or by}
test lseq-3.6b {error case} -body {
    lseq 1 to 7 or 3
} -returnCodes 1  -result {bad operation "or": must be .., to, count, or by}

test lseq-3.7 {lmap lseq} -body {
    lmap x [lseq 5] { expr {$x * $x} }
} -cleanup {unset x} -result {0 1 4 9 16}

test lseq-3.8 {lrange lseq} -body {

Changes to tests/namespace.test.

3366
3367
3368
3369
3370
3371
3372
















3373
3374
3375
3376
3377
3378
3379
    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
} ""

















test namespace-56.1 {bug f97d4ee020: mutually-entangled deletion} {
    namespace eval ::testing {
	proc abc {} {}
	proc def {} {}
	trace add command abc delete "rename ::testing::def {}; #"
	trace add command def delete "rename ::testing::abc {}; #"







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







3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
    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
} ""

test namespace-55.2 {compiled ensembles inside safe interpreters (for safe sub-commands), bug [1095bf7f756f9aed]} -setup {
    interp create -safe si
    set code {
	proc test_comp_dict d { dict for {k v} $d {expr $v} }
    	regexp -inline {Command 1:(?:[^\n]*\n){1,5}} [::tcl::unsupported::disassemble proc test_comp_dict]
    }
} -body {
    set a [   eval $code]
    set b [si eval $code]
    list [expr {$a eq $b}] [regexp { dictFirst } $a] [regexp { dictFirst } $b] $a $b
} -cleanup {
    rename test_comp_dict {}
    unset -nocomplain code a b
    interp delete si
} -match glob -result {1 1 1 *}

test namespace-56.1 {bug f97d4ee020: mutually-entangled deletion} {
    namespace eval ::testing {
	proc abc {} {}
	proc def {} {}
	trace add command abc delete "rename ::testing::def {}; #"
	trace add command def delete "rename ::testing::abc {}; #"

Changes to tests/obj.test.

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]

testConstraint testobj [llength [info commands testobj]]
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]

test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
    set r 1
    foreach {t} {
	bytecode
	cmdName







<







16
17
18
19
20
21
22

23
24
25
26
27
28
29
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]

testConstraint testobj [llength [info commands testobj]]

testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]

test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
    set r 1
    foreach {t} {
	bytecode
	cmdName
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
    set x {}
    for {set i 0} {$i<100000} {incr i} {
	set x [list $x {}]
    }
    unset x
} {}

test obj-33.1 {integer overflow on input} {longIs32bit wideIs64bit} {
    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 wideIs64bit} {
    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) }]
} {1 4294967296}
test obj-33.4 {integer overflow on input} {longIs32bit wideIs64bit} {
    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 wideIs64bit} {
    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 wideIs64bit} {
    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) }]
} {1 -4294967296}







|



|







|



|



|







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
    set x {}
    for {set i 0} {$i<100000} {incr i} {
	set x [list $x {}]
    }
    unset x
} {}

test obj-33.1 {integer overflow on input} {wideIs64bit} {
    set x 0x8000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {1 2147483648}
test obj-33.2 {integer overflow on input} {wideIs64bit} {
    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) }]
} {1 4294967296}
test obj-33.4 {integer overflow on input} {wideIs64bit} {
    set x -0x8000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {1 -2147483648}
test obj-33.5 {integer overflow on input} {wideIs64bit} {
    set x -0x8000; append x 0001
    list [string is integer $x] [expr { wide($x) }]
} {1 -2147483649}
test obj-33.6 {integer overflow on input} {wideIs64bit} {
    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) }]
} {1 -4294967296}

Changes to tests/pid.test.

43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
    close $f
    set pids
} -cleanup {
    removeFile test1
} -result {}
test pid-1.4 {pid command} pidDefined {
    list [catch {pid a b} msg] $msg
} {1 {wrong # args: should be "pid ?channelId?"}}
test pid-1.5 {pid command} pidDefined {
    list [catch {pid gorp} msg] $msg
} {1 {can not find channel named "gorp"}}

# cleanup
::tcltest::cleanupTests
return







|







43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
    close $f
    set pids
} -cleanup {
    removeFile test1
} -result {}
test pid-1.4 {pid command} pidDefined {
    list [catch {pid a b} msg] $msg
} {1 {wrong # args: should be "pid ?channel?"}}
test pid-1.5 {pid command} pidDefined {
    list [catch {pid gorp} msg] $msg
} {1 {can not find channel named "gorp"}}

# cleanup
::tcltest::cleanupTests
return

Changes to tests/remote.tcl.

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
}

proc __readAndExecute__ {s} {
    global command VERBOSE

    set l [gets $s]
    if {[string compare $l "--Marker--Marker--Marker--"] == 0} {
        puts $s [__doCommands__ $command($s) $s]
	puts $s "--Marker--Marker--Marker--"
        set command($s) ""
	return
    }
    if {[string compare $l ""] == 0} {
	if {[eof $s]} {
	    if {$VERBOSE} {
		puts "Server closing $s, eof from client"
	    }
	    close $s
	}
	return
    }
    if {[eof $s]} {
	if {$VERBOSE} {
	    puts "Server closing $s, eof from client"
	}
	close $s
        unset command($s)
        return
    }
    append command($s) $l "\n"
}

proc __accept__ {s a p} {
    global command VERBOSE








|

|
















|
|







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
}

proc __readAndExecute__ {s} {
    global command VERBOSE

    set l [gets $s]
    if {[string compare $l "--Marker--Marker--Marker--"] == 0} {
	puts $s [__doCommands__ $command($s) $s]
	puts $s "--Marker--Marker--Marker--"
	set command($s) ""
	return
    }
    if {[string compare $l ""] == 0} {
	if {[eof $s]} {
	    if {$VERBOSE} {
		puts "Server closing $s, eof from client"
	    }
	    close $s
	}
	return
    }
    if {[eof $s]} {
	if {$VERBOSE} {
	    puts "Server closing $s, eof from client"
	}
	close $s
	unset command($s)
	return
    }
    append command($s) $l "\n"
}

proc __accept__ {s a p} {
    global command VERBOSE

Changes to tests/scan.test.

78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
	default {
	    return 0
	}
    }
}

testConstraint ieeeFloatingPoint [testIEEE]
testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]

test scan-1.1 {BuildCharSet, CharInSet} {
    list [scan foo {%[^o]} x] $x
} {1 f}
test scan-1.2 {BuildCharSet, CharInSet} {
    list [scan \]foo {%[]f]} x] $x
} {1 \]f}







<







78
79
80
81
82
83
84

85
86
87
88
89
90
91
	default {
	    return 0
	}
    }
}

testConstraint ieeeFloatingPoint [testIEEE]


test scan-1.1 {BuildCharSet, CharInSet} {
    list [scan foo {%[^o]} x] $x
} {1 f}
test scan-1.2 {BuildCharSet, CharInSet} {
    list [scan \]foo {%[]f]} x] $x
} {1 \]f}
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
#
test scan-5.11 {integer scanning} -constraints {nonPortable} -setup {
    set a {}; set b {}
} -body {
    list [scan "4294967280 4294967280" "%u %d" a b] $a \
	    [expr {$b == -16 || $b == 0x7fffffff}]
} -result {2 4294967280 1}
test scan-5.12 {integer scanning} -constraints {wideIs64bit} -setup {
    set a {}; set b {}; set c {}
} -body {
    list [scan "7810179016327718216,6c63546f6c6c6548,661432506755433062510" \
	    %ld,%lx,%lo a b c] $a $b $c
} -result {3 7810179016327718216 7810179016327718216 7810179016327718216}
test scan-5.13 {integer scanning and overflow} {
    # This test used to fail on some 64-bit systems. [Bug 1011860]







|







512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
#
test scan-5.11 {integer scanning} -constraints {nonPortable} -setup {
    set a {}; set b {}
} -body {
    list [scan "4294967280 4294967280" "%u %d" a b] $a \
	    [expr {$b == -16 || $b == 0x7fffffff}]
} -result {2 4294967280 1}
test scan-5.12 {integer scanning} -setup {
    set a {}; set b {}; set c {}
} -body {
    list [scan "7810179016327718216,6c63546f6c6c6548,661432506755433062510" \
	    %ld,%lx,%lo a b c] $a $b $c
} -result {3 7810179016327718216 7810179016327718216 7810179016327718216}
test scan-5.13 {integer scanning and overflow} {
    # This test used to fail on some 64-bit systems. [Bug 1011860]

Changes to tests/trace.test.

1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
    set {*}$args
}

test trace-21.12 {bug 2438181} -setup {
    trace add execution set2 leave {puts one two three #;}
} -body {
    set2 a hello
} -returnCodes 1 -result {wrong # args: should be "puts ?-nonewline? ?channelId? string"}

proc factorial {n} {
    if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }
    return 1
}

test trace-22.1 {recursive(1) trace execution: enter} {







|







1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
    set {*}$args
}

test trace-21.12 {bug 2438181} -setup {
    trace add execution set2 leave {puts one two three #;}
} -body {
    set2 a hello
} -returnCodes 1 -result {wrong # args: should be "puts ?-nonewline? ?channel? string"}

proc factorial {n} {
    if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }
    return 1
}

test trace-22.1 {recursive(1) trace execution: enter} {

Changes to unix/Makefile.in.

1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
	@echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"
	@for i in $(TOP_DIR)/library/encoding/*.enc; do \
		$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/encoding"; \
	done
	@if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ] ; then \
	    echo "Customizing tcl module path"; \
	    echo "if {![interp issafe]} { ::tcl::tm::roots [list $(TCL_MODULE_PATH)] }" >> \
	        "$(SCRIPT_INSTALL_DIR)/tm.tcl"; \
	fi

install-tzdata:
	@for i in tzdata; do \
	    if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \
		echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
		$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \







|







1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
	@echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"
	@for i in $(TOP_DIR)/library/encoding/*.enc; do \
		$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/encoding"; \
	done
	@if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ] ; then \
	    echo "Customizing tcl module path"; \
	    echo "if {![interp issafe]} { ::tcl::tm::roots [list $(TCL_MODULE_PATH)] }" >> \
		    "$(SCRIPT_INSTALL_DIR)/tm.tcl"; \
	fi

install-tzdata:
	@for i in tzdata; do \
	    if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \
		echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
		$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \

Changes to unix/installManPage.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sym=""
Loc=""
Gz=""
Suffix=""

while true; do
    case $1 in
        -s | --symlinks  )      Sym="-s "      ;;
        -z | --compress  )     Gzip=$2;  shift ;;
	-e | --extension )       Gz=$2;  shift ;;
	-x | --suffix    )   Suffix=$2;  shift ;;
	-*) cat <<EOF
Unknown option "$1". Supported options:
    -s         Use symbolic links for manpages with multiple names.
    -z PROG    Use PROG to compress manual pages.
    -e EXT     Defines the extension added by -z PROG when compressing.







|
|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sym=""
Loc=""
Gz=""
Suffix=""

while true; do
    case $1 in
	-s | --symlinks  )      Sym="-s "      ;;
	-z | --compress  )     Gzip=$2;  shift ;;
	-e | --extension )       Gz=$2;  shift ;;
	-x | --suffix    )   Suffix=$2;  shift ;;
	-*) cat <<EOF
Unknown option "$1". Supported options:
    -s         Use symbolic links for manpages with multiple names.
    -z PROG    Use PROG to compress manual pages.
    -e EXT     Defines the extension added by -z PROG when compressing.

Changes to unix/tclEpollNotfy.c.

203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
    if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) {
	newEvent.events |= EPOLLIN;
    }
    if (filePtr->mask & TCL_WRITABLE) {
	newEvent.events |= EPOLLOUT;
    }
    if (isNew) {
        newPedPtr = (struct PlatformEventData *)
		Tcl_Alloc(sizeof(struct PlatformEventData));
        newPedPtr->filePtr = filePtr;
        newPedPtr->tsdPtr = tsdPtr;
	filePtr->pedPtr = newPedPtr;
    }
    newEvent.data.ptr = filePtr->pedPtr;

    /*
     * N.B. As discussed in Tcl_WaitForEvent(), epoll(7) does not support
     * regular files (S_IFREG). Therefore, filePtr is in these cases simply







|

|
|







203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
    if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) {
	newEvent.events |= EPOLLIN;
    }
    if (filePtr->mask & TCL_WRITABLE) {
	newEvent.events |= EPOLLOUT;
    }
    if (isNew) {
	newPedPtr = (struct PlatformEventData *)
		Tcl_Alloc(sizeof(struct PlatformEventData));
	newPedPtr->filePtr = filePtr;
	newPedPtr->tsdPtr = tsdPtr;
	filePtr->pedPtr = newPedPtr;
    }
    newEvent.data.ptr = filePtr->pedPtr;

    /*
     * N.B. As discussed in Tcl_WaitForEvent(), epoll(7) does not support
     * regular files (S_IFREG). Therefore, filePtr is in these cases simply
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
    tsdPtr->triggerFilePtr = filePtr;
    if ((tsdPtr->eventsFd = epoll_create1(EPOLL_CLOEXEC)) == -1) {
	Tcl_Panic("epoll_create1: %s", strerror(errno));
    }
    filePtr->mask = TCL_READABLE;
    PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_ADD, 1);
    if (!tsdPtr->readyEvents) {
        tsdPtr->maxReadyEvents = 512;
	tsdPtr->readyEvents = (struct epoll_event *) Tcl_Alloc(
		tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0]));
    }
    LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr);
}

/*







|







363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
    tsdPtr->triggerFilePtr = filePtr;
    if ((tsdPtr->eventsFd = epoll_create1(EPOLL_CLOEXEC)) == -1) {
	Tcl_Panic("epoll_create1: %s", strerror(errno));
    }
    filePtr->mask = TCL_READABLE;
    PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_ADD, 1);
    if (!tsdPtr->readyEvents) {
	tsdPtr->maxReadyEvents = 512;
	tsdPtr->readyEvents = (struct epoll_event *) Tcl_Alloc(
		tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0]));
    }
    LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr);
}

/*

Changes to unix/tclLoadOSF.c.

124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
     * impossible to get a package name given a module.
     *
     * I build loadable modules with a makefile rule like
     *		ld ... -export $@: -o $@ $(OBJS)
     */

    if ((pkg = strrchr(fileName, '/')) == NULL) {
        pkg = fileName;
    } else {
	pkg++;
    }
    newHandle = (Tcl_LoadHandle)Tcl_Alloc(sizeof(*newHandle));
    newHandle->clientData = pkg;
    newHandle->findSymbolProcPtr = &FindSymbol;
    newHandle->unloadFileProcPtr = &UnloadFile;







|







124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
     * impossible to get a package name given a module.
     *
     * I build loadable modules with a makefile rule like
     *		ld ... -export $@: -o $@ $(OBJS)
     */

    if ((pkg = strrchr(fileName, '/')) == NULL) {
	pkg = fileName;
    } else {
	pkg++;
    }
    newHandle = (Tcl_LoadHandle)Tcl_Alloc(sizeof(*newHandle));
    newHandle->clientData = pkg;
    newHandle->findSymbolProcPtr = &FindSymbol;
    newHandle->unloadFileProcPtr = &UnloadFile;

Changes to unix/tclUnixCompat.c.

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
    int *regsPtr)	/* Registers after the CPUID. */
{
    int status = TCL_ERROR;

    /* See: <http://en.wikipedia.org/wiki/CPUID> */
#if defined(__x86_64__) || defined(_M_AMD64) || defined (_M_X64)
    __asm__ __volatile__("movq %%rbx, %%rsi     \n\t" /* save %rbx */
                 "cpuid            \n\t"
                 "xchgq %%rsi, %%rbx   \n\t" /* restore the old %rbx */
                 : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3])
                 : "a"(index));
    status = TCL_OK;
#elif defined(__i386__) || defined(_M_IX86)
    __asm__ __volatile__("mov %%ebx, %%esi     \n\t" /* save %ebx */
                 "cpuid            \n\t"
                 "xchg %%esi, %%ebx   \n\t" /* restore the old %ebx */
                 : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3])
                 : "a"(index));
    status = TCL_OK;
#else
    (void)index;
    (void)regsPtr;
#endif
    return status;
}







|
|
|
|



|
|
|
|







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
    int *regsPtr)	/* Registers after the CPUID. */
{
    int status = TCL_ERROR;

    /* See: <http://en.wikipedia.org/wiki/CPUID> */
#if defined(__x86_64__) || defined(_M_AMD64) || defined (_M_X64)
    __asm__ __volatile__("movq %%rbx, %%rsi     \n\t" /* save %rbx */
	    "cpuid            \n\t"
	    "xchgq %%rsi, %%rbx   \n\t" /* restore the old %rbx */
	    : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3])
	    : "a"(index));
    status = TCL_OK;
#elif defined(__i386__) || defined(_M_IX86)
    __asm__ __volatile__("mov %%ebx, %%esi     \n\t" /* save %ebx */
	    "cpuid            \n\t"
	    "xchg %%esi, %%ebx   \n\t" /* restore the old %ebx */
	    : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3])
	    : "a"(index));
    status = TCL_OK;
#else
    (void)index;
    (void)regsPtr;
#endif
    return status;
}

Changes to unix/tclUnixInit.c.

50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
static const char *const processors[NUMPROCESSORS] = {
    "i686", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
    "x86_64", "ia32_on_win64", "neutral", "arm64", "arm32_on_win64", "ia32_on_arm64"
};

typedef struct {
    union {
        unsigned int  dwOemId;
        struct {
            int wProcessorArchitecture;
            int wReserved;
        };
    };
    unsigned int     dwPageSize;
    void *lpMinimumApplicationAddress;
    void *lpMaximumApplicationAddress;
    void *dwActiveProcessorMask;
    unsigned int     dwNumberOfProcessors;
    unsigned int     dwProcessorType;







|
|
|
|
|







50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
static const char *const processors[NUMPROCESSORS] = {
    "i686", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
    "x86_64", "ia32_on_win64", "neutral", "arm64", "arm32_on_win64", "ia32_on_arm64"
};

typedef struct {
    union {
	unsigned int  dwOemId;
	struct {
	    int wProcessorArchitecture;
	    int wReserved;
	};
    };
    unsigned int     dwPageSize;
    void *lpMinimumApplicationAddress;
    void *lpMaximumApplicationAddress;
    void *dwActiveProcessorMask;
    unsigned int     dwNumberOfProcessors;
    unsigned int     dwProcessorType;
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
	p = q+1;
    }
    if (*p) {
	Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(p, -1));
    }
    Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_pkgPath", -1), NULL, pkgListObj, TCL_GLOBAL_ONLY);
    {
        /* Some platforms build configure scripts expect ~ expansion so do that */
        Tcl_Obj *origPaths;
        Tcl_Obj *resolvedPaths;

        origPaths = Tcl_GetVar2Ex(interp, "tcl_pkgPath", NULL, TCL_GLOBAL_ONLY);
        resolvedPaths = TclResolveTildePathList(origPaths);
        if (resolvedPaths != origPaths && resolvedPaths != NULL) {
            Tcl_SetVar2Ex(interp, "tcl_pkgPath", NULL, resolvedPaths, TCL_GLOBAL_ONLY);
        }
    }

#ifdef DJGPP
    Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY);
#else
    Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY);
#endif







|
|
|

|
|
|
|
|







856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
	p = q+1;
    }
    if (*p) {
	Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(p, -1));
    }
    Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_pkgPath", -1), NULL, pkgListObj, TCL_GLOBAL_ONLY);
    {
	/* Some platforms build configure scripts expect ~ expansion so do that */
	Tcl_Obj *origPaths;
	Tcl_Obj *resolvedPaths;

	origPaths = Tcl_GetVar2Ex(interp, "tcl_pkgPath", NULL, TCL_GLOBAL_ONLY);
	resolvedPaths = TclResolveTildePathList(origPaths);
	if (resolvedPaths != origPaths && resolvedPaths != NULL) {
	    Tcl_SetVar2Ex(interp, "tcl_pkgPath", NULL, resolvedPaths, TCL_GLOBAL_ONLY);
	}
    }

#ifdef DJGPP
    Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY);
#else
    Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY);
#endif

Changes to unix/tclUnixPipe.c.

840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
    size_t numPids,		/* The number of pids in the pid array. */
    Tcl_Pid *pidPtr)		/* An array of process identifiers. Allocated
				 * by the caller, freed when the channel is
				 * closed or the processes are detached (in a
				 * background exec). */
{
    char channelName[16 + TCL_INTEGER_SPACE];
    int channelId;
    PipeState *statePtr = (PipeState *)Tcl_Alloc(sizeof(PipeState));
    int mode;

    statePtr->inFile = readFile;
    statePtr->outFile = writeFile;
    statePtr->errorFile = errorFile;
    statePtr->numPids = numPids;







|







840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
    size_t numPids,		/* The number of pids in the pid array. */
    Tcl_Pid *pidPtr)		/* An array of process identifiers. Allocated
				 * by the caller, freed when the channel is
				 * closed or the processes are detached (in a
				 * background exec). */
{
    char channelName[16 + TCL_INTEGER_SPACE];
    int fd;
    PipeState *statePtr = (PipeState *)Tcl_Alloc(sizeof(PipeState));
    int mode;

    statePtr->inFile = readFile;
    statePtr->outFile = writeFile;
    statePtr->errorFile = errorFile;
    statePtr->numPids = numPids;
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
    }

    /*
     * Use one of the fds associated with the channel as the channel id.
     */

    if (readFile) {
	channelId = GetFd(readFile);
    } else if (writeFile) {
	channelId = GetFd(writeFile);
    } else if (errorFile) {
	channelId = GetFd(errorFile);
    } else {
	channelId = 0;
    }

    /*
     * For backward compatibility with previous versions of Tcl, we use
     * "file%d" as the base name for pipes even though it would be more
     * natural to use "pipe%d".
     */

    snprintf(channelName, sizeof(channelName), "file%d", channelId);
    statePtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName,
	    statePtr, mode);
    return statePtr->channel;
}

/*
 *----------------------------------------------------------------------







|

|

|

|








|







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
    }

    /*
     * Use one of the fds associated with the channel as the channel id.
     */

    if (readFile) {
	fd = GetFd(readFile);
    } else if (writeFile) {
	fd = GetFd(writeFile);
    } else if (errorFile) {
	fd = GetFd(errorFile);
    } else {
	fd = 0;
    }

    /*
     * For backward compatibility with previous versions of Tcl, we use
     * "file%d" as the base name for pipes even though it would be more
     * natural to use "pipe%d".
     */

    snprintf(channelName, sizeof(channelName), "file%d", fd);
    statePtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName,
	    statePtr, mode);
    return statePtr->channel;
}

/*
 *----------------------------------------------------------------------
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
{
    Tcl_Channel chan;
    PipeState *pipePtr;
    size_t i;
    Tcl_Obj *resultPtr;

    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
	return TCL_ERROR;
    }

    if (objc == 1) {
	Tcl_SetObjResult(interp, Tcl_NewWideIntObj(getpid()));
    } else {
	/*







|







1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
{
    Tcl_Channel chan;
    PipeState *pipePtr;
    size_t i;
    Tcl_Obj *resultPtr;

    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?channel?");
	return TCL_ERROR;
    }

    if (objc == 1) {
	Tcl_SetObjResult(interp, Tcl_NewWideIntObj(getpid()));
    } else {
	/*

Changes to unix/tclUnixSock.c.

59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
    TcpFdList fds;		/* The file descriptors of the sockets. */
    int interest;		/* Event types of interest */

    /*
     * Only needed for server sockets
     */

    Tcl_TcpAcceptProc *acceptProc;
                                /* Proc to call on accept. */
    void *acceptProcData;  /* The data for the accept proc. */

    /*
     * Only needed for client sockets
     */

    struct addrinfo *addrlist;	/* Addresses to connect to. */







|
<







59
60
61
62
63
64
65
66

67
68
69
70
71
72
73
    TcpFdList fds;		/* The file descriptors of the sockets. */
    int interest;		/* Event types of interest */

    /*
     * Only needed for server sockets
     */

    Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */

    void *acceptProcData;  /* The data for the accept proc. */

    /*
     * Only needed for client sockets
     */

    struct addrinfo *addrlist;	/* Addresses to connect to. */
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

#ifndef NO_UNAME
    struct utsname u;
    struct hostent *hp;

    memset(&u, (int) 0, sizeof(struct utsname));
    if (uname(&u) >= 0) {				/* INTL: Native. */
        hp = TclpGetHostByName(u.nodename);		/* INTL: Native. */
	if (hp == NULL) {
	    /*
	     * Sometimes the nodename is fully qualified, but gets truncated
	     * as it exceeds SYS_NMLN. See if we can just get the immediate
	     * nodename and get a proper answer that way.
	     */

	    char *dot = strchr(u.nodename, '.');

	    if (dot != NULL) {
		char *node = (char *)Tcl_Alloc(dot - u.nodename + 1);

		memcpy(node, u.nodename, dot - u.nodename);
		node[dot - u.nodename] = '\0';
		hp = TclpGetHostByName(node);
		Tcl_Free(node);
	    }
	}
        if (hp != NULL) {
	    native = hp->h_name;
        } else {
	    native = u.nodename;
        }
    }
#else /* !NO_UNAME */
    /*
     * Uname doesn't exist; try gethostname instead.
     *
     * There is no portable macro for the maximum length of host names
     * returned by gethostbyname(). We should only trust SYS_NMLN if it is at







|


















|

|

|







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

#ifndef NO_UNAME
    struct utsname u;
    struct hostent *hp;

    memset(&u, (int) 0, sizeof(struct utsname));
    if (uname(&u) >= 0) {				/* INTL: Native. */
	hp = TclpGetHostByName(u.nodename);		/* INTL: Native. */
	if (hp == NULL) {
	    /*
	     * Sometimes the nodename is fully qualified, but gets truncated
	     * as it exceeds SYS_NMLN. See if we can just get the immediate
	     * nodename and get a proper answer that way.
	     */

	    char *dot = strchr(u.nodename, '.');

	    if (dot != NULL) {
		char *node = (char *)Tcl_Alloc(dot - u.nodename + 1);

		memcpy(node, u.nodename, dot - u.nodename);
		node[dot - u.nodename] = '\0';
		hp = TclpGetHostByName(node);
		Tcl_Free(node);
	    }
	}
	if (hp != NULL) {
	    native = hp->h_name;
	} else {
	    native = u.nodename;
	}
    }
#else /* !NO_UNAME */
    /*
     * Uname doesn't exist; try gethostname instead.
     *
     * There is no portable macro for the maximum length of host names
     * returned by gethostbyname(). We should only trust SYS_NMLN if it is at
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381

    if (mode == TCL_MODE_BLOCKING) {
	CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING);
    } else {
	SET_BITS(statePtr->flags, TCP_NONBLOCKING);
    }
    if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
        statePtr->cachedBlocking = mode;
        return 0;
    }
    if (TclUnixSetBlockingMode(statePtr->fds.fd, mode) < 0) {
	return errno;
    }
    return 0;
}








|
|







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

    if (mode == TCL_MODE_BLOCKING) {
	CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING);
    } else {
	SET_BITS(statePtr->flags, TCP_NONBLOCKING);
    }
    if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
	statePtr->cachedBlocking = mode;
	return 0;
    }
    if (TclUnixSetBlockingMode(statePtr->fds.fd, mode) < 0) {
	return errno;
    }
    return 0;
}

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
     * In socket test mode do not continue with the connect.
     * Exceptions are:
     * - Call by recv/send and blocking socket
     *   (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING))
     */

    if (GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE)
            && !(errorCodePtr != NULL
                    && !GOT_BITS(statePtr->flags, TCP_NONBLOCKING))) {
	*errorCodePtr = EWOULDBLOCK;
	return -1;
    }

    if (errorCodePtr == NULL || GOT_BITS(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 && GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT));

    if (errorCodePtr != NULL) {
        if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
            *errorCodePtr = EAGAIN;
            return -1;
        } else if (statePtr->connectError != 0) {
            *errorCodePtr = ENOTCONN;
            return -1;
        }
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *







|
|





|

|


|
|
|
|

|
|
|
|



|
|
|
|
|
|
|







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
     * In socket test mode do not continue with the connect.
     * Exceptions are:
     * - Call by recv/send and blocking socket
     *   (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING))
     */

    if (GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE)
	    && !(errorCodePtr != NULL
		    && !GOT_BITS(statePtr->flags, TCP_NONBLOCKING))) {
	*errorCodePtr = EWOULDBLOCK;
	return -1;
    }

    if (errorCodePtr == NULL || GOT_BITS(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 && GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT));

    if (errorCodePtr != NULL) {
	if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
	    *errorCodePtr = EAGAIN;
	    return -1;
	} else if (statePtr->connectError != 0) {
	    *errorCodePtr = ENOTCONN;
	    return -1;
	}
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
    while (fds != NULL) {
	TcpFdList *next = fds->next;

	Tcl_Free(fds);
	fds = next;
    }
    if (statePtr->addrlist != NULL) {
        freeaddrinfo(statePtr->addrlist);
    }
    if (statePtr->myaddrlist != NULL) {
        freeaddrinfo(statePtr->myaddrlist);
    }
    Tcl_Free(statePtr);
    return errorCode;
}

/*
 *----------------------------------------------------------------------







|


|







622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
    while (fds != NULL) {
	TcpFdList *next = fds->next;

	Tcl_Free(fds);
	fds = next;
    }
    if (statePtr->addrlist != NULL) {
	freeaddrinfo(statePtr->addrlist);
    }
    if (statePtr->myaddrlist != NULL) {
	freeaddrinfo(statePtr->myaddrlist);
    }
    Tcl_Free(statePtr);
    return errorCode;
}

/*
 *----------------------------------------------------------------------
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
#pragma GCC diagnostic ignored "-Wstrict-aliasing"
#endif
static inline int
IPv6AddressNeedsNumericRendering(
    struct in6_addr addr)
{
    if (IN6_ARE_ADDR_EQUAL(&addr, &in6addr_any)) {
        return 1;
    }

    /*
     * The IN6_IS_ADDR_V4MAPPED macro has a problem with aliasing warnings on
     * at least some versions of OSX.
     */

    if (!IN6_IS_ADDR_V4MAPPED(&addr)) {
        return 0;
    }

    return (addr.s6_addr[12] == 0 && addr.s6_addr[13] == 0
            && addr.s6_addr[14] == 0 && addr.s6_addr[15] == 0);
}
#if defined (__clang__) || ((__GNUC__)  && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5))))
#pragma GCC diagnostic pop
#endif
#endif /* NEED_FAKE_RFC2553 */

static void
TcpHostPortList(
    Tcl_Interp *interp,
    Tcl_DString *dsPtr,
    address addr,
    socklen_t salen)
{
#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS"
    char host[NI_MAXHOST], nhost[NI_MAXHOST], nport[NI_MAXSERV];
    int flags = 0;

    getnameinfo(&addr.sa, salen, nhost, sizeof(nhost), nport, sizeof(nport),
            NI_NUMERICHOST | NI_NUMERICSERV);
    Tcl_DStringAppendElement(dsPtr, nhost);

    /*
     * We don't want to resolve INADDR_ANY and sin6addr_any; they can
     * sometimes cause problems (and never have a name).
     */

    if (addr.sa.sa_family == AF_INET) {
        if (addr.sa4.sin_addr.s_addr == INADDR_ANY) {
            flags |= NI_NUMERICHOST;
        }
#ifndef NEED_FAKE_RFC2553
    } else if (addr.sa.sa_family == AF_INET6) {
        if (IPv6AddressNeedsNumericRendering(addr.sa6.sin6_addr)) {
            flags |= NI_NUMERICHOST;
        }
#endif /* NEED_FAKE_RFC2553 */
    }

    /*
     * Check if reverse DNS has been switched off globally.
     */

    if (interp != NULL &&
            Tcl_GetVar2(interp, SUPPRESS_RDNS_VAR, NULL, 0) != NULL) {
        flags |= NI_NUMERICHOST;
    }
    if (getnameinfo(&addr.sa, salen, host, sizeof(host), NULL, 0,
            flags) == 0) {
        /*
         * Reverse mapping worked.
         */

        Tcl_DStringAppendElement(dsPtr, host);
    } else {
        /*
         * Reverse mapping failed - use the numeric rep once more.
         */

        Tcl_DStringAppendElement(dsPtr, nhost);
    }
    Tcl_DStringAppendElement(dsPtr, nport);
}

/*
 *----------------------------------------------------------------------
 *







|








|



|


















|








|
|
|


|
|
|








|
|


|
|
|
|

|

|
|
|

|







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
#pragma GCC diagnostic ignored "-Wstrict-aliasing"
#endif
static inline int
IPv6AddressNeedsNumericRendering(
    struct in6_addr addr)
{
    if (IN6_ARE_ADDR_EQUAL(&addr, &in6addr_any)) {
	return 1;
    }

    /*
     * The IN6_IS_ADDR_V4MAPPED macro has a problem with aliasing warnings on
     * at least some versions of OSX.
     */

    if (!IN6_IS_ADDR_V4MAPPED(&addr)) {
	return 0;
    }

    return (addr.s6_addr[12] == 0 && addr.s6_addr[13] == 0
	    && addr.s6_addr[14] == 0 && addr.s6_addr[15] == 0);
}
#if defined (__clang__) || ((__GNUC__)  && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5))))
#pragma GCC diagnostic pop
#endif
#endif /* NEED_FAKE_RFC2553 */

static void
TcpHostPortList(
    Tcl_Interp *interp,
    Tcl_DString *dsPtr,
    address addr,
    socklen_t salen)
{
#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS"
    char host[NI_MAXHOST], nhost[NI_MAXHOST], nport[NI_MAXSERV];
    int flags = 0;

    getnameinfo(&addr.sa, salen, nhost, sizeof(nhost), nport, sizeof(nport),
	    NI_NUMERICHOST | NI_NUMERICSERV);
    Tcl_DStringAppendElement(dsPtr, nhost);

    /*
     * We don't want to resolve INADDR_ANY and sin6addr_any; they can
     * sometimes cause problems (and never have a name).
     */

    if (addr.sa.sa_family == AF_INET) {
	if (addr.sa4.sin_addr.s_addr == INADDR_ANY) {
	    flags |= NI_NUMERICHOST;
	}
#ifndef NEED_FAKE_RFC2553
    } else if (addr.sa.sa_family == AF_INET6) {
	if (IPv6AddressNeedsNumericRendering(addr.sa6.sin6_addr)) {
	    flags |= NI_NUMERICHOST;
	}
#endif /* NEED_FAKE_RFC2553 */
    }

    /*
     * Check if reverse DNS has been switched off globally.
     */

    if (interp != NULL &&
	    Tcl_GetVar2(interp, SUPPRESS_RDNS_VAR, NULL, 0) != NULL) {
	flags |= NI_NUMERICHOST;
    }
    if (getnameinfo(&addr.sa, salen, host, sizeof(host), NULL, 0,
	    flags) == 0) {
	/*
	 * Reverse mapping worked.
	 */

	Tcl_DStringAppendElement(dsPtr, host);
    } else {
	/*
	 * Reverse mapping failed - use the numeric rep once more.
	 */

	Tcl_DStringAppendElement(dsPtr, nhost);
    }
    Tcl_DStringAppendElement(dsPtr, nport);
}

/*
 *----------------------------------------------------------------------
 *
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
    }

    if ((len > 1) && (optionName[1] == 'e') &&
	    (strncmp(optionName, "-error", len) == 0)) {
	socklen_t optlen = sizeof(int);

	WaitForConnect(statePtr, NULL);
        if (GOT_BITS(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), TCL_INDEX_NONE);
        }
	return TCL_OK;
    }

    if ((len > 1) && (optionName[1] == 'c') &&
	    (strncmp(optionName, "-connecting", len) == 0)) {
	WaitForConnect(statePtr, NULL);
	Tcl_DStringAppend(dsPtr,
		GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT) ? "1" : "0", TCL_INDEX_NONE);
        return TCL_OK;
    }

    if ((len == 0) || ((len > 1) && (optionName[1] == 'p') &&
	    (strncmp(optionName, "-peername", len) == 0))) {
        address peername;
        socklen_t size = sizeof(peername);

	WaitForConnect(statePtr, NULL);
	if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
	    /*
	     * In async connect output an empty string
	     */








|
|
|
|

|
|
|
|
|
|

|
|
|
|
|

|








|




|
|







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
    }

    if ((len > 1) && (optionName[1] == 'e') &&
	    (strncmp(optionName, "-error", len) == 0)) {
	socklen_t optlen = sizeof(int);

	WaitForConnect(statePtr, NULL);
	if (GOT_BITS(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), TCL_INDEX_NONE);
	}
	return TCL_OK;
    }

    if ((len > 1) && (optionName[1] == 'c') &&
	    (strncmp(optionName, "-connecting", len) == 0)) {
	WaitForConnect(statePtr, NULL);
	Tcl_DStringAppend(dsPtr,
		GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT) ? "1" : "0", TCL_INDEX_NONE);
	return TCL_OK;
    }

    if ((len == 0) || ((len > 1) && (optionName[1] == 'p') &&
	    (strncmp(optionName, "-peername", len) == 0))) {
	address peername;
	socklen_t size = sizeof(peername);

	WaitForConnect(statePtr, NULL);
	if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
	    /*
	     * In async connect output an empty string
	     */

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
	     * Peername fetch succeeded - output list
	     */

	    if (len == 0) {
		Tcl_DStringAppendElement(dsPtr, "-peername");
		Tcl_DStringStartSublist(dsPtr);
	    }
            TcpHostPortList(interp, dsPtr, peername, size);
	    if (len) {
                return TCL_OK;
            }
            Tcl_DStringEndSublist(dsPtr);
	} else {
	    /*
	     * getpeername failed - but if we were asked for all the options
	     * (len==0), don't flag an error at that point because it could be
	     * an fconfigure request on a server socket (which have no peer).
	     * Same must be done on win&mac.
	     */

	    if (len) {
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                            "can't get peername: %s",
			    Tcl_PosixError(interp)));
		}
		return TCL_ERROR;
	    }
	}
    }








|

|
|
|











|







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
	     * Peername fetch succeeded - output list
	     */

	    if (len == 0) {
		Tcl_DStringAppendElement(dsPtr, "-peername");
		Tcl_DStringStartSublist(dsPtr);
	    }
	    TcpHostPortList(interp, dsPtr, peername, size);
	    if (len) {
		return TCL_OK;
	    }
	    Tcl_DStringEndSublist(dsPtr);
	} else {
	    /*
	     * getpeername failed - but if we were asked for all the options
	     * (len==0), don't flag an error at that point because it could be
	     * an fconfigure request on a server socket (which have no peer).
	     * Same must be done on win&mac.
	     */

	    if (len) {
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "can't get peername: %s",
			    Tcl_PosixError(interp)));
		}
		return TCL_ERROR;
	    }
	}
    }

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
	    Tcl_DStringStartSublist(dsPtr);
	}
	if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
	    /*
	     * In async connect output an empty string
	     */

            found = 1;
	} else {
	    for (fds = &statePtr->fds; fds != NULL; fds = fds->next) {
		size = sizeof(sockname);
		if (getsockname(fds->fd, &(sockname.sa), &size) >= 0) {
		    found = 1;
		    TcpHostPortList(interp, dsPtr, sockname, size);
		}
	    }
	}
        if (found) {
            if (len) {
                return TCL_OK;
            }
            Tcl_DStringEndSublist(dsPtr);
        } else {
            if (interp) {
                Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                        "can't get sockname: %s", Tcl_PosixError(interp)));
            }
	    return TCL_ERROR;
	}
    }

    if ((len == 0) || ((len > 1) && (optionName[1] == 'k') &&
	    (strncmp(optionName, "-keepalive", len) == 0))) {
	int opt = 0;







|









|
|
|
|
|
|
|
|
|
|







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
	    Tcl_DStringStartSublist(dsPtr);
	}
	if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
	    /*
	     * In async connect output an empty string
	     */

	    found = 1;
	} else {
	    for (fds = &statePtr->fds; fds != NULL; fds = fds->next) {
		size = sizeof(sockname);
		if (getsockname(fds->fd, &(sockname.sa), &size) >= 0) {
		    found = 1;
		    TcpHostPortList(interp, dsPtr, sockname, size);
		}
	    }
	}
	if (found) {
	    if (len) {
		return TCL_OK;
	    }
	    Tcl_DStringEndSublist(dsPtr);
	} else {
	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"can't get sockname: %s", Tcl_PosixError(interp)));
	    }
	    return TCL_ERROR;
	}
    }

    if ((len == 0) || ((len > 1) && (optionName[1] == 'k') &&
	    (strncmp(optionName, "-keepalive", len) == 0))) {
	int opt = 0;
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
	if (len > 0) {
	    return TCL_OK;
	}
    }

    if (len > 0) {
	return Tcl_BadChannelOption(interp, optionName,
                "connecting keepalive nodelay peername sockname");
    }

    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------







|







1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
	if (len > 0) {
	    return TCL_OK;
	}
    }

    if (len > 0) {
	return Tcl_BadChannelOption(interp, optionName,
		"connecting keepalive nodelay peername sockname");
    }

    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
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
    int mask)			/* Events of interest; an OR-ed combination of
				 * TCL_READABLE, TCL_WRITABLE and
				 * TCL_EXCEPTION. */
{
    TcpState *statePtr = (TcpState *)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 (GOT_BITS(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







|
|
|
|
|





|
|
|
|

|







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
    int mask)			/* Events of interest; an OR-ed combination of
				 * TCL_READABLE, TCL_WRITABLE and
				 * TCL_EXCEPTION. */
{
    TcpState *statePtr = (TcpState *)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 (GOT_BITS(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
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
    socklen_t optlen;
    int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING);
    int ret = -1, error = EHOSTUNREACH;
    int async = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
    static const int reuseaddr = 1;

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

            /*
             * Must 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, because
         * 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;
}

/*
 *----------------------------------------------------------------------
 *







|



|
|
|
|









|
|
|
|

|


|



|


















|
|
|
|
|
|

|
|
|
|

|

|
|
|
|
|
|
|
|









|
|
|
|

|
|
|
|
|
|

|
|
|

|
|
|
|
|
|

|

|
|
|
|










|
|
|

|
|

|
|
|

|
|
|
|
|
|
|
|






|
|
|
|
|

|
|
|
|
|
|







1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
    socklen_t optlen;
    int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING);
    int ret = -1, error = EHOSTUNREACH;
    int async = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
    static const int reuseaddr = 1;

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

	    /*
	     * Must 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, because
	 * 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;
}

/*
 *----------------------------------------------------------------------
 *
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
    char channelName[SOCK_CHAN_LENGTH];

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

    /*
     * Allocate a new TcpState for this socket.
     */

    statePtr = (TcpState *)Tcl_Alloc(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;
    }

    snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, PTR2INT(statePtr));

    statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
            statePtr, TCL_READABLE | TCL_WRITABLE);
    if (Tcl_SetChannelOption(interp, statePtr->channel, "-translation",
	    "auto crlf") == TCL_ERROR) {
	Tcl_CloseEx(NULL, statePtr->channel, 0);
	return NULL;
    }
    return statePtr->channel;
}







|
|
|
|
|
|
|
|
|
|



















|
|





|







1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
    char channelName[SOCK_CHAN_LENGTH];

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

    /*
     * Allocate a new TcpState for this socket.
     */

    statePtr = (TcpState *)Tcl_Alloc(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;
    }

    snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, PTR2INT(statePtr));

    statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
	    statePtr, TCL_READABLE | TCL_WRITABLE);
    if (Tcl_SetChannelOption(interp, statePtr->channel, "-translation",
	    "auto crlf") == TCL_ERROR) {
	Tcl_CloseEx(NULL, statePtr->channel, 0);
	return NULL;
    }
    return statePtr->channel;
}
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
 */

Tcl_Channel
Tcl_MakeTcpClientChannel(
    void *sock)		/* The socket to wrap up into a channel. */
{
    return (Tcl_Channel) TclpMakeTcpClientChannelMode(sock,
            TCL_READABLE | TCL_WRITABLE);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpMakeTcpClientChannelMode --
 *







|







1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
 */

Tcl_Channel
Tcl_MakeTcpClientChannel(
    void *sock)		/* The socket to wrap up into a channel. */
{
    return (Tcl_Channel) TclpMakeTcpClientChannelMode(sock,
	    TCL_READABLE | TCL_WRITABLE);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpMakeTcpClientChannelMode --
 *
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
     */

    int retry = 0;
#define MAXRETRY 10

 repeat:
    if (retry > 0) {
        if (statePtr != NULL) {
            TcpCloseProc(statePtr, NULL);
            statePtr = NULL;
        }
        if (addrlist != NULL) {
            freeaddrinfo(addrlist);
            addrlist = NULL;
        }
        if (retry >= MAXRETRY) {
            goto error;
        }
    }
    retry++;
    chosenport = 0;

    if (TclSockGetPort(interp, service, "tcp", &port) != TCL_OK) {
	errorMsg = "invalid port number";
	goto error;
    }

    if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1,
            &errorMsg)) {
	my_errno = errno;
	goto error;
    }

    for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) {
	sock = socket(addrPtr->ai_family, addrPtr->ai_socktype,
                addrPtr->ai_protocol);
	if (sock == -1) {
	    if (howfar < SOCKET) {
		howfar = SOCKET;
		my_errno = errno;
	    }
	    continue;
	}







|
|
|
|
|
|
|
|
|
|
|










|






|







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

    int retry = 0;
#define MAXRETRY 10

 repeat:
    if (retry > 0) {
	if (statePtr != NULL) {
	    TcpCloseProc(statePtr, NULL);
	    statePtr = NULL;
	}
	if (addrlist != NULL) {
	    freeaddrinfo(addrlist);
	    addrlist = NULL;
	}
	if (retry >= MAXRETRY) {
	    goto error;
	}
    }
    retry++;
    chosenport = 0;

    if (TclSockGetPort(interp, service, "tcp", &port) != TCL_OK) {
	errorMsg = "invalid port number";
	goto error;
    }

    if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1,
	    &errorMsg)) {
	my_errno = errno;
	goto error;
    }

    for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) {
	sock = socket(addrPtr->ai_family, addrPtr->ai_socktype,
		addrPtr->ai_protocol);
	if (sock == -1) {
	    if (howfar < SOCKET) {
		howfar = SOCKET;
		my_errno = errno;
	    }
	    continue;
	}
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
#else
	    optvalue = 1;
	    (void) setsockopt(sock, SOL_SOCKET, SO_REUSEPORT,
		    (char *) &optvalue, sizeof(optvalue));
#endif
	}

        /*
         * Make sure we use the same port number when opening two server
         * sockets for IPv4 and IPv6 on a random port.
         *
         * 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);
	}

#ifdef IPV6_V6ONLY
	/*
         * Missing on: Solaris 2.8
         */

        if (addrPtr->ai_family == AF_INET6) {
            int v6only = 1;

            (void) setsockopt(sock, IPPROTO_IPV6, IPV6_V6ONLY,
                    &v6only, sizeof(v6only));
        }
#endif /* IPV6_V6ONLY */

	status = bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen);
        if (status == -1) {
	    if (howfar < BIND) {
		howfar = BIND;
		my_errno = errno;
	    }
            close(sock);
            sock = -1;
            if (port == 0 && errno == EADDRINUSE) {
                goto repeat;
            }
            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);
            }
        }
        if (backlog < 0) {
            backlog = SOMAXCONN;
        }
        status = listen(sock, backlog);
        if (status < 0) {
	    if (howfar < LISTEN) {
		howfar = LISTEN;
		my_errno = errno;
	    }
            close(sock);
            sock = -1;
            if (port == 0 && errno == EADDRINUSE) {
                goto repeat;
            }
            continue;
        }
        if (statePtr == NULL) {
            /*
             * Allocate a new TcpState for this socket.
             */

            statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState));
            memset(statePtr, 0, sizeof(TcpState));
            statePtr->acceptProc = acceptProc;
            statePtr->acceptProcData = acceptProcData;
            snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, PTR2INT(statePtr));
            newfds = &statePtr->fds;
        } else {
            newfds = (TcpFdList *)Tcl_Alloc(sizeof(TcpFdList));
            memset(newfds, (int) 0, sizeof(TcpFdList));
            fds->next = newfds;
        }
        newfds->fd = sock;
        newfds->statePtr = statePtr;
        fds = newfds;

        /*
         * Set up the callback mechanism for accepting connections from new
         * clients.
         */

        Tcl_CreateFileHandler(sock, TCL_READABLE, TcpAccept, fds);
    }

  error:
    if (addrlist != NULL) {
	freeaddrinfo(addrlist);
    }
    if (statePtr != NULL) {
	statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
		statePtr, 0);
	return statePtr->channel;
    }
    if (interp != NULL) {
        Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", TCL_INDEX_NONE);

	if (errorMsg == NULL) {
            errno = my_errno;
            Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), TCL_INDEX_NONE);
        } else {
	    Tcl_AppendToObj(errorObj, errorMsg, TCL_INDEX_NONE);
	}
        Tcl_SetObjResult(interp, errorObj);
    }
    if (sock != -1) {
	close(sock);
    }
    return NULL;
}








|
|
|
|
|
|
|



|




|
|

|
|

|
|
|



|




|
|
|
|
|
|
|
|
|
|

|
|
|
|

|
|
|
|
|
|
|
|
|




|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|

|












|


|
|
|


|







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
#else
	    optvalue = 1;
	    (void) setsockopt(sock, SOL_SOCKET, SO_REUSEPORT,
		    (char *) &optvalue, sizeof(optvalue));
#endif
	}

	/*
	 * Make sure we use the same port number when opening two server
	 * sockets for IPv4 and IPv6 on a random port.
	 *
	 * 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);
	}

#ifdef IPV6_V6ONLY
	/*
	 * Missing on: Solaris 2.8
	 */

	if (addrPtr->ai_family == AF_INET6) {
	    int v6only = 1;

	    (void) setsockopt(sock, IPPROTO_IPV6, IPV6_V6ONLY,
		    &v6only, sizeof(v6only));
	}
#endif /* IPV6_V6ONLY */

	status = bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen);
	if (status == -1) {
	    if (howfar < BIND) {
		howfar = BIND;
		my_errno = errno;
	    }
	    close(sock);
	    sock = -1;
	    if (port == 0 && errno == EADDRINUSE) {
		goto repeat;
	    }
	    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);
	    }
	}
	if (backlog < 0) {
	    backlog = SOMAXCONN;
	}
	status = listen(sock, backlog);
	if (status < 0) {
	    if (howfar < LISTEN) {
		howfar = LISTEN;
		my_errno = errno;
	    }
	    close(sock);
	    sock = -1;
	    if (port == 0 && errno == EADDRINUSE) {
		goto repeat;
	    }
	    continue;
	}
	if (statePtr == NULL) {
	    /*
	     * Allocate a new TcpState for this socket.
	     */

	    statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState));
	    memset(statePtr, 0, sizeof(TcpState));
	    statePtr->acceptProc = acceptProc;
	    statePtr->acceptProcData = acceptProcData;
	    snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, PTR2INT(statePtr));
	    newfds = &statePtr->fds;
	} else {
	    newfds = (TcpFdList *)Tcl_Alloc(sizeof(TcpFdList));
	    memset(newfds, (int) 0, sizeof(TcpFdList));
	    fds->next = newfds;
	}
	newfds->fd = sock;
	newfds->statePtr = statePtr;
	fds = newfds;

	/*
	 * Set up the callback mechanism for accepting connections from new
	 * clients.
	 */

	Tcl_CreateFileHandler(sock, TCL_READABLE, TcpAccept, fds);
    }

  error:
    if (addrlist != NULL) {
	freeaddrinfo(addrlist);
    }
    if (statePtr != NULL) {
	statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
		statePtr, 0);
	return statePtr->channel;
    }
    if (interp != NULL) {
	Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", TCL_INDEX_NONE);

	if (errorMsg == NULL) {
	    errno = my_errno;
	    Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), TCL_INDEX_NONE);
	} else {
	    Tcl_AppendToObj(errorObj, errorMsg, TCL_INDEX_NONE);
	}
	Tcl_SetObjResult(interp, errorObj);
    }
    if (sock != -1) {
	close(sock);
    }
    return NULL;
}

1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
	    newSockState, TCL_READABLE | TCL_WRITABLE);

    Tcl_SetChannelOption(NULL, newSockState->channel, "-translation",
	    "auto crlf");

    if (fds->statePtr->acceptProc != NULL) {
	getnameinfo(&addr.sa, len, host, sizeof(host), port, sizeof(port),
                NI_NUMERICHOST|NI_NUMERICSERV);
	fds->statePtr->acceptProc(fds->statePtr->acceptProcData,
                newSockState->channel, host, atoi(port));
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * tab-width: 8
 * indent-tabs-mode: nil
 * End:
 */







|

|












1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
	    newSockState, TCL_READABLE | TCL_WRITABLE);

    Tcl_SetChannelOption(NULL, newSockState->channel, "-translation",
	    "auto crlf");

    if (fds->statePtr->acceptProc != NULL) {
	getnameinfo(&addr.sa, len, host, sizeof(host), port, sizeof(port),
		NI_NUMERICHOST|NI_NUMERICSERV);
	fds->statePtr->acceptProc(fds->statePtr->acceptProcData,
		newSockState->channel, host, atoi(port));
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * tab-width: 8
 * indent-tabs-mode: nil
 * End:
 */

Changes to win/Makefile.in.

603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
	@$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE}
	@MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
	$(COPY) tclsh.exe.manifest ${TEST_DLL_FILE}.manifest

${TEST_EXE_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} tclTestMain.${OBJEXT}
	@$(RM) ${TEST_EXE_FILE}
	$(CC) $(CFLAGS) $(TCLTEST_OBJS) tclTestMain.$(OBJEXT) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
        tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
	$(COPY) tclsh.exe.manifest ${TEST_EXE_FILE}.manifest

# use prebuilt zlib1.dll
${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE}
	@if test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win64-arm/zdll.libset" ; then \
		$(COPY) $(ZLIB_DIR)/win64-arm/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \
	elif test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.aset" ; then \







|







603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
	@$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE}
	@MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
	$(COPY) tclsh.exe.manifest ${TEST_DLL_FILE}.manifest

${TEST_EXE_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} tclTestMain.${OBJEXT}
	@$(RM) ${TEST_EXE_FILE}
	$(CC) $(CFLAGS) $(TCLTEST_OBJS) tclTestMain.$(OBJEXT) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
		tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
	$(COPY) tclsh.exe.manifest ${TEST_EXE_FILE}.manifest

# use prebuilt zlib1.dll
${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE}
	@if test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win64-arm/zdll.libset" ; then \
		$(COPY) $(ZLIB_DIR)/win64-arm/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \
	elif test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.aset" ; then \

Changes to win/nmakehlp.c.

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
    SetEnvironmentVariable("LINK", "");

    if (argc > 1 && *argv[1] == '-') {
	switch (*(argv[1]+1)) {
	case 'c':
	    if (argc != 3) {
		chars = snprintf(msg, sizeof(msg) - 1,
		        "usage: %s -c <compiler option>\n"
			"Tests for whether cl.exe supports an option\n"
			"exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
		WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
			&dwWritten, NULL);
		return 2;
	    }
	    return CheckForCompilerFeature(argv[2]);







|







86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
    SetEnvironmentVariable("LINK", "");

    if (argc > 1 && *argv[1] == '-') {
	switch (*(argv[1]+1)) {
	case 'c':
	    if (argc != 3) {
		chars = snprintf(msg, sizeof(msg) - 1,
			"usage: %s -c <compiler option>\n"
			"Tests for whether cl.exe supports an option\n"
			"exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
		WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
			&dwWritten, NULL);
		return 2;
	    }
	    return CheckForCompilerFeature(argv[2]);
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
	    NULL,	    /* Use parent's starting directory. */
	    &si,	    /* Pointer to STARTUPINFO structure. */
	    &pi);	    /* Pointer to PROCESS_INFORMATION structure. */

    if (!ok) {
	DWORD err = GetLastError();
	int chars = snprintf(msg, sizeof(msg) - 1,
		"Tried to launch: \"%s\", but got error [%lu]: ", cmdline, err);

	FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS|
		FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars],
		(300-chars), 0);
	WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL);
	return 2;
    }







|







267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
	    NULL,	    /* Use parent's starting directory. */
	    &si,	    /* Pointer to STARTUPINFO structure. */
	    &pi);	    /* Pointer to PROCESS_INFORMATION structure. */

    if (!ok) {
	DWORD err = GetLastError();
	int chars = snprintf(msg, sizeof(msg) - 1,
		"Tried to launch: \"%s\", but got error [%u]: ", cmdline, err);

	FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS|
		FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars],
		(300-chars), 0);
	WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL);
	return 2;
    }
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332

    /*
     * Look for the commandline warning code in both streams.
     *  - in MSVC 6 & 7 we get D4002, in MSVC 8 we get D9002.
     */

    return !(strstr(Out.buffer, "D4002") != NULL
             || strstr(Err.buffer, "D4002") != NULL
             || strstr(Out.buffer, "D9002") != NULL
             || strstr(Err.buffer, "D9002") != NULL
             || strstr(Out.buffer, "D2021") != NULL
             || strstr(Err.buffer, "D2021") != NULL);
}

static int
CheckForLinkerFeature(
    char **options,
    int count)
{







|
|
|
|
|







314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332

    /*
     * Look for the commandline warning code in both streams.
     *  - in MSVC 6 & 7 we get D4002, in MSVC 8 we get D9002.
     */

    return !(strstr(Out.buffer, "D4002") != NULL
	    || strstr(Err.buffer, "D4002") != NULL
	    || strstr(Out.buffer, "D9002") != NULL
	    || strstr(Err.buffer, "D9002") != NULL
	    || strstr(Out.buffer, "D2021") != NULL
	    || strstr(Err.buffer, "D2021") != NULL);
}

static int
CheckForLinkerFeature(
    char **options,
    int count)
{
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
	    NULL,	    /* Use parent's starting directory. */
	    &si,	    /* Pointer to STARTUPINFO structure. */
	    &pi);	    /* Pointer to PROCESS_INFORMATION structure. */

    if (!ok) {
	DWORD err = GetLastError();
	int chars = snprintf(msg, sizeof(msg) - 1,
		"Tried to launch: \"%s\", but got error [%lu]: ", cmdline, err);

	FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS|
		FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars],
		(300-chars), 0);
	WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL);
	return 2;
    }







|







401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
	    NULL,	    /* Use parent's starting directory. */
	    &si,	    /* Pointer to STARTUPINFO structure. */
	    &pi);	    /* Pointer to PROCESS_INFORMATION structure. */

    if (!ok) {
	DWORD err = GetLastError();
	int chars = snprintf(msg, sizeof(msg) - 1,
		"Tried to launch: \"%s\", but got error [%u]: ", cmdline, err);

	FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS|
		FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars],
		(300-chars), 0);
	WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL);
	return 2;
    }
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
 *	option here to handle autoconf style substitutions.
 *	The substitution file is whitespace and line delimited. The file should
 *	consist of lines matching the regular expression:
 *	  \s*\S+\s+\S*$
 *
 *	Usage is something like:
 *	  nmakehlp -S << $** > $@
 *        @PACKAGE_NAME@ $(PACKAGE_NAME)
 *        @PACKAGE_VERSION@ $(PACKAGE_VERSION)
 *        <<
 */

static int
SubstituteFile(
    const char *substitutions,
    const char *filename)
{







|
|
|







596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
 *	option here to handle autoconf style substitutions.
 *	The substitution file is whitespace and line delimited. The file should
 *	consist of lines matching the regular expression:
 *	  \s*\S+\s+\S*$
 *
 *	Usage is something like:
 *	  nmakehlp -S << $** > $@
 *	    @PACKAGE_NAME@ $(PACKAGE_NAME)
 *	    @PACKAGE_VERSION@ $(PACKAGE_VERSION)
 *	    <<
 */

static int
SubstituteFile(
    const char *substitutions,
    const char *filename)
{
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
    int keylen, ret;
    WIN32_FIND_DATA finfo;

    if (dir == NULL || keypath == NULL) {
	return 2; /* Have no real error reporting mechanism into nmake */
    }
    dirlen = strlen(dir);
    if (dirlen > sizeof(path) - 3) {
	return 2;
    }
    strncpy(path, dir, dirlen);
    strncpy(path+dirlen, "\\*", 3);	/* Including terminating \0 */
    keylen = strlen(keypath);

#if 0 /* This function is not available in Visual C++ 6 */
    /*
     * Use numerics 0 -> FindExInfoStandard,
     * 1 -> FindExSearchLimitToDirectories,
     * as these are not defined in Visual C++ 6
     */
    hSearch = FindFirstFileEx(path, 0, &finfo, 1, NULL, 0);
#else
    hSearch = FindFirstFile(path, &finfo);
#endif
    if (hSearch == INVALID_HANDLE_VALUE)
	return 1; /* Not found */


    /* Loop through all subdirs checking if the keypath is under there */
    ret = 1; /* Assume not found */
    do {
	int sublen;
	/*
	 * We need to check it is a directory despite the
	 * FindExSearchLimitToDirectories in the above call. See SDK docs
	 */
	if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0)
	    continue;

	sublen = strlen(finfo.cFileName);
	if ((dirlen+1+sublen+1+keylen+1) > sizeof(path))
	    continue;		/* Path does not fit, assume not matched */

	strncpy(path+dirlen+1, finfo.cFileName, sublen);
	path[dirlen+1+sublen] = '\\';
	strncpy(path+dirlen+1+sublen+1, keypath, keylen+1);
	if (FileExists(path)) {
	    /* Found a match, print to stdout */
	    path[dirlen+1+sublen] = '\0';
	    QualifyPath(path);
	    ret = 0;
	    break;
	}
    } while (FindNextFile(hSearch, &finfo));
    FindClose(hSearch);
    return ret;
}

/*
 * LocateDependency --
 *
 *	Locates a dependency for a package.
 *        keypath - a relative path within the package directory
 *          that is used to confirm it is the correct directory.
 *	The search path for the package directory is currently only
 *      the parent and grandparent of the current working directory.
 *      If found, the command prints
 *         name_DIRPATH=<full path of located directory>
 *      and returns 0. If not found, does not print anything and returns 1.
 */
static int LocateDependency(const char *keypath)
{
    size_t i;
    int ret;
    static const char *paths[] = {"..", "..\\..", "..\\..\\.."};








|
















|

>









|

>

|

>



















|
|

|
|
|
|







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
    int keylen, ret;
    WIN32_FIND_DATA finfo;

    if (dir == NULL || keypath == NULL) {
	return 2; /* Have no real error reporting mechanism into nmake */
    }
    dirlen = strlen(dir);
    if ((dirlen + 3) > sizeof(path)) {
	return 2;
    }
    strncpy(path, dir, dirlen);
    strncpy(path+dirlen, "\\*", 3);	/* Including terminating \0 */
    keylen = strlen(keypath);

#if 0 /* This function is not available in Visual C++ 6 */
    /*
     * Use numerics 0 -> FindExInfoStandard,
     * 1 -> FindExSearchLimitToDirectories,
     * as these are not defined in Visual C++ 6
     */
    hSearch = FindFirstFileEx(path, 0, &finfo, 1, NULL, 0);
#else
    hSearch = FindFirstFile(path, &finfo);
#endif
    if (hSearch == INVALID_HANDLE_VALUE) {
	return 1; /* Not found */
    }

    /* Loop through all subdirs checking if the keypath is under there */
    ret = 1; /* Assume not found */
    do {
	int sublen;
	/*
	 * We need to check it is a directory despite the
	 * FindExSearchLimitToDirectories in the above call. See SDK docs
	 */
	if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0) {
	    continue;
	}
	sublen = strlen(finfo.cFileName);
	if ((dirlen+1+sublen+1+keylen+1) > sizeof(path)) {
	    continue;		/* Path does not fit, assume not matched */
	}
	strncpy(path+dirlen+1, finfo.cFileName, sublen);
	path[dirlen+1+sublen] = '\\';
	strncpy(path+dirlen+1+sublen+1, keypath, keylen+1);
	if (FileExists(path)) {
	    /* Found a match, print to stdout */
	    path[dirlen+1+sublen] = '\0';
	    QualifyPath(path);
	    ret = 0;
	    break;
	}
    } while (FindNextFile(hSearch, &finfo));
    FindClose(hSearch);
    return ret;
}

/*
 * LocateDependency --
 *
 *	Locates a dependency for a package.
 *	    keypath - a relative path within the package directory
 *	      that is used to confirm it is the correct directory.
 *	The search path for the package directory is currently only
 *	    the parent and grandparent of the current working directory.
 *	    If found, the command prints
 *	      name_DIRPATH=<full path of located directory>
 *	    and returns 0. If not found, does not print anything and returns 1.
 */
static int LocateDependency(const char *keypath)
{
    size_t i;
    int ret;
    static const char *paths[] = {"..", "..\\..", "..\\..\\.."};

Changes to win/tclWinDde.c.

1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
    enum DdeSrvOptions {
	DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST,
    };
    static const char *const ddeExecOptions[] = {
	"-async", "-binary", NULL
    };
    enum DdeExecOptions {
        DDE_EXEC_ASYNC, DDE_EXEC_BINARY
    };
    static const char *const ddeEvalOptions[] = {
	"-async", NULL
    };
    static const char *const ddeReqOptions[] = {
	"-binary", NULL
    };







|







1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
    enum DdeSrvOptions {
	DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST,
    };
    static const char *const ddeExecOptions[] = {
	"-async", "-binary", NULL
    };
    enum DdeExecOptions {
	DDE_EXEC_ASYNC, DDE_EXEC_BINARY
    };
    static const char *const ddeEvalOptions[] = {
	"-async", NULL
    };
    static const char *const ddeReqOptions[] = {
	"-binary", NULL
    };

Changes to win/tclWinFCmd.c.

1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
	     *	fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]);
	     */

	    Tcl_DStringInit(&dsTemp);
	    Tcl_WCharToUtfDString(nativeName, TCL_INDEX_NONE, &dsTemp);
	    Tcl_DStringFree(&ds);

            tempPath = Tcl_DStringToObj(&dsTemp);
            Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath);
	    FindClose(handle);
	}
    }

    *attributePtrPtr = Tcl_FSJoinPath(splitPath, TCL_INDEX_NONE);

    if (splitPath != NULL) {







|
|







1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
	     *	fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]);
	     */

	    Tcl_DStringInit(&dsTemp);
	    Tcl_WCharToUtfDString(nativeName, TCL_INDEX_NONE, &dsTemp);
	    Tcl_DStringFree(&ds);

	    tempPath = Tcl_DStringToObj(&dsTemp);
	    Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath);
	    FindClose(handle);
	}
    }

    *attributePtrPtr = Tcl_FSJoinPath(splitPath, TCL_INDEX_NONE);

    if (splitPath != NULL) {

Changes to win/tclWinFile.c.

1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
    Tcl_DStringInit(bufferPtr);

    wDomain = NULL;
    domain = Tcl_UtfFindFirst(name, '@');
    if (domain == NULL) {
	const char *ptr;

        /*
         * Treat the current user as a special case because the general case
         * below does not properly retrieve the path. The NetUserGetInfo
         * call returns an empty path and the code defaults to the user's
         * name in the profiles directory. On modern Windows systems, this
         * is generally wrong as when the account is a Microsoft account,
         * for example [email protected], the directory name is
         * abcde and not abcdefghi.
         *
         * Note we could have just used env(USERPROFILE) here but
         * the intent is to retrieve (as on Unix) the system's view
         * of the home irrespective of environment settings of HOME
         * and USERPROFILE.
         *
         * Fixing this for the general user needs more investigating but
         * at least for the current user we can use a direct call.
         */
	ptr = TclpGetUserName(&ds);
	if (ptr != NULL && strcasecmp(name, ptr) == 0) {
	    HANDLE hProcess;
	    WCHAR buf[MAX_PATH];
	    DWORD nChars = sizeof(buf) / sizeof(buf[0]);
	    /* Sadly GetCurrentProcessToken not in Win 7 so slightly longer */
	    hProcess = GetCurrentProcess(); /* Need not be closed */







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
    Tcl_DStringInit(bufferPtr);

    wDomain = NULL;
    domain = Tcl_UtfFindFirst(name, '@');
    if (domain == NULL) {
	const char *ptr;

	/*
	 * Treat the current user as a special case because the general case
	 * below does not properly retrieve the path. The NetUserGetInfo
	 * call returns an empty path and the code defaults to the user's
	 * name in the profiles directory. On modern Windows systems, this
	 * is generally wrong as when the account is a Microsoft account,
	 * for example [email protected], the directory name is
	 * abcde and not abcdefghi.
	 *
	 * Note we could have just used env(USERPROFILE) here but
	 * the intent is to retrieve (as on Unix) the system's view
	 * of the home irrespective of environment settings of HOME
	 * and USERPROFILE.
	 *
	 * Fixing this for the general user needs more investigating but
	 * at least for the current user we can use a direct call.
	 */
	ptr = TclpGetUserName(&ds);
	if (ptr != NULL && strcasecmp(name, ptr) == 0) {
	    HANDLE hProcess;
	    WCHAR buf[MAX_PATH];
	    DWORD nChars = sizeof(buf) / sizeof(buf[0]);
	    /* Sadly GetCurrentProcessToken not in Win 7 so slightly longer */
	    hProcess = GetCurrentProcess(); /* Need not be closed */
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
	    NULL, OPEN_EXISTING,
	    FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL);

    if (fileHandle != INVALID_HANDLE_VALUE) {
	BY_HANDLE_FILE_INFORMATION data;

	if (GetFileInformationByHandle(fileHandle,&data) != TRUE) {
            fileType = GetFileType(fileHandle);
            CloseHandle(fileHandle);
            if (fileType != FILE_TYPE_CHAR && fileType != FILE_TYPE_DISK) {
                Tcl_SetErrno(ENOENT);
                return -1;
            }

            /*
	     * Mock up the expected structure
	     */

            memset(&data, 0, sizeof(data));
            statPtr->st_atime = 0;
            statPtr->st_mtime = 0;
            statPtr->st_ctime = 0;
        } else {
            CloseHandle(fileHandle);
            statPtr->st_atime = ToCTime(data.ftLastAccessTime);
            statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
            statPtr->st_ctime = ToCTime(data.ftCreationTime);
        }
	attr = data.dwFileAttributes;
	statPtr->st_size = ((long long) data.nFileSizeLow) |
		(((long long) data.nFileSizeHigh) << 32);

	/*
	 * On Unix, for directories, nlink apparently depends on the number of
	 * files in the directory.  We could calculate that, but it would be a







|
|
|
|
|
|

|



|
|
|
|
|
|
|
|
|
|







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
	    NULL, OPEN_EXISTING,
	    FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL);

    if (fileHandle != INVALID_HANDLE_VALUE) {
	BY_HANDLE_FILE_INFORMATION data;

	if (GetFileInformationByHandle(fileHandle,&data) != TRUE) {
	    fileType = GetFileType(fileHandle);
	    CloseHandle(fileHandle);
	    if (fileType != FILE_TYPE_CHAR && fileType != FILE_TYPE_DISK) {
		Tcl_SetErrno(ENOENT);
		return -1;
	    }

	    /*
	     * Mock up the expected structure
	     */

	    memset(&data, 0, sizeof(data));
	    statPtr->st_atime = 0;
	    statPtr->st_mtime = 0;
	    statPtr->st_ctime = 0;
	} else {
	    CloseHandle(fileHandle);
	    statPtr->st_atime = ToCTime(data.ftLastAccessTime);
	    statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
	    statPtr->st_ctime = ToCTime(data.ftCreationTime);
	}
	attr = data.dwFileAttributes;
	statPtr->st_size = ((long long) data.nFileSizeLow) |
		(((long long) data.nFileSizeHigh) << 32);

	/*
	 * On Unix, for directories, nlink apparently depends on the number of
	 * files in the directory.  We could calculate that, but it would be a
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
	statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
	statPtr->st_ctime = ToCTime(data.ftCreationTime);
    }

    dev = NativeDev(nativePath);
    mode = NativeStatMode(attr, checkLinks, NativeIsExec(nativePath));
    if (fileType == FILE_TYPE_CHAR) {
        mode &= ~S_IFMT;
        mode |= S_IFCHR;
    } else if (fileType == FILE_TYPE_DISK) {
        mode &= ~S_IFMT;
        mode |= S_IFBLK;
    }

    statPtr->st_dev	= (dev_t) dev;
    statPtr->st_ino	= inode;
    statPtr->st_mode	= mode;
    statPtr->st_nlink	= nlink;
    statPtr->st_uid	= 0;







|
|

|
|







2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
	statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
	statPtr->st_ctime = ToCTime(data.ftCreationTime);
    }

    dev = NativeDev(nativePath);
    mode = NativeStatMode(attr, checkLinks, NativeIsExec(nativePath));
    if (fileType == FILE_TYPE_CHAR) {
	mode &= ~S_IFMT;
	mode |= S_IFCHR;
    } else if (fileType == FILE_TYPE_DISK) {
	mode &= ~S_IFMT;
	mode |= S_IFBLK;
    }

    statPtr->st_dev	= (dev_t) dev;
    statPtr->st_ino	= inode;
    statPtr->st_mode	= mode;
    statPtr->st_nlink	= nlink;
    statPtr->st_uid	= 0;
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
3328
3329
3330
3331
3332
3333
3334
    int owned = 0;

    native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);

    if (GetNamedSecurityInfoW((LPWSTR) native, SE_FILE_OBJECT,
	    OWNER_SECURITY_INFORMATION, &ownerSid, NULL, NULL, NULL,
	    &secd) != ERROR_SUCCESS) {
        /*
	 * Either not a file, or we do not have access to it in which case we
	 * are in all likelihood not the owner.
	 */

        return 0;
    }

    /*
     * Getting the current process SID is a multi-step process.  We make the
     * assumption that if a call fails, this process is so underprivileged it
     * could not possibly own anything. Normally a process can *always* look
     * up its own token.
     */

    if (OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &token)) {
        /*
	 * Find out how big the buffer needs to be.
	 */

        bufsz = 0;
        GetTokenInformation(token, TokenUser, NULL, 0, &bufsz);
        if (bufsz) {
            buf = (LPBYTE)Tcl_Alloc(bufsz);
            if (GetTokenInformation(token, TokenUser, buf, bufsz, &bufsz)) {
                owned = EqualSid(ownerSid, ((PTOKEN_USER) buf)->User.Sid);
            }
        }
        CloseHandle(token);
    }

    /*
     * Free allocations and be done.
     */

    if (secd) {
        LocalFree(secd);            /* Also frees ownerSid */
    }
    if (buf) {
        Tcl_Free(buf);
    }

    return (owned != 0);        /* Convert non-0 to 1 */
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







|




|










|



|
|
|
|
|
|
|
|
|







|


|












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
3328
3329
3330
3331
3332
3333
3334
    int owned = 0;

    native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);

    if (GetNamedSecurityInfoW((LPWSTR) native, SE_FILE_OBJECT,
	    OWNER_SECURITY_INFORMATION, &ownerSid, NULL, NULL, NULL,
	    &secd) != ERROR_SUCCESS) {
	/*
	 * Either not a file, or we do not have access to it in which case we
	 * are in all likelihood not the owner.
	 */

	return 0;
    }

    /*
     * Getting the current process SID is a multi-step process.  We make the
     * assumption that if a call fails, this process is so underprivileged it
     * could not possibly own anything. Normally a process can *always* look
     * up its own token.
     */

    if (OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &token)) {
	/*
	 * Find out how big the buffer needs to be.
	 */

	bufsz = 0;
	GetTokenInformation(token, TokenUser, NULL, 0, &bufsz);
	if (bufsz) {
	    buf = (LPBYTE)Tcl_Alloc(bufsz);
	    if (GetTokenInformation(token, TokenUser, buf, bufsz, &bufsz)) {
		owned = EqualSid(ownerSid, ((PTOKEN_USER) buf)->User.Sid);
	    }
	}
	CloseHandle(token);
    }

    /*
     * Free allocations and be done.
     */

    if (secd) {
	LocalFree(secd);            /* Also frees ownerSid */
    }
    if (buf) {
	Tcl_Free(buf);
    }

    return (owned != 0);        /* Convert non-0 to 1 */
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to win/tclWinInit.c.

512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
	if (ptr != NULL) {
	    Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE);
	}
	if (Tcl_DStringLength(&ds) > 0) {
	    Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds),
		    TCL_GLOBAL_ONLY);
	} else {
            /* None of HOME, HOMEDRIVE, HOMEPATH exists. Try USERPROFILE */
            ptr = Tcl_GetVar2(interp, "env", "USERPROFILE", TCL_GLOBAL_ONLY);
            if (ptr != NULL && ptr[0]) {
                Tcl_SetVar2(interp, "env", "HOME", ptr, TCL_GLOBAL_ONLY);
            } else {
                /* Last resort */
                Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY);
            }
	}
    }

    /*
     * Initialize the user name from the environment first, since this is much
     * faster than asking the system.
     * Note: cchUserNameLen is number of characters including nul terminator.







|
|
|
|
|
|
|
|







512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
	if (ptr != NULL) {
	    Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE);
	}
	if (Tcl_DStringLength(&ds) > 0) {
	    Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds),
		    TCL_GLOBAL_ONLY);
	} else {
	    /* None of HOME, HOMEDRIVE, HOMEPATH exists. Try USERPROFILE */
	    ptr = Tcl_GetVar2(interp, "env", "USERPROFILE", TCL_GLOBAL_ONLY);
	    if (ptr != NULL && ptr[0]) {
		Tcl_SetVar2(interp, "env", "HOME", ptr, TCL_GLOBAL_ONLY);
	    } else {
		/* Last resort */
		Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY);
	    }
	}
    }

    /*
     * Initialize the user name from the environment first, since this is much
     * faster than asking the system.
     * Note: cchUserNameLen is number of characters including nul terminator.

Changes to win/tclWinLoad.c.

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
	 * Let the OS loader examine the binary search path for whatever
	 * string the user gave us which hopefully refers to a file on the
	 * binary path.
	 */

	Tcl_DString ds;

        /*
         * Remember the first error on load attempt to be used if the
         * second load attempt below also fails.
        */
        firstError = (nativeName == NULL) ?
		ERROR_MOD_NOT_FOUND : GetLastError();

	Tcl_DStringInit(&ds);
	nativeName = Tcl_UtfToWCharDString(TclGetString(pathPtr), TCL_INDEX_NONE, &ds);
	hInstance = LoadLibraryExW(nativeName, NULL,
		LOAD_WITH_ALTERED_SEARCH_PATH);
	Tcl_DStringFree(&ds);
    }

    if (hInstance == NULL) {
	DWORD lastError;
        Tcl_Obj *errMsg;

        /*
         * We choose to only use the error from the second call if the first
         * call failed due to the file not being found. Else stick to the
         * first error for reporting purposes.
         */
        if (firstError == ERROR_MOD_NOT_FOUND ||
		firstError == ERROR_DLL_NOT_FOUND) {
            lastError = GetLastError();
        } else {
            lastError = firstError;
        }

	errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ",
		TclGetString(pathPtr));

	/*
	 * Check for possible DLL errors. This doesn't work quite right,
	 * because Windows seems to only return ERROR_MOD_NOT_FOUND for just







|
|
|
|
|











|

|
|
|
|
|
|

|
|
|
|







86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
	 * Let the OS loader examine the binary search path for whatever
	 * string the user gave us which hopefully refers to a file on the
	 * binary path.
	 */

	Tcl_DString ds;

	/*
	 * Remember the first error on load attempt to be used if the
	 * second load attempt below also fails.
	*/
	firstError = (nativeName == NULL) ?
		ERROR_MOD_NOT_FOUND : GetLastError();

	Tcl_DStringInit(&ds);
	nativeName = Tcl_UtfToWCharDString(TclGetString(pathPtr), TCL_INDEX_NONE, &ds);
	hInstance = LoadLibraryExW(nativeName, NULL,
		LOAD_WITH_ALTERED_SEARCH_PATH);
	Tcl_DStringFree(&ds);
    }

    if (hInstance == NULL) {
	DWORD lastError;
	Tcl_Obj *errMsg;

	/*
	 * We choose to only use the error from the second call if the first
	 * call failed due to the file not being found. Else stick to the
	 * first error for reporting purposes.
	 */
	if (firstError == ERROR_MOD_NOT_FOUND ||
		firstError == ERROR_DLL_NOT_FOUND) {
	    lastError = GetLastError();
	} else {
	    lastError = firstError;
	}

	errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ",
		TclGetString(pathPtr));

	/*
	 * Check for possible DLL errors. This doesn't work quite right,
	 * because Windows seems to only return ERROR_MOD_NOT_FOUND for just
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
			" is damaged", TCL_INDEX_NONE);
		break;
	    case ERROR_DLL_INIT_FAILED:
		Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", (char *)NULL);
		Tcl_AppendToObj(errMsg, "the library initialization"
			" routine failed", TCL_INDEX_NONE);
		break;
            case ERROR_BAD_EXE_FORMAT:
		Tcl_SetErrorCode(interp, "WIN_LOAD", "BAD_EXE_FORMAT", (char *)NULL);
		Tcl_AppendToObj(errMsg, "Bad exe format. Possibly a 32/64-bit mismatch.", TCL_INDEX_NONE);
                break;
            default:
		Tcl_WinConvertError(lastError);
		Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), TCL_INDEX_NONE);
	    }
	    Tcl_SetObjResult(interp, errMsg);
	}
	return TCL_ERROR;
    }







|


|
|







153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
			" is damaged", TCL_INDEX_NONE);
		break;
	    case ERROR_DLL_INIT_FAILED:
		Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", (char *)NULL);
		Tcl_AppendToObj(errMsg, "the library initialization"
			" routine failed", TCL_INDEX_NONE);
		break;
	    case ERROR_BAD_EXE_FORMAT:
		Tcl_SetErrorCode(interp, "WIN_LOAD", "BAD_EXE_FORMAT", (char *)NULL);
		Tcl_AppendToObj(errMsg, "Bad exe format. Possibly a 32/64-bit mismatch.", TCL_INDEX_NONE);
		break;
	    default:
		Tcl_WinConvertError(lastError);
		Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), TCL_INDEX_NONE);
	    }
	    Tcl_SetObjResult(interp, errMsg);
	}
	return TCL_ERROR;
    }

Changes to win/tclWinPipe.c.

2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
    Tcl_Channel chan;
    const Tcl_ChannelType *chanTypePtr;
    PipeInfo *pipePtr;
    size_t i;
    Tcl_Obj *resultPtr;

    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
	return TCL_ERROR;
    }
    if (objc == 1) {
	Tcl_SetObjResult(interp, Tcl_NewWideIntObj(getpid()));
    } else {
	chan = Tcl_GetChannel(interp, TclGetString(objv[1]),
		NULL);







|







2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
    Tcl_Channel chan;
    const Tcl_ChannelType *chanTypePtr;
    PipeInfo *pipePtr;
    size_t i;
    Tcl_Obj *resultPtr;

    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?channel?");
	return TCL_ERROR;
    }
    if (objc == 1) {
	Tcl_SetObjResult(interp, Tcl_NewWideIntObj(getpid()));
    } else {
	chan = Tcl_GetChannel(interp, TclGetString(objv[1]),
		NULL);