Tcl Source Code

Check-in [19ff51752b]
Login
EuroTcl/OpenACS 11 - 12 JULY 2024, VIENNA

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

Overview
Comment:Merge trunk
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-697
Files: files | file ages | folders
SHA3-256: 19ff51752bec3accb7a4340c6c52d15cad6d5aace3ccbe331235f5d9009fa1b2
User & Date: jan.nijtmans 2024-06-19 09:25:51
Context
2024-06-19
10:32
TIP #697: 32-bit truncation in format and scan (let's gain some time) check-in: 810eb78647 user: jan.nijtmans tags: trunk, main
09:25
Merge trunk Closed-Leaf check-in: 19ff51752b user: jan.nijtmans tags: tip-697
2024-06-18
22:41
Fix some more indenting check-in: 229a985faf user: jan.nijtmans tags: trunk, main
2024-05-31
14:39
Rebase to 9.0 check-in: 7083ff878b user: jan.nijtmans tags: tip-697
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to compat/fake-rfc2553.c.

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
TCL_DECLARE_MUTEX(netdbMutex)

#ifndef HAVE_GETNAMEINFO
#ifndef HAVE_STRLCPY
static size_t
strlcpy(char *dst, const char *src, size_t siz)
{
        char *d = dst;
        const char *s = src;
        size_t n = siz;

        /* Copy as many bytes as will fit */
        if (n != 0 && --n != 0) {
                do {
                        if ((*d++ = *s++) == 0)
                                break;
                } while (--n != 0);
        }

        /* Not enough room in dst, add NUL and traverse rest of src */
        if (n == 0) {
                if (siz != 0)
                        *d = '\0';              /* NUL-terminate dst */
                while (*s++)
                        ;
        }

        return(s - src - 1);    /* count does not include NUL */
}
#endif

int fake_getnameinfo(const struct sockaddr *sa, size_t salen, char *host,
                size_t hostlen, char *serv, size_t servlen, int flags)
{
	struct sockaddr_in *sin = (struct sockaddr_in *)sa;
	struct hostent *hp;
	char tmpserv[16];
	(void)salen;

	if (sa->sa_family != AF_UNSPEC && sa->sa_family != AF_INET)







|
|
|

|
|
|
|
|
|
|

|
|
|
|
|
|
|

|




|







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
TCL_DECLARE_MUTEX(netdbMutex)

#ifndef HAVE_GETNAMEINFO
#ifndef HAVE_STRLCPY
static size_t
strlcpy(char *dst, const char *src, size_t siz)
{
	char *d = dst;
	const char *s = src;
	size_t n = siz;

	/* Copy as many bytes as will fit */
	if (n != 0 && --n != 0) {
		do {
			if ((*d++ = *s++) == 0)
				break;
		} while (--n != 0);
	}

	/* Not enough room in dst, add NUL and traverse rest of src */
	if (n == 0) {
		if (siz != 0)
			*d = '\0';	      /* NUL-terminate dst */
		while (*s++)
			;
	}

	return(s - src - 1);    /* count does not include NUL */
}
#endif

int fake_getnameinfo(const struct sockaddr *sa, size_t salen, char *host,
	size_t hostlen, char *serv, size_t servlen, int flags)
{
	struct sockaddr_in *sin = (struct sockaddr_in *)sa;
	struct hostent *hp;
	char tmpserv[16];
	(void)salen;

	if (sa->sa_family != AF_UNSPEC && sa->sa_family != AF_INET)

Changes to doc/Access.3.

29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
file exists and has read, write and execute permissions, respectively.
\fBF_OK\fR just requests a check for the existence of the file.
.AP "struct stat" *statPtr out
The structure that contains the result.
.BE
.SH DESCRIPTION
.PP
As of Tcl 8.4, the object-based APIs \fBTcl_FSAccess\fR and \fBTcl_FSStat\fR
should be used in preference to \fBTcl_Access\fR and \fBTcl_Stat\fR, wherever
possible. Those functions also support Tcl's virtual filesystem layer, which
these do not.
.SS "OBSOLETE FUNCTIONS"
.PP
There are two reasons for calling \fBTcl_Access\fR and \fBTcl_Stat\fR rather
than calling system level functions \fBaccess\fR and \fBstat\fR directly.







|







29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
file exists and has read, write and execute permissions, respectively.
\fBF_OK\fR just requests a check for the existence of the file.
.AP "struct stat" *statPtr out
The structure that contains the result.
.BE
.SH DESCRIPTION
.PP
The object-based APIs \fBTcl_FSAccess\fR and \fBTcl_FSStat\fR
should be used in preference to \fBTcl_Access\fR and \fBTcl_Stat\fR, wherever
possible. Those functions also support Tcl's virtual filesystem layer, which
these do not.
.SS "OBSOLETE FUNCTIONS"
.PP
There are two reasons for calling \fBTcl_Access\fR and \fBTcl_Stat\fR rather
than calling system level functions \fBaccess\fR and \fBstat\fR directly.

Changes to doc/AddErrInfo.3.

24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
.sp
\fBTcl_AppendObjToErrorInfo\fR(\fIinterp, objPtr\fR)
.sp
\fBTcl_AddObjErrorInfo\fR(\fIinterp, message, length\fR)
.sp
\fBTcl_SetObjErrorCode\fR(\fIinterp, errorObjPtr\fR)
.sp
\fBTcl_SetErrorCode\fR(\fIinterp, element, element, ... \fBNULL\fR)
.sp
int
\fBTcl_GetErrorLine\fR(\fIinterp\fR)
.sp
\fBTcl_SetErrorLine\fR(\fIinterp, lineNum\fR)
.sp
const char *







|







24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
.sp
\fBTcl_AppendObjToErrorInfo\fR(\fIinterp, objPtr\fR)
.sp
\fBTcl_AddObjErrorInfo\fR(\fIinterp, message, length\fR)
.sp
\fBTcl_SetObjErrorCode\fR(\fIinterp, errorObjPtr\fR)
.sp
\fBTcl_SetErrorCode\fR(\fIinterp, element, element, ... \fB(char *)NULL\fR)
.sp
int
\fBTcl_GetErrorLine\fR(\fIinterp\fR)
.sp
\fBTcl_SetErrorLine\fR(\fIinterp, lineNum\fR)
.sp
const char *
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
The number of bytes to copy from \fImessage\fR when
appending to the \fB\-errorinfo\fR return option.
If negative, all bytes up to the first null byte are used.
.AP Tcl_Obj *errorObjPtr in
The \fB\-errorcode\fR return option will be set to this value.
.AP "const char" *element in
String to record as one element of the \fB\-errorcode\fR return option.
Last \fIelement\fR argument must be NULL.
.AP int lineNum
The line number of a script where an error occurred.
.AP "const char" *script in
Pointer to first character in script containing command
(must be <= \fIcommand\fR).
.AP "const char" *command in
Pointer to first character in the command that generated the error; must







|







63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
The number of bytes to copy from \fImessage\fR when
appending to the \fB\-errorinfo\fR return option.
If negative, all bytes up to the first null byte are used.
.AP Tcl_Obj *errorObjPtr in
The \fB\-errorcode\fR return option will be set to this value.
.AP "const char" *element in
String to record as one element of the \fB\-errorcode\fR return option.
Last \fIelement\fR argument must be (char *)NULL.
.AP int lineNum
The line number of a script where an error occurred.
.AP "const char" *script in
Pointer to first character in script containing command
(must be <= \fIcommand\fR).
.AP "const char" *command in
Pointer to first character in the command that generated the error; must

Changes to doc/Alloc.3.

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
.BS
.SH NAME
Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, Tcl_GetMemoryInfo \- allocate or free heap memory
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
char *
\fBTcl_Alloc\fR(\fIsize\fR)
.sp
\fBTcl_Free\fR(\fIptr\fR)
.sp
void *
\fBTcl_Realloc\fR(\fIptr, size\fR)
.sp
void *
\fBTcl_AttemptAlloc\fR(\fIsize\fR)
.sp
void *
\fBTcl_AttemptRealloc\fR(\fIptr, size\fR)
.sp
\fBTcl_GetMemoryInfo\fR(\fIdsPtr\fR)
.fi
.SH ARGUMENTS
.AS char *size
.AP "size_t" size in
Size in bytes of the memory block to allocate.
.AP char *ptr in
Pointer to memory block to free or realloc.
.AP Tcl_DString *dsPtr in
Initialized DString pointer.
.BE

.SH DESCRIPTION
.PP







|



















|







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
.BS
.SH NAME
Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, Tcl_GetMemoryInfo \- allocate or free heap memory
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
void *
\fBTcl_Alloc\fR(\fIsize\fR)
.sp
\fBTcl_Free\fR(\fIptr\fR)
.sp
void *
\fBTcl_Realloc\fR(\fIptr, size\fR)
.sp
void *
\fBTcl_AttemptAlloc\fR(\fIsize\fR)
.sp
void *
\fBTcl_AttemptRealloc\fR(\fIptr, size\fR)
.sp
\fBTcl_GetMemoryInfo\fR(\fIdsPtr\fR)
.fi
.SH ARGUMENTS
.AS char *size
.AP "size_t" size in
Size in bytes of the memory block to allocate.
.AP void *ptr in
Pointer to memory block to free or realloc.
.AP Tcl_DString *dsPtr in
Initialized DString pointer.
.BE

.SH DESCRIPTION
.PP

Changes to doc/Eval.3.

33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
int
\fBTcl_GlobalEval\fR(\fIinterp, script\fR)
.sp
int
\fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR)
.sp
int
\fBTcl_VarEval\fR(\fIinterp, part, part, ... \fBNULL\fR)
.fi
.SH ARGUMENTS
.AS Tcl_Interp **termPtr
.AP Tcl_Interp *interp in
Interpreter in which to execute the script.  The interpreter's result is
modified to hold the result or error message from the script.
.AP Tcl_Obj *objPtr in







|







33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
int
\fBTcl_GlobalEval\fR(\fIinterp, script\fR)
.sp
int
\fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR)
.sp
int
\fBTcl_VarEval\fR(\fIinterp, part, part, ... \fB(char *)NULL\fR)
.fi
.SH ARGUMENTS
.AS Tcl_Interp **termPtr
.AP Tcl_Interp *interp in
Interpreter in which to execute the script.  The interpreter's result is
modified to hold the result or error message from the script.
.AP Tcl_Obj *objPtr in
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
equivalent to using the \fBTCL_EVAL_GLOBAL\fR flag (see below).
.PP
\fBTcl_VarEval\fR takes any number of string arguments
of any length, concatenates them into a single string,
then calls \fBTcl_Eval\fR to execute that string as a Tcl command.
It returns the result of the command and also modifies
the interpreter result in the same way as \fBTcl_Eval\fR.
The last argument to \fBTcl_VarEval\fR must be NULL to indicate the end
of arguments.

.SH "FLAG BITS"
.PP
Any OR'ed combination of the following values may be used for the
\fIflags\fR argument to procedures such as \fBTcl_EvalObjEx\fR:
.TP 23







|







134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
equivalent to using the \fBTCL_EVAL_GLOBAL\fR flag (see below).
.PP
\fBTcl_VarEval\fR takes any number of string arguments
of any length, concatenates them into a single string,
then calls \fBTcl_Eval\fR to execute that string as a Tcl command.
It returns the result of the command and also modifies
the interpreter result in the same way as \fBTcl_Eval\fR.
The last argument to \fBTcl_VarEval\fR must be (char *)NULL to indicate the end
of arguments.

.SH "FLAG BITS"
.PP
Any OR'ed combination of the following values may be used for the
\fIflags\fR argument to procedures such as \fBTcl_EvalObjEx\fR:
.TP 23

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/Preserve.3.

77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
.PP
All the work of freeing the object is carried out by \fIfreeProc\fR.
\fIFreeProc\fR must have arguments and result that match the
type \fBTcl_FreeProc\fR:
.PP
.CS
typedef void \fBTcl_FreeProc\fR(
        char *\fIblockPtr\fR);
.CE
.PP
The \fIblockPtr\fR argument to \fIfreeProc\fR will be the
same as the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR.
The type of \fIblockPtr\fR (\fBchar *\fR) is different than the type of the
\fIclientData\fR argument to \fBTcl_EventuallyFree\fR for historical
reasons, but the value is the same.
.PP
When the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR
refers to storage allocated and returned by a prior call to
\fBTcl_Alloc\fR or another function of the Tcl library,
then the \fIfreeProc\fR argument should be given the special value of
\fBTCL_DYNAMIC\fR.
.PP







|




<
<
<







77
78
79
80
81
82
83
84
85
86
87
88



89
90
91
92
93
94
95
.PP
All the work of freeing the object is carried out by \fIfreeProc\fR.
\fIFreeProc\fR must have arguments and result that match the
type \fBTcl_FreeProc\fR:
.PP
.CS
typedef void \fBTcl_FreeProc\fR(
        void *\fIblockPtr\fR);
.CE
.PP
The \fIblockPtr\fR argument to \fIfreeProc\fR will be the
same as the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR.



.PP
When the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR
refers to storage allocated and returned by a prior call to
\fBTcl_Alloc\fR or another function of the Tcl library,
then the \fIfreeProc\fR argument should be given the special value of
\fBTCL_DYNAMIC\fR.
.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.

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
\fBTcl_GetObjResult\fR(\fIinterp\fR)
.sp
\fBTcl_SetResult\fR(\fIinterp, result, freeProc\fR)
.sp
const char *
\fBTcl_GetStringResult\fR(\fIinterp\fR)
.sp
\fBTcl_AppendResult\fR(\fIinterp, result, result, ... , \fBNULL\fR)
.sp
\fBTcl_ResetResult\fR(\fIinterp\fR)
.sp
\fBTcl_TransferResult\fR(\fIsourceInterp, code, targetInterp\fR)
.sp
\fBTcl_AppendElement\fR(\fIinterp, element\fR)
.fi
.SH ARGUMENTS
.AS Tcl_FreeProc sourceInterp out
.AP Tcl_Interp *interp out
The interpreter get or set the result for.
.AP Tcl_Obj *objPtr in
A value to set the result to.
.AP char *result in

The string value set the result to, or to append to the existing result.
.AP "const char" *element in
The string value to append as a list element
to the existing result of \fIinterp\fR.
.AP Tcl_FreeProc *freeProc in
Pointer to a procedure to call to release storage at
\fIresult\fR.

.AP Tcl_Interp *sourceInterp in
The interpreter to transfer the result and return options from.
.AP Tcl_Interp *targetInterp in
The interpreter to transfer the result and return options to.
.AP int code in
Return code value that controls transfer of return options.
.BE
.SH DESCRIPTION
.PP
These procedures manipulate the result of an interpreter.  Some procedures
provide a Tcl_Obj interface while others provide a string interface.  For

example, \fBTcl_SetObjResult\fR accepts a Tcl_Obj and \fBTcl_SetResult\fR

accepts a char *.  Similarly, \fBTcl_GetObjResult\fR produces a Tcl_Obj * and

\fBTcl_GetStringResult\fR produces a char *.  The procedures can be mixed and

matched.  For example, if \fBTcl_SetObjResult\fR is called to set the result to

a Tcl_Obj value, and then \fBTcl_GetStringResult\fR is called, it returns a
char * (but see caveats below).

.PP
\fBTcl_SetObjResult\fR sets \fIobjPtr\fR as the result for \fIinterp\fR,

replacing any existing result.







.PP
\fBTcl_GetObjResult\fR returns the result for \fIinterp\fR, without
incrementing its reference count.



.PP
\fBTcl_SetResult\fR sets \fIresult\fR as the result for \fIinterp\fR, replacing

any existing result, and calls \fIfreeProc\fR to free \fIresult\fR.  See \fBTHE



TCL_FREEPROC ARGUMENT TO TCL_SETRESULT\fR below.  If \fIresult\fR is
\fBNULL\fR, ignores \fIfreeProc\fR and sets the result for \fIinterp\fR to

point to the empty string.
.PP
\fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as a string, i.e.
the bytes of the Tcl_Obj for the result, which can be decoded using
\fBTcl_UtfToExternal\fR.  This value is freed when its corresponding Tcl_Obj is


freed.Programmers are encouraged to use the newer Tcl_Obj API procedures, e.g.

to call \fBTcl_GetObjResult\fR instead.
.PP


\fBTcl_ResetResult\fR sets the empty string as the result for \fIinterp\fR and




clears the error state managed by \fBTcl_AddErrorInfo\fR,

\fBTcl_AddObjErrorInfo\fR, and \fBTcl_SetErrorCode\fR.
.PP
\fBTcl_AppendResult\fR builds up a result from smaller pieces, appending each

\fIresult\fR in order to the current result for \fIinterp\fR.  It may be called





repeatedly as additional pieces of the result are produced, and manages the


storage for the \fIinterp\fR's result, allocating a larger result area if
necessary.  It also manages conversion to and from the \fIresult\fR field of
the \fIinterp\fR to handle backward-compatibility with old-style extensions.

Any number of \fIresult\fR arguments may be passed in a single call; the last
argument in the list must be a NULL pointer.
.PP
\fBTcl_TransferResult\fR transfers interpreter state from \fIsourceInterp\fR to
\fItargetInterp\fR, both of which must have been created in the same thread,



resets the result in \fIsourceInterp\fR, and moves the return options
dictionary as controlled by the return code value \fIcode\fR in the same manner
as \fBTcl_GetReturnOptions\fR.
.PP
If \fIsourceInterp\fR and \fItargetInterp\fR are the same, nothing is done.
.SH "DEPRECATED INTERFACES"
.SS "OLD STRING PROCEDURES"
.PP

The following procedures are deprecated since they manipulate the Tcl result as
a string.  Procedures such as \fBTcl_SetObjResult\fR can be significantly more

efficient.
.PP
\fBTcl_AppendElement\fR is like \fBTcl_AppendResult\fR, but it appends only one


piece, and also appends that piece as a list item.

\fBTcl_AppendElement\fR adds backslashes or braces as necessary to ensure that


\fIelement\fR is properly formatted as a list item.  Under normal conditions,
\fBTcl_AppendElement\fR adds a space character to \fIinterp\fR's result just
before adding the new list element, so that the list elements in the result are

properly separated.  However if the new list element is the first item in the
list or sublist (i.e. \fIinterp\fR's current result is empty, or consists of
the single character
.QW { ,
or ends in the characters
.QW " {" )
then no space is added.
.SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT"
.PP










\fIFreeProc\fR has the following type:


















.PP
.CS
typedef void \fBTcl_FreeProc\fR(
        char *\fIblockPtr\fR);
.CE
.PP
When \fIfreeProc\fR is called, \fIblockPtr\fR is the \fIresult\fR value passed
to \fBTcl_SetResult\fR.



























.SH "SEE ALSO"
Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp,
Tcl_GetReturnOptions
.SH KEYWORDS
append, command, element, list, value, result, return value, interpreter







|










|

|

>
|

|


|
|
>

|

|





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

|
>

>
>
>
>
>
>
>

|
|
>
>
>

|
>
|
>
>
>
|
|
>
|

|
|
|
>
>
|
>
|

>
>
|
>
>
>
>
|
>
|

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

|
|
>
>
>
|
|

<
<



>
|
|
>
|

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






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



|


|
|

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





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
\fBTcl_GetObjResult\fR(\fIinterp\fR)
.sp
\fBTcl_SetResult\fR(\fIinterp, result, freeProc\fR)
.sp
const char *
\fBTcl_GetStringResult\fR(\fIinterp\fR)
.sp
\fBTcl_AppendResult\fR(\fIinterp, result, result, ... , \fB(char *)NULL\fR)
.sp
\fBTcl_ResetResult\fR(\fIinterp\fR)
.sp
\fBTcl_TransferResult\fR(\fIsourceInterp, code, targetInterp\fR)
.sp
\fBTcl_AppendElement\fR(\fIinterp, element\fR)
.fi
.SH ARGUMENTS
.AS Tcl_FreeProc sourceInterp out
.AP Tcl_Interp *interp out
Interpreter whose result is to be modified or read.
.AP Tcl_Obj *objPtr in
Tcl value to become result for \fIinterp\fR.
.AP char *result in
String value to become result for \fIinterp\fR or to be
appended to the existing result.
.AP "const char" *element in
String value to append as a list element
to the existing result of \fIinterp\fR.
.AP Tcl_FreeProc *freeProc in
Address of procedure to call to release storage at
\fIresult\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or
\fBTCL_VOLATILE\fR.
.AP Tcl_Interp *sourceInterp in
Interpreter that the result and return options should be transferred from.
.AP Tcl_Interp *targetInterp in
Interpreter that the result and return options should be transferred to.
.AP int code in
Return code value that controls transfer of return options.
.BE
.SH DESCRIPTION
.PP
The procedures described here are utilities for manipulating the
result value in a Tcl interpreter.
The interpreter result may be either a Tcl value or a string.
For example, \fBTcl_SetObjResult\fR and \fBTcl_SetResult\fR
set the interpreter result to, respectively, a value and a string.
Similarly, \fBTcl_GetObjResult\fR and \fBTcl_GetStringResult\fR
return the interpreter result as a value and as a string.
The procedures always keep the string and value forms
of the interpreter result consistent.
For example, if \fBTcl_SetObjResult\fR is called to set
the result to a value,
then \fBTcl_GetStringResult\fR is called,

it will return the value's string representation.
.PP
\fBTcl_SetObjResult\fR
arranges for \fIobjPtr\fR to be the result for \fIinterp\fR,
replacing any existing result.
The result is left pointing to the value
referenced by \fIobjPtr\fR.
\fIobjPtr\fR's reference count is incremented
since there is now a new reference to it from \fIinterp\fR.
The reference count for any old result value
is decremented and the old result value is freed if no
references to it remain.
.PP
\fBTcl_GetObjResult\fR returns the result for \fIinterp\fR as a value.
The value's reference count is not incremented;
if the caller needs to retain a long-term pointer to the value
they should use \fBTcl_IncrRefCount\fR to increment its reference count
in order to keep it from being freed too early or accidentally changed.
.PP
\fBTcl_SetResult\fR
arranges for \fIresult\fR to be the result for the current Tcl
command in \fIinterp\fR, replacing any existing result.
The \fIfreeProc\fR argument specifies how to manage the storage
for the \fIresult\fR argument;
it is discussed in the section
\fBTHE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT\fR below.
If \fIresult\fR is \fBNULL\fR, then \fIfreeProc\fR is ignored
and \fBTcl_SetResult\fR
re-initializes \fIinterp\fR's result to point to an empty string.
.PP
\fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as a string.
If the result was set to a value by a \fBTcl_SetObjResult\fR call,
the value form will be converted to a string and returned.
If the value's string representation contains null bytes,
this conversion will lose information.
For this reason, programmers are encouraged to
write their code to use the new value API procedures
and to call \fBTcl_GetObjResult\fR instead.
.PP
\fBTcl_ResetResult\fR clears the result for \fIinterp\fR
and leaves the result in its normal empty initialized state.
If the result is a value,
its reference count is decremented and the result is left
pointing to an unshared value representing an empty string.
If the result is a dynamically allocated string, its memory is free*d
and the result is left as a empty string.
\fBTcl_ResetResult\fR also clears the error state managed by
\fBTcl_AddErrorInfo\fR, \fBTcl_AddObjErrorInfo\fR,
and \fBTcl_SetErrorCode\fR.
.PP
\fBTcl_AppendResult\fR makes it easy to build up Tcl results in pieces.
It takes each of its \fIresult\fR arguments and appends them in order
to the current result associated with \fIinterp\fR.
If the result is in its initialized empty state (e.g. a command procedure
was just invoked or \fBTcl_ResetResult\fR was just called),
then \fBTcl_AppendResult\fR sets the result to the concatenation of
its \fIresult\fR arguments.
\fBTcl_AppendResult\fR may be called repeatedly as additional pieces
of the result are produced.
\fBTcl_AppendResult\fR takes care of all the
storage management issues associated with managing \fIinterp\fR's
result, such as allocating a larger result area if necessary.
It also manages conversion to and from the \fIresult\fR field of the
\fIinterp\fR so as to handle backward-compatibility with old-style
extensions.
Any number of \fIresult\fR arguments may be passed in a single
call; the last argument in the list must be (char *)NULL.
.PP
\fBTcl_TransferResult\fR transfers interpreter state from \fIsourceInterp\fR
to \fItargetInterp\fR. The two interpreters must have been created in the
same thread.  If \fIsourceInterp\fR and \fItargetInterp\fR are the same,
nothing is done. Otherwise, \fBTcl_TransferResult\fR moves the result
from \fIsourceInterp\fR to \fItargetInterp\fR, and resets the result
in \fIsourceInterp\fR. It also moves the return options dictionary as
controlled by the return code value \fIcode\fR in the same manner
as \fBTcl_GetReturnOptions\fR.


.SH "DEPRECATED INTERFACES"
.SS "OLD STRING PROCEDURES"
.PP
Use of the following procedures is deprecated
since they manipulate the Tcl result as a string.
Procedures such as \fBTcl_SetObjResult\fR
that manipulate the result as a value
can be significantly more efficient.
.PP
\fBTcl_AppendElement\fR is similar to \fBTcl_AppendResult\fR in
that it allows results to be built up in pieces.
However, \fBTcl_AppendElement\fR takes only a single \fIelement\fR
argument and it appends that argument to the current result
as a proper Tcl list element.
\fBTcl_AppendElement\fR adds backslashes or braces if necessary
to ensure that \fIinterp\fR's result can be parsed as a list and that
\fIelement\fR will be extracted as a single element.
Under normal conditions, \fBTcl_AppendElement\fR will add a space
character to \fIinterp\fR's result just before adding the new
list element, so that the list elements in the result are properly
separated.
However if the new list element is the first in a list or sub-list
(i.e. \fIinterp\fR's current result is empty, or consists of the
single character
.QW { ,
or ends in the characters
.QW " {" )
then no space is added.
.SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT"
.PP
\fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how
the Tcl system is to manage the storage for the \fIresult\fR argument.
If \fBTcl_SetResult\fR or \fBTcl_SetObjResult\fR are called
at a time when \fIinterp\fR holds a string result,
they do whatever is necessary to dispose of the old string result
(see the \fBTcl_Interp\fR manual entry for details on this).
.PP
If \fIfreeProc\fR is \fBTCL_STATIC\fR it means that \fIresult\fR
refers to an area of static storage that is guaranteed not to be
modified until at least the next call to \fBTcl_Eval\fR.
If \fIfreeProc\fR
is \fBTCL_DYNAMIC\fR it means that \fIresult\fR was allocated with a call
to \fBTcl_Alloc\fR and is now the property of the Tcl system.
\fBTcl_SetResult\fR will arrange for the string's storage to be
released by calling \fBTcl_Free\fR when it is no longer needed.
If \fIfreeProc\fR is \fBTCL_VOLATILE\fR it means that \fIresult\fR
points to an area of memory that is likely to be overwritten when
\fBTcl_SetResult\fR returns (e.g. it points to something in a stack frame).
In this case \fBTcl_SetResult\fR will make a copy of the string in
dynamically allocated storage and arrange for the copy to be the
result for the current Tcl command.
.PP
If \fIfreeProc\fR is not one of the values \fBTCL_STATIC\fR,
\fBTCL_DYNAMIC\fR, and \fBTCL_VOLATILE\fR, then it is the address
of a procedure that Tcl should call to free the string.
This allows applications to use non-standard storage allocators.
When Tcl no longer needs the storage for the string, it will
call \fIfreeProc\fR. \fIFreeProc\fR should have arguments and
result that match the type \fBTcl_FreeProc\fR:
.PP
.CS
typedef void \fBTcl_FreeProc\fR(
        void *\fIblockPtr\fR);
.CE
.PP
When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to
the value of \fIresult\fR passed to \fBTcl_SetResult\fR.

.SH "REFERENCE COUNT MANAGEMENT"
.PP
The interpreter result is one of the main places that owns references to
values, along with the bytecode execution stack, argument lists, variables,
and the list and dictionary collection values.
.PP
\fBTcl_SetObjResult\fR takes a value with an arbitrary reference count
\fI(specifically including zero)\fR and guarantees to increment the reference
count. If code wishes to continue using the value after setting it as the
result, it should add its own reference to it with \fBTcl_IncrRefCount\fR.
.PP
\fBTcl_GetObjResult\fR returns the current interpreter result value. This will
have a reference count of at least 1. If the caller wishes to keep the
interpreter result value, it should increment its reference count.
.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
.SH KEYWORDS
append, command, element, list, value, result, return value, interpreter

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, ... \fBNULL\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)
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
\fIobjPtr\fR.
.PP
\fBTcl_AppendStringsToObj\fR is similar to \fBTcl_AppendToObj\fR
except that it can be passed more than one value to append and
each value must be a null-terminated string (i.e. none of the
values may contain internal null characters).  Any number of
\fIstring\fR arguments may be provided, but the last argument
must be a NULL pointer to indicate the end of the list.
.PP
\fBTcl_AppendLimitedToObj\fR is similar to \fBTcl_AppendToObj\fR
except that it imposes a limit on how many bytes are appended.
This can be handy when the string to be appended might be
very large, but the value being constructed should not be allowed to grow
without bound. A common usage is when constructing an error message, where the
end result should be kept short enough to be read.







|







247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
\fIobjPtr\fR.
.PP
\fBTcl_AppendStringsToObj\fR is similar to \fBTcl_AppendToObj\fR
except that it can be passed more than one value to append and
each value must be a null-terminated string (i.e. none of the
values may contain internal null characters).  Any number of
\fIstring\fR arguments may be provided, but the last argument
must be (char *)NULL to indicate the end of the list.
.PP
\fBTcl_AppendLimitedToObj\fR is similar to \fBTcl_AppendToObj\fR
except that it imposes a limit on how many bytes are appended.
This can be handy when the string to be appended might be
very large, but the value being constructed should not be allowed to grow
without bound. A common usage is when constructing an error message, where the
end result should be kept short enough to be read.

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/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 \fIchannelId\fR
.
This tests whether the last input operation on the channel called
\fIchannelId\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 \fIchannelId\fR ?\fIdirection\fR?
.
Close and destroy the channel called \fIchannelId\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 \fIchannelId\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 \fIchannelId\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 \fIchannelId\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 \fIchannelId\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?...
.
Query or set the configuration options of the channel named
\fIchannelId\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 \fIchannelId\fR
.
Test whether the last input operation on the channel called
\fIchannelId\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 \fIchannelId 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
\fIchannelId\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 \fIchannelId\fR
.
Ensures that all pending output for the channel called \fIchannelId\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 \fIchannelId\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 channelId\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 \fIchannelId\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 \fIchannelId\fR
.
Removes the topmost transformation from the channel \fIchannelId\fR, if there
is any. If there are no transformations added to \fIchannelId\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 \fIchannelId eventSpec\fR
.
This subcommand is used by command handlers specified with \fBchan
create\fR. It notifies the channel represented by the handle
\fIchannelId\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 \fIchannelId cmdPrefix\fR
.
Adds a new transformation on top of the channel \fIchannelId\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? ?\fIchannelId\fR? \fIstring\fR
.
Writes \fIstring\fR to the channel named \fIchannelId\fR followed by a
newline character. A trailing newline character is written unless the
optional flag \fB\-nonewline\fR is given. If \fIchannelId\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 \fIchannelId\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 \fIchannelId\fR ?\fInumChars\fR?
.TP
\fBchan read \fR?\fB\-nonewline\fR? \fIchannelId\fR
.
In the first form, the result will be the next \fInumChars\fR
characters read from the channel named \fIchannelId\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 \fIchannelId\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 \fIchannelId \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 \fIchannelId numChars\fR
.
In this form \fBchan read\fR blocks until \fInumChars\fR have been
received from the serial port.
.TP
\fBchan read \fIchannelId\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 \fIchannelId offset\fR ?\fIorigin\fR?
.
Sets the current access position within the underlying data stream for
the channel named \fIchannelId\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 \fIchannelId\fR
.
Returns a number giving the current access position within the
underlying data stream for the channel named \fIchannelId\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 \fIchannelId\fR ?\fIlength\fR?
.
Sets the byte length of the underlying data stream for the channel
named \fIchannelId\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/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/expr.n.

329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
tcl::mathfunc::hypot $x $y
.CE
.PP
See the \fBmathfunc\fR(n) documentation for the math functions that are
available by default.
.SS "TYPES, OVERFLOW, AND PRECISION"
.PP
When needed to guarantee exact performance, internal computations involving
integers use the LibTomMath multiple precision integer library.  In Tcl releases
prior to 8.5, integer calculations were performed using one of the C types
\fIlong int\fR or \fITcl_WideInt\fR, causing implicit range truncation
in those calculations where values overflowed the range of those types.
Any code that relied on these implicit truncations should instead call
\fBwide()\fR, which does truncate.
.PP
Internal floating-point computations are
performed using the \fIdouble\fR C type.
When converting a string to floating-point value, exponent overflow is
detected and results in the \fIdouble\fR value of \fBInf\fR or
\fB\-Inf\fR as appropriate.  Floating-point overflow and underflow
are detected to the degree supported by the hardware, which is generally
fairly reliable.







<
<
<
<
<
<
<
<







329
330
331
332
333
334
335








336
337
338
339
340
341
342
tcl::mathfunc::hypot $x $y
.CE
.PP
See the \fBmathfunc\fR(n) documentation for the math functions that are
available by default.
.SS "TYPES, OVERFLOW, AND PRECISION"
.PP








Internal floating-point computations are
performed using the \fIdouble\fR C type.
When converting a string to floating-point value, exponent overflow is
detected and results in the \fIdouble\fR value of \fBInf\fR or
\fB\-Inf\fR as appropriate.  Floating-point overflow and underflow
are detected to the degree supported by the hardware, which is generally
fairly reliable.

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/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
93
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, \fBz\fR, \fBt\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 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.


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

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/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 \fIchannelId 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/regc_color.c.

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

    return sco;
}

/*
 - subrange - allocate new subcolors to this range of chrs, fill in arcs
 ^ static void subrange(struct vars *, pchr, pchr, struct state *,
 ^ 	struct state *);
 */
static void
subrange(
    struct vars *v,
    pchr from,
    pchr to,
    struct state *lp,







|







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

    return sco;
}

/*
 - subrange - allocate new subcolors to this range of chrs, fill in arcs
 ^ static void subrange(struct vars *, pchr, pchr, struct state *,
 ^	struct state *);
 */
static void
subrange(
    struct vars *v,
    pchr from,
    pchr to,
    struct state *lp,
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
    a->colorchain = NULL;	/* paranoia */
    a->colorchainRev = NULL;
}

/*
 - rainbow - add arcs of all full colors (but one) between specified states
 ^ static void rainbow(struct nfa *, struct colormap *, int, pcolor,
 ^ 	struct state *, struct state *);
 */
static void
rainbow(
    struct nfa *nfa,
    struct colormap *cm,
    int type,
    pcolor but,			/* COLORLESS if no exceptions */







|







685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
    a->colorchain = NULL;	/* paranoia */
    a->colorchainRev = NULL;
}

/*
 - rainbow - add arcs of all full colors (but one) between specified states
 ^ static void rainbow(struct nfa *, struct colormap *, int, pcolor,
 ^	struct state *, struct state *);
 */
static void
rainbow(
    struct nfa *nfa,
    struct colormap *cm,
    int type,
    pcolor but,			/* COLORLESS if no exceptions */
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
    }
}

/*
 - colorcomplement - add arcs of complementary colors
 * The calling sequence ought to be reconciled with cloneouts().
 ^ static void colorcomplement(struct nfa *, struct colormap *, int,
 ^ 	struct state *, struct state *, struct state *);
 */
static void
colorcomplement(
    struct nfa *nfa,
    struct colormap *cm,
    int type,
    struct state *of,		/* complements of this guy's PLAIN outarcs */







|







712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
    }
}

/*
 - colorcomplement - add arcs of complementary colors
 * The calling sequence ought to be reconciled with cloneouts().
 ^ static void colorcomplement(struct nfa *, struct colormap *, int,
 ^	struct state *, struct state *, struct state *);
 */
static void
colorcomplement(
    struct nfa *nfa,
    struct colormap *cm,
    int type,
    struct state *of,		/* complements of this guy's PLAIN outarcs */

Changes to generic/regc_locale.c.

1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
	    }
	    for (i=0 ; i<NUM_UPPER_CHAR ; i++) {
		addchr(cv, upperCharTable[i]);
	    }
	}
	break;
    case CC_PRINT:
    	cv  = getcvec(v, NUM_SPACE_CHAR + NUM_GRAPH_CHAR, NUM_SPACE_RANGE + NUM_GRAPH_RANGE  - 1);
    	if (cv) {
    	    for (i=1 ; i<NUM_SPACE_RANGE ; i++) {
    		addrange(cv, spaceRangeTable[i].start,
    				spaceRangeTable[i].end);
    	    }
    	    for (i=0 ; i<NUM_SPACE_CHAR ; i++) {
    		addchr(cv, spaceCharTable[i]);
    	    }
    	    for (i=0 ; i<NUM_GRAPH_RANGE ; i++) {
    		addrange(cv, graphRangeTable[i].start,
    				graphRangeTable[i].end);
    	    }
    	    for (i=0 ; i<NUM_GRAPH_CHAR ; i++) {
    		addchr(cv, graphCharTable[i]);
    	    }
    	}
    	break;
    case CC_GRAPH:
	cv  = getcvec(v, NUM_GRAPH_CHAR, NUM_GRAPH_RANGE);
	if (cv) {
	    for (i=0 ; i<NUM_GRAPH_RANGE ; i++) {
		addrange(cv, graphRangeTable[i].start,
			graphRangeTable[i].end);
	    }







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
	    }
	    for (i=0 ; i<NUM_UPPER_CHAR ; i++) {
		addchr(cv, upperCharTable[i]);
	    }
	}
	break;
    case CC_PRINT:
	cv  = getcvec(v, NUM_SPACE_CHAR + NUM_GRAPH_CHAR, NUM_SPACE_RANGE + NUM_GRAPH_RANGE  - 1);
	if (cv) {
	    for (i=1 ; i<NUM_SPACE_RANGE ; i++) {
		addrange(cv, spaceRangeTable[i].start,
				spaceRangeTable[i].end);
	    }
	    for (i=0 ; i<NUM_SPACE_CHAR ; i++) {
		addchr(cv, spaceCharTable[i]);
	    }
	    for (i=0 ; i<NUM_GRAPH_RANGE ; i++) {
		addrange(cv, graphRangeTable[i].start,
				graphRangeTable[i].end);
	    }
	    for (i=0 ; i<NUM_GRAPH_CHAR ; i++) {
		addchr(cv, graphCharTable[i]);
	    }
	}
	break;
    case CC_GRAPH:
	cv  = getcvec(v, NUM_GRAPH_CHAR, NUM_GRAPH_RANGE);
	if (cv) {
	    for (i=0 ; i<NUM_GRAPH_RANGE ; i++) {
		addrange(cv, graphRangeTable[i].start,
			graphRangeTable[i].end);
	    }

Changes to generic/regc_nfa.c.

566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
    }
    return NULL;
}

/*
 - cparc - allocate a new arc within an NFA, copying details from old one
 ^ static void cparc(struct nfa *, struct arc *, struct state *,
 ^ 	struct state *);
 */
static void
cparc(
    struct nfa *nfa,
    struct arc *oa,
    struct state *from,
    struct state *to)







|







566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
    }
    return NULL;
}

/*
 - cparc - allocate a new arc within an NFA, copying details from old one
 ^ static void cparc(struct nfa *, struct arc *, struct state *,
 ^	struct state *);
 */
static void
cparc(
    struct nfa *nfa,
    struct arc *oa,
    struct state *from,
    struct state *to)
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
    const struct arc *bb = *((const struct arc * const *) b);

    /* we check the fields in the order they are most likely to be different */
    if (aa->from->no < bb->from->no) {
	return -1;
    }
    if (aa->from->no > bb->from->no) {
 	return 1;
    }
    if (aa->co < bb->co) {
 	return -1;
    }
    if (aa->co > bb->co) {
 	return 1;
    }
    if (aa->type < bb->type) {
 	return -1;
    }
    if (aa->type > bb->type) {
 	return 1;
    }
    return 0;
}

/*
 * sortouts - sort the out arcs of a state by to/color/type
 */







|


|


|


|


|







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
    const struct arc *bb = *((const struct arc * const *) b);

    /* we check the fields in the order they are most likely to be different */
    if (aa->from->no < bb->from->no) {
	return -1;
    }
    if (aa->from->no > bb->from->no) {
	return 1;
    }
    if (aa->co < bb->co) {
	return -1;
    }
    if (aa->co > bb->co) {
	return 1;
    }
    if (aa->type < bb->type) {
	return -1;
    }
    if (aa->type > bb->type) {
	return 1;
    }
    return 0;
}

/*
 * sortouts - sort the out arcs of a state by to/color/type
 */
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
	/* With not too many arcs, just do them one at a time */
	struct arc *a;

	for (a = oldState->outs; a != NULL; a = a->outchain) {
	    cparc(nfa, a, newState, a->to);
	}
    } else {
 	/*
	 * With many arcs, use a sort-merge approach.  Note that createarc()
	 * will put new arcs onto the front of newState's chain, so it does
	 * not break our walk through the sorted part of the chain.
	 */
	struct arc *oa;
	struct arc *na;








|







1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
	/* With not too many arcs, just do them one at a time */
	struct arc *a;

	for (a = oldState->outs; a != NULL; a = a->outchain) {
	    cparc(nfa, a, newState, a->to);
	}
    } else {
	/*
	 * With many arcs, use a sort-merge approach.  Note that createarc()
	 * will put new arcs onto the front of newState's chain, so it does
	 * not break our walk through the sorted part of the chain.
	 */
	struct arc *oa;
	struct arc *na;

1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
	}
    }
}

/*
 - cloneouts - copy out arcs of a state to another state pair, modifying type
 ^ static void cloneouts(struct nfa *, struct state *, struct state *,
 ^ 	struct state *, int);
 */
static void
cloneouts(
    struct nfa *nfa,
    struct state *old,
    struct state *from,
    struct state *to,







|







1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
	}
    }
}

/*
 - cloneouts - copy out arcs of a state to another state pair, modifying type
 ^ static void cloneouts(struct nfa *, struct state *, struct state *,
 ^	struct state *, int);
 */
static void
cloneouts(
    struct nfa *nfa,
    struct state *old,
    struct state *from,
    struct state *to,
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277

/*
 - dupnfa - duplicate sub-NFA
 * Another recursive traversal, this time using tmp to point to duplicates as
 * well as mark already-seen states. (You knew there was a reason why it's a
 * state pointer, didn't you? :-))
 ^ static void dupnfa(struct nfa *, struct state *, struct state *,
 ^ 	struct state *, struct state *);
 */
static void
dupnfa(
    struct nfa *nfa,
    struct state *start,	/* duplicate of subNFA starting here */
    struct state *stop,		/* and stopping here */
    struct state *from,		/* stringing duplicate from here */







|







1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277

/*
 - dupnfa - duplicate sub-NFA
 * Another recursive traversal, this time using tmp to point to duplicates as
 * well as mark already-seen states. (You knew there was a reason why it's a
 * state pointer, didn't you? :-))
 ^ static void dupnfa(struct nfa *, struct state *, struct state *,
 ^	struct state *, struct state *);
 */
static void
dupnfa(
    struct nfa *nfa,
    struct state *start,	/* duplicate of subNFA starting here */
    struct state *stop,		/* and stopping here */
    struct state *from,		/* stringing duplicate from here */
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
		s = newstate(nfa);
		if (NISERR()) {
		    return 0;
		}
		s->tmp = *intermediates;
		*intermediates = s;
	    }
  	    cparc(nfa, con, a->from, s);
	    cparc(nfa, a, s, to);
 	    freearc(nfa, a);
  	    break;
	default:
	    assert(NOTREACHED);
	    break;
	}
    }

    /*







|

|
|







1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
		s = newstate(nfa);
		if (NISERR()) {
		    return 0;
		}
		s->tmp = *intermediates;
		*intermediates = s;
	    }
	    cparc(nfa, con, a->from, s);
	    cparc(nfa, a, s, to);
	    freearc(nfa, a);
	    break;
	default:
	    assert(NOTREACHED);
	    break;
	}
    }

    /*
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
		if (NISERR()) {
		    return 0;
		}
		s->tmp = *intermediates;
		*intermediates = s;
	    }
	    cparc(nfa, con, s, a->to);
  	    cparc(nfa, a, from, s);
  	    freearc(nfa, a);
  	    break;
	default:
	    assert(NOTREACHED);
	    break;
	}
    }

    /*







|
|
|







1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
		if (NISERR()) {
		    return 0;
		}
		s->tmp = *intermediates;
		*intermediates = s;
	    }
	    cparc(nfa, con, s, a->to);
	    cparc(nfa, a, from, s);
	    freearc(nfa, a);
	    break;
	default:
	    assert(NOTREACHED);
	    break;
	}
    }

    /*
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
	    /* Add s2's original inarcs to arcarray[], but ignore empties */
	    for (a = inarcsorig[s2->no]; a != NULL; a = a->inchain) {
		if (a->type != EMPTY) {
		    arcarray[arccount++] = a;
		}
	    }

  	    /* Reset the tmp fields as we walk back */
  	    nexts = s2->tmp;
  	    s2->tmp = NULL;
  	}
  	s->tmp = NULL;
	assert(arccount <= totalinarcs);

	/* Remember how many original inarcs this state has */
	prevnins = s->nins;

	/* Add non-duplicate inarcs to target state */
	mergeins(nfa, s, arcarray, arccount);







|
|
|
|
|







2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
	    /* Add s2's original inarcs to arcarray[], but ignore empties */
	    for (a = inarcsorig[s2->no]; a != NULL; a = a->inchain) {
		if (a->type != EMPTY) {
		    arcarray[arccount++] = a;
		}
	    }

	    /* Reset the tmp fields as we walk back */
	    nexts = s2->tmp;
	    s2->tmp = NULL;
	}
	s->tmp = NULL;
	assert(arccount <= totalinarcs);

	/* Remember how many original inarcs this state has */
	prevnins = s->nins;

	/* Add non-duplicate inarcs to target state */
	mergeins(nfa, s, arcarray, arccount);
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
	for (a = s->outs; a != NULL && !NISERR(); a = nexta) {
	    nexta = a->outchain;
	    if (isconstraintarc(a)) {
		if (a->to == s) {
		    freearc(nfa, a);
		} else {
		    hasconstraints = 1;
 		}
	    }
	}
 	/* If we removed all the outarcs, the state is useless. */
 	if (s->nouts == 0 && !s->flag) {
 	    dropstate(nfa, s);
	}
    }

    /* Nothing to do if no remaining constraint arcs */
    if (NISERR() || !hasconstraints) {
	return;
    }







|


|
|
|







2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
	for (a = s->outs; a != NULL && !NISERR(); a = nexta) {
	    nexta = a->outchain;
	    if (isconstraintarc(a)) {
		if (a->to == s) {
		    freearc(nfa, a);
		} else {
		    hasconstraints = 1;
		}
	    }
	}
	/* If we removed all the outarcs, the state is useless. */
	if (s->nouts == 0 && !s->flag) {
	    dropstate(nfa, s);
	}
    }

    /* Nothing to do if no remaining constraint arcs */
    if (NISERR() || !hasconstraints) {
	return;
    }
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
	s->tmp = NULL;
	if ((s->nins == 0 || s->nouts == 0) && !s->flag) {
	    dropstate(nfa, s);
	}
    }

    if (f != NULL) {
 	dumpnfa(nfa, f);
    }
}

/*
 * findconstraintloop - recursively find a loop of constraint arcs
 *
 * If we find a loop, break it by calling breakconstraintloop(), then







|







2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
	s->tmp = NULL;
	if ((s->nins == 0 || s->nouts == 0) && !s->flag) {
	    dropstate(nfa, s);
	}
    }

    if (f != NULL) {
	dumpnfa(nfa, f);
    }
}

/*
 * findconstraintloop - recursively find a loop of constraint arcs
 *
 * If we find a loop, break it by calling breakconstraintloop(), then
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
    }
    nfa->nstates = n;
}

/*
 - markreachable - recursive marking of reachable states
 ^ static void markreachable(struct nfa *, struct state *, struct state *,
 ^ 	struct state *);
 */
static void
markreachable(
    struct nfa *nfa,
    struct state *s,
    struct state *okay,		/* consider only states with this mark */
    struct state *mark)		/* the value to mark with */







|







2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
    }
    nfa->nstates = n;
}

/*
 - markreachable - recursive marking of reachable states
 ^ static void markreachable(struct nfa *, struct state *, struct state *,
 ^	struct state *);
 */
static void
markreachable(
    struct nfa *nfa,
    struct state *s,
    struct state *okay,		/* consider only states with this mark */
    struct state *mark)		/* the value to mark with */
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
	markreachable(nfa, a->to, okay, mark);
    }
}

/*
 - markcanreach - recursive marking of states which can reach here
 ^ static void markcanreach(struct nfa *, struct state *, struct state *,
 ^ 	struct state *);
 */
static void
markcanreach(
    struct nfa *nfa,
    struct state *s,
    struct state *okay,		/* consider only states with this mark */
    struct state *mark)		/* the value to mark with */







|







2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
	markreachable(nfa, a->to, okay, mark);
    }
}

/*
 - markcanreach - recursive marking of states which can reach here
 ^ static void markcanreach(struct nfa *, struct state *, struct state *,
 ^	struct state *);
 */
static void
markcanreach(
    struct nfa *nfa,
    struct state *s,
    struct state *okay,		/* consider only states with this mark */
    struct state *mark)		/* the value to mark with */

Changes to generic/regcomp.c.

640
641
642
643
644
645
646
647
648
649
650
651
652
653
654

/*
 - parse - parse an RE
 * This is actually just the top level, which parses a bunch of branches tied
 * together with '|'. They appear in the tree as the left children of a chain
 * of '|' subres.
 ^ static struct subre *parse(struct vars *, int, int, struct state *,
 ^ 	struct state *);
 */
static struct subre *
parse(
    struct vars *v,
    int stopper,		/* EOS or ')' */
    int type,			/* LACON (lookahead subRE) or PLAIN */
    struct state *init,		/* initial state */







|







640
641
642
643
644
645
646
647
648
649
650
651
652
653
654

/*
 - parse - parse an RE
 * This is actually just the top level, which parses a bunch of branches tied
 * together with '|'. They appear in the tree as the left children of a chain
 * of '|' subres.
 ^ static struct subre *parse(struct vars *, int, int, struct state *,
 ^	struct state *);
 */
static struct subre *
parse(
    struct vars *v,
    int stopper,		/* EOS or ')' */
    int type,			/* LACON (lookahead subRE) or PLAIN */
    struct state *init,		/* initial state */
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736

/*
 - parsebranch - parse one branch of an RE
 * This mostly manages concatenation, working closely with parseqatom().
 * Concatenated things are bundled up as much as possible, with separate
 * ',' nodes introduced only when necessary due to substructure.
 ^ static struct subre *parsebranch(struct vars *, int, int, struct state *,
 ^ 	struct state *, int);
 */
static struct subre *
parsebranch(
    struct vars *v,
    int stopper,		/* EOS or ')' */
    int type,			/* LACON (lookahead subRE) or PLAIN */
    struct state *left,		/* leftmost state */







|







722
723
724
725
726
727
728
729
730
731
732
733
734
735
736

/*
 - parsebranch - parse one branch of an RE
 * This mostly manages concatenation, working closely with parseqatom().
 * Concatenated things are bundled up as much as possible, with separate
 * ',' nodes introduced only when necessary due to substructure.
 ^ static struct subre *parsebranch(struct vars *, int, int, struct state *,
 ^	struct state *, int);
 */
static struct subre *
parsebranch(
    struct vars *v,
    int stopper,		/* EOS or ')' */
    int type,			/* LACON (lookahead subRE) or PLAIN */
    struct state *left,		/* leftmost state */
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785

/*
 - parseqatom - parse one quantified atom or constraint of an RE
 * The bookkeeping near the end cooperates very closely with parsebranch(); in
 * particular, it contains a recursion that can involve parsing the rest of
 * the branch, making this function's name somewhat inaccurate.
 ^ static void parseqatom(struct vars *, int, int, struct state *,
 ^ 	struct state *, struct subre *);
 */
static void
parseqatom(
    struct vars *v,
    int stopper,		/* EOS or ')' */
    int type,			/* LACON (lookahead subRE) or PLAIN */
    struct state *lp,		/* left state to hang it on */







|







771
772
773
774
775
776
777
778
779
780
781
782
783
784
785

/*
 - parseqatom - parse one quantified atom or constraint of an RE
 * The bookkeeping near the end cooperates very closely with parsebranch(); in
 * particular, it contains a recursion that can involve parsing the rest of
 * the branch, making this function's name somewhat inaccurate.
 ^ static void parseqatom(struct vars *, int, int, struct state *,
 ^	struct state *, struct subre *);
 */
static void
parseqatom(
    struct vars *v,
    int stopper,		/* EOS or ')' */
    int type,			/* LACON (lookahead subRE) or PLAIN */
    struct state *lp,		/* left state to hang it on */
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659

    dovec(v, allcases(v, c), lp, rp);
}

/*
 - dovec - fill in arcs for each element of a cvec
 ^ static void dovec(struct vars *, struct cvec *, struct state *,
 ^ 	struct state *);
 */
static void
dovec(
    struct vars *v,
    struct cvec *cv,
    struct state *lp,
    struct state *rp)







|







1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659

    dovec(v, allcases(v, c), lp, rp);
}

/*
 - dovec - fill in arcs for each element of a cvec
 ^ static void dovec(struct vars *, struct cvec *, struct state *,
 ^	struct state *);
 */
static void
dovec(
    struct vars *v,
    struct cvec *cv,
    struct state *lp,
    struct state *rp)

Changes to generic/rege_dfa.c.

155
156
157
158
159
160
161
162
163
164
165
166
167
168
169

    return NULL;
}

/*
 - shortest - shortest-preferred matching engine
 ^ static chr *shortest(struct vars *, struct dfa *, chr *, chr *, chr *,
 ^ 	chr **, int *);
 */
static chr *			/* endpoint, or NULL */
shortest(
    struct vars *const v,
    struct dfa *const d,
    chr *const start,		/* where the match should start */
    chr *const min,		/* match must end at or after here */







|







155
156
157
158
159
160
161
162
163
164
165
166
167
168
169

    return NULL;
}

/*
 - shortest - shortest-preferred matching engine
 ^ static chr *shortest(struct vars *, struct dfa *, chr *, chr *, chr *,
 ^	chr **, int *);
 */
static chr *			/* endpoint, or NULL */
shortest(
    struct vars *const v,
    struct dfa *const d,
    chr *const start,		/* where the match should start */
    chr *const min,		/* match must end at or after here */
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
    }
    return nopr;
}

/*
 - newDFA - set up a fresh DFA
 ^ static struct dfa *newDFA(struct vars *, struct cnfa *,
 ^ 	struct colormap *, struct smalldfa *);
 */
static struct dfa *
newDFA(
    struct vars *const v,
    struct cnfa *const cnfa,
    struct colormap *const cm,
    struct smalldfa *sml)	/* preallocated space, may be NULL */







|







304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
    }
    return nopr;
}

/*
 - newDFA - set up a fresh DFA
 ^ static struct dfa *newDFA(struct vars *, struct cnfa *,
 ^	struct colormap *, struct smalldfa *);
 */
static struct dfa *
newDFA(
    struct vars *const v,
    struct cnfa *const cnfa,
    struct colormap *const cm,
    struct smalldfa *sml)	/* preallocated space, may be NULL */
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
    d->lastnopr = NULL;
    return ss;
}

/*
 - miss - handle a cache miss
 ^ static struct sset *miss(struct vars *, struct dfa *, struct sset *,
 ^ 	pcolor, chr *, chr *);
 */
static struct sset *		/* NULL if goes to empty set */
miss(
    struct vars *const v,	/* used only for debug flags */
    struct dfa *const d,
    struct sset *const css,
    const pcolor co,







|







473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
    d->lastnopr = NULL;
    return ss;
}

/*
 - miss - handle a cache miss
 ^ static struct sset *miss(struct vars *, struct dfa *, struct sset *,
 ^	pcolor, chr *, chr *);
 */
static struct sset *		/* NULL if goes to empty set */
miss(
    struct vars *const v,	/* used only for debug flags */
    struct dfa *const d,
    struct sset *const css,
    const pcolor co,

Changes to generic/tcl.h.

1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
 *				hash table will attempt to rectify this by
 *				randomising the bits and then using the upper
 *				N bits as the index into the table.
 * TCL_HASH_KEY_SYSTEM_HASH -	If this flag is set then all memory internally
 *                              allocated for the hash table that is not for an
 *                              entry will use the system heap.
 * TCL_HASH_KEY_DIRECT_COMPARE -
 * 	                        Allows fast comparison for hash keys directly
 *                              by compare of their key.oneWordValue values,
 *                              before call of compareKeysProc (much slower
 *                              than a direct compare, so it is speed-up only
 *                              flag). Don't use it if keys contain values rather
 *                              than pointers.
 */








|







1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
 *				hash table will attempt to rectify this by
 *				randomising the bits and then using the upper
 *				N bits as the index into the table.
 * TCL_HASH_KEY_SYSTEM_HASH -	If this flag is set then all memory internally
 *                              allocated for the hash table that is not for an
 *                              entry will use the system heap.
 * TCL_HASH_KEY_DIRECT_COMPARE -
 *	                        Allows fast comparison for hash keys directly
 *                              by compare of their key.oneWordValue values,
 *                              before call of compareKeysProc (much slower
 *                              than a direct compare, so it is speed-up only
 *                              flag). Don't use it if keys contain values rather
 *                              than pointers.
 */

1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
 * dictionaries. These fields should not be accessed by code outside
 * tclDictObj.c
 */

typedef struct {
    void *next;			/* Search position for underlying hash
				 * table. */
    TCL_HASH_TYPE epoch; 	/* Epoch marker for dictionary being searched,
				 * or 0 if search has terminated. */
    Tcl_Dict dictionaryPtr;	/* Reference to dictionary being searched. */
} Tcl_DictSearch;

/*
 *----------------------------------------------------------------------------
 * Flag values to pass to Tcl_DoOneEvent to disable searches for some kinds of







|







1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
 * dictionaries. These fields should not be accessed by code outside
 * tclDictObj.c
 */

typedef struct {
    void *next;			/* Search position for underlying hash
				 * table. */
    TCL_HASH_TYPE epoch;	/* Epoch marker for dictionary being searched,
				 * or 0 if search has terminated. */
    Tcl_Dict dictionaryPtr;	/* Reference to dictionary being searched. */
} Tcl_DictSearch;

/*
 *----------------------------------------------------------------------------
 * Flag values to pass to Tcl_DoOneEvent to disable searches for some kinds of
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
 *				stream. Tells the conversion routine to
 *				perform any finalization that needs to occur
 *				after the last byte is converted and then to
 *				reset to an initial state. If the source
 *				buffer contains the entire input stream to be
 *				converted, this flag should be set.
 * TCL_ENCODING_STOPONERROR -	Not used any more.
 * TCL_ENCODING_NO_TERMINATE - 	If set, Tcl_ExternalToUtf does not append a
 *				terminating NUL byte.  Since it does not need
 *				an extra byte for a terminating NUL, it fills
 *				all dstLen bytes with encoded UTF-8 content if
 *				needed.  If clear, a byte is reserved in the
 *				dst space for NUL termination, and a
 *				terminating NUL is appended.
 * TCL_ENCODING_CHAR_LIMIT -	If set and dstCharsPtr is not NULL, then







|







1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
 *				stream. Tells the conversion routine to
 *				perform any finalization that needs to occur
 *				after the last byte is converted and then to
 *				reset to an initial state. If the source
 *				buffer contains the entire input stream to be
 *				converted, this flag should be set.
 * TCL_ENCODING_STOPONERROR -	Not used any more.
 * TCL_ENCODING_NO_TERMINATE -	If set, Tcl_ExternalToUtf does not append a
 *				terminating NUL byte.  Since it does not need
 *				an extra byte for a terminating NUL, it fills
 *				all dstLen bytes with encoded UTF-8 content if
 *				needed.  If clear, a byte is reserved in the
 *				dst space for NUL termination, and a
 *				terminating NUL is appended.
 * TCL_ENCODING_CHAR_LIMIT -	If set and dstCharsPtr is not NULL, then

Changes to generic/tclArithSeries.c.

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
}

/*
 *----------------------------------------------------------------------
 *
 * ArithSeriesLen --
 *
 * 	Compute the length of the equivalent list where
 * 	every element is generated starting from *start*,
 * 	and adding *step* to generate every successive element
 * 	that's < *end* for positive steps, or > *end* for negative
 * 	steps.
 *
 * Results:
 *
 * 	The length of the list generated by the given range,
 * 	that may be zero.
 * 	The function returns -1 if the list is of length infinite.
 *
 * Side effects:
 *
 * 	None.
 *
 *----------------------------------------------------------------------
 */
static Tcl_WideInt
ArithSeriesLenInt(
    Tcl_WideInt start,
    Tcl_WideInt end,







|
|
|
|
|


<
|
|
|


<
|







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
}

/*
 *----------------------------------------------------------------------
 *
 * ArithSeriesLen --
 *
 *	Compute the length of the equivalent list where
 *	every element is generated starting from *start*,
 *	and adding *step* to generate every successive element
 *	that's < *end* for positive steps, or > *end* for negative
 *	steps.
 *
 * Results:

 *	The length of the list generated by the given range,
 *	that may be zero.
 *	The function returns -1 if the list is of length infinite.
 *
 * Side effects:

 *	None.
 *
 *----------------------------------------------------------------------
 */
static Tcl_WideInt
ArithSeriesLenInt(
    Tcl_WideInt start,
    Tcl_WideInt end,
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
 *
 * NewArithSeriesInt --
 *
 *	Creates a new ArithSeries object. The returned object has
 *	refcount = 0.
 *
 * Results:
 *
 * 	A Tcl_Obj pointer to the created ArithSeries object.
 * 	A NULL pointer of the range is invalid.
 *
 * Side Effects:
 * 	None.
 *
 *----------------------------------------------------------------------
 */
static Tcl_Obj *
NewArithSeriesInt(
    Tcl_WideInt start,
    Tcl_WideInt end,







<
|
|


|







377
378
379
380
381
382
383

384
385
386
387
388
389
390
391
392
393
394
395
 *
 * NewArithSeriesInt --
 *
 *	Creates a new ArithSeries object. The returned object has
 *	refcount = 0.
 *
 * Results:

 *	A Tcl_Obj pointer to the created ArithSeries object.
 *	A NULL pointer of the range is invalid.
 *
 * Side Effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */
static Tcl_Obj *
NewArithSeriesInt(
    Tcl_WideInt start,
    Tcl_WideInt end,
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
    arithSeriesRepPtr->start = start;
    arithSeriesRepPtr->end = end;
    arithSeriesRepPtr->step = step;
    arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
    arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
    arithSeriesObj->typePtr = &arithSeriesType;
    if (length > 0) {
    	Tcl_InvalidateStringRep(arithSeriesObj);
    }

    return arithSeriesObj;
}

/*
 *----------------------------------------------------------------------
 *
 * NewArithSeriesDbl --
 *
 *	Creates a new ArithSeries object with doubles. The returned object has
 *	refcount = 0.
 *
 * Results:
 *
 * 	A Tcl_Obj pointer to the created ArithSeries object.
 * 	A NULL pointer of the range is invalid.
 *
 * Side Effects:
 *
 * 	None.
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
NewArithSeriesDbl(
    double start,
    double end,
    double step,
    Tcl_WideInt len)
{







|














<
|
|


<
|


<







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
    arithSeriesRepPtr->start = start;
    arithSeriesRepPtr->end = end;
    arithSeriesRepPtr->step = step;
    arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
    arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
    arithSeriesObj->typePtr = &arithSeriesType;
    if (length > 0) {
	Tcl_InvalidateStringRep(arithSeriesObj);
    }

    return arithSeriesObj;
}

/*
 *----------------------------------------------------------------------
 *
 * NewArithSeriesDbl --
 *
 *	Creates a new ArithSeries object with doubles. The returned object has
 *	refcount = 0.
 *
 * Results:

 *	A Tcl_Obj pointer to the created ArithSeries object.
 *	A NULL pointer of the range is invalid.
 *
 * Side Effects:

 *	None.
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
NewArithSeriesDbl(
    double start,
    double end,
    double step,
    Tcl_WideInt len)
{
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
    arithSeriesRepPtr->step = step;
    arithSeriesRepPtr->precision = maxPrecision(start, end, step);
    arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
    arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
    arithSeriesObj->typePtr = &arithSeriesType;

    if (length > 0) {
    	Tcl_InvalidateStringRep(arithSeriesObj);
    }

    return arithSeriesObj;
}

/*
 *----------------------------------------------------------------------
 *
 * assignNumber --
 *
 *	Create the appropriate Tcl_Obj value for the given numeric values.
 *      Used locally only for decoding [lseq] numeric arguments.
 *	refcount = 0.
 *
 * 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;







|















<
<
|


<
|


|

>








>
|
>
>
|
>
>
>
|














>












<
|
|


<
|


|
<


<










>


|
>
>





|
>
>






|
|



|
>
>



|







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
    arithSeriesRepPtr->step = step;
    arithSeriesRepPtr->precision = maxPrecision(start, end, step);
    arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
    arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
    arithSeriesObj->typePtr = &arithSeriesType;

    if (length > 0) {
	Tcl_InvalidateStringRep(arithSeriesObj);
    }

    return arithSeriesObj;
}

/*
 *----------------------------------------------------------------------
 *
 * assignNumber --
 *
 *	Create the appropriate Tcl_Obj value for the given numeric values.
 *      Used locally only for decoding [lseq] numeric arguments.
 *	refcount = 0.
 *
 * 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;
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
	}
    }

    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 --
 *
 *	Returns the element with the specified index in the list
 *	represented by the specified Arithmetic Sequence object.
 *	If the index is out of range, TCL_ERROR is returned,
 *	otherwise TCL_OK is returned and the integer value of the
 *	element is stored in *element.
 *
 * Results:
 *
 * 	TCL_OK on success.
 *
 * Side Effects:
 *
 * 	On success, the integer pointed by *element is modified.
 * 	An empty string ("") is assigned if index is out-of-bounds.
 *
 *----------------------------------------------------------------------
 */
int
TclArithSeriesObjIndex(
    TCL_UNUSED(Tcl_Interp *),
    Tcl_Obj *arithSeriesObj,	/* List obj */







|


<
|


<
|














<
|


<
|
|







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

    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 --
 *
 *	Returns the element with the specified index in the list
 *	represented by the specified Arithmetic Sequence object.
 *	If the index is out of range, TCL_ERROR is returned,
 *	otherwise TCL_OK is returned and the integer value of the
 *	element is stored in *element.
 *
 * Results:

 *	TCL_OK on success.
 *
 * Side Effects:

 *	On success, the integer pointed by *element is modified.
 *	An empty string ("") is assigned if index is out-of-bounds.
 *
 *----------------------------------------------------------------------
 */
int
TclArithSeriesObjIndex(
    TCL_UNUSED(Tcl_Interp *),
    Tcl_Obj *arithSeriesObj,	/* List obj */
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
 *----------------------------------------------------------------------
 *
 * ArithSeriesObjLength
 *
 *	Returns the length of the arithmetic series.
 *
 * Results:
 *
 * 	The length of the series as Tcl_WideInt.
 *
 * Side Effects:
 *
 * 	None.
 *
 *----------------------------------------------------------------------
 */
Tcl_Size
ArithSeriesObjLength(
    Tcl_Obj *arithSeriesObj)
{







<
|


<
|







699
700
701
702
703
704
705

706
707
708

709
710
711
712
713
714
715
716
 *----------------------------------------------------------------------
 *
 * ArithSeriesObjLength
 *
 *	Returns the length of the arithmetic series.
 *
 * Results:

 *	The length of the series as Tcl_WideInt.
 *
 * Side Effects:

 *	None.
 *
 *----------------------------------------------------------------------
 */
Tcl_Size
ArithSeriesObjLength(
    Tcl_Obj *arithSeriesObj)
{
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
 *
 * TclArithSeriesObjStep --
 *
 *	Return a Tcl_Obj with the step value from the give ArithSeries Obj.
 *	refcount = 0.
 *
 * Results:
 *
 * 	A Tcl_Obj pointer to the created ArithSeries object.
 * 	A NULL pointer of the range is invalid.
 *
 * Side Effects:
 *
 * 	None.
 *----------------------------------------------------------------------
 */

int
TclArithSeriesObjStep(
    Tcl_Obj *arithSeriesObj,
    Tcl_Obj **stepObj)







<
|
|


<
|







724
725
726
727
728
729
730

731
732
733
734

735
736
737
738
739
740
741
742
 *
 * TclArithSeriesObjStep --
 *
 *	Return a Tcl_Obj with the step value from the give ArithSeries Obj.
 *	refcount = 0.
 *
 * Results:

 *	A Tcl_Obj pointer to the created ArithSeries object.
 *	A NULL pointer of the range is invalid.
 *
 * Side Effects:

 *	None.
 *----------------------------------------------------------------------
 */

int
TclArithSeriesObjStep(
    Tcl_Obj *arithSeriesObj,
    Tcl_Obj **stepObj)
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
}

/*
 *----------------------------------------------------------------------
 *
 * SetArithSeriesFromAny --
 *
 * 	The Arithmetic Series object is just an way to optimize
 * 	Lists space complexity, so no one should try to convert
 * 	a string to an Arithmetic Series object.
 *
 * 	This function is here just to populate the Type structure.
 *
 * Results:
 *
 * 	The result is always TCL_ERROR. But see Side Effects.
 *
 * Side effects:
 *
 * 	Tcl Panic if called.
 *
 *----------------------------------------------------------------------
 */

static int
SetArithSeriesFromAny(
    TCL_UNUSED(Tcl_Interp *),		/* Used for error reporting if not NULL. */







|
|
|

|


<
|


<
|







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
}

/*
 *----------------------------------------------------------------------
 *
 * SetArithSeriesFromAny --
 *
 *	The Arithmetic Series object is just an way to optimize
 *	Lists space complexity, so no one should try to convert
 *	a string to an Arithmetic Series object.
 *
 *	This function is here just to populate the Type structure.
 *
 * Results:

 *	The result is always TCL_ERROR. But see Side Effects.
 *
 * Side effects:

 *	Tcl Panic if called.
 *
 *----------------------------------------------------------------------
 */

static int
SetArithSeriesFromAny(
    TCL_UNUSED(Tcl_Interp *),		/* Used for error reporting if not NULL. */
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
    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.
     */

    /*
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
	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);
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107

    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 --
 *
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
 * Side effects:
 *	The object's string is set to a valid string that results from
 *	the list-to-string conversion. This string will be empty if the
 *	list has no elements. The list internal representation
 *	should not be NULL and we assume it is not NULL.
 *
 * Notes:
 * 	At the cost of overallocation it's possible to estimate
 * 	the length of the string representation and make this procedure
 * 	much faster. Because the programmer shouldn't expect the
 * 	string conversion of a big arithmetic sequence to be fast
 * 	this version takes more care of space than time.
 *
 *----------------------------------------------------------------------
 */
static void
UpdateStringOfArithSeries(
    Tcl_Obj *arithSeriesObjPtr)
{







|
|
|
|
|







1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
 * Side effects:
 *	The object's string is set to a valid string that results from
 *	the list-to-string conversion. This string will be empty if the
 *	list has no elements. The list internal representation
 *	should not be NULL and we assume it is not NULL.
 *
 * Notes:
 *	At the cost of overallocation it's possible to estimate
 *	the length of the string representation and make this procedure
 *	much faster. Because the programmer shouldn't expect the
 *	string conversion of a big arithmetic sequence to be fast
 *	this version takes more care of space than time.
 *
 *----------------------------------------------------------------------
 */
static void
UpdateStringOfArithSeries(
    Tcl_Obj *arithSeriesObjPtr)
{

Changes to generic/tclAssembly.c.

47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
 * State identified for a basic block's catch context.
 */

typedef enum BasicBlockCatchState {
    BBCS_UNKNOWN = 0,		/* Catch context has not yet been identified */
    BBCS_NONE,			/* Block is outside of any catch */
    BBCS_INCATCH,		/* Block is within a catch context */
    BBCS_CAUGHT 		/* Block is within a catch context and
				 * may be executed after an exception fires */
} BasicBlockCatchState;

/*
 * Structure that defines a basic block - a linear sequence of bytecode
 * instructions with no jumps in or out (including not changing the
 * state of any exception range).







|







47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
 * State identified for a basic block's catch context.
 */

typedef enum BasicBlockCatchState {
    BBCS_UNKNOWN = 0,		/* Catch context has not yet been identified */
    BBCS_NONE,			/* Block is outside of any catch */
    BBCS_INCATCH,		/* Block is within a catch context */
    BBCS_CAUGHT			/* Block is within a catch context and
				 * may be executed after an exception fires */
} BasicBlockCatchState;

/*
 * Structure that defines a basic block - a linear sequence of bytecode
 * instructions with no jumps in or out (including not changing the
 * state of any exception range).
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
     */

    DEBUG_PRINT("basic block %p has %d exceptions starting at %d\n",
	    curr_bb, exceptionCount, savedExceptArrayNext);
    curr_bb->foreignExceptionBase = savedExceptArrayNext;
    curr_bb->foreignExceptionCount = exceptionCount;
    curr_bb->foreignExceptions =
    		(ExceptionRange*)Tcl_Alloc(exceptionCount * sizeof(ExceptionRange));
    memcpy(curr_bb->foreignExceptions,
	    envPtr->exceptArrayPtr + savedExceptArrayNext,
	    exceptionCount * sizeof(ExceptionRange));
    for (i = 0; i < exceptionCount; ++i) {
	curr_bb->foreignExceptions[i].nestingLevel -= envPtr->exceptDepth;
    }
    envPtr->exceptArrayNext = savedExceptArrayNext;







|







1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
     */

    DEBUG_PRINT("basic block %p has %d exceptions starting at %d\n",
	    curr_bb, exceptionCount, savedExceptArrayNext);
    curr_bb->foreignExceptionBase = savedExceptArrayNext;
    curr_bb->foreignExceptionCount = exceptionCount;
    curr_bb->foreignExceptions =
		(ExceptionRange*)Tcl_Alloc(exceptionCount * sizeof(ExceptionRange));
    memcpy(curr_bb->foreignExceptions,
	    envPtr->exceptArrayPtr + savedExceptArrayNext,
	    exceptionCount * sizeof(ExceptionRange));
    for (i = 0; i < exceptionCount; ++i) {
	curr_bb->foreignExceptions[i].nestingLevel -= envPtr->exceptDepth;
    }
    envPtr->exceptArrayNext = savedExceptArrayNext;

Changes to generic/tclBasic.c.

315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
     */

    {"append",		Tcl_AppendObjCmd,	TclCompileAppendCmd,	NULL,	CMD_IS_SAFE},
    {"apply",		Tcl_ApplyObjCmd,	NULL,			TclNRApplyObjCmd,	CMD_IS_SAFE},
    {"break",		Tcl_BreakObjCmd,	TclCompileBreakCmd,	NULL,	CMD_IS_SAFE},
    {"catch",		Tcl_CatchObjCmd,	TclCompileCatchCmd,	TclNRCatchObjCmd,	CMD_IS_SAFE},
    {"concat",		Tcl_ConcatObjCmd,	TclCompileConcatCmd,	NULL,	CMD_IS_SAFE},
    {"const", 		Tcl_ConstObjCmd,	TclCompileConstCmd,	NULL,	CMD_IS_SAFE},
    {"continue",	Tcl_ContinueObjCmd,	TclCompileContinueCmd,	NULL,	CMD_IS_SAFE},
    {"coroinject",	NULL,			NULL,			TclNRCoroInjectObjCmd,	CMD_IS_SAFE},
    {"coroprobe",	NULL,			NULL,			TclNRCoroProbeObjCmd,	CMD_IS_SAFE},
    {"coroutine",	NULL,			NULL,			TclNRCoroutineObjCmd,	CMD_IS_SAFE},
    {"error",		Tcl_ErrorObjCmd,	TclCompileErrorCmd,	NULL,	CMD_IS_SAFE},
    {"eval",		Tcl_EvalObjCmd,		NULL,			TclNREvalObjCmd,	CMD_IS_SAFE},
    {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	TclNRExprObjCmd,	CMD_IS_SAFE},







|







315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
     */

    {"append",		Tcl_AppendObjCmd,	TclCompileAppendCmd,	NULL,	CMD_IS_SAFE},
    {"apply",		Tcl_ApplyObjCmd,	NULL,			TclNRApplyObjCmd,	CMD_IS_SAFE},
    {"break",		Tcl_BreakObjCmd,	TclCompileBreakCmd,	NULL,	CMD_IS_SAFE},
    {"catch",		Tcl_CatchObjCmd,	TclCompileCatchCmd,	TclNRCatchObjCmd,	CMD_IS_SAFE},
    {"concat",		Tcl_ConcatObjCmd,	TclCompileConcatCmd,	NULL,	CMD_IS_SAFE},
    {"const",		Tcl_ConstObjCmd,	TclCompileConstCmd,	NULL,	CMD_IS_SAFE},
    {"continue",	Tcl_ContinueObjCmd,	TclCompileContinueCmd,	NULL,	CMD_IS_SAFE},
    {"coroinject",	NULL,			NULL,			TclNRCoroInjectObjCmd,	CMD_IS_SAFE},
    {"coroprobe",	NULL,			NULL,			TclNRCoroProbeObjCmd,	CMD_IS_SAFE},
    {"coroutine",	NULL,			NULL,			TclNRCoroutineObjCmd,	CMD_IS_SAFE},
    {"error",		Tcl_ErrorObjCmd,	TclCompileErrorCmd,	NULL,	CMD_IS_SAFE},
    {"eval",		Tcl_EvalObjCmd,		NULL,			TclNREvalObjCmd,	CMD_IS_SAFE},
    {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	TclNRExprObjCmd,	CMD_IS_SAFE},
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
    {"lindex",		Tcl_LindexObjCmd,	TclCompileLindexCmd,	NULL,	CMD_IS_SAFE},
    {"linsert",		Tcl_LinsertObjCmd,	TclCompileLinsertCmd,	NULL,	CMD_IS_SAFE},
    {"list",		Tcl_ListObjCmd,		TclCompileListCmd,	NULL,	CMD_IS_SAFE|CMD_COMPILES_EXPANDED},
    {"llength",		Tcl_LlengthObjCmd,	TclCompileLlengthCmd,	NULL,	CMD_IS_SAFE},
    {"lmap",		Tcl_LmapObjCmd,		TclCompileLmapCmd,	TclNRLmapCmd,	CMD_IS_SAFE},
    {"lpop",		Tcl_LpopObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
    {"lrange",		Tcl_LrangeObjCmd,	TclCompileLrangeCmd,	NULL,	CMD_IS_SAFE},
    {"lremove", 	Tcl_LremoveObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"lrepeat",		Tcl_LrepeatObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"lreplace",	Tcl_LreplaceObjCmd,	TclCompileLreplaceCmd,	NULL,	CMD_IS_SAFE},
    {"lreverse",	Tcl_LreverseObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"lsearch",		Tcl_LsearchObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"lseq",		Tcl_LseqObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
    {"lset",		Tcl_LsetObjCmd,		TclCompileLsetCmd,	NULL,	CMD_IS_SAFE},
    {"lsort",		Tcl_LsortObjCmd,	NULL,			NULL,	CMD_IS_SAFE},







|







341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
    {"lindex",		Tcl_LindexObjCmd,	TclCompileLindexCmd,	NULL,	CMD_IS_SAFE},
    {"linsert",		Tcl_LinsertObjCmd,	TclCompileLinsertCmd,	NULL,	CMD_IS_SAFE},
    {"list",		Tcl_ListObjCmd,		TclCompileListCmd,	NULL,	CMD_IS_SAFE|CMD_COMPILES_EXPANDED},
    {"llength",		Tcl_LlengthObjCmd,	TclCompileLlengthCmd,	NULL,	CMD_IS_SAFE},
    {"lmap",		Tcl_LmapObjCmd,		TclCompileLmapCmd,	TclNRLmapCmd,	CMD_IS_SAFE},
    {"lpop",		Tcl_LpopObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
    {"lrange",		Tcl_LrangeObjCmd,	TclCompileLrangeCmd,	NULL,	CMD_IS_SAFE},
    {"lremove",		Tcl_LremoveObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"lrepeat",		Tcl_LrepeatObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"lreplace",	Tcl_LreplaceObjCmd,	TclCompileLreplaceCmd,	NULL,	CMD_IS_SAFE},
    {"lreverse",	Tcl_LreverseObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"lsearch",		Tcl_LsearchObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"lseq",		Tcl_LseqObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
    {"lset",		Tcl_LsetObjCmd,		TclCompileLsetCmd,	NULL,	CMD_IS_SAFE},
    {"lsort",		Tcl_LsortObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
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
    {"file", "attributes"},
    {"file", "copy"},
    {"file", "delete"},
    {"file", "dirname"},
    {"file", "executable"},
    {"file", "exists"},
    {"file", "extension"},

    {"file", "isdirectory"},
    {"file", "isfile"},
    {"file", "link"},
    {"file", "lstat"},
    {"file", "mtime"},
    {"file", "mkdir"},
    {"file", "nativename"},
    {"file", "normalize"},
    {"file", "owned"},
    {"file", "readable"},
    {"file", "readlink"},
    {"file", "rename"},
    {"file", "rootname"},
    {"file", "size"},
    {"file", "stat"},
    {"file", "tail"},
    {"file", "tempdir"},
    {"file", "tempfile"},

    {"file", "type"},
    {"file", "volumes"},
    {"file", "writable"},
    /* [info] has two unsafe commands */
    {"info", "cmdtype"},
    {"info", "nameofexecutable"},
    /* [tcl::process] has ONLY unsafe commands! */







>


















>







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
    {"file", "attributes"},
    {"file", "copy"},
    {"file", "delete"},
    {"file", "dirname"},
    {"file", "executable"},
    {"file", "exists"},
    {"file", "extension"},
    {"file", "home"},
    {"file", "isdirectory"},
    {"file", "isfile"},
    {"file", "link"},
    {"file", "lstat"},
    {"file", "mtime"},
    {"file", "mkdir"},
    {"file", "nativename"},
    {"file", "normalize"},
    {"file", "owned"},
    {"file", "readable"},
    {"file", "readlink"},
    {"file", "rename"},
    {"file", "rootname"},
    {"file", "size"},
    {"file", "stat"},
    {"file", "tail"},
    {"file", "tempdir"},
    {"file", "tempfile"},
    {"file", "tildeexpand"},
    {"file", "type"},
    {"file", "volumes"},
    {"file", "writable"},
    /* [info] has two unsafe commands */
    {"info", "cmdtype"},
    {"info", "nameofexecutable"},
    /* [tcl::process] has ONLY unsafe commands! */
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
	for (p = strchr(buildData, '.'); p++; p = strchr(p, '.')) {
	    if (!strncmp(p, arg, len)
		    && ((p[len] == '.') || (p[len] == '-') || (p[len] == '\0'))) {
		if (p[len] == '-') {
		    p += len;
		    q = strchr(++p, '.');
		    if (!q) {
		 	q = p + strlen(p);
		    }
		    memcpy(buf, p, q - p);
		    buf[q - p] = '\0';
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, TCL_INDEX_NONE));
		} else {
		    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
		}







|







747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
	for (p = strchr(buildData, '.'); p++; p = strchr(p, '.')) {
	    if (!strncmp(p, arg, len)
		    && ((p[len] == '.') || (p[len] == '-') || (p[len] == '\0'))) {
		if (p[len] == '-') {
		    p += len;
		    q = strchr(++p, '.');
		    if (!q) {
			q = p + strlen(p);
		    }
		    memcpy(buf, p, q - p);
		    buf[q - p] = '\0';
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, TCL_INDEX_NONE));
		} else {
		    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
		}
8864
8865
8866
8867
8868
8869
8870
8871
8872
8873
8874
8875
8876
8877
8878
	/*
	 * The tailcall data is in a Tcl list: the first element is the
	 * namespace, the rest the command to be tailcalled.
	 */

	nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE);
	listPtr = Tcl_NewListObj(objc, objv);
 	TclListObjSetElement(interp, listPtr, 0, nsObjPtr);

	iPtr->varFramePtr->tailcallPtr = listPtr;
    }
    return TCL_RETURN;
}

/*







|







8866
8867
8868
8869
8870
8871
8872
8873
8874
8875
8876
8877
8878
8879
8880
	/*
	 * The tailcall data is in a Tcl list: the first element is the
	 * namespace, the rest the command to be tailcalled.
	 */

	nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE);
	listPtr = Tcl_NewListObj(objc, objv);
	TclListObjSetElement(interp, listPtr, 0, nsObjPtr);

	iPtr->varFramePtr->tailcallPtr = listPtr;
    }
    return TCL_RETURN;
}

/*

Changes to generic/tclClock.c.

124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
				 * is "::tcl::clock::<name>". When NULL marks
				 * the end of the table. */
    Tcl_ObjCmdProc *objCmdProc; /* Function that implements the command. This
				 * will always have the ClockClientData sent
				 * to it, but may well ignore this data. */
    CompileProc *compileProc;	/* The compiler for the command. */
    void *clientData;		/* Any clientData to give the command (if NULL
    				 * a reference to ClockClientData will be sent) */
};

static const struct ClockCommand clockCommands[] = {
    {"add",		ClockAddObjCmd,		TclCompileBasicMin1ArgCmd, NULL},
    {"clicks",		ClockClicksObjCmd,	TclCompileClockClicksCmd,  NULL},
    {"format",		ClockFormatObjCmd,	TclCompileBasicMin1ArgCmd, NULL},
    {"getenv",		ClockGetenvObjCmd,	TclCompileBasicMin1ArgCmd, NULL},







|







124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
				 * is "::tcl::clock::<name>". When NULL marks
				 * the end of the table. */
    Tcl_ObjCmdProc *objCmdProc; /* Function that implements the command. This
				 * will always have the ClockClientData sent
				 * to it, but may well ignore this data. */
    CompileProc *compileProc;	/* The compiler for the command. */
    void *clientData;		/* Any clientData to give the command (if NULL
				 * a reference to ClockClientData will be sent) */
};

static const struct ClockCommand clockCommands[] = {
    {"add",		ClockAddObjCmd,		TclCompileBasicMin1ArgCmd, NULL},
    {"clicks",		ClockClicksObjCmd,	TclCompileClockClicksCmd,  NULL},
    {"format",		ClockFormatObjCmd,	TclCompileBasicMin1ArgCmd, NULL},
    {"getenv",		ClockGetenvObjCmd,	TclCompileBasicMin1ArgCmd, NULL},
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
    /*
     * Install the commands.
     */

#define TCL_CLOCK_PREFIX_LEN 14 /* == strlen("::tcl::clock::") */
    memcpy(cmdName, "::tcl::clock::", TCL_CLOCK_PREFIX_LEN);
    for (clockCmdPtr=clockCommands ; clockCmdPtr->name!=NULL ; clockCmdPtr++) {
    	void *clientData;

	strcpy(cmdName + TCL_CLOCK_PREFIX_LEN, clockCmdPtr->name);
	if (!(clientData = clockCmdPtr->clientData)) {
	    clientData = data;
	    data->refCount++;
	}
	cmdPtr = (Command *)Tcl_CreateObjCommand(interp, cmdName,







|







253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
    /*
     * Install the commands.
     */

#define TCL_CLOCK_PREFIX_LEN 14 /* == strlen("::tcl::clock::") */
    memcpy(cmdName, "::tcl::clock::", TCL_CLOCK_PREFIX_LEN);
    for (clockCmdPtr=clockCommands ; clockCmdPtr->name!=NULL ; clockCmdPtr++) {
	void *clientData;

	strcpy(cmdName + TCL_CLOCK_PREFIX_LEN, clockCmdPtr->name);
	if (!(clientData = clockCmdPtr->clientData)) {
	    clientData = data;
	    data->refCount++;
	}
	cmdPtr = (Command *)Tcl_CreateObjCommand(interp, cmdName,
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
    *loaded = 1;
    if (timezoneObj == dataPtr->lastSetupTimeZoneUnnorm
	    && dataPtr->lastSetupTimeZone != NULL) {
	return dataPtr->lastSetupTimeZone;
    }
    if (timezoneObj == dataPtr->prevSetupTimeZoneUnnorm
	    && dataPtr->prevSetupTimeZone != NULL) {
    	return dataPtr->prevSetupTimeZone;
    }
    if (timezoneObj == dataPtr->gmtSetupTimeZoneUnnorm
	    && dataPtr->gmtSetupTimeZone != NULL) {
	return dataPtr->literals[LIT_GMT];
    }
    if (timezoneObj == dataPtr->lastSetupTimeZone
	    || timezoneObj == dataPtr->prevSetupTimeZone







|







434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
    *loaded = 1;
    if (timezoneObj == dataPtr->lastSetupTimeZoneUnnorm
	    && dataPtr->lastSetupTimeZone != NULL) {
	return dataPtr->lastSetupTimeZone;
    }
    if (timezoneObj == dataPtr->prevSetupTimeZoneUnnorm
	    && dataPtr->prevSetupTimeZone != NULL) {
	return dataPtr->prevSetupTimeZone;
    }
    if (timezoneObj == dataPtr->gmtSetupTimeZoneUnnorm
	    && dataPtr->gmtSetupTimeZone != NULL) {
	return dataPtr->literals[LIT_GMT];
    }
    if (timezoneObj == dataPtr->lastSetupTimeZone
	    || timezoneObj == dataPtr->prevSetupTimeZone
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
	TclSetObjRef(dataPtr->prevUsedLocaleUnnorm, localeObj);
	return dataPtr->prevUsedLocale;
    }

    if ((localeObj->length == 1 /* C */
	    && strcasecmp(loc, Literals[LIT_C]) == 0)
	    || (dataPtr->defaultLocale && (loc2 = TclGetString(dataPtr->defaultLocale))
      	    && localeObj->length == dataPtr->defaultLocale->length
	    && strcasecmp(loc, loc2) == 0)) {
	*mcDictObj = dataPtr->defaultLocaleDict;
	return dataPtr->defaultLocale ?
		dataPtr->defaultLocale : dataPtr->literals[LIT_C];
    }

    if (localeObj->length == 7 /* current */







|







644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
	TclSetObjRef(dataPtr->prevUsedLocaleUnnorm, localeObj);
	return dataPtr->prevUsedLocale;
    }

    if ((localeObj->length == 1 /* C */
	    && strcasecmp(loc, Literals[LIT_C]) == 0)
	    || (dataPtr->defaultLocale && (loc2 = TclGetString(dataPtr->defaultLocale))
	    && localeObj->length == dataPtr->defaultLocale->length
	    && strcasecmp(loc, loc2) == 0)) {
	*mcDictObj = dataPtr->defaultLocaleDict;
	return dataPtr->defaultLocale ?
		dataPtr->defaultLocale : dataPtr->literals[LIT_C];
    }

    if (localeObj->length == 7 /* current */
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
    /* if loaded (setup already called for this TZ) */
    if (loaded) {
	return callargs[1];
    }

    /* before setup just take a look in TZData variable */
    if (Tcl_ObjGetVar2(interp, dataPtr->literals[LIT_TZDATA], timezoneObj, 0)) {
    	/* put it to last slot and return normalized */
    	TimezoneLoaded(dataPtr, callargs[1], timezoneObj);
	return callargs[1];
    }
    /* setup now */
    callargs[0] = dataPtr->literals[LIT_SETUPTIMEZONE];
    if (Tcl_EvalObjv(interp, 2, callargs, 0) == TCL_OK) {
	/* save unnormalized last used */
	TclSetObjRef(dataPtr->lastSetupTimeZoneUnnorm, timezoneObj);







|
|







1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
    /* if loaded (setup already called for this TZ) */
    if (loaded) {
	return callargs[1];
    }

    /* before setup just take a look in TZData variable */
    if (Tcl_ObjGetVar2(interp, dataPtr->literals[LIT_TZDATA], timezoneObj, 0)) {
	/* put it to last slot and return normalized */
	TimezoneLoaded(dataPtr, callargs[1], timezoneObj);
	return callargs[1];
    }
    /* setup now */
    callargs[0] = dataPtr->literals[LIT_SETUPTIMEZONE];
    if (Tcl_EvalObjv(interp, 2, callargs, 0) == TCL_OK) {
	/* save unnormalized last used */
	TclSetObjRef(dataPtr->lastSetupTimeZoneUnnorm, timezoneObj);
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
    };
    int optionIndex;		/* Index of an option. */
    int saw = 0;		/* Flag == 1 if option was seen already. */
    Tcl_Size i, baseIdx;
    Tcl_WideInt baseVal;	/* Base time, expressed in seconds from the Epoch */

    if (operation == CLC_OP_SCN) {
    	/* default flags (from configure) */
    	opts->flags |= dataPtr->defFlags & CLF_VALIDATE;
    } else {
    	/* clock value (as current base) */
	opts->baseObj = objv[(baseIdx = 1)];
	saw |= 1 << CLC_ARGS_BASE;
    }

    /*
     * Extract values for the keywords.
     */







|
|

|







3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
    };
    int optionIndex;		/* Index of an option. */
    int saw = 0;		/* Flag == 1 if option was seen already. */
    Tcl_Size i, baseIdx;
    Tcl_WideInt baseVal;	/* Base time, expressed in seconds from the Epoch */

    if (operation == CLC_OP_SCN) {
	/* default flags (from configure) */
	opts->flags |= dataPtr->defFlags & CLF_VALIDATE;
    } else {
	/* clock value (as current base) */
	opts->baseObj = objv[(baseIdx = 1)];
	saw |= 1 << CLC_ARGS_BASE;
    }

    /*
     * Extract values for the keywords.
     */

Changes to generic/tclClockFmt.c.

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
 * Miscellaneous forward declarations and functions used within this file
 */

static void		ClockFmtObj_DupInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void		ClockFmtObj_FreeInternalRep(Tcl_Obj *objPtr);
static int		ClockFmtObj_SetFromAny(Tcl_Interp *, Tcl_Obj *objPtr);
static void		ClockFmtObj_UpdateString(Tcl_Obj *objPtr);




TCL_DECLARE_MUTEX(ClockFmtMutex);	/* Serializes access to common format list. */

static void		ClockFmtScnStorageDelete(ClockFmtScnStorage *fss);

#ifndef TCL_CLOCK_FULL_COMPAT
#define TCL_CLOCK_FULL_COMPAT 1
#endif

/*
 * Derivation of tclStringHashKeyType with another allocEntryProc
 */

static Tcl_HashKeyType ClockFmtScnStorageHashKeyType;








#define IntFieldAt(info, offset) \
	((int *) (((char *) (info)) + (offset)))
#define WideFieldAt(info, offset) \
	((Tcl_WideInt *) (((char *) (info)) + (offset)))

/*







>
>
>


<
<






|


|
>
>
>
>
>
>
>







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
 * Miscellaneous forward declarations and functions used within this file
 */

static void		ClockFmtObj_DupInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void		ClockFmtObj_FreeInternalRep(Tcl_Obj *objPtr);
static int		ClockFmtObj_SetFromAny(Tcl_Interp *, Tcl_Obj *objPtr);
static void		ClockFmtObj_UpdateString(Tcl_Obj *objPtr);
static Tcl_HashEntry *	ClockFmtScnStorageAllocProc(Tcl_HashTable *, void *keyPtr);
static void		ClockFmtScnStorageFreeProc(Tcl_HashEntry *hPtr);
static void		ClockFmtScnStorageDelete(ClockFmtScnStorage *fss);

TCL_DECLARE_MUTEX(ClockFmtMutex);	/* Serializes access to common format list. */



#ifndef TCL_CLOCK_FULL_COMPAT
#define TCL_CLOCK_FULL_COMPAT 1
#endif

/*
 * Derivation of tclStringHashKeyType with extra memory management trickery.
 */

static const Tcl_HashKeyType ClockFmtScnStorageHashKeyType = {
    TCL_HASH_KEY_TYPE_VERSION,		/* version */
    0,					/* flags */
    TclHashStringKey,			/* hashKeyProc */
    TclCompareStringKeys,		/* compareKeysProc */
    ClockFmtScnStorageAllocProc,	/* allocEntryProc */
    ClockFmtScnStorageFreeProc		/* freeEntryProc */
};

#define IntFieldAt(info, offset) \
	((int *) (((char *) (info)) + (offset)))
#define WideFieldAt(info, offset) \
	((Tcl_WideInt *) (((char *) (info)) + (offset)))

/*
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
 *	The return value is a pointer to the created entry.
 *
 *----------------------------------------------------------------------
 */

static Tcl_HashEntry *
ClockFmtScnStorageAllocProc(
    TCL_UNUSED(Tcl_HashTable *),	/* Hash table. */
    void *keyPtr)		/* Key to store in the hash table entry. */
{
    ClockFmtScnStorage *fss;
    const char *string = (const char *) keyPtr;
    Tcl_HashEntry *hPtr;
    unsigned size = strlen(string) + 1;
    unsigned allocsize = sizeof(ClockFmtScnStorage) + sizeof(Tcl_HashEntry);







|







547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
 *	The return value is a pointer to the created entry.
 *
 *----------------------------------------------------------------------
 */

static Tcl_HashEntry *
ClockFmtScnStorageAllocProc(
    TCL_UNUSED(Tcl_HashTable *),/* Hash table. */
    void *keyPtr)		/* Key to store in the hash table entry. */
{
    ClockFmtScnStorage *fss;
    const char *string = (const char *) keyPtr;
    Tcl_HashEntry *hPtr;
    unsigned size = strlen(string) + 1;
    unsigned allocsize = sizeof(ClockFmtScnStorage) + sizeof(Tcl_HashEntry);
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
 *	If format object is not localizable, it is equal the given format
 *	pointer (special case to fast fallback by not-localizable formats).
 *
 * Results:
 *	Returns tcl object with key or format object if not localizable.
 *
 * Side effects:
 * 	Converts given format object to ClockFmtObjType on demand for caching
 *	the key inside its internal representation.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj*
ClockFrmObjGetLocFmtKey(







|







762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
 *	If format object is not localizable, it is equal the given format
 *	pointer (special case to fast fallback by not-localizable formats).
 *
 * Results:
 *	Returns tcl object with key or format object if not localizable.
 *
 * Side effects:
 *	Converts given format object to ClockFmtObjType on demand for caching
 *	the key inside its internal representation.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj*
ClockFrmObjGetLocFmtKey(
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
 *	reference in the first pointer of internal representation of given
 *	object.
 *
 * Results:
 *	Returns scan/format storage pointer to ClockFmtScnStorage.
 *
 * Side effects:
 * 	Converts given format object to ClockFmtObjType on demand for caching
 *	the format storage reference inside its internal representation.
 *	Increments objRefCount of the ClockFmtScnStorage reference.
 *
 *----------------------------------------------------------------------
 */

static ClockFmtScnStorage *
FindOrCreateFmtScnStorage(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr)
{
    const char *strFmt = TclGetString(objPtr);
    ClockFmtScnStorage *fss = NULL;
    int isNew;
    Tcl_HashEntry *hPtr;

    Tcl_MutexLock(&ClockFmtMutex);

    /* if not yet initialized */
    if (!initialized) {
	/* initialize type */
	memcpy(&ClockFmtScnStorageHashKeyType, &tclStringHashKeyType, sizeof(tclStringHashKeyType));
	ClockFmtScnStorageHashKeyType.allocEntryProc = ClockFmtScnStorageAllocProc;
	ClockFmtScnStorageHashKeyType.freeEntryProc = ClockFmtScnStorageFreeProc;

	/* initialize hash table */
	Tcl_InitCustomHashTable(&FmtScnHashTable, TCL_CUSTOM_TYPE_KEYS,
		&ClockFmtScnStorageHashKeyType);

	initialized = 1;
    }








|




















<
<
<
<
<







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
 *	reference in the first pointer of internal representation of given
 *	object.
 *
 * Results:
 *	Returns scan/format storage pointer to ClockFmtScnStorage.
 *
 * Side effects:
 *	Converts given format object to ClockFmtObjType on demand for caching
 *	the format storage reference inside its internal representation.
 *	Increments objRefCount of the ClockFmtScnStorage reference.
 *
 *----------------------------------------------------------------------
 */

static ClockFmtScnStorage *
FindOrCreateFmtScnStorage(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr)
{
    const char *strFmt = TclGetString(objPtr);
    ClockFmtScnStorage *fss = NULL;
    int isNew;
    Tcl_HashEntry *hPtr;

    Tcl_MutexLock(&ClockFmtMutex);

    /* if not yet initialized */
    if (!initialized) {





	/* initialize hash table */
	Tcl_InitCustomHashTable(&FmtScnHashTable, TCL_CUSTOM_TYPE_KEYS,
		&ClockFmtScnStorageHashKeyType);

	initialized = 1;
    }

1237
1238
1239
1240
1241
1242
1243
1244

1245


1246

1247
1248
1249
1250
1251
1252
1253
    }
    return TCL_RETURN;
}
#if 0
/* currently unused */

static int
LocaleListSearch(ClockFmtScnCmdArgs *opts,

    DateInfo *info, int mcKey, int *val,


    int minLen, int maxLen)

{
    Tcl_Obj **lstv;
    Tcl_Size lstc;
    Tcl_Obj *valObj;

    /* get msgcat value */
    valObj = ClockMCGet(opts, mcKey);







|
>
|
>
>
|
>







1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
    }
    return TCL_RETURN;
}
#if 0
/* currently unused */

static int
LocaleListSearch(
    ClockFmtScnCmdArgs *opts,
    DateInfo *info,
    int mcKey,
    int *val,
    int minLen,
    int maxLen)
{
    Tcl_Obj **lstv;
    Tcl_Size lstc;
    Tcl_Obj *valObj;

    /* get msgcat value */
    valObj = ClockMCGet(opts, mcKey);
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
 *
 *	Find largest part of the input string from start regarding lengths
 *	in the given localized string indexed tree (utf-8, case sensitive).
 *
 * Results:
 *	TCL_OK - match found and the index stored in *val,
 *	TCL_RETURN - not matched or ambigous,
 * 	TCL_ERROR - in error case.
 *
 * Side effects:
 *	Input points to end of the found token in string.
 *
 *----------------------------------------------------------------------
 */








|







1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
 *
 *	Find largest part of the input string from start regarding lengths
 *	in the given localized string indexed tree (utf-8, case sensitive).
 *
 * Results:
 *	TCL_OK - match found and the index stored in *val,
 *	TCL_RETURN - not matched or ambigous,
 *	TCL_ERROR - in error case.
 *
 * Side effects:
 *	Input points to end of the found token in string.
 *
 *----------------------------------------------------------------------
 */

1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
	}
	/* calendar JD */
	yydate.julianDay = intJD;
	return TCL_OK;
    }
    s = p;
    while (p < end && isdigit(UCHAR(*p))) {
    	fractJDDiv *= 10;
	p++;
    }
    if (Clock_str2int(&fractJD, s, p, 1) != TCL_OK) {
	return TCL_RETURN;
    }
    yyInput = p;








|







1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
	}
	/* calendar JD */
	yydate.julianDay = intJD;
	return TCL_OK;
    }
    s = p;
    while (p < end && isdigit(UCHAR(*p))) {
	fractJDDiv *= 10;
	p++;
    }
    if (Clock_str2int(&fractJD, s, p, 1) != TCL_OK) {
	return TCL_RETURN;
    }
    yyInput = p;

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
			} else {
			    yyYear += info->dateCentury * 100;
			}
		    }
		}
		if (flags & (CLF_ISO8601WEEK | CLF_ISO8601YEAR)) {
		    if ((flags & (CLF_ISO8601YEAR | CLF_YEAR)) == CLF_YEAR) {
		    	/* for calculations expected iso year */
			info->date.iso8601Year = yyYear;
		    } else if (info->date.iso8601Year < 100) {
			if (!(flags & CLF_ISO8601CENTURY)) {
			    if (info->date.iso8601Year >= dataPtr->yearOfCenturySwitch) {
				info->date.iso8601Year -= 100;
			    }
			    info->date.iso8601Year += dataPtr->currentYearCentury;
			} else {
			    info->date.iso8601Year += info->dateCentury * 100;
			}
		    }
		    if ((flags & (CLF_ISO8601YEAR | CLF_YEAR)) == CLF_ISO8601YEAR) {
		    	/* for calculations expected year (e. g. CLF_ISO8601WEEK not set) */
			yyYear = info->date.iso8601Year;
		    }
		}
	    }
	}

	/* if no time - reset time */







|












|







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
			} else {
			    yyYear += info->dateCentury * 100;
			}
		    }
		}
		if (flags & (CLF_ISO8601WEEK | CLF_ISO8601YEAR)) {
		    if ((flags & (CLF_ISO8601YEAR | CLF_YEAR)) == CLF_YEAR) {
			/* for calculations expected iso year */
			info->date.iso8601Year = yyYear;
		    } else if (info->date.iso8601Year < 100) {
			if (!(flags & CLF_ISO8601CENTURY)) {
			    if (info->date.iso8601Year >= dataPtr->yearOfCenturySwitch) {
				info->date.iso8601Year -= 100;
			    }
			    info->date.iso8601Year += dataPtr->currentYearCentury;
			} else {
			    info->date.iso8601Year += info->dateCentury * 100;
			}
		    }
		    if ((flags & (CLF_ISO8601YEAR | CLF_YEAR)) == CLF_ISO8601YEAR) {
			/* for calculations expected year (e. g. CLF_ISO8601WEEK not set) */
			yyYear = info->date.iso8601Year;
		    }
		}
	    }
	}

	/* if no time - reset time */
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
    Tcl_WideInt intJD = dateFmt->date.julianDay;
    int fractJD;

    /* Convert to JDN parts (regarding start offset) and time fraction */
    fractJD = dateFmt->date.secondOfDay
	    - (int)tok->map->offs;	/* 0 for calendar or 43200 for astro JD */
    if (fractJD < 0) {
    	intJD--;
	fractJD += SECONDS_PER_DAY;
    }
    if (fractJD && intJD < 0) {		/* avoid jump over 0, by negative JD's */
	intJD++;
	if (intJD == 0) {
	    /* -0.0 / -0.9 has zero integer part, so append "-" extra */
	    if (FrmResultAllocate(dateFmt, 1) != TCL_OK) {







|







2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
    Tcl_WideInt intJD = dateFmt->date.julianDay;
    int fractJD;

    /* Convert to JDN parts (regarding start offset) and time fraction */
    fractJD = dateFmt->date.secondOfDay
	    - (int)tok->map->offs;	/* 0 for calendar or 43200 for astro JD */
    if (fractJD < 0) {
	intJD--;
	fractJD += SECONDS_PER_DAY;
    }
    if (fractJD && intJD < 0) {		/* avoid jump over 0, by negative JD's */
	intJD++;
	if (intJD == 0) {
	    /* -0.0 / -0.9 has zero integer part, so append "-" extra */
	    if (FrmResultAllocate(dateFmt, 1) != TCL_OK) {

Changes to generic/tclCmdAH.c.

26
27
28
29
30
31
32
33
34
35
36
37
38
39
40

struct ForeachState {
    Tcl_Obj *bodyPtr;		/* The script body of the command. */
    Tcl_Size bodyIdx;		/* The argument index of the body. */
    Tcl_Size j, maxj;		/* Number of loop iterations. */
    Tcl_Size numLists;		/* Count of value lists. */
    Tcl_Size *index;		/* Array of value list indices. */
    Tcl_Size *varcList; 	/* # loop variables per list. */
    Tcl_Obj ***varvList;	/* Array of var name lists. */
    Tcl_Obj **vCopyList;	/* Copies of var name list arguments. */
    Tcl_Size *argcList;		/* Array of value list sizes. */
    Tcl_Obj ***argvList;	/* Array of value lists. */
    Tcl_Obj **aCopyList;	/* Copies of value list arguments. */
    Tcl_Obj *resultList;	/* List of result values from the loop body,
				 * or NULL if we're not collecting them







|







26
27
28
29
30
31
32
33
34
35
36
37
38
39
40

struct ForeachState {
    Tcl_Obj *bodyPtr;		/* The script body of the command. */
    Tcl_Size bodyIdx;		/* The argument index of the body. */
    Tcl_Size j, maxj;		/* Number of loop iterations. */
    Tcl_Size numLists;		/* Count of value lists. */
    Tcl_Size *index;		/* Array of value list indices. */
    Tcl_Size *varcList;		/* # loop variables per list. */
    Tcl_Obj ***varvList;	/* Array of var name lists. */
    Tcl_Obj **vCopyList;	/* Copies of var name list arguments. */
    Tcl_Size *argcList;		/* Array of value list sizes. */
    Tcl_Obj ***argvList;	/* Array of value lists. */
    Tcl_Obj **aCopyList;	/* Copies of value list arguments. */
    Tcl_Obj *resultList;	/* List of result values from the loop body,
				 * or NULL if we're not collecting them

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
    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;
    int i, 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
    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;
    int i, 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;
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
4392
4393
4394
4395



4396
4397
4398


4399

4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
	    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;
}

/*
 *----------------------------------------------------------------------
 *







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


>




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




|


>
>
|







>
>
>



>
>
|
>
|
|
|







4319
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
	    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/tclCmdMZ.c.

2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
		goto str_cmp_args;
	    }
	    i++;
	    if (TclGetWideIntFromObj(interp, objv[i], &wreqlength) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if ((Tcl_WideUInt)wreqlength > TCL_SIZE_MAX) {
	    	*reqlength = -1;
	    } else {
	    	*reqlength = wreqlength;
	    }
	} else {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "bad option \"%s\": must be -nocase or -length",
		    string));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
		    string, (char *)NULL);







|

|







2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
		goto str_cmp_args;
	    }
	    i++;
	    if (TclGetWideIntFromObj(interp, objv[i], &wreqlength) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if ((Tcl_WideUInt)wreqlength > TCL_SIZE_MAX) {
		*reqlength = -1;
	    } else {
		*reqlength = wreqlength;
	    }
	} else {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "bad option \"%s\": must be -nocase or -length",
		    string));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
		    string, (char *)NULL);

Changes to generic/tclCompCmds.c.

375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
	 * a non-local variable: upvar from a local one! This consumes the
	 * variable name that was left at stacktop.
	 */

	localIndex = TclFindCompiledLocal(varTokenPtr->start,
		varTokenPtr->size, 1, envPtr);
	PushStringLiteral(envPtr, "0");
	TclEmitInstInt4(INST_REVERSE, 2,        		envPtr);
	TclEmitInstInt4(INST_UPVAR, localIndex, 		envPtr);
	TclEmitOpcode(INST_POP,          			envPtr);
    }

    /*
     * Prepare for the internal foreach.
     */

    keyVar = AnonymousLocal(envPtr);







|
|
|







375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
	 * a non-local variable: upvar from a local one! This consumes the
	 * variable name that was left at stacktop.
	 */

	localIndex = TclFindCompiledLocal(varTokenPtr->start,
		varTokenPtr->size, 1, envPtr);
	PushStringLiteral(envPtr, "0");
	TclEmitInstInt4(INST_REVERSE, 2,			envPtr);
	TclEmitInstInt4(INST_UPVAR, localIndex,			envPtr);
	TclEmitOpcode(INST_POP,					envPtr);
    }

    /*
     * Prepare for the internal foreach.
     */

    keyVar = AnonymousLocal(envPtr);
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
 *
 * TclLocalScalarFromToken --
 *
 *	Get the index into the table of compiled locals that corresponds
 *	to a local scalar variable name.
 *
 * Results:
 * 	Returns the non-negative integer index value into the table of
 * 	compiled locals corresponding to a local scalar variable name.
 * 	If the arguments passed in do not identify a local scalar variable
 * 	then return TCL_INDEX_NONE.
 *
 * Side effects:
 *	May add an entry into the table of compiled locals.
 *
 *----------------------------------------------------------------------
 */








|
|
|
|







3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
 *
 * TclLocalScalarFromToken --
 *
 *	Get the index into the table of compiled locals that corresponds
 *	to a local scalar variable name.
 *
 * Results:
 *	Returns the non-negative integer index value into the table of
 *	compiled locals corresponding to a local scalar variable name.
 *	If the arguments passed in do not identify a local scalar variable
 *	then return TCL_INDEX_NONE.
 *
 * Side effects:
 *	May add an entry into the table of compiled locals.
 *
 *----------------------------------------------------------------------
 */

Changes to generic/tclCompile.h.

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
 * what level of tracing is desired:
 *    0: no compilation tracing
 *    1: summarize compilation of top level cmds and proc bodies
 *    2: display all instructions of each ByteCode compiled
 * This variable is linked to the Tcl variable "tcl_traceCompile".
 */

MODULE_SCOPE int 	tclTraceCompile;

/*
 * Variable that controls whether execution tracing is enabled and, if so,
 * what level of tracing is desired:
 *    0: no execution tracing
 *    1: trace invocations of Tcl procs only
 *    2: trace invocations of all (not compiled away) commands
 *    3: display each instruction executed
 * This variable is linked to the Tcl variable "tcl_traceExec".
 */

MODULE_SCOPE int 	tclTraceExec;
#endif

/*
 * The type of lambda expressions. Note that every lambda will *always* have a
 * string representation.
 */








|











|







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
 * what level of tracing is desired:
 *    0: no compilation tracing
 *    1: summarize compilation of top level cmds and proc bodies
 *    2: display all instructions of each ByteCode compiled
 * This variable is linked to the Tcl variable "tcl_traceCompile".
 */

MODULE_SCOPE int	tclTraceCompile;

/*
 * Variable that controls whether execution tracing is enabled and, if so,
 * what level of tracing is desired:
 *    0: no execution tracing
 *    1: trace invocations of Tcl procs only
 *    2: trace invocations of all (not compiled away) commands
 *    3: display each instruction executed
 * This variable is linked to the Tcl variable "tcl_traceExec".
 */

MODULE_SCOPE int	tclTraceExec;
#endif

/*
 * The type of lambda expressions. Note that every lambda will *always* have a
 * string representation.
 */

321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
    int mallocedCodeArray;	/* Set 1 if code array was expanded and
				 * codeStart points into the heap.*/
#if TCL_MAJOR_VERSION > 8
    int mallocedExceptArray;	/* 1 if ExceptionRange array was expanded and
				 * exceptArrayPtr points in heap, else 0. */
#endif
    LiteralEntry *literalArrayPtr;
    				/* Points to start of LiteralEntry array. */
    Tcl_Size literalArrayNext;	/* Index of next free object array entry. */
    Tcl_Size literalArrayEnd;	/* Index just after last obj array entry. */
    int mallocedLiteralArray;	/* 1 if object array was expanded and objArray
				 * points into the heap, else 0. */
    ExceptionRange *exceptArrayPtr;
    				/* Points to start of the ExceptionRange
				 * array. */
    Tcl_Size exceptArrayNext;	/* Next free ExceptionRange array index.
				 * exceptArrayNext is the number of ranges and
				 * (exceptArrayNext-1) is the index of the
				 * current range's array entry. */
    Tcl_Size exceptArrayEnd;	/* Index after the last ExceptionRange array
				 * entry. */







|





|







321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
    int mallocedCodeArray;	/* Set 1 if code array was expanded and
				 * codeStart points into the heap.*/
#if TCL_MAJOR_VERSION > 8
    int mallocedExceptArray;	/* 1 if ExceptionRange array was expanded and
				 * exceptArrayPtr points in heap, else 0. */
#endif
    LiteralEntry *literalArrayPtr;
				/* Points to start of LiteralEntry array. */
    Tcl_Size literalArrayNext;	/* Index of next free object array entry. */
    Tcl_Size literalArrayEnd;	/* Index just after last obj array entry. */
    int mallocedLiteralArray;	/* 1 if object array was expanded and objArray
				 * points into the heap, else 0. */
    ExceptionRange *exceptArrayPtr;
				/* Points to start of the ExceptionRange
				 * array. */
    Tcl_Size exceptArrayNext;	/* Next free ExceptionRange array index.
				 * exceptArrayNext is the number of ranges and
				 * (exceptArrayNext-1) is the index of the
				 * current range's array entry. */
    Tcl_Size exceptArrayEnd;	/* Index after the last ExceptionRange array
				 * entry. */
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
    unsigned char *codeStart;	/* Points to the first byte of the code. This
				 * is just after the final ByteCode member
				 * cmdMapPtr. */
    Tcl_Obj **objArrayPtr;	/* Points to the start of the literal object
				 * array. This is just after the last code
				 * byte. */
    ExceptionRange *exceptArrayPtr;
    				/* Points to the start of the ExceptionRange
				 * array. This is just after the last object
				 * in the object array. */
    AuxData *auxDataArrayPtr;	/* Points to the start of the auxiliary data
				 * array. This is just after the last entry in
				 * the ExceptionRange array. */
    unsigned char *codeDeltaStart;
				/* Points to the first of a sequence of bytes







|







478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
    unsigned char *codeStart;	/* Points to the first byte of the code. This
				 * is just after the final ByteCode member
				 * cmdMapPtr. */
    Tcl_Obj **objArrayPtr;	/* Points to the start of the literal object
				 * array. This is just after the last code
				 * byte. */
    ExceptionRange *exceptArrayPtr;
				/* Points to the start of the ExceptionRange
				 * array. This is just after the last object
				 * in the object array. */
    AuxData *auxDataArrayPtr;	/* Points to the start of the auxiliary data
				 * array. This is just after the last entry in
				 * the ExceptionRange array. */
    unsigned char *codeDeltaStart;
				/* Points to the first of a sequence of bytes

Changes to generic/tclDate.c.

2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659

    /* ignore spaces at begin */
    yyInput = bypassSpaces(yyInput);

    /* parse */
    status = yyparse(info);
    if (status == 1) {
    	const char *msg = NULL;
	if (info->errFlags & CLF_HAVEDATE) {
	    msg = "more than one date in string";
	} else if (info->errFlags & CLF_TIME) {
	    msg = "more than one time of day in string";
	} else if (info->errFlags & CLF_ZONE) {
	    msg = "more than one time zone in string";
	} else if (info->errFlags & CLF_DAYOFWEEK) {







|







2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659

    /* ignore spaces at begin */
    yyInput = bypassSpaces(yyInput);

    /* parse */
    status = yyparse(info);
    if (status == 1) {
	const char *msg = NULL;
	if (info->errFlags & CLF_HAVEDATE) {
	    msg = "more than one date in string";
	} else if (info->errFlags & CLF_TIME) {
	    msg = "more than one time of day in string";
	} else if (info->errFlags & CLF_ZONE) {
	    msg = "more than one time zone in string";
	} else if (info->errFlags & CLF_DAYOFWEEK) {

Changes to generic/tclDictObj.c.

76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
    {"getdef",	DictGetDefCmd,	TclCompileDictGetWithDefaultCmd, NULL,NULL,0},
    {"getwithdefault",	DictGetDefCmd,	TclCompileDictGetWithDefaultCmd,
	NULL, NULL, 0 },
    {"incr",	DictIncrCmd,	TclCompileDictIncrCmd, NULL, NULL, 0 },
    {"info",	DictInfoCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0 },
    {"keys",	DictKeysCmd,	TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
    {"lappend",	DictLappendCmd,	TclCompileDictLappendCmd, NULL, NULL, 0 },
    {"map", 	NULL,       	TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 },
    {"merge",	DictMergeCmd,	TclCompileDictMergeCmd, NULL, NULL, 0 },
    {"remove",	DictRemoveCmd,	TclCompileBasicMin1ArgCmd, NULL, NULL, 0 },
    {"replace",	DictReplaceCmd, NULL, NULL, NULL, 0 },
    {"set",	DictSetCmd,	TclCompileDictSetCmd, NULL, NULL, 0 },
    {"size",	DictSizeCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0 },
    {"unset",	DictUnsetCmd,	TclCompileDictUnsetCmd, NULL, NULL, 0 },
    {"update",	DictUpdateCmd,	TclCompileDictUpdateCmd, NULL, NULL, 0 },







|







76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
    {"getdef",	DictGetDefCmd,	TclCompileDictGetWithDefaultCmd, NULL,NULL,0},
    {"getwithdefault",	DictGetDefCmd,	TclCompileDictGetWithDefaultCmd,
	NULL, NULL, 0 },
    {"incr",	DictIncrCmd,	TclCompileDictIncrCmd, NULL, NULL, 0 },
    {"info",	DictInfoCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0 },
    {"keys",	DictKeysCmd,	TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
    {"lappend",	DictLappendCmd,	TclCompileDictLappendCmd, NULL, NULL, 0 },
    {"map",	NULL,		TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 },
    {"merge",	DictMergeCmd,	TclCompileDictMergeCmd, NULL, NULL, 0 },
    {"remove",	DictRemoveCmd,	TclCompileBasicMin1ArgCmd, NULL, NULL, 0 },
    {"replace",	DictReplaceCmd, NULL, NULL, NULL, 0 },
    {"set",	DictSetCmd,	TclCompileDictSetCmd, NULL, NULL, 0 },
    {"size",	DictSizeCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0 },
    {"unset",	DictUnsetCmd,	TclCompileDictUnsetCmd, NULL, NULL, 0 },
    {"update",	DictUpdateCmd,	TclCompileDictUpdateCmd, NULL, NULL, 0 },
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
				 * dictionary. Used for doing traversal of the
				 * entries in the order that they are
				 * created. */
    ChainEntry *entryChainTail;	/* Other end of linked list of all entries in
				 * the dictionary. Used for doing traversal of
				 * the entries in the order that they are
				 * created. */
    size_t epoch; 		/* Epoch counter */
    size_t refCount;		/* Reference counter (see above) */
    Tcl_Obj *chain;		/* Linked list used for invalidating the
				 * string representations of updated nested
				 * dictionaries. */
} Dict;

/*







|







125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
				 * dictionary. Used for doing traversal of the
				 * entries in the order that they are
				 * created. */
    ChainEntry *entryChainTail;	/* Other end of linked list of all entries in
				 * the dictionary. Used for doing traversal of
				 * the entries in the order that they are
				 * created. */
    size_t epoch;		/* Epoch counter */
    size_t refCount;		/* Reference counter (see above) */
    Tcl_Obj *chain;		/* Linked list used for invalidating the
				 * string representations of updated nested
				 * dictionaries. */
} Dict;

/*
1054
1055
1056
1057
1058
1059
1060
1061

1062
1063
1064
1065
1066
1067
1068
 *	'tclDicttype'.
 *
 *
 *----------------------------------------------------------------------
 */

Tcl_Size
TclDictGetSize(Tcl_Obj *dictPtr)

{
    Dict *dict;
    DictGetInternalRep(dictPtr, dict);
    return dict->table.numEntries;
}

/*







|
>







1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
 *	'tclDicttype'.
 *
 *
 *----------------------------------------------------------------------
 */

Tcl_Size
TclDictGetSize(
    Tcl_Obj *dictPtr)
{
    Dict *dict;
    DictGetInternalRep(dictPtr, dict);
    return dict->table.numEntries;
}

/*

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) {
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311

4312
4313
4314

4315
4316
4317
4318

4319
4320
4321
4322
4323
4324
4325
 *
 *------------------------------------------------------------------------
 */
int
TclEncodingProfileNameToId(
    Tcl_Interp *interp,		/* For error messages. May be NULL */
    const char *profileName,	/* Name of profile */
    int *profilePtr)  		/* Output */
{
    size_t i;
    size_t numProfiles = sizeof(encodingProfiles) / sizeof(encodingProfiles[0]);

    for (i = 0; i < numProfiles; ++i) {
	if (!strcmp(profileName, encodingProfiles[i].name)) {
	    *profilePtr = encodingProfiles[i].value;
	    return TCL_OK;
	}
    }
    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;
}

/*
 *------------------------------------------------------------------------
 *







|
















|
>


|
>



|
>







4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
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
 *
 *------------------------------------------------------------------------
 */
int
TclEncodingProfileNameToId(
    Tcl_Interp *interp,		/* For error messages. May be NULL */
    const char *profileName,	/* Name of profile */
    int *profilePtr)		/* Output */
{
    size_t i;
    size_t numProfiles = sizeof(encodingProfiles) / sizeof(encodingProfiles[0]);

    for (i = 0; i < numProfiles; ++i) {
	if (!strcmp(profileName, encodingProfiles[i].name)) {
	    *profilePtr = encodingProfiles[i].value;
	    return TCL_OK;
	}
    }
    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
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
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;
}

/*
 *------------------------------------------------------------------------
 *
 * TclGetEncodingProfiles --
 *
 *	Get the list of supported encoding profiles.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The list of profile names is stored in the interpreter result.
 *
 *------------------------------------------------------------------------
 */
void
TclGetEncodingProfiles(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:
 */







|
>









|




















|
>






|
|



|







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
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
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;
}

/*
 *------------------------------------------------------------------------
 *
 * TclGetEncodingProfiles --
 *
 *	Get the list of supported encoding profiles.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The list of profile names is stored in the interpreter result.
 *
 *------------------------------------------------------------------------
 */
void
TclGetEncodingProfiles(
    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, int objc,
			    Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr);
static int		NsEnsembleImplementationCmdNR(void *clientData,
			    Tcl_Interp *interp,int 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, int objc,
			    Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr);
static int		NsEnsembleImplementationCmdNR(void *clientData,
			    Tcl_Interp *interp,int 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,
    int 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,
    int 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->objProc != 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->objClientData;
}

/*
 *----------------------------------------------------------------------
 *
 * 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->objProc != 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->objClientData;
    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->objProc != 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->objClientData;
    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->objProc != 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->objClientData;
    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->objProc != 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->objClientData;
    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->objProc != 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->objClientData;
    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->objProc != 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->objClientData;
    *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->objProc != 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->objClientData;
    *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->objProc != 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->objClientData;
    *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->objProc != 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->objClientData;
    *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->objProc != 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->objClientData;
    *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->objProc != 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->objClientData;
    *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->objProc != TclEnsembleImplementationCmd) {
	/*
	 * Reuse existing infrastructure for following import link chains
	 * rather than duplicating it.
	 */

	cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);

	if (cmdPtr == NULL
		|| cmdPtr->objProc != 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)->objProc != TclEnsembleImplementationCmd) {
	/*
	 * Reuse existing infrastructure for following import link chains
	 * rather than duplicating it.
	 */

	token = TclGetOriginalCommand(token);

	if (token == NULL ||
		((Command *) token)->objProc != 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->objProc == 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->objProc == 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
	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].proc || map[i].nreProc) {
		/*
		 * 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_NRCreateCommand(interp, "___tmp", map[i].proc,
			    map[i].nreProc, 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!
		     */








|

















|
>







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
	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].proc || map[i].nreProc) {
		/*
		 * 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_NRCreateCommand(interp, "___tmp", map[i].proc,
			    map[i].nreProc, 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));
		    }
		} else {
		    /*
		     * Not hidden, so just create it. Yay!
		     */

1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
{
    return Tcl_NRCallObjProc(interp, NsEnsembleImplementationCmdNR,
	    clientData, objc, objv);
}

static int
NsEnsembleImplementationCmdNR(
    void *clientData,
    Tcl_Interp *interp,
    int 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. */







|




|







1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
{
    return Tcl_NRCallObjProc(interp, NsEnsembleImplementationCmdNR,
	    clientData, objc, objv);
}

static int
NsEnsembleImplementationCmdNR(
    void *clientData,		/* The ensemble this is the impl. of. */
    Tcl_Interp *interp,
    int 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







<
|
















|
>







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







|
|




















<







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







|









|







1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
		    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







|







1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005

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







|
>




|
>







2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
		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.







|

|







2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
	}
    }

    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;







>
>
>
>
>
>
>
>
>
>






>

|




















<














|







2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313

2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
    }

    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,
    int objc,
    Tcl_Obj *const objv[],
    Tcl_Obj **prefixObjPtr)


{
    Tcl_Size paramc;
    int result;
    Tcl_Size i, prefixObjc;
    Tcl_Obj **paramv, *unknownCmd, *ensObj;

    /*







|
|
|
|
>
>







2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
 *
 * ----------------------------------------------------------------------
 */

static inline int
EnsembleUnknownCallback(
    Tcl_Interp *interp,
    EnsembleConfig *ensemblePtr,/* The ensemble structure. */
    int 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);








|
>







2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410

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







|
>


|
>


|
>


|
>







2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
     * 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.
     */








|
|
|
|
>














|







2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
 *	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;








|




|
|

|
|
|
|
|
|






|

|







2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
 *	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);

		    /*







|














|
|
|

|
|
|
|

|
|
|
|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|



|
|
|
|
|
|

|



|
|
|
|
|
|
|
|

|
|
|
|
|
|

|
|
|
|
|
|

|
|
|
|
|

|
|
|

|
|
|
|

|
|
|
|
|















|
|







2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
 *	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 ;







|
|







2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
     * 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);
}

/*
 *----------------------------------------------------------------------
 *







|
>




|
>













>
|













|
|







2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
     * 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++;







|
>







2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968

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++;
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
    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;
    }







|







3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
    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;
    }
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.
     */








|
|
|







3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
    }

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







|







3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
     * 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







|
>







3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
    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);
}

/*
 *----------------------------------------------------------------------
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
	cleanup = 2;
	part1Ptr = OBJ_UNDER_TOS;
	objPtr = OBJ_AT_TOS;
	TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(objPtr)));
	varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL,
		/*createPart1*/1, /*createPart2*/0, &arrayPtr);
    doConst:
    	if (TclIsVarConstant(varPtr)) {
	    TRACE_APPEND(("\n"));
	    NEXT_INST_V(pcAdjustment, cleanup, 0);
	}
	if (TclIsVarArray(varPtr)) {
	    msgPart = "variable is array";
	    goto constError;
	} else if (TclIsVarArrayElement(varPtr)) {







|







3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
	cleanup = 2;
	part1Ptr = OBJ_UNDER_TOS;
	objPtr = OBJ_AT_TOS;
	TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(objPtr)));
	varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL,
		/*createPart1*/1, /*createPart2*/0, &arrayPtr);
    doConst:
	if (TclIsVarConstant(varPtr)) {
	    TRACE_APPEND(("\n"));
	    NEXT_INST_V(pcAdjustment, cleanup, 0);
	}
	if (TclIsVarArray(varPtr)) {
	    msgPart = "variable is array";
	    goto constError;
	} else if (TclIsVarArrayElement(varPtr)) {
7861
7862
7863
7864
7865
7866
7867
7868


7869
7870
7871
7872
7873
7874
7875
7876

/*
 * WidePwrSmallExpon --
 *
 * Helper to calculate small powers of integers whose result is wide.
 */
static inline Tcl_WideInt
WidePwrSmallExpon(Tcl_WideInt w1, long exponent) {



    Tcl_WideInt wResult;

    wResult = w1 * w1;		/* b**2 */
    switch (exponent) {
    case 2:
	break;
    case 3:







|
>
>
|







7861
7862
7863
7864
7865
7866
7867
7868
7869
7870
7871
7872
7873
7874
7875
7876
7877
7878

/*
 * WidePwrSmallExpon --
 *
 * Helper to calculate small powers of integers whose result is wide.
 */
static inline Tcl_WideInt
WidePwrSmallExpon(
    Tcl_WideInt w1,
    long exponent)
{
    Tcl_WideInt wResult;

    wResult = w1 * w1;		/* b**2 */
    switch (exponent) {
    case 2:
	break;
    case 3:

Changes to generic/tclGetDate.y.

1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035

    /* ignore spaces at begin */
    yyInput = bypassSpaces(yyInput);

    /* parse */
    status = yyparse(info);
    if (status == 1) {
    	const char *msg = NULL;
	if (info->errFlags & CLF_HAVEDATE) {
	    msg = "more than one date in string";
	} else if (info->errFlags & CLF_TIME) {
	    msg = "more than one time of day in string";
	} else if (info->errFlags & CLF_ZONE) {
	    msg = "more than one time zone in string";
	} else if (info->errFlags & CLF_DAYOFWEEK) {







|







1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035

    /* ignore spaces at begin */
    yyInput = bypassSpaces(yyInput);

    /* parse */
    status = yyparse(info);
    if (status == 1) {
	const char *msg = NULL;
	if (info->errFlags & CLF_HAVEDATE) {
	    msg = "more than one date in string";
	} else if (info->errFlags & CLF_TIME) {
	    msg = "more than one time of day in string";
	} else if (info->errFlags & CLF_ZONE) {
	    msg = "more than one time zone in string";
	} else if (info->errFlags & CLF_DAYOFWEEK) {

Changes to generic/tclHash.c.

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

/*
 * Prototypes for the string hash key methods.
 */

static Tcl_HashEntry *	AllocStringEntry(Tcl_HashTable *tablePtr,
			    void *keyPtr);
static int		CompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr);
static size_t		HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr);

/*
 * Function prototypes for static functions in this file:
 */

static Tcl_HashEntry *	BogusFind(Tcl_HashTable *tablePtr, const char *key);
static Tcl_HashEntry *	BogusCreate(Tcl_HashTable *tablePtr, const char *key,







<
<







40
41
42
43
44
45
46


47
48
49
50
51
52
53

/*
 * Prototypes for the string hash key methods.
 */

static Tcl_HashEntry *	AllocStringEntry(Tcl_HashTable *tablePtr,
			    void *keyPtr);



/*
 * Function prototypes for static functions in this file:
 */

static Tcl_HashEntry *	BogusFind(Tcl_HashTable *tablePtr, const char *key);
static Tcl_HashEntry *	BogusCreate(Tcl_HashTable *tablePtr, const char *key,
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
    NULL, /* AllocOneWordKey, */	/* allocEntryProc */
    NULL  /* FreeOneWordKey, */		/* freeEntryProc */
};

const Tcl_HashKeyType tclStringHashKeyType = {
    TCL_HASH_KEY_TYPE_VERSION,		/* version */
    0,					/* flags */
    HashStringKey,			/* hashKeyProc */
    CompareStringKeys,			/* compareKeysProc */
    AllocStringEntry,			/* allocEntryProc */
    NULL				/* freeEntryProc */
};

/*
 *----------------------------------------------------------------------
 *







|
|







74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
    NULL, /* AllocOneWordKey, */	/* allocEntryProc */
    NULL  /* FreeOneWordKey, */		/* freeEntryProc */
};

const Tcl_HashKeyType tclStringHashKeyType = {
    TCL_HASH_KEY_TYPE_VERSION,		/* version */
    0,					/* flags */
    TclHashStringKey,			/* hashKeyProc */
    TclCompareStringKeys,		/* compareKeysProc */
    AllocStringEntry,			/* allocEntryProc */
    NULL				/* freeEntryProc */
};

/*
 *----------------------------------------------------------------------
 *
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_HashEntry *
Tcl_NextHashEntry(
    Tcl_HashSearch *searchPtr)
				/* Place to store information about progress
				 * through the table. Must have been
				 * initialized by calling
				 * Tcl_FirstHashEntry. */
{
    Tcl_HashEntry *hPtr;
    Tcl_HashTable *tablePtr = searchPtr->tablePtr;








|
<







550
551
552
553
554
555
556
557

558
559
560
561
562
563
564
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_HashEntry *
Tcl_NextHashEntry(
    Tcl_HashSearch *searchPtr)	/* Place to store information about progress

				 * through the table. Must have been
				 * initialized by calling
				 * Tcl_FirstHashEntry. */
{
    Tcl_HashEntry *hPtr;
    Tcl_HashTable *tablePtr = searchPtr->tablePtr;

667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
 *
 *----------------------------------------------------------------------
 */

static Tcl_HashEntry *
AllocArrayEntry(
    Tcl_HashTable *tablePtr,	/* Hash table. */
    void *keyPtr)			/* Key to store in the hash table entry. */
{
    Tcl_HashEntry *hPtr;
    size_t count = tablePtr->keyType * sizeof(int);
    size_t size = offsetof(Tcl_HashEntry, key) + count;

    if (size < sizeof(Tcl_HashEntry)) {
	size = sizeof(Tcl_HashEntry);







|







664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
 *
 *----------------------------------------------------------------------
 */

static Tcl_HashEntry *
AllocArrayEntry(
    Tcl_HashTable *tablePtr,	/* Hash table. */
    void *keyPtr)		/* Key to store in the hash table entry. */
{
    Tcl_HashEntry *hPtr;
    size_t count = tablePtr->keyType * sizeof(int);
    size_t size = offsetof(Tcl_HashEntry, key) + count;

    if (size < sizeof(Tcl_HashEntry)) {
	size = sizeof(Tcl_HashEntry);
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
CompareArrayKeys(
    void *keyPtr,			/* New key to compare. */
    Tcl_HashEntry *hPtr)	/* Existing key to compare. */
{
    size_t count = hPtr->tablePtr->keyType * sizeof(int);

    return !memcmp(keyPtr, hPtr->key.string, count);
}








|







700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
CompareArrayKeys(
    void *keyPtr,		/* New key to compare. */
    Tcl_HashEntry *hPtr)	/* Existing key to compare. */
{
    size_t count = hPtr->tablePtr->keyType * sizeof(int);

    return !memcmp(keyPtr, hPtr->key.string, count);
}

732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
 *
 *----------------------------------------------------------------------
 */

static size_t
HashArrayKey(
    Tcl_HashTable *tablePtr,	/* Hash table. */
    void *keyPtr)				/* Key from which to compute hash value. */
{
    const int *array = (const int *) keyPtr;
    size_t result;
    int count;

    for (result = 0, count = tablePtr->keyType; count > 0;
	    count--, array++) {







|







729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
 *
 *----------------------------------------------------------------------
 */

static size_t
HashArrayKey(
    Tcl_HashTable *tablePtr,	/* Hash table. */
    void *keyPtr)		/* Key from which to compute hash value. */
{
    const int *array = (const int *) keyPtr;
    size_t result;
    int count;

    for (result = 0, count = tablePtr->keyType; count > 0;
	    count--, array++) {
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
 *
 *----------------------------------------------------------------------
 */

static Tcl_HashEntry *
AllocStringEntry(
    TCL_UNUSED(Tcl_HashTable *),
    void *keyPtr)			/* Key to store in the hash table entry. */
{
    const char *string = (const char *) keyPtr;
    Tcl_HashEntry *hPtr;
    size_t size, allocsize;

    allocsize = size = strlen(string) + 1;
    if (size < sizeof(hPtr->key)) {
	allocsize = sizeof(hPtr->key);
    }
    hPtr = (Tcl_HashEntry *)Tcl_Alloc(offsetof(Tcl_HashEntry, key) + allocsize);
    memset(hPtr, 0, offsetof(Tcl_HashEntry, key) + allocsize);
    memcpy(hPtr->key.string, string, size);
    Tcl_SetHashValue(hPtr, NULL);
    return hPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * CompareStringKeys --
 *
 *	Compares two string keys.
 *
 * Results:
 *	The return value is 0 if they are different and 1 if they are the
 *	same.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
CompareStringKeys(
    void *keyPtr,			/* New key to compare. */
    Tcl_HashEntry *hPtr)	/* Existing key to compare. */
{
    return !strcmp((char *)keyPtr, hPtr->key.string);
}

/*
 *----------------------------------------------------------------------
 *
 * HashStringKey --
 *
 *	Compute a one-word summary of a text string, which can be used to
 *	generate a hash index.
 *
 * Results:
 *	The return value is a one-word summary of the information in string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static size_t
HashStringKey(
    TCL_UNUSED(Tcl_HashTable *),
    void *keyPtr)			/* Key from which to compute hash value. */
{
    const char *string = (const char *)keyPtr;
    size_t result;
    char c;

    /*
     * I tried a zillion different hash functions and asked many other people







|



















|













|
|
|








|













|
|

|







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

static Tcl_HashEntry *
AllocStringEntry(
    TCL_UNUSED(Tcl_HashTable *),
    void *keyPtr)		/* Key to store in the hash table entry. */
{
    const char *string = (const char *) keyPtr;
    Tcl_HashEntry *hPtr;
    size_t size, allocsize;

    allocsize = size = strlen(string) + 1;
    if (size < sizeof(hPtr->key)) {
	allocsize = sizeof(hPtr->key);
    }
    hPtr = (Tcl_HashEntry *)Tcl_Alloc(offsetof(Tcl_HashEntry, key) + allocsize);
    memset(hPtr, 0, offsetof(Tcl_HashEntry, key) + allocsize);
    memcpy(hPtr->key.string, string, size);
    Tcl_SetHashValue(hPtr, NULL);
    return hPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompareStringKeys --
 *
 *	Compares two string keys.
 *
 * Results:
 *	The return value is 0 if they are different and 1 if they are the
 *	same.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclCompareStringKeys(
    void *keyPtr,		/* New key to compare. */
    Tcl_HashEntry *hPtr)	/* Existing key to compare. */
{
    return !strcmp((char *)keyPtr, hPtr->key.string);
}

/*
 *----------------------------------------------------------------------
 *
 * TclHashStringKey --
 *
 *	Compute a one-word summary of a text string, which can be used to
 *	generate a hash index.
 *
 * Results:
 *	The return value is a one-word summary of the information in string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

size_t
TclHashStringKey(
    TCL_UNUSED(Tcl_HashTable *),
    void *keyPtr)		/* Key from which to compute hash value. */
{
    const char *string = (const char *)keyPtr;
    size_t result;
    char c;

    /*
     * I tried a zillion different hash functions and asked many other people

Changes to generic/tclIO.c.

1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
    if (interp == NULL) {
	return TCL_ERROR;
    }

    ChanGetInternalRep(objPtr, resPtr);
    if (resPtr) {
	/*
 	 * Confirm validity of saved lookup results.
 	 */

	statePtr = resPtr->statePtr;
	if ((resPtr->interp == interp)		/* Same interp context */
			/* No epoch change in channel since lookup */
		&& (resPtr->epoch == statePtr->epoch)) {
	    /*
	     * Have a valid saved lookup. Jump to end to return it.







|
|







1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
    if (interp == NULL) {
	return TCL_ERROR;
    }

    ChanGetInternalRep(objPtr, resPtr);
    if (resPtr) {
	/*
	 * Confirm validity of saved lookup results.
	 */

	statePtr = resPtr->statePtr;
	if ((resPtr->interp == interp)		/* Same interp context */
			/* No epoch change in channel since lookup */
		&& (resPtr->epoch == statePtr->epoch)) {
	    /*
	     * Have a valid saved lookup. Jump to end to return it.
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_CreateChannel(
    const Tcl_ChannelType *typePtr, /* The channel type record. */
    const char *chanName,	/* Name of channel to record. */
    void *instanceData,	/* Instance specific data. */
    int mask)			/* TCL_READABLE & TCL_WRITABLE to indicate if
				 * the channel is readable, writable. */
{
    Channel *chanPtr;		/* The channel structure newly created. */
    ChannelState *statePtr;	/* The stack-level independent state info for
				 * the channel. */
    const char *name;







|







1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_CreateChannel(
    const Tcl_ChannelType *typePtr, /* The channel type record. */
    const char *chanName,	/* Name of channel to record. */
    void *instanceData,		/* Instance specific data. */
    int mask)			/* TCL_READABLE & TCL_WRITABLE to indicate if
				 * the channel is readable, writable. */
{
    Channel *chanPtr;		/* The channel structure newly created. */
    ChannelState *statePtr;	/* The stack-level independent state info for
				 * the channel. */
    const char *name;
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819

Tcl_Channel
Tcl_StackChannel(
    Tcl_Interp *interp,		/* The interpreter we are working in */
    const Tcl_ChannelType *typePtr,
				/* The channel type record for the new
				 * channel. */
    void *instanceData,	/* Instance specific data for the new
				 * channel. */
    int mask,			/* TCL_READABLE & TCL_WRITABLE to indicate if
				 * the channel is readable, writable. */
    Tcl_Channel prevChan)	/* The channel structure to replace */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Channel *chanPtr, *prevChanPtr;







|







1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819

Tcl_Channel
Tcl_StackChannel(
    Tcl_Interp *interp,		/* The interpreter we are working in */
    const Tcl_ChannelType *typePtr,
				/* The channel type record for the new
				 * channel. */
    void *instanceData,		/* Instance specific data for the new
				 * channel. */
    int mask,			/* TCL_READABLE & TCL_WRITABLE to indicate if
				 * the channel is readable, writable. */
    Tcl_Channel prevChan)	/* The channel structure to replace */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Channel *chanPtr, *prevChanPtr;
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
	if (IsBufferFull(bufPtr)) {
	    if (FlushChannel(NULL, chanPtr, 0) != 0) {
		return -1;
	    }
	    flushed += statePtr->bufSize;

	    /*
 	     * We just flushed.  So if we have needNlFlush set to record that
 	     * we need to flush because there is a (translated) newline in the
 	     * buffer, that's likely not true any more.  But there is a tricky
 	     * exception.  If we have saved bytes that did not really get
 	     * flushed and those bytes came from a translation of a newline as
 	     * the last thing taken from the src array, then needNlFlush needs
 	     * to remain set to flag that the next buffer still needs a
 	     * newline flush.
 	     */

	    if (needNlFlush && (saved == 0 || src[-1] != '\n')) {
		needNlFlush = 0;
	    }
	}
    }
    if (((flushed < total) && GotFlag(statePtr, CHANNEL_UNBUFFERED)) ||







|
|
|
|
|
|
|
|
|







4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
	if (IsBufferFull(bufPtr)) {
	    if (FlushChannel(NULL, chanPtr, 0) != 0) {
		return -1;
	    }
	    flushed += statePtr->bufSize;

	    /*
	     * We just flushed.  So if we have needNlFlush set to record that
	     * we need to flush because there is a (translated) newline in the
	     * buffer, that's likely not true any more.  But there is a tricky
	     * exception.  If we have saved bytes that did not really get
	     * flushed and those bytes came from a translation of a newline as
	     * the last thing taken from the src array, then needNlFlush needs
	     * to remain set to flag that the next buffer still needs a
	     * newline flush.
	     */

	    if (needNlFlush && (saved == 0 || src[-1] != '\n')) {
		needNlFlush = 0;
	    }
	}
    }
    if (((flushed < total) && GotFlag(statePtr, CHANNEL_UNBUFFERED)) ||
10002
10003
10004
10005
10006
10007
10008
10009
10010
10011
10012
10013
10014
10015
10016
10017
10018
10019
10020
10021
 *	Stores up to "bytesToRead" bytes in memory pointed to by "dst".
 *	These bytes come from reading the channel "chanPtr" and
 *	performing the configured translations.  No encoding conversions
 *	are applied to the bytes being read.
 *
 * Results:
 *	The number of bytes actually stored (<= bytesToRead),
 * 	or TCL_INDEX_NONE if there is an error in reading the channel.  Use
 * 	Tcl_GetErrno() to retrieve the error code for the error
 *	that occurred.
 *
 *	The number of bytes stored can be less than the number
 * 	requested when
 *	  - EOF is reached on the channel; or
 *	  - the channel is non-blocking, and we've read all we can
 *	    without blocking.
 *	  - a channel reading error occurs (and we return TCL_INDEX_NONE)
 *
 * Side effects:
 *	May cause input to be buffered.







|
|



|







10002
10003
10004
10005
10006
10007
10008
10009
10010
10011
10012
10013
10014
10015
10016
10017
10018
10019
10020
10021
 *	Stores up to "bytesToRead" bytes in memory pointed to by "dst".
 *	These bytes come from reading the channel "chanPtr" and
 *	performing the configured translations.  No encoding conversions
 *	are applied to the bytes being read.
 *
 * Results:
 *	The number of bytes actually stored (<= bytesToRead),
 *	or TCL_INDEX_NONE if there is an error in reading the channel.  Use
 *	Tcl_GetErrno() to retrieve the error code for the error
 *	that occurred.
 *
 *	The number of bytes stored can be less than the number
 *	requested when
 *	  - EOF is reached on the channel; or
 *	  - the channel is non-blocking, and we've read all we can
 *	    without blocking.
 *	  - a channel reading error occurs (and we return TCL_INDEX_NONE)
 *
 * Side effects:
 *	May cause input to be buffered.
10086
10087
10088
10089
10090
10091
10092
10093
10094
10095
10096
10097
10098
10099
10100
	ChannelBuffer *bufPtr = statePtr->inQueueHead;

	/*
	 * Don't read more data if we have what we need.
	 */

	while (!bufPtr ||			/* We got no buffer!   OR */
		(!IsBufferFull(bufPtr) && 	/* Our buffer has room AND */
		((Tcl_Size) BytesLeft(bufPtr) < bytesToRead))) {
						/* Not enough bytes in it yet
						 * to fill the dst */
	    int code;

	moreData:
	    code = GetInput(chanPtr);







|







10086
10087
10088
10089
10090
10091
10092
10093
10094
10095
10096
10097
10098
10099
10100
	ChannelBuffer *bufPtr = statePtr->inQueueHead;

	/*
	 * Don't read more data if we have what we need.
	 */

	while (!bufPtr ||			/* We got no buffer!   OR */
		(!IsBufferFull(bufPtr) &&	/* Our buffer has room AND */
		((Tcl_Size) BytesLeft(bufPtr) < bytesToRead))) {
						/* Not enough bytes in it yet
						 * to fill the dst */
	    int code;

	moreData:
	    code = GetInput(chanPtr);
10758
10759
10760
10761
10762
10763
10764
10765

10766
10767
10768
10769
10770
10771
10772
 *	None.
 *
 *----------------------------------------------------------------------
 */

const char *
Tcl_ChannelName(
    const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */

{
    return chanTypePtr->typeName;
}

/*
 *----------------------------------------------------------------------
 *







|
>







10758
10759
10760
10761
10762
10763
10764
10765
10766
10767
10768
10769
10770
10771
10772
10773
 *	None.
 *
 *----------------------------------------------------------------------
 */

const char *
Tcl_ChannelName(
    const Tcl_ChannelType *chanTypePtr)
				/* Pointer to channel type. */
{
    return chanTypePtr->typeName;
}

/*
 *----------------------------------------------------------------------
 *

Changes to generic/tclIO.h.

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
 * Buffers data being sent to or from a channel.
 */

typedef struct ChannelBuffer {
    Tcl_Size refCount;		/* Current uses count */
    Tcl_Size nextAdded;		/* The next position into which a character
				 * will be put in the buffer. */
    Tcl_Size nextRemoved;		/* Position of next byte to be removed from
				 * the buffer. */
    Tcl_Size bufLength;		/* How big is the buffer? */
    struct ChannelBuffer *nextPtr;
    				/* Next buffer in chain. */
    char buf[TCLFLEXARRAY];		/* Placeholder for real buffer. The real
				 * buffer occupies this space + bufSize-1
				 * bytes. This must be the last field in the
				 * structure. */
} ChannelBuffer;

#define CHANNELBUFFER_HEADER_SIZE	offsetof(ChannelBuffer, buf)








|



|
|







35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
 * Buffers data being sent to or from a channel.
 */

typedef struct ChannelBuffer {
    Tcl_Size refCount;		/* Current uses count */
    Tcl_Size nextAdded;		/* The next position into which a character
				 * will be put in the buffer. */
    Tcl_Size nextRemoved;	/* Position of next byte to be removed from
				 * the buffer. */
    Tcl_Size bufLength;		/* How big is the buffer? */
    struct ChannelBuffer *nextPtr;
				/* Next buffer in chain. */
    char buf[TCLFLEXARRAY];	/* Placeholder for real buffer. The real
				 * buffer occupies this space + bufSize-1
				 * bytes. This must be the last field in the
				 * structure. */
} ChannelBuffer;

#define CHANNELBUFFER_HEADER_SIZE	offsetof(ChannelBuffer, buf)

92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
 * data specific to the channel but which belongs to the generic part of the
 * Tcl channel mechanism, and it points at an instance specific (and type
 * specific) instance data, and at a channel type structure.
 */

typedef struct Channel {
    struct ChannelState *state; /* Split out state information */
    void *instanceData;	/* Instance-specific data provided by creator
				 * of channel. */
    const Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */
    struct Channel *downChanPtr;/* Refers to channel this one was stacked
				 * upon. This reference is NULL for normal
				 * channels. See Tcl_StackChannel. */
    struct Channel *upChanPtr;	/* Refers to the channel above stacked this
				 * one. NULL for the top most channel. */







|







92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
 * data specific to the channel but which belongs to the generic part of the
 * Tcl channel mechanism, and it points at an instance specific (and type
 * specific) instance data, and at a channel type structure.
 */

typedef struct Channel {
    struct ChannelState *state; /* Split out state information */
    void *instanceData;		/* Instance-specific data provided by creator
				 * of channel. */
    const Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */
    struct Channel *downChanPtr;/* Refers to channel this one was stacked
				 * upon. This reference is NULL for normal
				 * channels. See Tcl_StackChannel. */
    struct Channel *upChanPtr;	/* Refers to the channel above stacked this
				 * one. NULL for the top most channel. */
156
157
158
159
160
161
162
163

164
165
166
167
168
169
170
    TclEolTranslation outputTranslation;
				/* What translation to use for generating end
				 * of line sequences in output? */
    int inEofChar;		/* If nonzero, use this as a signal of EOF on
				 * input. */
#if TCL_MAJOR_VERSION < 9
    int outEofChar;		/* If nonzero, append this to the channel when
				 * it is closed if it is open for writing. For Tcl 8.x only */

#endif
    int unreportedError;	/* Non-zero if an error report was deferred
				 * because it happened in the background. The
				 * value is the POSIX error code. */
    Tcl_Size refCount;		/* How many interpreters hold references to
				 * this IO channel? */
    struct CloseCallback *closeCbPtr;







|
>







156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
    TclEolTranslation outputTranslation;
				/* What translation to use for generating end
				 * of line sequences in output? */
    int inEofChar;		/* If nonzero, use this as a signal of EOF on
				 * input. */
#if TCL_MAJOR_VERSION < 9
    int outEofChar;		/* If nonzero, append this to the channel when
				 * it is closed if it is open for writing.
				 * For Tcl 8.x only */
#endif
    int unreportedError;	/* Non-zero if an error report was deferred
				 * because it happened in the background. The
				 * value is the POSIX error code. */
    Tcl_Size refCount;		/* How many interpreters hold references to
				 * this IO channel? */
    struct CloseCallback *closeCbPtr;
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
    /*
     * TIP #219 ... Info for the I/O system ...
     * Error message set by channel drivers, for the propagation of arbitrary
     * Tcl errors. This information, if present (chanMsg not NULL), takes
     * precedence over a Posix error code returned by a channel operation.
     */

    Tcl_Obj* chanMsg;
    Tcl_Obj* unreportedMsg;     /* Non-NULL if an error report was deferred
				 * because it happened in the background. The
				 * value is the chanMg, if any. #219's
				 * companion to 'unreportedError'. */
    size_t epoch;		/* Used to test validity of stored channelname
				 * lookup results. */
    int maxPerms;		/* TIP #220: Max access privileges
				 * the channel was created with. */







|
|







211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
    /*
     * TIP #219 ... Info for the I/O system ...
     * Error message set by channel drivers, for the propagation of arbitrary
     * Tcl errors. This information, if present (chanMsg not NULL), takes
     * precedence over a Posix error code returned by a channel operation.
     */

    Tcl_Obj *chanMsg;
    Tcl_Obj *unreportedMsg;	/* Non-NULL if an error report was deferred
				 * because it happened in the background. The
				 * value is the chanMg, if any. #219's
				 * companion to 'unreportedError'. */
    size_t epoch;		/* Used to test validity of stored channelname
				 * lookup results. */
    int maxPerms;		/* TIP #220: Max access privileges
				 * the channel was created with. */

Changes to generic/tclIOCmd.c.

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
static Tcl_ThreadDataKey dataKey;

/*
 * Static functions for this file:
 */

static Tcl_ExitProc		FinalizeIOCmdTSD;
static Tcl_TcpAcceptProc 	AcceptCallbackProc;
static Tcl_ObjCmdProc		ChanPendingObjCmd;
static Tcl_ObjCmdProc		ChanTruncateObjCmd;
static void		RegisterTcpServerInterpCleanup(
			    Tcl_Interp *interp,
			    AcceptCallback *acceptCallbackPtr);
static Tcl_InterpDeleteProc	TcpAcceptCallbacksDeleteProc;
static void		TcpServerCloseProc(void *callbackData);







|







35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
static Tcl_ThreadDataKey dataKey;

/*
 * Static functions for this file:
 */

static Tcl_ExitProc		FinalizeIOCmdTSD;
static Tcl_TcpAcceptProc	AcceptCallbackProc;
static Tcl_ObjCmdProc		ChanPendingObjCmd;
static Tcl_ObjCmdProc		ChanTruncateObjCmd;
static void		RegisterTcpServerInterpCleanup(
			    Tcl_Interp *interp,
			    AcceptCallback *acceptCallbackPtr);
static Tcl_InterpDeleteProc	TcpAcceptCallbacksDeleteProc;
static void		TcpServerCloseProc(void *callbackData);

Changes to generic/tclIOGT.c.

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

/*
 * This structure describes the channel type structure for Tcl-based
 * transformations.
 */

static const Tcl_ChannelType transformChannelType = {
    "transform",		/* Type name. */
    TCL_CHANNEL_VERSION_5,	/* v5 channel */
    NULL,		/* Close proc. */
    TransformInputProc,		/* Input proc. */
    TransformOutputProc,	/* Output proc. */
    NULL,			/* Seek proc. */
    TransformSetOptionProc,	/* Set option proc. */
    TransformGetOptionProc,	/* Get option proc. */
    TransformWatchProc,		/* Initialize notifier. */
    TransformGetFileHandleProc,	/* Get OS handles out of channel. */
    TransformCloseProc,		/* close2proc */
    TransformBlockModeProc,	/* Set blocking/nonblocking mode.*/
    NULL,			/* Flush proc. */
    TransformNotifyProc,	/* Handling of events bubbling up. */
    TransformWideSeekProc,	/* Wide seek proc. */
    NULL,			/* Thread action. */
    NULL			/* Truncate. */
};

/*
 * Possible values for 'flags' field in control structure, see below.
 */

#define CHANNEL_ASYNC (1<<0)	/* Non-blocking mode. */







|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|







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

/*
 * This structure describes the channel type structure for Tcl-based
 * transformations.
 */

static const Tcl_ChannelType transformChannelType = {
    "transform",
    TCL_CHANNEL_VERSION_5,
    NULL,			/* Deprecated. */
    TransformInputProc,
    TransformOutputProc,
    NULL,			/* Deprecated. */
    TransformSetOptionProc,
    TransformGetOptionProc,
    TransformWatchProc,
    TransformGetFileHandleProc,
    TransformCloseProc,
    TransformBlockModeProc,
    NULL,			/* Flush proc. */
    TransformNotifyProc,
    TransformWideSeekProc,
    NULL,			/* Thread action proc. */
    NULL			/* Truncate proc. */
};

/*
 * Possible values for 'flags' field in control structure, see below.
 */

#define CHANNEL_ASYNC (1<<0)	/* Non-blocking mode. */
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
 *	contains the POSIX error code if an error occurred, or zero.
 *
 *----------------------------------------------------------------------
 */

static long long
TransformWideSeekProc(
    void *instanceData,	/* The channel to manipulate. */
    long long offset,		/* Size of movement. */
    int mode,			/* How to move. */
    int *errorCodePtr)		/* Location of error flag. */
{
    TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
    Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self);
    const Tcl_ChannelType *parentType	= Tcl_GetChannelType(parent);
    Tcl_DriverWideSeekProc *parentWideSeekProc =
	    Tcl_ChannelWideSeekProc(parentType);
    void *parentData = Tcl_GetChannelInstanceData(parent);

    if ((offset == 0) && (mode == SEEK_CUR)) {
	/*
	 * This is no seek but a request to tell the caller the current







|






|







846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
 *	contains the POSIX error code if an error occurred, or zero.
 *
 *----------------------------------------------------------------------
 */

static long long
TransformWideSeekProc(
    void *instanceData,		/* The channel to manipulate. */
    long long offset,		/* Size of movement. */
    int mode,			/* How to move. */
    int *errorCodePtr)		/* Location of error flag. */
{
    TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
    Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self);
    const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent);
    Tcl_DriverWideSeekProc *parentWideSeekProc =
	    Tcl_ChannelWideSeekProc(parentType);
    void *parentData = Tcl_GetChannelInstanceData(parent);

    if ((offset == 0) && (mode == SEEK_CUR)) {
	/*
	 * This is no seek but a request to tell the caller the current
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
     * If we have a wide seek capability, we should stick with that.
     */

    if (parentWideSeekProc == NULL) {
	*errorCodePtr = EINVAL;
	return -1;
    }
	return parentWideSeekProc(parentData, offset, mode, errorCodePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TransformSetOptionProc --
 *







|







901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
     * If we have a wide seek capability, we should stick with that.
     */

    if (parentWideSeekProc == NULL) {
	*errorCodePtr = EINVAL;
	return -1;
    }
    return parentWideSeekProc(parentData, offset, mode, errorCodePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TransformSetOptionProc --
 *

Changes to generic/tclIORChan.c.

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
static int		ReflectTruncate(void *clientData,
			    long long length);

/*
 * The C layer channel type/driver definition used by the reflection.
 */

static const Tcl_ChannelType tclRChannelType = {
    "tclrchannel",	   /* Type name. */
    TCL_CHANNEL_VERSION_5, /* v5 channel */
    NULL,		   /* Old close	API */
    ReflectInput,	   /* Handle read request */
    ReflectOutput,	   /* Handle write request */
    NULL,
    ReflectSetOption,	   /* Set options. */
    ReflectGetOption,	   /* Get options. */
    ReflectWatch,	   /* Initialize notifier */
    NULL,		   /* Get OS handle from the channel. */
    ReflectClose,	   /* Close channel. Clean instance data */
    ReflectBlock,	   /* Set blocking/nonblocking. */
    NULL,		   /* Flush channel. */
    NULL,		   /* Handle events. */
    ReflectSeekWide,	   /* Move access point (64 bit). */
#if TCL_THREADS
    ReflectThread,	   /* thread action, tracking owner */
#else
    NULL,		   /* thread action */
#endif
    ReflectTruncate	   /* Truncate. */
};

/*
 * Instance data for a reflected channel. ===========================
 */

typedef struct {







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|

|

|







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
static int		ReflectTruncate(void *clientData,
			    long long length);

/*
 * The C layer channel type/driver definition used by the reflection.
 */

static const Tcl_ChannelType reflectedChannelType = {
    "tclrchannel",
    TCL_CHANNEL_VERSION_5,
    NULL,			/* Deprecated */
    ReflectInput,
    ReflectOutput,
    NULL,			/* Deprecated */
    ReflectSetOption,
    ReflectGetOption,
    ReflectWatch,
    NULL,			/* Get OS handle from the channel. */
    ReflectClose,
    ReflectBlock,
    NULL,			/* Flush channel. */
    NULL,			/* Handle bubbled events. */
    ReflectSeekWide,
#if TCL_THREADS
    ReflectThread,
#else
    NULL,			/* Thread action proc */
#endif
    ReflectTruncate		/* Truncate proc. */
};

/*
 * Instance data for a reflected channel. ===========================
 */

typedef struct {
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

    Tcl_ResetResult(interp);

    /*
     * Everything is fine now.
     */

    chan = Tcl_CreateChannel(&tclRChannelType, TclGetString(rcId), rcPtr,
	    mode);
    rcPtr->chan = chan;
    TclChannelPreserve(chan);
    chanPtr = (Channel *) chan;

    if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) {
	/*
	 * Some of the nullable methods are not supported. We clone the
	 * channel type, null the associated C functions, and use the result
	 * as the actual channel type.
	 */

	Tcl_ChannelType *clonePtr = (Tcl_ChannelType *)Tcl_Alloc(sizeof(Tcl_ChannelType));

	memcpy(clonePtr, &tclRChannelType, sizeof(Tcl_ChannelType));

	if (!(methods & FLAG(METH_CONFIGURE))) {
	    clonePtr->setOptionProc = NULL;
	}

	if (!(methods & FLAG(METH_CGET)) && !(methods & FLAG(METH_CGETALL))) {
	    clonePtr->getOptionProc = NULL;







|














|







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

    Tcl_ResetResult(interp);

    /*
     * Everything is fine now.
     */

    chan = Tcl_CreateChannel(&reflectedChannelType, TclGetString(rcId), rcPtr,
	    mode);
    rcPtr->chan = chan;
    TclChannelPreserve(chan);
    chanPtr = (Channel *) chan;

    if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) {
	/*
	 * Some of the nullable methods are not supported. We clone the
	 * channel type, null the associated C functions, and use the result
	 * as the actual channel type.
	 */

	Tcl_ChannelType *clonePtr = (Tcl_ChannelType *)Tcl_Alloc(sizeof(Tcl_ChannelType));

	memcpy(clonePtr, &reflectedChannelType, sizeof(Tcl_ChannelType));

	if (!(methods & FLAG(METH_CONFIGURE))) {
	    clonePtr->setOptionProc = NULL;
	}

	if (!(methods & FLAG(METH_CGET)) && !(methods & FLAG(METH_CGETALL))) {
	    clonePtr->getOptionProc = NULL;
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
	    if (result != TCL_OK) {
		FreeReceivedError(&p);
	    }
	}
#endif

	tctPtr = ((Channel *)rcPtr->chan)->typePtr;
	if (tctPtr && tctPtr != &tclRChannelType) {
	    Tcl_Free((void *)tctPtr);
	    ((Channel *)rcPtr->chan)->typePtr = NULL;
	}
	Tcl_EventuallyFree(rcPtr, FreeReflectedChannel);
	return EOK;
    }








|







1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
	    if (result != TCL_OK) {
		FreeReceivedError(&p);
	    }
	}
#endif

	tctPtr = ((Channel *)rcPtr->chan)->typePtr;
	if (tctPtr && tctPtr != &reflectedChannelType) {
	    Tcl_Free((void *)tctPtr);
	    ((Channel *)rcPtr->chan)->typePtr = NULL;
	}
	Tcl_EventuallyFree(rcPtr, FreeReflectedChannel);
	return EOK;
    }

1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
		Tcl_GetChannelName(rcPtr->chan));
	if (hPtr) {
	    Tcl_DeleteHashEntry(hPtr);
	}
    }
#endif
    tctPtr = ((Channel *)rcPtr->chan)->typePtr;
    if (tctPtr && tctPtr != &tclRChannelType) {
	Tcl_Free((void *)tctPtr);
	((Channel *)rcPtr->chan)->typePtr = NULL;
    }
    Tcl_EventuallyFree(rcPtr, FreeReflectedChannel);
    return (result == TCL_OK) ? EOK : EINVAL;
}








|







1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
		Tcl_GetChannelName(rcPtr->chan));
	if (hPtr) {
	    Tcl_DeleteHashEntry(hPtr);
	}
    }
#endif
    tctPtr = ((Channel *)rcPtr->chan)->typePtr;
    if (tctPtr && tctPtr != &reflectedChannelType) {
	Tcl_Free((void *)tctPtr);
	((Channel *)rcPtr->chan)->typePtr = NULL;
    }
    Tcl_EventuallyFree(rcPtr, FreeReflectedChannel);
    return (result == TCL_OK) ? EOK : EINVAL;
}


Changes to generic/tclIORTrans.c.

51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
			    void **handle);
static int		ReflectNotify(void *clientData, int mask);

/*
 * The C layer channel type/driver definition used by the reflection.
 */

static const Tcl_ChannelType tclRTransformType = {
    "tclrtransform",		/* Type name. */
    TCL_CHANNEL_VERSION_5,	/* v5 channel. */
    NULL,
    ReflectInput,		/* Handle read request. */
    ReflectOutput,		/* Handle write request. */
    NULL,			/* Move location of access point. */
    ReflectSetOption,		/* Set options. */
    ReflectGetOption,		/* Get options. */
    ReflectWatch,		/* Initialize notifier. */
    ReflectHandle,		/* Get OS handle from the channel. */
    ReflectClose,		/* Close channel, clean instance data. */
    ReflectBlock,		/* Set blocking/nonblocking. */
    NULL,			/* Flush channel. Not used by core. */
    ReflectNotify,		/* Handle events. */
    ReflectSeekWide,		/* Move access point (64 bit). */
    NULL,			/* thread action */
    NULL			/* truncate */
};

/*
 * Structure of the buffer to hold transform results to be consumed by higher
 * layers upon reading from the channel, plus the functions to manage such.
 */








|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|







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
			    void **handle);
static int		ReflectNotify(void *clientData, int mask);

/*
 * The C layer channel type/driver definition used by the reflection.
 */

static const Tcl_ChannelType reflectedTransformType = {
    "tclrtransform",
    TCL_CHANNEL_VERSION_5,
    NULL,			/* Deprecated. */
    ReflectInput,
    ReflectOutput,
    NULL,			/* Deprecated. */
    ReflectSetOption,
    ReflectGetOption,
    ReflectWatch,
    ReflectHandle,
    ReflectClose,
    ReflectBlock,
    NULL,			/* Flush channel. Not used by core. */
    ReflectNotify,
    ReflectSeekWide,
    NULL,			/* Thread action proc. */
    NULL			/* Truncate proc. */
};

/*
 * Structure of the buffer to hold transform results to be consumed by higher
 * layers upon reading from the channel, plus the functions to manage such.
 */

674
675
676
677
678
679
680
681
682
683
684
685
686
687
688

    /*
     * Everything is fine now.
     */

    rtPtr->methods = methods;
    rtPtr->mode = mode;
    rtPtr->chan = Tcl_StackChannel(interp, &tclRTransformType, rtPtr, mode,
	    rtPtr->parent);

    /*
     * Register the transform in our our map for proper handling of deleted
     * interpreters and/or threads.
     */








|







674
675
676
677
678
679
680
681
682
683
684
685
686
687
688

    /*
     * Everything is fine now.
     */

    rtPtr->methods = methods;
    rtPtr->mode = mode;
    rtPtr->chan = Tcl_StackChannel(interp, &reflectedTransformType, rtPtr, mode,
	    rtPtr->parent);

    /*
     * Register the transform in our our map for proper handling of deleted
     * interpreters and/or threads.
     */

1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
     * non-NULL...
     */

    if (Tcl_ChannelWideSeekProc(parent->typePtr) == NULL) {
	*errorCodePtr = EINVAL;
	curPos = -1;
    } else {
    	curPos = Tcl_ChannelWideSeekProc(parent->typePtr)(parent->instanceData, offset,
    		seekMode, errorCodePtr);
    }
    if (curPos == -1) {
	Tcl_SetErrno(*errorCodePtr);
    }

    *errorCodePtr = EOK;
    Tcl_Release(rtPtr);







|
|







1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
     * non-NULL...
     */

    if (Tcl_ChannelWideSeekProc(parent->typePtr) == NULL) {
	*errorCodePtr = EINVAL;
	curPos = -1;
    } else {
	curPos = Tcl_ChannelWideSeekProc(parent->typePtr)(parent->instanceData, offset,
		seekMode, errorCodePtr);
    }
    if (curPos == -1) {
	Tcl_SetErrno(*errorCodePtr);
    }

    *errorCodePtr = EOK;
    Tcl_Release(rtPtr);

Changes to generic/tclIOUtil.c.

3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
 *	from the virtual filesystem to a native filesystem.
 *
 *----------------------------------------------------------------------
 */

static void *
DivertFindSymbol(
    Tcl_Interp *interp, 	/* The relevant interpreter. */
    Tcl_LoadHandle loadHandle,	/* A handle to the diverted module. */
    const char *symbol)		/* The name of symbol to resolve. */
{
    FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle->clientData;
    Tcl_LoadHandle originalHandle = tvdlPtr->loadHandle;

    return originalHandle->findSymbolProcPtr(interp, originalHandle, symbol);







|







3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
 *	from the virtual filesystem to a native filesystem.
 *
 *----------------------------------------------------------------------
 */

static void *
DivertFindSymbol(
    Tcl_Interp *interp,		/* The relevant interpreter. */
    Tcl_LoadHandle loadHandle,	/* A handle to the diverted module. */
    const char *symbol)		/* The name of symbol to resolve. */
{
    FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle->clientData;
    Tcl_LoadHandle originalHandle = tvdlPtr->loadHandle;

    return originalHandle->findSymbolProcPtr(interp, originalHandle, symbol);

Changes to generic/tclInt.h.

1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
} ActiveInterpTrace;

/*
 * Flag values designating types of execution traces. See tclTrace.c for
 * related flag values.
 *
 * TCL_TRACE_ENTER_EXEC		- triggers enter/enterstep traces.
 * 				- passed to Tcl_CreateObjTrace to set up
 *				  "enterstep" traces.
 * TCL_TRACE_LEAVE_EXEC		- triggers leave/leavestep traces.
 * 				- passed to Tcl_CreateObjTrace to set up
 *				  "leavestep" traces.
 */

#define TCL_TRACE_ENTER_EXEC	1
#define TCL_TRACE_LEAVE_EXEC	2

#if TCL_MAJOR_VERSION > 8







|


|







1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
} ActiveInterpTrace;

/*
 * Flag values designating types of execution traces. See tclTrace.c for
 * related flag values.
 *
 * TCL_TRACE_ENTER_EXEC		- triggers enter/enterstep traces.
 *				- passed to Tcl_CreateObjTrace to set up
 *				  "enterstep" traces.
 * TCL_TRACE_LEAVE_EXEC		- triggers leave/leavestep traces.
 *				- passed to Tcl_CreateObjTrace to set up
 *				  "leavestep" traces.
 */

#define TCL_TRACE_ENTER_EXEC	1
#define TCL_TRACE_LEAVE_EXEC	2

#if TCL_MAJOR_VERSION > 8
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
/*
 * The type of procedures called by the Tcl bytecode compiler to compile
 * commands. Pointers to these procedures are kept in the Command structure
 * describing each command. The integer value returned by a CompileProc must
 * be one of the following:
 *
 * TCL_OK		Compilation completed normally.
 * TCL_ERROR 		Compilation could not be completed. This can be just a
 * 			judgment by the CompileProc that the command is too
 * 			complex to compile effectively, or it can indicate
 * 			that in the current state of the interp, the command
 * 			would raise an error. The bytecode compiler will not
 * 			do any error reporting at compiler time. Error
 * 			reporting is deferred until the actual runtime,
 * 			because by then changes in the interp state may allow
 * 			the command to be successfully evaluated.
 */

typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr,
	struct Command *cmdPtr, struct CompileEnv *compEnvPtr);

/*
 * The type of procedure called from the compilation hook point in







|
|
|
|
|
|
|
|
|







1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
/*
 * The type of procedures called by the Tcl bytecode compiler to compile
 * commands. Pointers to these procedures are kept in the Command structure
 * describing each command. The integer value returned by a CompileProc must
 * be one of the following:
 *
 * TCL_OK		Compilation completed normally.
 * TCL_ERROR		Compilation could not be completed. This can be just a
 *			judgment by the CompileProc that the command is too
 *			complex to compile effectively, or it can indicate
 *			that in the current state of the interp, the command
 *			would raise an error. The bytecode compiler will not
 *			do any error reporting at compiler time. Error
 *			reporting is deferred until the actual runtime,
 *			because by then changes in the interp state may allow
 *			the command to be successfully evaluated.
 */

typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr,
	struct Command *cmdPtr, struct CompileEnv *compEnvPtr);

/*
 * The type of procedure called from the compilation hook point in
2162
2163
2164
2165
2166
2167
2168
2169

2170
2171
2172
2173
2174
2175
2176
	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.
     */








|
>







2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
	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.
     */

2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
    Tcl_Size epoch;		/* Epoch counter to detect changes in the
				 * global value. */
    TCL_HASH_TYPE numBytes;	/* Length of the global string. */
    char *value;		/* The global string value. */
    Tcl_Encoding encoding;	/* system encoding when global string was
				 * initialized. */
    TclInitProcessGlobalValueProc *proc;
    				/* A procedure to initialize the global string
				 * copy when a "get" request comes in before
				 * any "set" request has been received. */
    Tcl_Mutex mutex;		/* Enforce orderly access from multiple
				 * threads. */
    Tcl_ThreadDataKey key;	/* Key for per-thread data holding the
				 * (Tcl_Obj) copy for each thread. */
} ProcessGlobalValue;







|







2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
    Tcl_Size epoch;		/* Epoch counter to detect changes in the
				 * global value. */
    TCL_HASH_TYPE numBytes;	/* Length of the global string. */
    char *value;		/* The global string value. */
    Tcl_Encoding encoding;	/* system encoding when global string was
				 * initialized. */
    TclInitProcessGlobalValueProc *proc;
				/* A procedure to initialize the global string
				 * copy when a "get" request comes in before
				 * any "set" request has been received. */
    Tcl_Mutex mutex;		/* Enforce orderly access from multiple
				 * threads. */
    Tcl_ThreadDataKey key;	/* Key for per-thread data holding the
				 * (Tcl_Obj) copy for each thread. */
} ProcessGlobalValue;
3105
3106
3107
3108
3109
3110
3111

3112
3113
3114
3115
3116
3117
3118
 * 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;







>







3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
 * 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;
3401
3402
3403
3404
3405
3406
3407


3408
3409
3410
3411
3412
3413
3414
MODULE_SCOPE char *	TclGetStringStorage(Tcl_Obj *objPtr,
			    Tcl_Size *sizePtr);
MODULE_SCOPE int	TclGetLoadedLibraries(Tcl_Interp *interp,
				const char *targetName,
				const char *packageName);
MODULE_SCOPE int	TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *,
				Tcl_WideInt *);


MODULE_SCOPE int	TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr,
			    Tcl_Obj *incrPtr);
MODULE_SCOPE Tcl_Obj *	TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
			    Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags);
MODULE_SCOPE Tcl_ObjCmdProc TclInfoExistsCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclInfoCoroutineCmd;
MODULE_SCOPE Tcl_Obj *	TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr);







>
>







3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
MODULE_SCOPE char *	TclGetStringStorage(Tcl_Obj *objPtr,
			    Tcl_Size *sizePtr);
MODULE_SCOPE int	TclGetLoadedLibraries(Tcl_Interp *interp,
				const char *targetName,
				const char *packageName);
MODULE_SCOPE int	TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *,
				Tcl_WideInt *);
MODULE_SCOPE int	TclCompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr);
MODULE_SCOPE size_t	TclHashStringKey(Tcl_HashTable *tablePtr, void *keyPtr);
MODULE_SCOPE int	TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr,
			    Tcl_Obj *incrPtr);
MODULE_SCOPE Tcl_Obj *	TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
			    Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags);
MODULE_SCOPE Tcl_ObjCmdProc TclInfoExistsCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclInfoCoroutineCmd;
MODULE_SCOPE Tcl_Obj *	TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr);
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
			    const char *expected, const char *bytes,
			    Tcl_Size numBytes, const char **endPtrPtr, int flags);
MODULE_SCOPE void	TclParseInit(Tcl_Interp *interp, const char *string,
			    Tcl_Size numBytes, Tcl_Parse *parsePtr);
MODULE_SCOPE Tcl_Size	TclParseAllWhiteSpace(const char *src, Tcl_Size numBytes);
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);







|




|
<







3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498

3499
3500
3501
3502
3503
3504
3505
			    const char *expected, const char *bytes,
			    Tcl_Size numBytes, const char **endPtrPtr, int flags);
MODULE_SCOPE void	TclParseInit(Tcl_Interp *interp, const char *string,
			    Tcl_Size numBytes, Tcl_Parse *parsePtr);
MODULE_SCOPE Tcl_Size	TclParseAllWhiteSpace(const char *src, Tcl_Size numBytes);
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/tclLink.c.

105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
static int		SetInvalidRealFromAny(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);

/*
 * A marker type used to flag weirdnesses so we can pass them around right.
 */

static Tcl_ObjType invalidRealType = {
    "invalidReal",			/* name */
    NULL,				/* freeIntRepProc */
    NULL,				/* dupIntRepProc */
    NULL,				/* updateStringProc */
    NULL,				/* setFromAnyProc */
    TCL_OBJTYPE_V0
};







|







105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
static int		SetInvalidRealFromAny(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);

/*
 * A marker type used to flag weirdnesses so we can pass them around right.
 */

static const Tcl_ObjType invalidRealType = {
    "invalidReal",			/* name */
    NULL,				/* freeIntRepProc */
    NULL,				/* dupIntRepProc */
    NULL,				/* updateStringProc */
    NULL,				/* setFromAnyProc */
    TCL_OBJTYPE_V0
};

Changes to generic/tclListObj.c.

262
263
264
265
266
267
268
269

270
271
272
273
274
275
276
 *
 * Side effects:
 *   The memory may be freed.
 *
 *------------------------------------------------------------------------
 */
static inline void
ListSpanDecrRefs(ListSpan *spanPtr)

{
    if (spanPtr->refCount <= 1) {
	Tcl_Free(spanPtr);
    } else {
	spanPtr->refCount -= 1;
    }
}







|
>







262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
 *
 * Side effects:
 *   The memory may be freed.
 *
 *------------------------------------------------------------------------
 */
static inline void
ListSpanDecrRefs(
    ListSpan *spanPtr)
{
    if (spanPtr->refCount <= 1) {
	Tcl_Free(spanPtr);
    } else {
	spanPtr->refCount -= 1;
    }
}
339
340
341
342
343
344
345
346

347
348
349
350
351
352
353
 *
 * Side effects:
 *    See comments for ListRepUnsharedFreeUnreferenced.
 *
 *------------------------------------------------------------------------
 */
static inline void
ListRepFreeUnreferenced(const ListRep *repPtr)

{
    if (! ListRepIsShared(repPtr) && repPtr->spanPtr) {
	/* T:listrep-1.5.1 */
	ListRepUnsharedFreeUnreferenced(repPtr);
    }
}








|
>







340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
 *
 * Side effects:
 *    See comments for ListRepUnsharedFreeUnreferenced.
 *
 *------------------------------------------------------------------------
 */
static inline void
ListRepFreeUnreferenced(
    const ListRep *repPtr)
{
    if (! ListRepIsShared(repPtr) && repPtr->spanPtr) {
	/* T:listrep-1.5.1 */
	ListRepUnsharedFreeUnreferenced(repPtr);
    }
}

488
489
490
491
492
493
494
495

496
497
498
499
500
501
502
503
504
505
506
507
 *
 * Side effects:
 *    Error message and code are stored in the interpreter if not NULL.
 *
 *------------------------------------------------------------------------
 */
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;
}

/*
 *------------------------------------------------------------------------







|
>


|
<
|







490
491
492
493
494
495
496
497
498
499
500
501

502
503
504
505
506
507
508
509
 *
 * Side effects:
 *    Error message and code are stored in the interpreter if not NULL.
 *
 *------------------------------------------------------------------------
 */
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;
}

/*
 *------------------------------------------------------------------------
519
520
521
522
523
524
525
526


527
528
529
530
531
532
533
 * Side effects:
 *    The contents of the ListRep's ListStore area are shifted down in the
 *    storage area. The ListRep's ListSpan is updated accordingly.
 *
 *------------------------------------------------------------------------
 */
static inline void
ListRepUnsharedShiftDown(ListRep *repPtr, Tcl_Size shiftCount)


{
    ListStore *storePtr;

    LISTREP_CHECK(repPtr);
    LIST_ASSERT(!ListRepIsShared(repPtr));

    storePtr = repPtr->storePtr;







|
>
>







521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
 * Side effects:
 *    The contents of the ListRep's ListStore area are shifted down in the
 *    storage area. The ListRep's ListSpan is updated accordingly.
 *
 *------------------------------------------------------------------------
 */
static inline void
ListRepUnsharedShiftDown(
    ListRep *repPtr,
    Tcl_Size shiftCount)
{
    ListStore *storePtr;

    LISTREP_CHECK(repPtr);
    LIST_ASSERT(!ListRepIsShared(repPtr));

    storePtr = repPtr->storePtr;
574
575
576
577
578
579
580
581


582
583
584
585
586
587
588
 *    The contents of the ListRep's ListStore area are shifted up in the
 *    storage area. The ListRep's ListSpan is updated accordingly.
 *
 *------------------------------------------------------------------------
 */
#if 0
static inline void
ListRepUnsharedShiftUp(ListRep *repPtr, Tcl_Size shiftCount)


{
    ListStore *storePtr;

    LISTREP_CHECK(repPtr);
    LIST_ASSERT(!ListRepIsShared(repPtr));
    LIST_COUNT_ASSERT(shiftCount);








|
>
>







578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
 *    The contents of the ListRep's ListStore area are shifted up in the
 *    storage area. The ListRep's ListSpan is updated accordingly.
 *
 *------------------------------------------------------------------------
 */
#if 0
static inline void
ListRepUnsharedShiftUp(
    ListRep *repPtr,
    Tcl_Size shiftCount)
{
    ListStore *storePtr;

    LISTREP_CHECK(repPtr);
    LIST_ASSERT(!ListRepIsShared(repPtr));
    LIST_COUNT_ASSERT(shiftCount);

620
621
622
623
624
625
626
627



628
629
630
631
632
633
634
 *
 * Side effects:
 *    Panics if any invariant is not met.
 *
 *------------------------------------------------------------------------
 */
static void
ListRepValidate(const ListRep *repPtr, const char *file, int lineNum)



{
    ListStore *storePtr = repPtr->storePtr;
    const char *condition;

    (void)storePtr; /* To stop gcc from whining about unused vars */

#define INVARIANT(cond_)        \







|
>
>
>







626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
 *
 * Side effects:
 *    Panics if any invariant is not met.
 *
 *------------------------------------------------------------------------
 */
static void
ListRepValidate(
    const ListRep *repPtr,
    const char *file,
    int lineNum)
{
    ListStore *storePtr = repPtr->storePtr;
    const char *condition;

    (void)storePtr; /* To stop gcc from whining about unused vars */

#define INVARIANT(cond_)        \
685
686
687
688
689
690
691
692


693
694
695
696
697
698
699
 * Side effects:
 *    Will panic if internal structure is not consistent or if object
 *    cannot be converted to a list object.
 *
 *------------------------------------------------------------------------
 */
void
TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj)


{
    ListRep listRep;
    if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
	Tcl_Panic("Object passed to TclListObjValidate cannot be converted to "
		  "a list object.");
    }
    ListRepValidate(&listRep, __FILE__, __LINE__);







|
>
>







694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
 * Side effects:
 *    Will panic if internal structure is not consistent or if object
 *    cannot be converted to a list object.
 *
 *------------------------------------------------------------------------
 */
void
TclListObjValidate(
    Tcl_Interp *interp,
    Tcl_Obj *listObj)
{
    ListRep listRep;
    if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
	Tcl_Panic("Object passed to TclListObjValidate cannot be converted to "
		  "a list object.");
    }
    ListRepValidate(&listRep, __FILE__, __LINE__);
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
{
    ListRep listRep;

    if (TclObjTypeHasProc(objPtr, getElementsProc)) {
	return TclObjTypeGetElements(interp, objPtr, objcPtr, objvPtr);
    }
    if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) {
    	return TCL_ERROR;
    }
    ListRepElements(&listRep, *objcPtr, *objvPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------







|







1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
{
    ListRep listRep;

    if (TclObjTypeHasProc(objPtr, getElementsProc)) {
	return TclObjTypeGetElements(interp, objPtr, objcPtr, objvPtr);
    }
    if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) {
	return TCL_ERROR;
    }
    ListRepElements(&listRep, *objcPtr, *objvPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
 *
 * TclListObjAppendElements --
 *
 *      Appends multiple elements to a Tcl_Obj list object. If
 *      the passed Tcl_Obj is not a list object, it will be converted to one
 *      and an error raised if the conversion fails.
 *
 * 	The Tcl_Obj must not be shared though the internal representation
 * 	may be.
 *
 * Results:
 *	On success, TCL_OK is returned with the specified elements appended.
 *	On failure, TCL_ERROR is returned with an error message in the
 *	interpreter if not NULL.
 *
 * Side effects:







|
|







1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
 *
 * TclListObjAppendElements --
 *
 *      Appends multiple elements to a Tcl_Obj list object. If
 *      the passed Tcl_Obj is not a list object, it will be converted to one
 *      and an error raised if the conversion fails.
 *
 *	The Tcl_Obj must not be shared though the internal representation
 *	may be.
 *
 * Results:
 *	On success, TCL_OK is returned with the specified elements appended.
 *	On failure, TCL_ERROR is returned with an error message in the
 *	interpreter if not NULL.
 *
 * Side effects:
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjIndex --
 *
 * 	Retrieve a pointer to the element of 'listPtr' at 'index'.  The index
 * 	of the first element is 0.
 *
 * Value
 *
 * 	TCL_OK
 *
 *	    A pointer to the element at 'index' is stored in 'objPtrPtr'.  If
 *	    'index' is out of range, NULL is stored in 'objPtrPtr'.  This
 *	    object should be treated as readonly and its 'refCount' is _not_
 *	    incremented. The caller must do that if it holds on to the
 *	    reference.
 *
 * 	TCL_ERROR
 *
 * 	    'listPtr' is not a valid list. An error message is left in the
 * 	    interpreter's result if 'interp' is not NULL.
 *
 *  Effect
 *
 * 	If 'listPtr' is not already of type 'tclListType', it is converted.
 *
 *----------------------------------------------------------------------
 */
int
Tcl_ListObjIndex(
    Tcl_Interp *interp,		/* Used to report errors if not NULL. */
    Tcl_Obj *listObj,		/* List object to index into. */







|
|

|
<
|
<






|
<
|
|

|
<
|







1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935

1936

1937
1938
1939
1940
1941
1942
1943

1944
1945
1946
1947

1948
1949
1950
1951
1952
1953
1954
1955
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjIndex --
 *
 *	Retrieve a pointer to the element of 'listPtr' at 'index'.  The index
 *	of the first element is 0.
 *
 * Returns:

 *	TCL_OK

 *	    A pointer to the element at 'index' is stored in 'objPtrPtr'.  If
 *	    'index' is out of range, NULL is stored in 'objPtrPtr'.  This
 *	    object should be treated as readonly and its 'refCount' is _not_
 *	    incremented. The caller must do that if it holds on to the
 *	    reference.
 *
 *	TCL_ERROR

 *	    'listPtr' is not a valid list. An error message is left in the
 *	    interpreter's result if 'interp' is not NULL.
 *
 * Effect:

 *	If 'listPtr' is not already of type 'tclListType', it is converted.
 *
 *----------------------------------------------------------------------
 */
int
Tcl_ListObjIndex(
    Tcl_Interp *interp,		/* Used to report errors if not NULL. */
    Tcl_Obj *listObj,		/* List object to index into. */
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
     * invalidated if the operation succeeds.
     */

    retValueObj = subListObj;
    result = TCL_OK;

    /* Allocate if static array for pending invalidations is too small */
    if (indexCount > (int) (sizeof(pendingInvalidates) /
	    sizeof(pendingInvalidates[0]))) {
	pendingInvalidatesPtr =
	    (Tcl_Obj **) Tcl_Alloc(indexCount * sizeof(*pendingInvalidatesPtr));
    }

    /*
     * Loop through all the index arguments, and for each one dive into the







|







2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
     * invalidated if the operation succeeds.
     */

    retValueObj = subListObj;
    result = TCL_OK;

    /* Allocate if static array for pending invalidations is too small */
    if (indexCount > (Tcl_Size) (sizeof(pendingInvalidates) /
	    sizeof(pendingInvalidates[0]))) {
	pendingInvalidatesPtr =
	    (Tcl_Obj **) Tcl_Alloc(indexCount * sizeof(*pendingInvalidatesPtr));
    }

    /*
     * Loop through all the index arguments, and for each one dive into the
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
	     * so far is replace a list element with an unshared copy.  The
	     * list value remains the same, so the string rep. is still
	     * valid, and unchanged, which is good because if this whole
	     * routine returns NULL, we'd like to leave no change to the
	     * value of the lset variable.  Later on, when we set valueObj
	     * in its proper place, then all containing lists will have
	     * their values changed, and will need their string reps
	     * spoiled.  We maintain a list of all those Tcl_Obj's (via a
	     * little internalrep surgery) so we can spoil them at that
	     * time.
	     */

	    pendingInvalidatesPtr[numPendingInvalidates] = parentList;
	    ++numPendingInvalidates;
	}
    } while (indexCount > 0);








|
|
<







3027
3028
3029
3030
3031
3032
3033
3034
3035

3036
3037
3038
3039
3040
3041
3042
	     * so far is replace a list element with an unshared copy.  The
	     * list value remains the same, so the string rep. is still
	     * valid, and unchanged, which is good because if this whole
	     * routine returns NULL, we'd like to leave no change to the
	     * value of the lset variable.  Later on, when we set valueObj
	     * in its proper place, then all containing lists will have
	     * their values changed, and will need their string reps
	     * spoiled.  We maintain a list of all those Tcl_Obj's
	     * pendingInvalidatesPtr[] so we can spoil them at that time.

	     */

	    pendingInvalidatesPtr[numPendingInvalidates] = parentList;
	    ++numPendingInvalidates;
	}
    } while (indexCount > 0);

Changes to generic/tclParse.c.

1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ParseTokens(
    const char *src,	/* First character to parse. */
    Tcl_Size numBytes,		/* Max number of bytes to scan. */
    int mask,			/* Specifies when to stop parsing. The parse
				 * stops at the first unquoted character whose
				 * CHAR_TYPE contains any of the bits in
				 * mask. */
    int flags,			/* OR-ed bits indicating what substitutions to
				 * perform: TCL_SUBST_COMMANDS,







|







1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ParseTokens(
    const char *src,		/* First character to parse. */
    Tcl_Size numBytes,		/* Max number of bytes to scan. */
    int mask,			/* Specifies when to stop parsing. The parse
				 * stops at the first unquoted character whose
				 * CHAR_TYPE contains any of the bits in
				 * mask. */
    int flags,			/* OR-ed bits indicating what substitutions to
				 * perform: TCL_SUBST_COMMANDS,
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
 *
 *----------------------------------------------------------------------
 */

const char *
Tcl_ParseVar(
    Tcl_Interp *interp,		/* Context for looking up variable. */
    const char *start,	/* Start of variable substitution. First
				 * character must be "$". */
    const char **termPtr)	/* If non-NULL, points to word to fill in with
				 * character just after last one in the
				 * variable specifier. */
{
    Tcl_Obj *objPtr;
    int code;







|







1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
 *
 *----------------------------------------------------------------------
 */

const char *
Tcl_ParseVar(
    Tcl_Interp *interp,		/* Context for looking up variable. */
    const char *start,		/* Start of variable substitution. First
				 * character must be "$". */
    const char **termPtr)	/* If non-NULL, points to word to fill in with
				 * character just after last one in the
				 * variable specifier. */
{
    Tcl_Obj *objPtr;
    int code;

Changes to generic/tclParse.h.

1
2
3
4
5

6
7
8
9
10
11
12
13
14
15


16
17
18
19
/*
 * Minimal set of shared macro definitions and declarations so that multiple
 * source files can make use of the parsing table in tclParse.c
 */


#define TYPE_NORMAL		0
#define TYPE_SPACE		0x1
#define TYPE_COMMAND_END	0x2
#define TYPE_SUBS		0x4
#define TYPE_QUOTE		0x8
#define TYPE_CLOSE_PAREN	0x10
#define TYPE_CLOSE_BRACK	0x20
#define TYPE_BRACE		0x40
#define TYPE_OPEN_PAREN		0x80
#define TYPE_BAD_ARRAY_INDEX	(TYPE_OPEN_PAREN|TYPE_CLOSE_PAREN|TYPE_QUOTE|TYPE_BRACE)



#define CHAR_TYPE(c) tclCharTypeTable[(unsigned char)(c)]

MODULE_SCOPE const unsigned char tclCharTypeTable[];

|



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




1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
/*
 * Minimal set of shared flag definitions and declarations so that multiple
 * source files can make use of the parsing table in tclParse.c
 */

enum ParseTypeFlags {
    TYPE_NORMAL = 0,
    TYPE_SPACE = 0x1,
    TYPE_COMMAND_END = 0x2,
    TYPE_SUBS = 0x4,
    TYPE_QUOTE = 0x8,
    TYPE_CLOSE_PAREN = 0x10,
    TYPE_CLOSE_BRACK = 0x20,
    TYPE_BRACE = 0x40,
    TYPE_OPEN_PAREN = 0x80,
    TYPE_BAD_ARRAY_INDEX = (
	TYPE_OPEN_PAREN | TYPE_CLOSE_PAREN | TYPE_QUOTE | TYPE_BRACE)
};

#define CHAR_TYPE(c) tclCharTypeTable[(unsigned char)(c)]

MODULE_SCOPE const unsigned char tclCharTypeTable[];

Changes to generic/tclPathObj.c.

36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54

/*
 * Define the 'path' object type, which Tcl uses to represent file paths
 * internally.
 */

static const Tcl_ObjType fsPathType = {
    "path",				/* name */
    FreeFsPathInternalRep,		/* freeIntRepProc */
    DupFsPathInternalRep,		/* dupIntRepProc */
    UpdateStringOfFsPath,		/* updateStringProc */
    SetFsPathFromAny,			/* setFromAnyProc */
    TCL_OBJTYPE_V0
};

/*
 * struct FsPath --
 *
 * Internal representation of a Tcl_Obj of fsPathType







|
|
|
|
|







36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54

/*
 * Define the 'path' object type, which Tcl uses to represent file paths
 * internally.
 */

static const Tcl_ObjType fsPathType = {
    "path",			/* name */
    FreeFsPathInternalRep,	/* freeIntRepProc */
    DupFsPathInternalRep,	/* dupIntRepProc */
    UpdateStringOfFsPath,	/* updateStringProc */
    SetFsPathFromAny,		/* setFromAnyProc */
    TCL_OBJTYPE_V0
};

/*
 * struct FsPath --
 *
 * Internal representation of a Tcl_Obj of fsPathType
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
 *	Memory may be allocated.
 *
 *---------------------------------------------------------------------------
 */

static void
UpdateStringOfFsPath(
    Tcl_Obj *pathPtr)	/* path obj with string rep to update. */
{
    FsPath *fsPathPtr = PATHOBJ(pathPtr);
    Tcl_Size cwdLen;
    Tcl_Obj *copy;

    if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) {
	if (fsPathPtr->translatedPathPtr == NULL) {







|







2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
 *	Memory may be allocated.
 *
 *---------------------------------------------------------------------------
 */

static void
UpdateStringOfFsPath(
    Tcl_Obj *pathPtr)		/* path obj with string rep to update. */
{
    FsPath *fsPathPtr = PATHOBJ(pathPtr);
    Tcl_Size cwdLen;
    Tcl_Obj *copy;

    if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) {
	if (fsPathPtr->translatedPathPtr == NULL) {
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
 *	Returns TCL_OK on success with home directory path in *dsPtr
 *	and TCL_ERROR on failure with error message in interp if non-NULL.
 *
 *----------------------------------------------------------------------
 */
int
MakeTildeRelativePath(
    Tcl_Interp *interp,  /* May be NULL. Only used for error messages */
    const char *user,    /* User name. NULL -> current user */
    const char *subPath, /* Rest of path. May be NULL */
    Tcl_DString *dsPtr)  /* Output. Is initialized by the function. Must be
                          * freed on success */
{
    const char *dir;
    Tcl_DString dirString;

    Tcl_DStringInit(dsPtr);
    Tcl_DStringInit(&dirString);








|
|
|
|
|







2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
 *	Returns TCL_OK on success with home directory path in *dsPtr
 *	and TCL_ERROR on failure with error message in interp if non-NULL.
 *
 *----------------------------------------------------------------------
 */
int
MakeTildeRelativePath(
    Tcl_Interp *interp,		/* May be NULL. Only used for error messages */
    const char *user,		/* User name. NULL -> current user */
    const char *subPath,	/* Rest of path. May be NULL */
    Tcl_DString *dsPtr)		/* Output. Is initialized by the function. Must
				 * be freed on success */
{
    const char *dir;
    Tcl_DString dirString;

    Tcl_DStringInit(dsPtr);
    Tcl_DStringInit(&dirString);

2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
 *      Returns a Tcl_Obj containing the home directory of a user
 *	or NULL on failure with error message in interp if non-NULL.
 *
 *----------------------------------------------------------------------
 */
Tcl_Obj *
TclGetHomeDirObj(
    Tcl_Interp *interp, /* May be NULL. Only used for error messages */
    const char *user)   /* User name. NULL -> current user */
{
    Tcl_DString dirString;

    if (MakeTildeRelativePath(interp, user, NULL, &dirString) != TCL_OK) {
	return NULL;
    }
    return Tcl_DStringToObj(&dirString);







|
|







2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
 *      Returns a Tcl_Obj containing the home directory of a user
 *	or NULL on failure with error message in interp if non-NULL.
 *
 *----------------------------------------------------------------------
 */
Tcl_Obj *
TclGetHomeDirObj(
    Tcl_Interp *interp,		/* May be NULL. Only used for error messages */
    const char *user)		/* User name. NULL -> current user */
{
    Tcl_DString dirString;

    if (MakeTildeRelativePath(interp, user, NULL, &dirString) != TCL_OK) {
	return NULL;
    }
    return Tcl_DStringToObj(&dirString);
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
 *      Returns NULL if the path begins with a ~ that cannot be resolved
 *	and stores an error message in interp if non-NULL.
 *
 *----------------------------------------------------------------------
 */
Tcl_Obj *
TclResolveTildePath(
    Tcl_Interp *interp, /* May be NULL. Only used for error messages */
    Tcl_Obj *pathObj)
{
    const char *path;
    Tcl_Size len;
    Tcl_Size split;
    Tcl_DString resolvedPath;








|







2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
 *      Returns NULL if the path begins with a ~ that cannot be resolved
 *	and stores an error message in interp if non-NULL.
 *
 *----------------------------------------------------------------------
 */
Tcl_Obj *
TclResolveTildePath(
    Tcl_Interp *interp,		/* May be NULL. Only used for error messages */
    Tcl_Obj *pathObj)
{
    const char *path;
    Tcl_Size len;
    Tcl_Size split;
    Tcl_DString resolvedPath;

Changes to generic/tclPipe.c.

1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_OpenCommandChannel(
    Tcl_Interp *interp,		/* Interpreter for error reporting. Can NOT be
				 * NULL. */
    Tcl_Size argc,			/* How many arguments. */
    const char **argv,		/* Array of arguments for command pipe. */
    int flags)			/* Or'ed combination of TCL_STDIN, TCL_STDOUT,
				 * TCL_STDERR, and TCL_ENFORCE_MODE. */
{
    TclFile *inPipePtr, *outPipePtr, *errFilePtr;
    TclFile inPipe, outPipe, errFile;
    Tcl_Size numPids;







|







1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_OpenCommandChannel(
    Tcl_Interp *interp,		/* Interpreter for error reporting. Can NOT be
				 * NULL. */
    Tcl_Size argc,		/* How many arguments. */
    const char **argv,		/* Array of arguments for command pipe. */
    int flags)			/* Or'ed combination of TCL_STDIN, TCL_STDOUT,
				 * TCL_STDERR, and TCL_ENFORCE_MODE. */
{
    TclFile *inPipePtr, *outPipePtr, *errFilePtr;
    TclFile inPipe, outPipe, errFile;
    Tcl_Size numPids;

Changes to generic/tclPkgConfig.c.

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
 *
 * - TCL_THREADS		OSCMa compilation as threaded core.
 * - TCL_MEM_DEBUG		OSCMa memory debugging.
 * - TCL_COMPILE_DEBUG		OSCMa debugging of bytecode compiler.
 * - TCL_COMPILE_STATS		OSCMa bytecode compiler statistics.
 *
 * - TCL_CFG_DO64BIT		NSCMdt tcl is compiled for a 64bit system.
 * - NDEBUG		NSCMdt tcl is compiled with symbol info off.
 * - TCL_CFG_OPTIMIZED		NSCMdt tcl is compiled with cc optimizations on
 * - TCL_CFG_PROFILED		NSCMdt tcl is compiled with profiling info.
 *
 * - CFG_RUNTIME_*		Paths to various stuff at runtime.
 * - CFG_INSTALL_*		Paths to various stuff at installation time.
 *
 * - TCL_CFGVAL_ENCODING	string containing the encoding used for the







|







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
 *
 * - TCL_THREADS		OSCMa compilation as threaded core.
 * - TCL_MEM_DEBUG		OSCMa memory debugging.
 * - TCL_COMPILE_DEBUG		OSCMa debugging of bytecode compiler.
 * - TCL_COMPILE_STATS		OSCMa bytecode compiler statistics.
 *
 * - TCL_CFG_DO64BIT		NSCMdt tcl is compiled for a 64bit system.
 * - NDEBUG			NSCMdt tcl is compiled with symbol info off.
 * - TCL_CFG_OPTIMIZED		NSCMdt tcl is compiled with cc optimizations on
 * - TCL_CFG_PROFILED		NSCMdt tcl is compiled with profiling info.
 *
 * - CFG_RUNTIME_*		Paths to various stuff at runtime.
 * - CFG_INSTALL_*		Paths to various stuff at installation time.
 *
 * - TCL_CFGVAL_ENCODING	string containing the encoding used for the

Changes to generic/tclPreserve.c.

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
/*
 * The following data structure is used to keep track of all the Tcl_Preserve
 * calls that are still in effect. It grows as needed to accommodate any
 * number of calls in effect.
 */

typedef struct {
    void *clientData;	/* Address of preserved block. */
    size_t refCount;		/* Number of Tcl_Preserve calls in effect for
				 * block. */
    int mustFree;		/* Non-zero means Tcl_EventuallyFree was
				 * called while a Tcl_Preserve call was in
				 * effect, so the structure must be freed when
				 * refCount becomes zero. */
    Tcl_FreeProc *freeProc;	/* Function to call to free. */
} Reference;

/*
 * Global data structures used to hold the list of preserved data references.
 * These variables are protected by "preserveMutex".
 */

static Reference *refArray = NULL;	/* First in array of references. */

static size_t spaceAvl = 0;	/* Total number of structures available at
				 * *firstRefPtr. */
static size_t inUse = 0;		/* Count of structures currently in use in
				 * refArray. */
TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */

#define INITIAL_SIZE	2	/* Initial number of reference slots to make */

/*
 * The following data structure is used to keep track of whether an arbitrary







|














|
>


|







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
/*
 * The following data structure is used to keep track of all the Tcl_Preserve
 * calls that are still in effect. It grows as needed to accommodate any
 * number of calls in effect.
 */

typedef struct {
    void *clientData;		/* Address of preserved block. */
    size_t refCount;		/* Number of Tcl_Preserve calls in effect for
				 * block. */
    int mustFree;		/* Non-zero means Tcl_EventuallyFree was
				 * called while a Tcl_Preserve call was in
				 * effect, so the structure must be freed when
				 * refCount becomes zero. */
    Tcl_FreeProc *freeProc;	/* Function to call to free. */
} Reference;

/*
 * Global data structures used to hold the list of preserved data references.
 * These variables are protected by "preserveMutex".
 */

static Reference *refArray = NULL;
				/* First in array of references. */
static size_t spaceAvl = 0;	/* Total number of structures available at
				 * *firstRefPtr. */
static size_t inUse = 0;	/* Count of structures currently in use in
				 * refArray. */
TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */

#define INITIAL_SIZE	2	/* Initial number of reference slots to make */

/*
 * The following data structure is used to keep track of whether an arbitrary
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
 *	until at least the matching call to Tcl_Release.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_Preserve(
    void *clientData)	/* Pointer to malloc'ed block of memory. */
{
    Reference *refPtr;
    size_t i;

    /*
     * See if there is already a reference for this pointer. If so, just
     * increment its reference count.







|







114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
 *	until at least the matching call to Tcl_Release.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_Preserve(
    void *clientData)		/* Pointer to malloc'ed block of memory. */
{
    Reference *refPtr;
    size_t i;

    /*
     * See if there is already a reference for this pointer. If so, just
     * increment its reference count.
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
 *	call to Tcl_Preserve is still in effect, the block of memory is freed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_Release(
    void *clientData)	/* Pointer to malloc'ed block of memory. */
{
    Reference *refPtr;
    size_t i;

    Tcl_MutexLock(&preserveMutex);
    for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) {
	int mustFree;







|







177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
 *	call to Tcl_Preserve is still in effect, the block of memory is freed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_Release(
    void *clientData)		/* Pointer to malloc'ed block of memory. */
{
    Reference *refPtr;
    size_t i;

    Tcl_MutexLock(&preserveMutex);
    for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) {
	int mustFree;
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
 *	Ptr may be released by calling free().
 *
 *----------------------------------------------------------------------
 */

void
Tcl_EventuallyFree(
    void *clientData,	/* Pointer to malloc'ed block of memory. */
    Tcl_FreeProc *freeProc)	/* Function to actually do free. */
{
    Reference *refPtr;
    size_t i;

    /*
     * See if there is a reference for this pointer. If so, set its "mustFree"







|







256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
 *	Ptr may be released by calling free().
 *
 *----------------------------------------------------------------------
 */

void
Tcl_EventuallyFree(
    void *clientData,		/* Pointer to malloc'ed block of memory. */
    Tcl_FreeProc *freeProc)	/* Function to actually do free. */
{
    Reference *refPtr;
    size_t i;

    /*
     * See if there is a reference for this pointer. If so, set its "mustFree"

Changes to generic/tclProc.c.

1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
    return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
}

static int
NRInterpProc(
    void *clientData,		/* Record describing procedure to be
				 * interpreted. */
    Tcl_Interp *interp, 	/* Interpreter in which procedure was
				 * invoked. */
    int objc,			/* Count of number of arguments to this
				 * procedure. */
    Tcl_Obj *const objv[])	/* Argument value objects. */
{
    int result = TclPushProcCallFrame(clientData, interp, objc, objv,
	    /*isLambda*/ 0);







|







1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
    return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
}

static int
NRInterpProc(
    void *clientData,		/* Record describing procedure to be
				 * interpreted. */
    Tcl_Interp *interp,		/* Interpreter in which procedure was
				 * invoked. */
    int objc,			/* Count of number of arguments to this
				 * procedure. */
    Tcl_Obj *const objv[])	/* Argument value objects. */
{
    int result = TclPushProcCallFrame(clientData, interp, objc, objv,
	    /*isLambda*/ 0);
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
 *	procedure completes.
 *
 *----------------------------------------------------------------------
 */

void
TclProcDeleteProc(
    void *clientData)	/* Procedure to be deleted. */
{
    Proc *procPtr = (Proc *)clientData;

    if (procPtr->refCount-- <= 1) {
	TclProcCleanupProc(procPtr);
    }
}







|







2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
 *	procedure completes.
 *
 *----------------------------------------------------------------------
 */

void
TclProcDeleteProc(
    void *clientData)		/* Procedure to be deleted. */
{
    Proc *procPtr = (Proc *)clientData;

    if (procPtr->refCount-- <= 1) {
	TclProcCleanupProc(procPtr);
    }
}

Changes to generic/tclRegexp.c.

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

/*
 * The regular expression Tcl object type. This serves as a cache of the
 * compiled form of the regular expression.
 */

const Tcl_ObjType tclRegexpType = {
    "regexp",				/* name */
    FreeRegexpInternalRep,		/* freeIntRepProc */
    DupRegexpInternalRep,		/* dupIntRepProc */
    NULL,				/* updateStringProc */
    SetRegexpFromAny,			/* setFromAnyProc */
    TCL_OBJTYPE_V0
};

#define RegexpSetInternalRep(objPtr, rePtr) \
    do {								\
	Tcl_ObjInternalRep ir;						\
	(rePtr)->refCount++;						\







|
|
|
|
|







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

/*
 * The regular expression Tcl object type. This serves as a cache of the
 * compiled form of the regular expression.
 */

const Tcl_ObjType tclRegexpType = {
    "regexp",			/* name */
    FreeRegexpInternalRep,	/* freeIntRepProc */
    DupRegexpInternalRep,	/* dupIntRepProc */
    NULL,			/* updateStringProc */
    SetRegexpFromAny,		/* setFromAnyProc */
    TCL_OBJTYPE_V0
};

#define RegexpSetInternalRep(objPtr, rePtr) \
    do {								\
	Tcl_ObjInternalRep ir;						\
	(rePtr)->refCount++;						\

Changes to generic/tclResult.c.

384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
 *	It also clears any error information for the interpreter.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ResetResult(
    Tcl_Interp *interp)/* Interpreter for which to clear result. */
{
    Interp *iPtr = (Interp *) interp;

    ResetObjResult(iPtr);
    if (iPtr->errorCode) {
	/* Legacy support */
	if (iPtr->flags & ERR_LEGACY_COPY) {







|







384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
 *	It also clears any error information for the interpreter.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ResetResult(
    Tcl_Interp *interp)		/* Interpreter for which to clear result. */
{
    Interp *iPtr = (Interp *) interp;

    ResetObjResult(iPtr);
    if (iPtr->errorCode) {
	/* Legacy support */
	if (iPtr->flags & ERR_LEGACY_COPY) {
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
 *	the interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
ResetObjResult(
    Interp *iPtr)	/* Points to the interpreter whose result
				 * object should be reset. */
{
    Tcl_Obj *objResultPtr = iPtr->objResultPtr;

    if (Tcl_IsShared(objResultPtr)) {
	TclDecrRefCount(objResultPtr);
	TclNewObj(objResultPtr);







|







437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
 *	the interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
ResetObjResult(
    Interp *iPtr)		/* Points to the interpreter whose result
				 * object should be reset. */
{
    Tcl_Obj *objResultPtr = iPtr->objResultPtr;

    if (Tcl_IsShared(objResultPtr)) {
	TclDecrRefCount(objResultPtr);
	TclNewObj(objResultPtr);
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770

            /*
             * Reset while keeping the list internalrep as much as possible.
             */

            Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc,
                    valueObjv);
 	}
	Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE],
                &valuePtr);
	if (valuePtr != NULL) {
	    Tcl_SetObjErrorCode(interp, valuePtr);
	} else {
	    Tcl_SetErrorCode(interp, "NONE", (void *)NULL);
	}







|







756
757
758
759
760
761
762
763
764
765
766
767
768
769
770

            /*
             * Reset while keeping the list internalrep as much as possible.
             */

            Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc,
                    valueObjv);
	}
	Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE],
                &valuePtr);
	if (valuePtr != NULL) {
	    Tcl_SetObjErrorCode(interp, valuePtr);
	} else {
	    Tcl_SetErrorCode(interp, "NONE", (void *)NULL);
	}

Changes to generic/tclScan.c.

12
13
14
15
16
17
18
19
20
21
22
23
24
25
26

27
28
29
30
31
32
33
#include "tclInt.h"
#include "tclTomMath.h"
#include <assert.h>

/*
 * Flag values used by Tcl_ScanObjCmd.
 */

#define SCAN_NOSKIP	0x1		/* Don't skip blanks. */
#define SCAN_SUPPRESS	0x2		/* Suppress assignment. */
#define SCAN_UNSIGNED	0x4		/* Read an unsigned value. */
#define SCAN_WIDTH	0x8		/* A width value was supplied. */

#define SCAN_LONGER	0x400		/* Asked for a wide value. */
#define SCAN_BIG	0x800		/* Asked for a bignum value. */


/*
 * The following structure contains the information associated with a
 * character set.
 */

typedef struct {







|
|
|
|
|

|
|
>







12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
#include "tclInt.h"
#include "tclTomMath.h"
#include <assert.h>

/*
 * Flag values used by Tcl_ScanObjCmd.
 */
enum ScanFlags {
    SCAN_NOSKIP = 0x1,		/* Don't skip blanks. */
    SCAN_SUPPRESS = 0x2,	/* Suppress assignment. */
    SCAN_UNSIGNED = 0x4,	/* Read an unsigned value. */
    SCAN_WIDTH = 0x8,		/* A width value was supplied. */

    SCAN_LONGER = 0x400,	/* Asked for a wide value. */
    SCAN_BIG = 0x800		/* Asked for a bignum value. */
};

/*
 * The following structure contains the information associated with a
 * character set.
 */

typedef struct {
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
	 * 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", (void *)NULL);
		goto error;
	    }
	    flags |= SCAN_WIDTH;
	    format += TclUtfToUniChar(format, &ch);
	}

	/*







|


|
<
|
|
<
|

|







354
355
356
357
358
359
360
361
362
363
364

365
366

367
368
369
370
371
372
373
374
375
376
	 * 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);
	}

	/*
1002
1003
1004
1005
1006
1007
1008











1009

1010
1011
1012
1013
1014
1015
1016
		    if (TclGetString(objPtr)[0] == '-') {
			value = INT_MIN;
		    } else {
			value = INT_MAX;
		    }
		}
		if ((flags & SCAN_UNSIGNED) && (value < 0)) {











		    Tcl_SetWideIntObj(objPtr, (unsigned int)value);

		} else {
		    TclSetIntObj(objPtr, value);
		}
	    }
	    objs[objIndex++] = objPtr;
	    break;








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







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
		    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(
				"insufficient memory to create bignum", -1));
			Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
			return TCL_ERROR;
		    } else {
			Tcl_SetBignumObj(objPtr, &big);
		    }
#else
		    Tcl_SetWideIntObj(objPtr, (unsigned long)value);
#endif
		} else {
		    TclSetIntObj(objPtr, value);
		}
	    }
	    objs[objIndex++] = objPtr;
	    break;

1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111


1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
	}
    } 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/tclStrToD.c.

120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
#define TWO_OVER_3LOG10 0.28952965460216784
#define LOG10_3HALVES_PLUS_FUDGE 0.1760912590558

/*
 * Definitions of the parts of an IEEE754-format floating point number.
 */

#define SIGN_BIT 	0x80000000
				/* Mask for the sign bit in the first word of
				 * a double. */
#define EXP_MASK	0x7FF00000
				/* Mask for the exponent field in the first
				 * word of a double. */
#define EXP_SHIFT	20	/* Shift count to make the exponent an
				 * integer. */







|







120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
#define TWO_OVER_3LOG10 0.28952965460216784
#define LOG10_3HALVES_PLUS_FUDGE 0.1760912590558

/*
 * Definitions of the parts of an IEEE754-format floating point number.
 */

#define SIGN_BIT	0x80000000
				/* Mask for the sign bit in the first word of
				 * a double. */
#define EXP_MASK	0x7FF00000
				/* Mask for the exponent field in the first
				 * word of a double. */
#define EXP_SHIFT	20	/* Shift count to make the exponent an
				 * integer. */
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
			    long exponent);
#ifdef IEEE_FLOATING_POINT
static double		MakeNaN(int signum, Tcl_WideUInt tag);
#endif
static double		RefineApproximation(double approx,
			    mp_int *exactSignificand, int exponent);
static mp_err		MulPow5(mp_int *, unsigned, mp_int *) MP_WUR;
static int 		NormalizeRightward(Tcl_WideUInt *);
static int		RequiredPrecision(Tcl_WideUInt);
static void		DoubleToExpAndSig(double, Tcl_WideUInt *, int *,
			    int *);
static void		TakeAbsoluteValue(Double *, int *);
static char *		FormatInfAndNaN(Double *, int *, char **);
static char *		FormatZero(int *, char **);
static int		ApproximateLog10(Tcl_WideUInt, int, int);







|







304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
			    long exponent);
#ifdef IEEE_FLOATING_POINT
static double		MakeNaN(int signum, Tcl_WideUInt tag);
#endif
static double		RefineApproximation(double approx,
			    mp_int *exactSignificand, int exponent);
static mp_err		MulPow5(mp_int *, unsigned, mp_int *) MP_WUR;
static int		NormalizeRightward(Tcl_WideUInt *);
static int		RequiredPrecision(Tcl_WideUInt);
static void		DoubleToExpAndSig(double, Tcl_WideUInt *, int *,
			    int *);
static void		TakeAbsoluteValue(Double *, int *);
static char *		FormatInfAndNaN(Double *, int *, char **);
static char *		FormatZero(int *, char **);
static int		ApproximateLog10(Tcl_WideUInt, int, int);
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
     * With gcc on x86, the floating point rounding mode is double-extended.
     * This causes the result of double-precision calculations to be rounded
     * twice: once to the precision of double-extended and then again to the
     * precision of double. Double-rounding introduces gratuitous errors of 1
     * ulp, so we need to change rounding mode to 53-bits. We also make
     * 'retval' volatile, so that it doesn't get promoted to a register.
     */
    volatile double retval;		/* Value of the number. */

    /*
     * Test for zero significand, which requires explicit construction
     * of -0.0. (Unary minus returns a positive zero.)
     */
    if (significand == 0) {
	return copysign(0.0, -signum);







|







1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
     * With gcc on x86, the floating point rounding mode is double-extended.
     * This causes the result of double-precision calculations to be rounded
     * twice: once to the precision of double-extended and then again to the
     * precision of double. Double-rounding introduces gratuitous errors of 1
     * ulp, so we need to change rounding mode to 53-bits. We also make
     * 'retval' volatile, so that it doesn't get promoted to a register.
     */
    volatile double retval;	/* Value of the number. */

    /*
     * Test for zero significand, which requires explicit construction
     * of -0.0. (Unary minus returns a positive zero.)
     */
    if (significand == 0) {
	return copysign(0.0, -signum);
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
 *	Stores base*5**n in result.
 *
 *----------------------------------------------------------------------
 */

static inline mp_err
MulPow5(
    mp_int *base, 		/* Number to multiply. */
    unsigned n,			/* Power of 5 to multiply by. */
    mp_int *result)		/* Place to store the result. */
{
    mp_int *p = base;
    int n13 = n / 13;
    int r = n % 13;
    mp_err err = MP_OKAY;







|







2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
 *	Stores base*5**n in result.
 *
 *----------------------------------------------------------------------
 */

static inline mp_err
MulPow5(
    mp_int *base,		/* Number to multiply. */
    unsigned n,			/* Power of 5 to multiply by. */
    mp_int *result)		/* Place to store the result. */
{
    mp_int *p = base;
    int n13 = n / 13;
    int r = n % 13;
    mp_err err = MP_OKAY;
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
 *	one too high.
 *
 *----------------------------------------------------------------------
 */

static inline void
SetPrecisionLimits(
    int flags,		/* Type of conversion: TCL_DD_SHORTEST,
				 * TCL_DD_E_FMT, TCL_DD_F_FMT. */
    int k,			/* Floor(log10(number to convert)) */
    int *ndigitsPtr,		/* IN/OUT: Number of digits requested (will be
				 *         adjusted if needed). */
    int *iPtr,			/* OUT: Maximum number of digits to return. */
    int *iLimPtr,		/* OUT: Number of digits of significance if
				 *      the bignum method is used.*/







|







2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
 *	one too high.
 *
 *----------------------------------------------------------------------
 */

static inline void
SetPrecisionLimits(
    int flags,			/* Type of conversion: TCL_DD_SHORTEST,
				 * TCL_DD_E_FMT, TCL_DD_F_FMT. */
    int k,			/* Floor(log10(number to convert)) */
    int *ndigitsPtr,		/* IN/OUT: Number of digits requested (will be
				 *         adjusted if needed). */
    int *iPtr,			/* OUT: Maximum number of digits to return. */
    int *iLimPtr,		/* OUT: Number of digits of significance if
				 *      the bignum method is used.*/
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
 *	"1" and moves the decimal point (*kPtr) one place to the right.
 *
 *----------------------------------------------------------------------
 */

static inline char *
BumpUp(
    char *s,		    	/* Cursor pointing one past the end of the
				 * string. */
    char *retval,		/* Start of the string of digits. */
    int *kPtr)			/* Position of the decimal point. */
{
    while (*--s == '9') {
	if (s == retval) {
	    ++(*kPtr);







|







2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
 *	"1" and moves the decimal point (*kPtr) one place to the right.
 *
 *----------------------------------------------------------------------
 */

static inline char *
BumpUp(
    char *s,			/* Cursor pointing one past the end of the
				 * string. */
    char *retval,		/* Start of the string of digits. */
    int *kPtr)			/* Position of the decimal point. */
{
    while (*--s == '9') {
	if (s == retval) {
	    ++(*kPtr);
3429
3430
3431
3432
3433
3434
3435
3436

3437
3438
3439
3440
3441
3442
3443

    /*
     * Compare B and S-m - which is the same as comparing B+m and S - which we
     * do by computing b+m and doing a bitwhack compare against
     * 2**(MP_DIGIT_BIT*sd)
     */

    if ((mp_add(b, m, temp) != MP_OKAY) || (temp->used <= sd)) {	/* Too few digits to be > s */

	return 0;
    }
    if (temp->used > sd+1 || temp->dp[sd] > 1) {
				/* >= 2s */
	return 1;
    }
    for (i = sd-1; i >= 0; --i) {







|
>







3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444

    /*
     * Compare B and S-m - which is the same as comparing B+m and S - which we
     * do by computing b+m and doing a bitwhack compare against
     * 2**(MP_DIGIT_BIT*sd)
     */

    if ((mp_add(b, m, temp) != MP_OKAY) || (temp->used <= sd)) {
	/* Too few digits to be > s */
	return 0;
    }
    if (temp->used > sd+1 || temp->dp[sd] > 1) {
				/* >= 2s */
	return 1;
    }
    for (i = sd-1; i >= 0; --i) {
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
    }
    if (mp_init_u64(&b, bw) != MP_OKAY) {
	mp_clear(&dig);
	return NULL;
    }
    err = mp_mul_2d(&b, b2, &b);
    if (err == MP_OKAY) {
 	err = mp_init_set(&S, 1);
    }
    if (err == MP_OKAY) {
	err = MulPow5(&S, s5, &S);
	if (err == MP_OKAY) {
	    err = mp_mul_2d(&S, s2, &S);
	}
    }







|







4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
    }
    if (mp_init_u64(&b, bw) != MP_OKAY) {
	mp_clear(&dig);
	return NULL;
    }
    err = mp_mul_2d(&b, b2, &b);
    if (err == MP_OKAY) {
	err = mp_init_set(&S, 1);
    }
    if (err == MP_OKAY) {
	err = MulPow5(&S, s5, &S);
	if (err == MP_OKAY) {
	    err = mp_mul_2d(&S, s2, &S);
	}
    }
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
	mp_zero(b);
    } else {
	Tcl_WideInt w = (Tcl_WideInt)ldexp(fract, mantBits);
	int shift = expt - mantBits;

	err = mp_init_i64(b, w);
	if (err != MP_OKAY) {
		/* just skip */
	} else if (shift < 0) {
	    err = mp_div_2d(b, -shift, b, NULL);
	} else if (shift > 0) {
	    err = mp_mul_2d(b, shift, b);
	}
    }
    if (err != MP_OKAY) {







|







4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
	mp_zero(b);
    } else {
	Tcl_WideInt w = (Tcl_WideInt)ldexp(fract, mantBits);
	int shift = expt - mantBits;

	err = mp_init_i64(b, w);
	if (err != MP_OKAY) {
	    /* just skip */
	} else if (shift < 0) {
	    err = mp_div_2d(b, -shift, b, NULL);
	} else if (shift > 0) {
	    err = mp_mul_2d(b, shift, b);
	}
    }
    if (err != MP_OKAY) {
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
 *	too large to convert.
 *
 *----------------------------------------------------------------------
 */

double
TclBignumToDouble(
    const void *big)			/* Integer to convert. */
{
    mp_int b;
    int bits, shift, i, lsb;
    double r;
    mp_err err;
    const mp_int *a = (const mp_int *)big;








|







4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
 *	too large to convert.
 *
 *----------------------------------------------------------------------
 */

double
TclBignumToDouble(
    const void *big)		/* Integer to convert. */
{
    mp_int b;
    int bits, shift, i, lsb;
    double r;
    mp_err err;
    const mp_int *a = (const mp_int *)big;

4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
 *	Returns the floating point number.
 *
 *----------------------------------------------------------------------
 */

double
TclCeil(
    const void *big)			/* Integer to convert. */
{
    double r = 0.0;
    mp_int b;
    mp_err err;
    const mp_int *a = (const mp_int *)big;

    err = mp_init(&b);







|







4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
 *	Returns the floating point number.
 *
 *----------------------------------------------------------------------
 */

double
TclCeil(
    const void *big)		/* Integer to convert. */
{
    double r = 0.0;
    mp_int b;
    mp_err err;
    const mp_int *a = (const mp_int *)big;

    err = mp_init(&b);
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
 *	Returns the floating point value.
 *
 *----------------------------------------------------------------------
 */

double
TclFloor(
    const void *big)			/* Integer to convert. */
{
    double r = 0.0;
    mp_int b;
    mp_err err;
    const mp_int *a = (const mp_int *)big;

    err = mp_init(&b);







|







5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
 *	Returns the floating point value.
 *
 *----------------------------------------------------------------------
 */

double
TclFloor(
    const void *big)		/* Integer to convert. */
{
    double r = 0.0;
    mp_int b;
    mp_err err;
    const mp_int *a = (const mp_int *)big;

    err = mp_init(&b);

Changes to generic/tclStringObj.c.

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
/*
 * tclStringObj.c --
 *
 *  This file contains functions that implement string operations on Tcl
 *  objects. Some string operations work with UTF-8 encoding forms.
 *  Functions that require knowledge of the width of each character,
 * 	such as indexing, operate on fixed width encoding forms such as UTF-32.
 *
 * 	Conceptually, a string is a sequence of Unicode code points. Internally
 * 	it may be stored in an encoding form such as a modified version of
 * 	UTF-8 or UTF-32.
 *
 *	The String object is optimized for the case where each UTF char
 *	in a string is only one byte. In this case, we store the value of
 *	numChars, but we don't store the fixed form encoding (unless
 * 	Tcl_GetUnicode is explicitly called).
 *
 *  The String object type stores one or both formats. The default
 *  behavior is to store UTF-8. Once UTF-16/UTF32 is calculated, it is
 *  stored in the internal rep for future access (without an additional
 *  O(n) cost).
 *
 *	To allow many appends to be done to an object without constantly
 *	reallocating space, we allocate double the space and use the
 *	internal representation to keep track of how much space is used vs.
 *	allocated.
 *
 * Copyright © 1995-1997 Sun Microsystems, Inc.



|
|
|
|

|
|
|




|

|
|
|
|







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
/*
 * tclStringObj.c --
 *
 *	This file contains functions that implement string operations on Tcl
 *	objects. Some string operations work with UTF-8 encoding forms.
 *	Functions that require knowledge of the width of each character,
 *	such as indexing, operate on fixed width encoding forms such as UTF-32.
 *
 *	Conceptually, a string is a sequence of Unicode code points. Internally
 *	it may be stored in an encoding form such as a modified version of
 *	UTF-8 or UTF-32.
 *
 *	The String object is optimized for the case where each UTF char
 *	in a string is only one byte. In this case, we store the value of
 *	numChars, but we don't store the fixed form encoding (unless
 *	Tcl_GetUnicode is explicitly called).
 *
 *	The String object type stores one or both formats. The default
 *	behavior is to store UTF-8. Once UTF-16/UTF32 is calculated, it is
 *	stored in the internal rep for future access (without an additional
 *	O(n) cost).
 *
 *	To allow many appends to be done to an object without constantly
 *	reallocating space, we allocate double the space and use the
 *	internal representation to keep track of how much space is used vs.
 *	allocated.
 *
 * Copyright © 1995-1997 Sun Microsystems, Inc.
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
#ifndef TCL_MIN_UNICHAR_GROWTH
#define TCL_MIN_UNICHAR_GROWTH	TCL_MIN_GROWTH/sizeof(Tcl_UniChar)
#endif

static void
GrowStringBuffer(
    Tcl_Obj *objPtr,
    Tcl_Size needed, /* Not including terminating nul */
    int flag)      /* If 0, try to overallocate */
{
    /*
     * Preconditions:
     *	TclHasInternalRep(objPtr, &tclStringType)
     *	needed > stringPtr->allocated
     *	flag || objPtr->bytes != NULL
     */







|
|







120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
#ifndef TCL_MIN_UNICHAR_GROWTH
#define TCL_MIN_UNICHAR_GROWTH	TCL_MIN_GROWTH/sizeof(Tcl_UniChar)
#endif

static void
GrowStringBuffer(
    Tcl_Obj *objPtr,
    Tcl_Size needed,		/* Not including terminating nul */
    int flag)			/* If 0, try to overallocate */
{
    /*
     * Preconditions:
     *	TclHasInternalRep(objPtr, &tclStringType)
     *	needed > stringPtr->allocated
     *	flag || objPtr->bytes != NULL
     */
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_GetRange(
    Tcl_Obj *objPtr,		/* The Tcl object to find the range of. */
    Tcl_Size first,			/* First index of the range. */
    Tcl_Size last)			/* Last index of the range. */
{
    Tcl_Obj *newObjPtr;		/* The Tcl object to find the range of. */
    String *stringPtr;
    Tcl_Size length = 0;

    if (first < 0) {
	first = 0;







|
|







714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_GetRange(
    Tcl_Obj *objPtr,		/* The Tcl object to find the range of. */
    Tcl_Size first,		/* First index of the range. */
    Tcl_Size last)		/* Last index of the range. */
{
    Tcl_Obj *newObjPtr;		/* The Tcl object to find the range of. */
    String *stringPtr;
    Tcl_Size length = 0;

    if (first < 0) {
	first = 0;
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332

void
Tcl_AppendUnicodeToObj(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const Tcl_UniChar *unicode,	/* The Unicode string to append to the
				 * object. */
    Tcl_Size length)		/* Number of chars in Unicode. Negative
    				 * lengths means nul terminated */
{
    String *stringPtr;

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








|







1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332

void
Tcl_AppendUnicodeToObj(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const Tcl_UniChar *unicode,	/* The Unicode string to append to the
				 * object. */
    Tcl_Size length)		/* Number of chars in Unicode. Negative
				 * lengths means nul terminated */
{
    String *stringPtr;

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

2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
	    char buf[4] = "";
	    int code, length;

	    if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) {
		goto error;
	    }
	    if ((unsigned)code > 0x10FFFF) {
	    	code = 0xFFFD;
	    }
	    length = Tcl_UniCharToUtf(code, buf);
	    segment = Tcl_NewStringObj(buf, length);
	    Tcl_IncrRefCount(segment);
	    allocSegment = 1;
	    break;
	}







|







2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
	    char buf[4] = "";
	    int code, length;

	    if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) {
		goto error;
	    }
	    if ((unsigned)code > 0x10FFFF) {
		code = 0xFFFD;
	    }
	    length = Tcl_UniCharToUtf(code, buf);
	    segment = Tcl_NewStringObj(buf, length);
	    Tcl_IncrRefCount(segment);
	    allocSegment = 1;
	    break;
	}
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
 *---------------------------------------------------------------------------
 *
 * TclStringRepeat --
 *
 *	Performs the [string repeat] function.
 *
 * Results:
 * 	A (Tcl_Obj *) pointing to the result value, or NULL in case of an
 * 	error.
 *
 * Side effects:
 * 	On error, when interp is not NULL, error information is left in it.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclStringRepeat(
    Tcl_Interp *interp,







|
|


|







2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
 *---------------------------------------------------------------------------
 *
 * TclStringRepeat --
 *
 *	Performs the [string repeat] function.
 *
 * Results:
 *	A (Tcl_Obj *) pointing to the result value, or NULL in case of an
 *	error.
 *
 * Side effects:
 *	On error, when interp is not NULL, error information is left in it.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclStringRepeat(
    Tcl_Interp *interp,
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
    Tcl_Size done = 1;
    int binary = TclIsPureByteArray(objPtr);
    Tcl_Size maxCount;

    /*
     * Analyze to determine what representation result should be.
     * GOALS:	Avoid shimmering & string rep generation.
     * 		Produce pure bytearray when possible.
     * 		Error on overflow.
     */

    if (!binary) {
	if (TclHasInternalRep(objPtr, &tclStringType)) {
	    String *stringPtr = GET_STRING(objPtr);
	    if (stringPtr->hasUnicode) {
		unichar = 1;







|
|







2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
    Tcl_Size done = 1;
    int binary = TclIsPureByteArray(objPtr);
    Tcl_Size maxCount;

    /*
     * Analyze to determine what representation result should be.
     * GOALS:	Avoid shimmering & string rep generation.
     *		Produce pure bytearray when possible.
     *		Error on overflow.
     */

    if (!binary) {
	if (TclHasInternalRep(objPtr, &tclStringType)) {
	    String *stringPtr = GET_STRING(objPtr);
	    if (stringPtr->hasUnicode) {
		unichar = 1;
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
	/* Any repeats of empty is empty. */
	return objPtr;
    }

    /* maxCount includes space for null */
    if (count > (maxCount-1)) {
	if (interp) {
	    Tcl_SetObjResult(
		interp,
		Tcl_ObjPrintf("max size for a Tcl value (%" TCL_SIZE_MODIFIER
			      "d bytes) exceeded",
			      TCL_SIZE_MAX));
	    Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
	}
	return NULL;
    }

    if (binary) {
	/* Efficiently produce a pure byte array result */







|
<
|
|
<







3029
3030
3031
3032
3033
3034
3035
3036

3037
3038

3039
3040
3041
3042
3043
3044
3045
	/* Any repeats of empty is empty. */
	return objPtr;
    }

    /* maxCount includes space for null */
    if (count > (maxCount-1)) {
	if (interp) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(

		    "max size for a Tcl value (%" TCL_SIZE_MODIFIER
		    "d bytes) exceeded", TCL_SIZE_MAX));

	    Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
	}
	return NULL;
    }

    if (binary) {
	/* Efficiently produce a pure byte array result */
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
 *---------------------------------------------------------------------------
 *
 * TclStringCat --
 *
 *	Performs the [string cat] function.
 *
 * Results:
 * 	A (Tcl_Obj *) pointing to the result value, or NULL in case of an
 * 	error.
 *
 * Side effects:
 * 	On error, when interp is not NULL, error information is left in it.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclStringCat(
    Tcl_Interp *interp,







|
|


|







3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
 *---------------------------------------------------------------------------
 *
 * TclStringCat --
 *
 *	Performs the [string cat] function.
 *
 * Results:
 *	A (Tcl_Obj *) pointing to the result value, or NULL in case of an
 *	error.
 *
 * Side effects:
 *	On error, when interp is not NULL, error information is left in it.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclStringCat(
    Tcl_Interp *interp,
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
	/* One object; return first */
	return objv[0];
    }

    /*
     * Analyze to determine what representation result should be.
     * GOALS:	Avoid shimmering & string rep generation.
     * 		Produce pure bytearray when possible.
     * 		Error on overflow.
     */

    ov = objv, oc = objc;
    do {
	Tcl_Obj *objPtr = *ov++;

	if (TclIsPureByteArray(objPtr)) {
	    allowUniChar = 0;
	} else if (objPtr->bytes) {
	    /* Value has a string rep. */
	    if (objPtr->length) {
		/*
		 * Non-empty string rep. Not a pure bytearray, so we won't
		 * create a pure bytearray.
		 */

	 	binary = 0;
	 	if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) {
	 	    forceUniChar = 1;
	 	} else if ((objPtr->typePtr) && TclHasInternalRep(objPtr, &tclStringType)) {
		    /* Prevent shimmer of non-string types. */
		    allowUniChar = 0;
		}
	    }
	} else {
	    binary = 0;
	    if (TclHasInternalRep(objPtr, &tclStringType)) {







|
|
















|
|
|
|







3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
	/* One object; return first */
	return objv[0];
    }

    /*
     * Analyze to determine what representation result should be.
     * GOALS:	Avoid shimmering & string rep generation.
     *		Produce pure bytearray when possible.
     *		Error on overflow.
     */

    ov = objv, oc = objc;
    do {
	Tcl_Obj *objPtr = *ov++;

	if (TclIsPureByteArray(objPtr)) {
	    allowUniChar = 0;
	} else if (objPtr->bytes) {
	    /* Value has a string rep. */
	    if (objPtr->length) {
		/*
		 * Non-empty string rep. Not a pure bytearray, so we won't
		 * create a pure bytearray.
		 */

		binary = 0;
		if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) {
		    forceUniChar = 1;
		} else if ((objPtr->typePtr) && TclHasInternalRep(objPtr, &tclStringType)) {
		    /* Prevent shimmer of non-string types. */
		    allowUniChar = 0;
		}
	    }
	} else {
	    binary = 0;
	    if (TclHasInternalRep(objPtr, &tclStringType)) {
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
		    pendingPtr = objPtr;
		} else {
		    (void) TclGetStringFromObj(objPtr, &length); /* PANIC? */
		}
	    } while (--oc && (length == 0) && (pendingPtr == NULL));

	    /*
 	     * Either we found a possibly non-empty value, and we remember
 	     * this index as the first and last such value so far seen,
	     * or (oc == 0) and all values are known empty,
 	     * so first = last = objc - 1 signals the right quick return.
 	     */

	    first = last = objc - oc - 1;

	    if (oc && (length == 0)) {
		Tcl_Size numBytes;

		/*







|
|

|
|







3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
		    pendingPtr = objPtr;
		} else {
		    (void) TclGetStringFromObj(objPtr, &length); /* PANIC? */
		}
	    } while (--oc && (length == 0) && (pendingPtr == NULL));

	    /*
	     * Either we found a possibly non-empty value, and we remember
	     * this index as the first and last such value so far seen,
	     * or (oc == 0) and all values are known empty,
	     * so first = last = objc - 1 signals the right quick return.
	     */

	    first = last = objc - oc - 1;

	    if (oc && (length == 0)) {
		Tcl_Size numBytes;

		/*
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428

	    /* Ugly interface! Force resize of the unicode array. */
	    (void)Tcl_GetUnicodeFromObj(objResultPtr, &start);
	    Tcl_InvalidateStringRep(objResultPtr);
	    if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    	"concatenation failed: unable to alloc %"
			TCL_Z_MODIFIER "u bytes",
			STRING_SIZE(length)));
		    Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
		}
		return NULL;
	    }
	    dst = Tcl_GetUnicode(objResultPtr) + start;
	} else {
	    Tcl_UniChar ch = 0;

	    /* Ugly interface! No scheme to init array size. */
	    objResultPtr = Tcl_NewUnicodeObj(&ch, 0);	/* PANIC? */
	    if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
		Tcl_DecrRefCount(objResultPtr);
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    	"concatenation failed: unable to alloc %"
			TCL_Z_MODIFIER "u bytes",
			STRING_SIZE(length)));
		    Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
		}
		return NULL;
	    }
	    dst = Tcl_GetUnicode(objResultPtr);







|
















|







3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426

	    /* Ugly interface! Force resize of the unicode array. */
	    (void)Tcl_GetUnicodeFromObj(objResultPtr, &start);
	    Tcl_InvalidateStringRep(objResultPtr);
	    if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"concatenation failed: unable to alloc %"
			TCL_Z_MODIFIER "u bytes",
			STRING_SIZE(length)));
		    Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
		}
		return NULL;
	    }
	    dst = Tcl_GetUnicode(objResultPtr) + start;
	} else {
	    Tcl_UniChar ch = 0;

	    /* Ugly interface! No scheme to init array size. */
	    objResultPtr = Tcl_NewUnicodeObj(&ch, 0);	/* PANIC? */
	    if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
		Tcl_DecrRefCount(objResultPtr);
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"concatenation failed: unable to alloc %"
			TCL_Z_MODIFIER "u bytes",
			STRING_SIZE(length)));
		    Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
		}
		return NULL;
	    }
	    dst = Tcl_GetUnicode(objResultPtr);
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475

	    objResultPtr = *objv++; objc--;

	    (void)TclGetStringFromObj(objResultPtr, &start);
	    if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    	"concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes",
			length));
		    Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
		}
		return NULL;
	    }
	    dst = TclGetString(objResultPtr) + start;

	    TclFreeInternalRep(objResultPtr);
	} else {
	    TclNewObj(objResultPtr);	/* PANIC? */
	    if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
		Tcl_DecrRefCount(objResultPtr);
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    	"concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes",
			length));
		    Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
		}
		return NULL;
	    }
	    dst = TclGetString(objResultPtr);
	}







|














|







3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473

	    objResultPtr = *objv++; objc--;

	    (void)TclGetStringFromObj(objResultPtr, &start);
	    if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes",
			length));
		    Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
		}
		return NULL;
	    }
	    dst = TclGetString(objResultPtr) + start;

	    TclFreeInternalRep(objResultPtr);
	} else {
	    TclNewObj(objResultPtr);	/* PANIC? */
	    if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
		Tcl_DecrRefCount(objResultPtr);
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes",
			length));
		    Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
		}
		return NULL;
	    }
	    dst = TclGetString(objResultPtr);
	}
3488
3489
3490
3491
3492
3493
3494
3495

3496
3497
3498
3499
3500
3501
3502
	*dst = '\0';
    }
    return objResultPtr;

  overflow:
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "max size for a Tcl value (%" TCL_SIZE_MODIFIER "d bytes) exceeded", TCL_SIZE_MAX));

	Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
    }
    return NULL;
}

/*
 *---------------------------------------------------------------------------







|
>







3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
	*dst = '\0';
    }
    return objResultPtr;

  overflow:
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"max size for a Tcl value (%" TCL_SIZE_MODIFIER
		"d bytes) exceeded", TCL_SIZE_MAX));
	Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
    }
    return NULL;
}

/*
 *---------------------------------------------------------------------------
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
 *	be changed.
 *
 *---------------------------------------------------------------------------
 */

static int
UniCharNcasememcmp(
    const void *ucsPtr,	/* Unicode string to compare to uct. */
    const void *uctPtr,	/* Unicode string ucs is compared to. */
    size_t numChars)	/* Number of Unichars to compare. */
{
    const Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr;
    const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr;
    for ( ; numChars != 0; numChars--, ucs++, uct++) {
	if (*ucs != *uct) {
	    Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs);
	    Tcl_UniChar lct = Tcl_UniCharToLower(*uct);

	    if (lcs != lct) {
		return (lcs - lct);
	    }
	}
    }
    return 0;
}

static int
UtfNmemcmp(
    const void *csPtr,		/* UTF string to compare to ct. */
    const void *ctPtr,		/* UTF string cs is compared to. */
    size_t numChars)	/* Number of UTF chars to compare. */
{
    Tcl_UniChar ch1 = 0, ch2 = 0;
    const char *cs = (const char *)csPtr;
    const char *ct = (const char *)ctPtr;

    /*
     * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the







|
|
|




















|







3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
 *	be changed.
 *
 *---------------------------------------------------------------------------
 */

static int
UniCharNcasememcmp(
    const void *ucsPtr,		/* Unicode string to compare to uct. */
    const void *uctPtr,		/* Unicode string ucs is compared to. */
    size_t numChars)		/* Number of Unichars to compare. */
{
    const Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr;
    const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr;
    for ( ; numChars != 0; numChars--, ucs++, uct++) {
	if (*ucs != *uct) {
	    Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs);
	    Tcl_UniChar lct = Tcl_UniCharToLower(*uct);

	    if (lcs != lct) {
		return (lcs - lct);
	    }
	}
    }
    return 0;
}

static int
UtfNmemcmp(
    const void *csPtr,		/* UTF string to compare to ct. */
    const void *ctPtr,		/* UTF string cs is compared to. */
    size_t numChars)		/* Number of UTF chars to compare. */
{
    Tcl_UniChar ch1 = 0, ch2 = 0;
    const char *cs = (const char *)csPtr;
    const char *ct = (const char *)ctPtr;

    /*
     * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
    return 0;
}

static int
UtfNcasememcmp(
    const void *csPtr,		/* UTF string to compare to ct. */
    const void *ctPtr,		/* UTF string cs is compared to. */
    size_t numChars)	/* Number of UTF chars to compare. */
{
    Tcl_UniChar ch1 = 0, ch2 = 0;
    const char *cs = (const char *)csPtr;
    const char *ct = (const char *)ctPtr;

    while (numChars-- > 0) {
	/*







|







3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
    return 0;
}

static int
UtfNcasememcmp(
    const void *csPtr,		/* UTF string to compare to ct. */
    const void *ctPtr,		/* UTF string cs is compared to. */
    size_t numChars)		/* Number of UTF chars to compare. */
{
    Tcl_UniChar ch1 = 0, ch2 = 0;
    const char *cs = (const char *)csPtr;
    const char *ct = (const char *)ctPtr;

    while (numChars-- > 0) {
	/*
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
	}
    }
    return 0;
}

static int
UniCharNmemcmp(
    const void *ucsPtr,	/* Unicode string to compare to uct. */
    const void *uctPtr,	/* Unicode string ucs is compared to. */
    size_t numChars)	/* Number of unichars to compare. */
{
    const Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr;
    const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr;
#if defined(WORDS_BIGENDIAN)
    /*
     * We are definitely on a big-endian machine; memcmp() is safe
     */







|
|
|







3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
	}
    }
    return 0;
}

static int
UniCharNmemcmp(
    const void *ucsPtr,		/* Unicode string to compare to uct. */
    const void *uctPtr,		/* Unicode string ucs is compared to. */
    size_t numChars)		/* Number of unichars to compare. */
{
    const Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr;
    const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr;
#if defined(WORDS_BIGENDIAN)
    /*
     * We are definitely on a big-endian machine; memcmp() is safe
     */
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
int
TclStringCmp(
    Tcl_Obj *value1Ptr,
    Tcl_Obj *value2Ptr,
    int checkEq,		/* comparison is only for equality */
    int nocase,			/* comparison is not case sensitive */
    Tcl_Size reqlength)		/* requested length in characters;
						 * TCL_INDEX_NONE to compare whole strings */
{
    const char *s1, *s2;
    int empty, match;
    Tcl_Size length, s1len = 0, s2len = 0;
    memCmpFn_t memCmpFn;

    if ((reqlength == 0) || (value1Ptr == value2Ptr)) {







|







3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
int
TclStringCmp(
    Tcl_Obj *value1Ptr,
    Tcl_Obj *value2Ptr,
    int checkEq,		/* comparison is only for equality */
    int nocase,			/* comparison is not case sensitive */
    Tcl_Size reqlength)		/* requested length in characters;
				 * TCL_INDEX_NONE to compare whole strings */
{
    const char *s1, *s2;
    int empty, match;
    Tcl_Size length, s1len = 0, s2len = 0;
    memCmpFn_t memCmpFn;

    if ((reqlength == 0) || (value1Ptr == value2Ptr)) {
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
	    } else {
		s1len = Tcl_GetCharLength(value1Ptr);
		s2len = Tcl_GetCharLength(value2Ptr);
		if ((s1len == value1Ptr->length)
			&& (value1Ptr->bytes != NULL)
			&& (s2len == value2Ptr->length)
			&& (value2Ptr->bytes != NULL)) {
			/* each byte represents one character so s1l3n, s2l3n, and
			 * reqlength are in both bytes and characters
			 */
		    s1 = value1Ptr->bytes;
		    s2 = value2Ptr->bytes;
		    memCmpFn = memcmp;
		} else {
		    s1 = (char *) Tcl_GetUnicode(value1Ptr);
		    s2 = (char *) Tcl_GetUnicode(value2Ptr);
		    if (







|
|
<







3673
3674
3675
3676
3677
3678
3679
3680
3681

3682
3683
3684
3685
3686
3687
3688
	    } else {
		s1len = Tcl_GetCharLength(value1Ptr);
		s2len = Tcl_GetCharLength(value2Ptr);
		if ((s1len == value1Ptr->length)
			&& (value1Ptr->bytes != NULL)
			&& (s2len == value2Ptr->length)
			&& (value2Ptr->bytes != NULL)) {
			/* each byte represents one character so s1l3n, s2l3n,
			 * and reqlength are in both bytes and characters */

		    s1 = value1Ptr->bytes;
		    s2 = value2Ptr->bytes;
		    memCmpFn = memcmp;
		} else {
		    s1 = (char *) Tcl_GetUnicode(value1Ptr);
		    s2 = (char *) Tcl_GetUnicode(value2Ptr);
		    if (
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
    Tcl_Size lh = 0, ln = Tcl_GetCharLength(needle);
    Tcl_Size value = -1;
    Tcl_UniChar *checkStr, *uh, *un;
    Tcl_Obj *obj;

    if (ln == 0) {
	/*
	 * 	We don't find empty substrings.  Bizarre!
	 *
	 * 	TODO: When we one day make this a true substring
	 * 	finder, change this to "return last", after limitation.
	 */
	goto lastEnd;
    }

    if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
	unsigned char *check, *bh = Tcl_GetBytesFromObj(NULL, haystack, &lh);
	unsigned char *bn = Tcl_GetBytesFromObj(NULL, needle, &ln);







|

|
|







3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
    Tcl_Size lh = 0, ln = Tcl_GetCharLength(needle);
    Tcl_Size value = -1;
    Tcl_UniChar *checkStr, *uh, *un;
    Tcl_Obj *obj;

    if (ln == 0) {
	/*
	 *	We don't find empty substrings.  Bizarre!
	 *
	 *	TODO: When we one day make this a true substring
	 *	finder, change this to "return last", after limitation.
	 */
	goto lastEnd;
    }

    if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
	unsigned char *check, *bh = Tcl_GetBytesFromObj(NULL, haystack, &lh);
	unsigned char *bn = Tcl_GetBytesFromObj(NULL, needle, &ln);

Changes to generic/tclTest.c.

2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
 * UtfTransformFn --
 *
 *    Implements a direct call into Tcl_UtfToExternal and Tcl_ExternalToUtf
 *    as otherwise there is no script level command that directly exercises
 *    these functions (i/o command cannot test all combinations)
 *    The arguments at the script level are roughly those of the above
 *    functions:
 *        encodingname srcbytes flags state dstlen ?srcreadvar? ?dstwrotevar? ?dstcharsvar?
 *
 * Results:
 *    TCL_OK or TCL_ERROR. This any errors running the test, NOT the
 *    result of Tcl_UtfToExternal or Tcl_ExternalToUtf.
 *
 * Side effects:
 *







|







2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
 * UtfTransformFn --
 *
 *    Implements a direct call into Tcl_UtfToExternal and Tcl_ExternalToUtf
 *    as otherwise there is no script level command that directly exercises
 *    these functions (i/o command cannot test all combinations)
 *    The arguments at the script level are roughly those of the above
 *    functions:
 *	encodingname srcbytes flags state dstlen ?srcreadvar? ?dstwrotevar? ?dstcharsvar?
 *
 * Results:
 *    TCL_OK or TCL_ERROR. This any errors running the test, NOT the
 *    result of Tcl_UtfToExternal or Tcl_ExternalToUtf.
 *
 * Side effects:
 *
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
	    if (arg[1] != 'r') {
		goto wrongArgs;
	    }
	    readonly = TCL_LINK_READ_ONLY;
	    i++;
	}
	if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0,
 		&typeIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", -1));
	    return TCL_ERROR;
	}
	name = Tcl_GetString(objv[i++]);

	/*
	 * If no address is given request one in the underlying function
	 */

	if (i < objc) {
	    if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) {
 		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"wrong address value", -1));
		return TCL_ERROR;
	    }
	} else {
	    addr = 0;
	}
	return Tcl_LinkArray(interp, name, INT2PTR(addr),







|














|







3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
	    if (arg[1] != 'r') {
		goto wrongArgs;
	    }
	    readonly = TCL_LINK_READ_ONLY;
	    i++;
	}
	if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0,
		&typeIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", -1));
	    return TCL_ERROR;
	}
	name = Tcl_GetString(objv[i++]);

	/*
	 * If no address is given request one in the underlying function
	 */

	if (i < objc) {
	    if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"wrong address value", -1));
		return TCL_ERROR;
	    }
	} else {
	    addr = 0;
	}
	return Tcl_LinkArray(interp, name, INT2PTR(addr),
8527
8528
8529
8530
8531
8532
8533
8534
8535
8536
8537
8538
8539
8540
8541
8542
8543
8544
8545
8546
8547
8548
8549
    TCL_UNUSED(Tcl_Interp *),
    const char *name,
    TCL_UNUSED(Tcl_Size) /* length */,
    TCL_UNUSED(Tcl_Namespace *),
    Tcl_ResolvedVarInfo **rPtr)
{
    if (*name == 'T') {
 	MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)Tcl_Alloc(sizeof(MyResolvedVarInfo));

 	resVarInfo->vInfo.fetchProc = MyCompiledVarFetch;
 	resVarInfo->vInfo.deleteProc = MyCompiledVarFree;
 	resVarInfo->var = NULL;
 	resVarInfo->nameObj = Tcl_NewStringObj(name, -1);
 	Tcl_IncrRefCount(resVarInfo->nameObj);
 	*rPtr = &resVarInfo->vInfo;
 	return TCL_OK;
    }
    return TCL_CONTINUE;
}

static int
TestInterpResolverCmd(
    TCL_UNUSED(void *),







|

|
|
|
|
|
|
|







8527
8528
8529
8530
8531
8532
8533
8534
8535
8536
8537
8538
8539
8540
8541
8542
8543
8544
8545
8546
8547
8548
8549
    TCL_UNUSED(Tcl_Interp *),
    const char *name,
    TCL_UNUSED(Tcl_Size) /* length */,
    TCL_UNUSED(Tcl_Namespace *),
    Tcl_ResolvedVarInfo **rPtr)
{
    if (*name == 'T') {
	MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)Tcl_Alloc(sizeof(MyResolvedVarInfo));

	resVarInfo->vInfo.fetchProc = MyCompiledVarFetch;
	resVarInfo->vInfo.deleteProc = MyCompiledVarFree;
	resVarInfo->var = NULL;
	resVarInfo->nameObj = Tcl_NewStringObj(name, -1);
	Tcl_IncrRefCount(resVarInfo->nameObj);
	*rPtr = &resVarInfo->vInfo;
	return TCL_OK;
    }
    return TCL_CONTINUE;
}

static int
TestInterpResolverCmd(
    TCL_UNUSED(void *),
8652
8653
8654
8655
8656
8657
8658
8659
8660
8661
8662
8663
8664
8665
8666
8667
    /*
     * The bug trigger. Repeating the command but:
     *  - we are calling apply with a lambda that is a list (as BEFORE),
     *    BUT
     *  - The body of the lambda (lambdaObjs[1]) ALREADY has internal
     *    representation of ByteCode and thus will not be compiled again
     */
    evalObjs[1] = lambdaObj; /* lambdaObj already has a ref count so
     				no need for IncrRef */
    result = Tcl_EvalObjv(interp, 2, evalObjs, TCL_EVAL_GLOBAL);
    Tcl_DecrRefCount(evalObjs[0]);
    Tcl_DecrRefCount(lambdaObj);

    return result;
}








|
<







8652
8653
8654
8655
8656
8657
8658
8659

8660
8661
8662
8663
8664
8665
8666
    /*
     * The bug trigger. Repeating the command but:
     *  - we are calling apply with a lambda that is a list (as BEFORE),
     *    BUT
     *  - The body of the lambda (lambdaObjs[1]) ALREADY has internal
     *    representation of ByteCode and thus will not be compiled again
     */
    evalObjs[1] = lambdaObj; /* lambdaObj already has a ref count so no need for IncrRef */

    result = Tcl_EvalObjv(interp, 2, evalObjs, TCL_EVAL_GLOBAL);
    Tcl_DecrRefCount(evalObjs[0]);
    Tcl_DecrRefCount(lambdaObj);

    return result;
}

Changes to generic/tclThreadTest.c.

981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
     * Since Tcl_CancelEval can be safely called from any thread,
     * we do it now.
     */

    Tcl_MutexUnlock(&threadMutex);
    Tcl_ResetResult(interp);
    return Tcl_CancelEval(tsdPtr->interp,
    	(result != NULL) ? Tcl_NewStringObj(result, -1) : NULL, 0, flags);
}

/*
 *------------------------------------------------------------------------
 *
 * ThreadEventProc --
 *







|







981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
     * Since Tcl_CancelEval can be safely called from any thread,
     * we do it now.
     */

    Tcl_MutexUnlock(&threadMutex);
    Tcl_ResetResult(interp);
    return Tcl_CancelEval(tsdPtr->interp,
	    (result != NULL) ? Tcl_NewStringObj(result, -1) : NULL, 0, flags);
}

/*
 *------------------------------------------------------------------------
 *
 * ThreadEventProc --
 *

Changes to generic/tclUtf.c.

202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Size
Tcl_UniCharToUtf(
    int ch,	/* The Tcl_UniChar to be stored in the
		 * buffer. Can be or'ed with flag TCL_COMBINE.
		 */
    char *buf)	/* Buffer in which the UTF-8 representation of
		 * ch is stored. Must be large enough to hold the UTF-8
		 * character (at most 4 bytes).
		 */
{
    int flags = ch;

    if (ch >= TCL_COMBINE) {
	ch &= (TCL_COMBINE - 1);
    }
    if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {







|
|
<
|
|
|
<







202
203
204
205
206
207
208
209
210

211
212
213

214
215
216
217
218
219
220
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Size
Tcl_UniCharToUtf(
    int ch,			/* The Tcl_UniChar to be stored in the buffer.
				 * Can be or'ed with flag TCL_COMBINE. */

    char *buf)			/* Buffer in which the UTF-8 representation of
				 * ch is stored. Must be large enough to hold
				 * the UTF-8 character (at most 4 bytes). */

{
    int flags = ch;

    if (ch >= TCL_COMBINE) {
	ch &= (TCL_COMBINE - 1);
    }
    if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
 *	None.
 *
 *---------------------------------------------------------------------------
 */

char *
Tcl_UniCharToUtfDString(
    const int *uniStr,	/* Unicode string to convert to UTF-8. */
    Tcl_Size uniLength,		/* Length of Unicode string. Negative for nul
    				 * terminated string */
    Tcl_DString *dsPtr)		/* UTF-8 representation of string is appended
				 * to this previously initialized DString. */
{
    const int *w, *wEnd;
    char *p, *string;
    Tcl_Size oldLength;








|

|







303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
 *	None.
 *
 *---------------------------------------------------------------------------
 */

char *
Tcl_UniCharToUtfDString(
    const int *uniStr,		/* Unicode string to convert to UTF-8. */
    Tcl_Size uniLength,		/* Length of Unicode string. Negative for nul
				 * terminated string */
    Tcl_DString *dsPtr)		/* UTF-8 representation of string is appended
				 * to this previously initialized DString. */
{
    const int *w, *wEnd;
    char *p, *string;
    Tcl_Size oldLength;

436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
  0x02C6, 0x2030, 0x0160, 0x2039, 0x0152,   0x8D, 0x017D,   0x8F,
    0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014,
   0x2DC, 0x2122, 0x0161, 0x203A, 0x0153,   0x9D, 0x017E, 0x0178
};

Tcl_Size
Tcl_UtfToUniChar(
    const char *src,	/* The UTF-8 string. */
    int *chPtr)/* Filled with the Unicode character represented by
				 * the UTF-8 string. */
{
    int byte;

    /*
     * Unroll 1 to 4 byte UTF-8 sequences.
     */








|
|
|







434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
  0x02C6, 0x2030, 0x0160, 0x2039, 0x0152,   0x8D, 0x017D,   0x8F,
    0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014,
   0x2DC, 0x2122, 0x0161, 0x203A, 0x0153,   0x9D, 0x017E, 0x0178
};

Tcl_Size
Tcl_UtfToUniChar(
    const char *src,		/* The UTF-8 string. */
    int *chPtr)			/* Filled with the Unicode character
				 * represented by the UTF-8 string. */
{
    int byte;

    /*
     * Unroll 1 to 4 byte UTF-8 sequences.
     */

Changes to generic/tclUtil.c.

154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
 * The ASCII characters which can make up the whitespace between list elements
 * are:
 *
 *	\u0009	\t	TAB
 *	\u000A	\n	NEWLINE
 *	\u000B	\v	VERTICAL TAB
 *	\u000C	\f	FORM FEED
 * 	\u000D	\r	CARRIAGE RETURN
 *	\u0020		SPACE
 *
 * NOTE: differences between this and other places where Tcl defines a role
 * for "whitespace".
 *
 *	* Unlike command parsing, here NEWLINE is just another whitespace
 *	  character; its role as a command terminator in a script has no







|







154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
 * The ASCII characters which can make up the whitespace between list elements
 * are:
 *
 *	\u0009	\t	TAB
 *	\u000A	\n	NEWLINE
 *	\u000B	\v	VERTICAL TAB
 *	\u000C	\f	FORM FEED
 *	\u000D	\r	CARRIAGE RETURN
 *	\u0020		SPACE
 *
 * NOTE: differences between this and other places where Tcl defines a role
 * for "whitespace".
 *
 *	* Unlike command parsing, here NEWLINE is just another whitespace
 *	  character; its role as a command terminator in a script has no
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
 *   characters that have special meaning during script evaluation need
 *   special treatment when canonical lists are produced:
 *
 *	* Whitespace between elements may not include NEWLINE.
 *	* The command terminating character,
 *		\u003b	;	SEMICOLON
 *	  must be BRACEd, QUOTEd, or escaped so that it does not terminate the
 * 	  command prematurely.
 *	* Any of the characters that begin substitutions in scripts,
 *		\u0024	$	DOLLAR
 *		\u005b	[	OPEN BRACKET
 *		\u005c	\	BACKSLASH
 *	  need to be BRACEd or escaped.
 *	* In any list where the first character of the first element is
 *		\u0023	#	HASH







|







272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
 *   characters that have special meaning during script evaluation need
 *   special treatment when canonical lists are produced:
 *
 *	* Whitespace between elements may not include NEWLINE.
 *	* The command terminating character,
 *		\u003b	;	SEMICOLON
 *	  must be BRACEd, QUOTEd, or escaped so that it does not terminate the
 *	  command prematurely.
 *	* Any of the characters that begin substitutions in scripts,
 *		\u0024	$	DOLLAR
 *		\u005b	[	OPEN BRACKET
 *		\u005c	\	BACKSLASH
 *	  need to be BRACEd or escaped.
 *	* In any list where the first character of the first element is
 *		\u0023	#	HASH
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
    do {
	const char *q = trim;
	Tcl_Size pInc = 0, bytesLeft = numTrim;

	pp = Tcl_UtfPrev(p, bytes);
	do {
	    pp += pInc;
 	    pInc = TclUtfToUniChar(pp, &ch1);
	} while (pp + pInc < p);

	/*
	 * Inner loop: scan trim string for match to current character.
	 */

	do {







|







1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
    do {
	const char *q = trim;
	Tcl_Size pInc = 0, bytesLeft = numTrim;

	pp = Tcl_UtfPrev(p, bytes);
	do {
	    pp += pInc;
	    pInc = TclUtfToUniChar(pp, &ch1);
	} while (pp + pInc < p);

	/*
	 * Inner loop: scan trim string for match to current character.
	 */

	do {
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891

    /*
     * First allocate the result buffer at the size required.
     */

    for (i = 0;  i < argc;  i++) {
	bytesNeeded += strlen(argv[i]);
    	if (bytesNeeded < 0) {
	    Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
	}
    }

    /*
     * All element bytes + (argc - 1) spaces + 1 terminating NULL.
     */







|







1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891

    /*
     * First allocate the result buffer at the size required.
     */

    for (i = 0;  i < argc;  i++) {
	bytesNeeded += strlen(argv[i]);
	if (bytesNeeded < 0) {
	    Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
	}
    }

    /*
     * All element bytes + (argc - 1) spaces + 1 terminating NULL.
     */
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
 *	TCL_SIZE_MAX. Negative values are returned as TCL_INDEX_NONE (-1).
 *
 *	Callers should pass reasonable values for endValue - one in the
 *      valid index range or TCL_INDEX_NONE (-1), for example for an empty
 *	list.
 *
 * Results:
 * 	TCL_OK
 *
 * 	    The index is stored at the address given by by 'indexPtr'.
 *
 * 	TCL_ERROR
 *
 * 	    The value of 'objPtr' does not have one of the expected formats. If
 * 	    'interp' is non-NULL, an error message is left in the interpreter's
 * 	    result object.
 *
 * Side effects:
 *
 * 	The internal representation contained within objPtr may shimmer.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetIntForIndex(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting. If







|

|

|

|
|
|



|







3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
 *	TCL_SIZE_MAX. Negative values are returned as TCL_INDEX_NONE (-1).
 *
 *	Callers should pass reasonable values for endValue - one in the
 *      valid index range or TCL_INDEX_NONE (-1), for example for an empty
 *	list.
 *
 * Results:
 *	TCL_OK
 *
 *	    The index is stored at the address given by by 'indexPtr'.
 *
 *	TCL_ERROR
 *
 *	    The value of 'objPtr' does not have one of the expected formats. If
 *	    'interp' is non-NULL, an error message is left in the interpreter's
 *	    result object.
 *
 * Side effects:
 *
 *	The internal representation contained within objPtr may shimmer.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetIntForIndex(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting. If
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
	 * listLen-1 as endValue and and listLen is 0. The -1 will be
	 * interpreted as FF...FF and adding 1 will result in 0 which
	 * is what we want. Callers like lset which pass in listLen-1 == -1
         * as endValue will have to adjust accordingly.
	 */
	*widePtr = (endValue == -1) ? WIDE_MAX : endValue + 1;
    } else if (offset == WIDE_MIN) {
	/* -1 - position before first */
	*widePtr = -1;
    } else if (offset < 0) {
	/* end-(n-1) - Different signs, sum cannot overflow */
	*widePtr = endValue + offset + 1;
    } else if (offset < WIDE_MAX) {
	/* 0:WIDE_MAX-1 - plain old index. */
	*widePtr = offset;
    } else {
	/* Huh, what case remains here? */
	*widePtr = WIDE_MAX;
    }
    return TCL_OK;

    /* Report a parse error. */
  parseError:
    if (interp != NULL) {
        char * bytes = TclGetString(objPtr);







<
|



|
|

<
<
<







3703
3704
3705
3706
3707
3708
3709

3710
3711
3712
3713
3714
3715
3716



3717
3718
3719
3720
3721
3722
3723
	 * listLen-1 as endValue and and listLen is 0. The -1 will be
	 * interpreted as FF...FF and adding 1 will result in 0 which
	 * is what we want. Callers like lset which pass in listLen-1 == -1
         * as endValue will have to adjust accordingly.
	 */
	*widePtr = (endValue == -1) ? WIDE_MAX : endValue + 1;
    } else if (offset == WIDE_MIN) {

	*widePtr = (endValue == -1) ? WIDE_MIN : -1;
    } else if (offset < 0) {
	/* end-(n-1) - Different signs, sum cannot overflow */
	*widePtr = endValue + offset + 1;
    } else {
	/* 0:WIDE_MAX - plain old index. */
	*widePtr = offset;



    }
    return TCL_OK;

    /* Report a parse error. */
  parseError:
    if (interp != NULL) {
        char * bytes = TclGetString(objPtr);

Changes to generic/tclVar.c.

6568
6569
6570
6571
6572
6573
6574
6575
6576
6577
6578
6579
6580
6581
6582
	     * Skip nameless (temporary) variables and undefined variables.
	     */

	    if (*varNamePtr && !TclIsVarUndefined(varPtr)
		    && (includeLinks || !TclIsVarLink(varPtr))) {
		varName = TclGetString(*varNamePtr);
		if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
	    	    if (!justConstants || TclIsVarConstant(varPtr)) {
			Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr);
		    }
		    if (includeLinks) {
			Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added);
		    }
		}
	    }







|







6568
6569
6570
6571
6572
6573
6574
6575
6576
6577
6578
6579
6580
6581
6582
	     * Skip nameless (temporary) variables and undefined variables.
	     */

	    if (*varNamePtr && !TclIsVarUndefined(varPtr)
		    && (includeLinks || !TclIsVarLink(varPtr))) {
		varName = TclGetString(*varNamePtr);
		if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
		    if (!justConstants || TclIsVarConstant(varPtr)) {
			Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr);
		    }
		    if (includeLinks) {
			Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added);
		    }
		}
	    }
6622
6623
6624
6625
6626
6627
6628
6629
6630
6631
6632
6633
6634
6635
6636
	    varPtr != NULL;
	    varPtr = VarHashNextVar(&search)) {
	if (!TclIsVarUndefined(varPtr)
		&& (includeLinks || !TclIsVarLink(varPtr))) {
	    objNamePtr = VarHashGetKey(varPtr);
	    varName = TclGetString(objNamePtr);
	    if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
	    	if (!justConstants || TclIsVarConstant(varPtr)) {
		    Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
		}
		if (includeLinks) {
		    Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
		}
	    }
	}







|







6622
6623
6624
6625
6626
6627
6628
6629
6630
6631
6632
6633
6634
6635
6636
	    varPtr != NULL;
	    varPtr = VarHashNextVar(&search)) {
	if (!TclIsVarUndefined(varPtr)
		&& (includeLinks || !TclIsVarLink(varPtr))) {
	    objNamePtr = VarHashGetKey(varPtr);
	    varName = TclGetString(objNamePtr);
	    if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
		if (!justConstants || TclIsVarConstant(varPtr)) {
		    Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
		}
		if (includeLinks) {
		    Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
		}
	    }
	}

Changes to generic/tclZipfs.c.

213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
 */

typedef struct ZipEntry {
    char *name;			/* The full pathname of the virtual file */
    ZipFile *zipFilePtr;	/* The ZIP file holding this virtual file */
    size_t offset;		/* Data offset into memory mapped ZIP file */
    int numBytes;		/* Uncompressed size of the virtual file.
    				 * -1 for zip64 */
    int numCompressedBytes;	/* Compressed size of the virtual file.
    				 * -1 for zip64 */
    int compressMethod;		/* Compress method */
    int isDirectory;		/* 0 if file, 1 if directory, -1 if root */
    int depth;			/* Number of slashes in path. */
    int crc32;			/* CRC-32 as stored in ZIP */
    int timestamp;		/* Modification time */
    int isEncrypted;		/* True if data is encrypted */
    int flags;







|

|







213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
 */

typedef struct ZipEntry {
    char *name;			/* The full pathname of the virtual file */
    ZipFile *zipFilePtr;	/* The ZIP file holding this virtual file */
    size_t offset;		/* Data offset into memory mapped ZIP file */
    int numBytes;		/* Uncompressed size of the virtual file.
				 * -1 for zip64 */
    int numCompressedBytes;	/* Compressed size of the virtual file.
				 * -1 for zip64 */
    int compressMethod;		/* Compress method */
    int isDirectory;		/* 0 if file, 1 if directory, -1 if root */
    int depth;			/* Number of slashes in path. */
    int crc32;			/* CRC-32 as stored in ZIP */
    int timestamp;		/* Modification time */
    int isEncrypted;		/* True if data is encrypted */
    int flags;
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
    ZipFile *zipFilePtr;	/* The ZIP file holding this channel */
    ZipEntry *zipEntryPtr;	/* Pointer back to virtual file */
    Tcl_Size maxWrite;		/* Maximum size for write */
    Tcl_Size numBytes;		/* Number of bytes of uncompressed data */
    Tcl_Size cursor;		/* Seek position for next read or write*/
    unsigned char *ubuf;	/* Pointer to the uncompressed data */
    unsigned char *ubufToFree;  /* NULL if ubuf points to memory that does not
    				   need freeing. Else memory to free (ubuf
				   may point *inside* the block) */
    Tcl_Size ubufSize;		/* Size of allocated ubufToFree */
    int iscompr;                /* True if data is compressed */
    int isDirectory;		/* Set to 1 if directory, or -1 if root */
    int isEncrypted;		/* True if data is encrypted */
    int mode;			/* O_WRITE, O_APPEND, O_TRUNC etc.*/
    unsigned long keys[3];	/* Key for decryption */







|







254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
    ZipFile *zipFilePtr;	/* The ZIP file holding this channel */
    ZipEntry *zipEntryPtr;	/* Pointer back to virtual file */
    Tcl_Size maxWrite;		/* Maximum size for write */
    Tcl_Size numBytes;		/* Number of bytes of uncompressed data */
    Tcl_Size cursor;		/* Seek position for next read or write*/
    unsigned char *ubuf;	/* Pointer to the uncompressed data */
    unsigned char *ubufToFree;  /* NULL if ubuf points to memory that does not
				   need freeing. Else memory to free (ubuf
				   may point *inside* the block) */
    Tcl_Size ubufSize;		/* Size of allocated ubufToFree */
    int iscompr;                /* True if data is compressed */
    int isDirectory;		/* Set to 1 if directory, or -1 if root */
    int isEncrypted;		/* True if data is encrypted */
    int mode;			/* O_WRITE, O_APPEND, O_TRUNC etc.*/
    unsigned long keys[3];	/* Key for decryption */
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
    NULL, /* getCwdProc */
    NULL, /* chdirProc */
};

/*
 * The channel type/driver definition used for ZIP archive members.
 */

static Tcl_ChannelType ZipChannelType = {
    "zip",			/* Type name. */
    TCL_CHANNEL_VERSION_5,
    NULL,			/* Close channel, clean instance data */
    ZipChannelRead,		/* Handle read request */
    ZipChannelWrite,		/* Handle write request */
    NULL,			/* Move location of access point, NULL'able */
    NULL,			/* Set options, NULL'able */
    NULL,			/* Get options, NULL'able */
    ZipChannelWatchChannel,	/* Initialize notifier */
    ZipChannelGetFile,		/* Get OS handle from the channel */
    ZipChannelClose,		/* 2nd version of close channel, NULL'able */
    NULL,			/* Set blocking mode for raw channel,
				 * NULL'able */
    NULL,			/* Function to flush channel, NULL'able */
    NULL,			/* Function to handle event, NULL'able */
    ZipChannelWideSeek,		/* Wide seek function, NULL'able */
    NULL,			/* Thread action function, NULL'able */
    NULL,			/* Truncate function, NULL'able */
};

/*
 *------------------------------------------------------------------------
 *
 * TclIsZipfsPath --
 *
 *    Checks if the passed path has a zipfs volume prefix.
 *







<
|
|

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

|







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
    NULL, /* getCwdProc */
    NULL, /* chdirProc */
};

/*
 * The channel type/driver definition used for ZIP archive members.
 */

static const Tcl_ChannelType zipChannelType = {
    "zip",
    TCL_CHANNEL_VERSION_5,
    NULL,			/* Deprecated. */
    ZipChannelRead,
    ZipChannelWrite,
    NULL,			/* Deprecated. */
    NULL,			/* Set options proc. */
    NULL,			/* Get options proc. */
    ZipChannelWatchChannel,
    ZipChannelGetFile,
    ZipChannelClose,
    NULL,			/* Set blocking mode for raw channel. */

    NULL,			/* Function to flush channel. */
    NULL,			/* Function to handle bubbled events. */
    ZipChannelWideSeek,
    NULL,			/* Thread action function. */
    NULL,			/* Truncate function. */
};

/*
 *------------------------------------------------------------------------
 *
 * TclIsZipfsPath --
 *
 *    Checks if the passed path has a zipfs volume prefix.
 *
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
 *-------------------------------------------------------------------------
 */

static char *
DecodeZipEntryText(
    const unsigned char *inputBytes,
    unsigned int inputLength,
    Tcl_DString *dstPtr) /* Must have been initialized by caller! */
{
    Tcl_Encoding encoding;
    const char *src;
    char *dst;
    int dstLen, srcLen = inputLength, flags;
    Tcl_EncodingState state;








|







869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
 *-------------------------------------------------------------------------
 */

static char *
DecodeZipEntryText(
    const unsigned char *inputBytes,
    unsigned int inputLength,
    Tcl_DString *dstPtr)	/* Must have been initialized by caller! */
{
    Tcl_Encoding encoding;
    const char *src;
    char *dst;
    int dstLen, srcLen = inputLength, flags;
    Tcl_EncodingState state;

976
977
978
979
980
981
982
983

984
985
986
987
988
989
990
991
992
 * Results:
 *    TCL_OK on success with normalized mount path in dsPtr
 *    TCL_ERROR on fail with error message in interp if not NULL
 *
 *------------------------------------------------------------------------
 */
static int
NormalizeMountPoint(Tcl_Interp *interp,

		    const char *mountPath,
		    Tcl_DString *dsPtr) /* Must be initialized by caller! */
{
    const char *joiner[2];
    char *joinedPath;
    Tcl_Obj *unnormalizedObj;
    Tcl_Obj *normalizedObj;
    const char *normalizedPath;
    Tcl_Size normalizedLen;







|
>
|
|







974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
 * Results:
 *    TCL_OK on success with normalized mount path in dsPtr
 *    TCL_ERROR on fail with error message in interp if not NULL
 *
 *------------------------------------------------------------------------
 */
static int
NormalizeMountPoint(
    Tcl_Interp *interp,
    const char *mountPath,
    Tcl_DString *dsPtr)		/* Must be initialized by caller! */
{
    const char *joiner[2];
    char *joinedPath;
    Tcl_Obj *unnormalizedObj;
    Tcl_Obj *normalizedObj;
    const char *normalizedPath;
    Tcl_Size normalizedLen;
2226
2227
2228
2229
2230
2231
2232
2233

2234
2235
2236
2237
2238
2239
2240
 *    None.
 *
 * Side effects:
 *    Memory associated with the mounted archive is deallocated.
 *------------------------------------------------------------------------
 */
static void
CleanupMount(ZipFile *zf)        /* Mount point */

{
    ZipEntry *z, *znext;
    Tcl_HashEntry *hPtr;
    for (z = zf->entries; z; z = znext) {
	znext = z->next;
	hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name);
	if (hPtr) {







|
>







2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
 *    None.
 *
 * Side effects:
 *    Memory associated with the mounted archive is deallocated.
 *------------------------------------------------------------------------
 */
static void
CleanupMount(
    ZipFile *zf)		/* Mount point */
{
    ZipEntry *z, *znext;
    Tcl_HashEntry *hPtr;
    for (z = zf->entries; z; z = znext) {
	znext = z->next;
	hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name);
	if (hPtr) {
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
     * Wrap the ZipChannel into a Tcl_Channel.
     */

    snprintf(cname, sizeof(cname), "zipfs_%" TCL_Z_MODIFIER "x_%d", z->offset,
	    ZipFS.idCount++);
    z->zipFilePtr->numOpen++;
    Unlock();
    return Tcl_CreateChannel(&ZipChannelType, cname, info, flags);

  error:
    Unlock();
    return NULL;
}

/*







|







4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
     * Wrap the ZipChannel into a Tcl_Channel.
     */

    snprintf(cname, sizeof(cname), "zipfs_%" TCL_Z_MODIFIER "x_%d", z->offset,
	    ZipFS.idCount++);
    z->zipFilePtr->numOpen++;
    Unlock();
    return Tcl_CreateChannel(&zipChannelType, cname, info, flags);

  error:
    Unlock();
    return NULL;
}

/*

Changes to generic/tclZlib.c.

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
/*
 * Type of zlib-based compressing and decompressing channels.
 */

static const Tcl_ChannelType zlibChannelType = {
    "zlib",
    TCL_CHANNEL_VERSION_5,
    NULL,
    ZlibTransformInput,
    ZlibTransformOutput,
    NULL,			/* seekProc */
    ZlibTransformSetOption,
    ZlibTransformGetOption,
    ZlibTransformWatch,
    ZlibTransformGetHandle,
    ZlibTransformClose,		/* close2Proc */
    ZlibTransformBlockMode,
    NULL,			/* flushProc */
    ZlibTransformEventHandler,
    NULL,			/* wideSeekProc */
    NULL,
    NULL
};

/*
 *----------------------------------------------------------------------
 *
 * Latin1 --
 *	Helper to definitely get the ISO 8859-1 encoding. It's internally







|


|




|

|

|
|
|







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
/*
 * Type of zlib-based compressing and decompressing channels.
 */

static const Tcl_ChannelType zlibChannelType = {
    "zlib",
    TCL_CHANNEL_VERSION_5,
    NULL,			/* Deprecated. */
    ZlibTransformInput,
    ZlibTransformOutput,
    NULL,			/* Deprecated. */
    ZlibTransformSetOption,
    ZlibTransformGetOption,
    ZlibTransformWatch,
    ZlibTransformGetHandle,
    ZlibTransformClose,
    ZlibTransformBlockMode,
    NULL,			/* Flush proc. */
    ZlibTransformEventHandler,
    NULL,			/* Seek proc. */
    NULL,			/* Thread action proc. */
    NULL			/* Truncate proc. */
};

/*
 *----------------------------------------------------------------------
 *
 * Latin1 --
 *	Helper to definitely get the ISO 8859-1 encoding. It's internally
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
	return inProc(Tcl_GetChannelInstanceData(chanDataPtr->parent), buf,
		toRead, errorCodePtr);
    }

    gotBytes = 0;
    readBytes = chanDataPtr->inStream.avail_in; /* how many bytes in buffer now */
    while (!HaveFlag(chanDataPtr, STREAM_DONE) && toRead > 0) {
    	unsigned int n;
	int decBytes;

	/* if starting from scratch or continuation after full decompression */
	if (!chanDataPtr->inStream.avail_in) {
	    /* buffer to start, we can read to whole available buffer */
	    chanDataPtr->inStream.next_in = (Bytef *) chanDataPtr->inBuffer;
	}







|







3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
	return inProc(Tcl_GetChannelInstanceData(chanDataPtr->parent), buf,
		toRead, errorCodePtr);
    }

    gotBytes = 0;
    readBytes = chanDataPtr->inStream.avail_in; /* how many bytes in buffer now */
    while (!HaveFlag(chanDataPtr, STREAM_DONE) && toRead > 0) {
	unsigned int n;
	int decBytes;

	/* if starting from scratch or continuation after full decompression */
	if (!chanDataPtr->inStream.avail_in) {
	    /* buffer to start, we can read to whole available buffer */
	    chanDataPtr->inStream.next_in = (Bytef *) chanDataPtr->inBuffer;
	}

Changes to library/auto.tcl.

41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
# tcl_findLibrary --
#
#	This is a utility for extensions that searches for a library directory
#	using a canonical searching algorithm. A side effect is to source the
#	initialization script and set a global library variable.
#
# Arguments:
# 	basename	Prefix of the directory name, (e.g., "tk")
#	version		Version number of the package, (e.g., "8.0")
#	patch		Patchlevel of the package, (e.g., "8.0.3")
#	initScript	Initialization script to source (e.g., tk.tcl)
#	enVarName	environment variable to honor (e.g., TK_LIBRARY)
#	varName		Global variable to set when done (e.g., tk_library)

proc tcl_findLibrary {basename version patch initScript enVarName varName} {







|







41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
# tcl_findLibrary --
#
#	This is a utility for extensions that searches for a library directory
#	using a canonical searching algorithm. A side effect is to source the
#	initialization script and set a global library variable.
#
# Arguments:
#	basename	Prefix of the directory name, (e.g., "tk")
#	version		Version number of the package, (e.g., "8.0")
#	patch		Patchlevel of the package, (e.g., "8.0.3")
#	initScript	Initialization script to source (e.g., tk.tcl)
#	enVarName	environment variable to honor (e.g., TK_LIBRARY)
#	varName		Global variable to set when done (e.g., tk_library)

proc tcl_findLibrary {basename version patch initScript enVarName varName} {
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
			} elseif {[zipfs exists [file join $mountpoint $initScript]]} {
			    lappend dirs [file join $mountpoint $initScript]
			    set found 1
			    break
			} else {
			    catch {zipfs unmount $mountpoint}
			}
	      	    }
		}
	    }
	}

	# 2. In the package script directory registered within the
	#    configuration of the package itself.








|







126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
			} elseif {[zipfs exists [file join $mountpoint $initScript]]} {
			    lappend dirs [file join $mountpoint $initScript]
			    set found 1
			    break
			} else {
			    catch {zipfs unmount $mountpoint}
			}
		    }
		}
	    }
	}

	# 2. In the package script directory registered within the
	#    configuration of the package itself.

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
#
# This procedure allows extensions to register their own commands with the
# auto_mkindex facility.  For example, a package like [incr Tcl] might
# register a "class" command so that class definitions could be added to a
# "tclIndex" file for auto-loading.
#
# Arguments:
#	name 	Name of command recognized in Tcl files.
#	arglist	Argument list for command.
#	body 	Implementation of command to handle indexing.

proc auto_mkindex_parser::command {name arglist body} {
    hook [list auto_mkindex_parser::commandInit $name $arglist $body]
}

# auto_mkindex_parser::commandInit --
#
# This does the actual work set up by auto_mkindex_parser::command. This is
# called when the interpreter used by the parser is created.
#
# Arguments:
#	name 	Name of command recognized in Tcl files.
#	arglist	Argument list for command.
#	body 	Implementation of command to handle indexing.

proc auto_mkindex_parser::commandInit {name arglist body} {
    variable parser

    set ns [namespace qualifiers $name]
    set tail [namespace tail $name]
    if {$ns eq ""} {







|

|











|

|







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
#
# This procedure allows extensions to register their own commands with the
# auto_mkindex facility.  For example, a package like [incr Tcl] might
# register a "class" command so that class definitions could be added to a
# "tclIndex" file for auto-loading.
#
# Arguments:
#	name	Name of command recognized in Tcl files.
#	arglist	Argument list for command.
#	body	Implementation of command to handle indexing.

proc auto_mkindex_parser::command {name arglist body} {
    hook [list auto_mkindex_parser::commandInit $name $arglist $body]
}

# auto_mkindex_parser::commandInit --
#
# This does the actual work set up by auto_mkindex_parser::command. This is
# called when the interpreter used by the parser is created.
#
# Arguments:
#	name	Name of command recognized in Tcl files.
#	arglist	Argument list for command.
#	body	Implementation of command to handle indexing.

proc auto_mkindex_parser::commandInit {name arglist body} {
    variable parser

    set ns [namespace qualifiers $name]
    set tail [namespace tail $name]
    if {$ns eq ""} {

Changes to library/clock.tcl.

136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
	}
	LOCALE_TIME_FORMAT {%H:%M:%S}
	LOCALE_YEAR_FORMAT {%EC%Ey}
	MONTHS_ABBREV		{
	    Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
	}
	MONTHS_FULL		{
	    	January		February	March
	    	April		May		June
	    	July		August		September
		October		November	December
	}
	PM {pm}
	TIME_FORMAT {%H:%M:%S}
	TIME_FORMAT_12 {%I:%M:%S %P}
	TIME_FORMAT_24 {%H:%M}
	TIME_FORMAT_24_SECS {%H:%M:%S}







|
|
|







136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
	}
	LOCALE_TIME_FORMAT {%H:%M:%S}
	LOCALE_YEAR_FORMAT {%EC%Ey}
	MONTHS_ABBREV		{
	    Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
	}
	MONTHS_FULL		{
		January		February	March
		April		May		June
		July		August		September
		October		November	December
	}
	PM {pm}
	TIME_FORMAT {%H:%M:%S}
	TIME_FORMAT_12 {%I:%M:%S %P}
	TIME_FORMAT_24 {%H:%M}
	TIME_FORMAT_24_SECS {%H:%M:%S}
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
    # Translation table to map Windows TZI onto cities, so that the Olson
    # rules can apply.  In some cases the mapping is ambiguous, so it's wise
    # to specify $::env(TCL_TZ) rather than simply depending on the system
    # time zone.

    # The keys are long lists of values obtained from the time zone
    # information in the Registry.  In order, the list elements are:
    # 	Bias StandardBias DaylightBias
    #   StandardDate.wYear StandardDate.wMonth StandardDate.wDayOfWeek
    #   StandardDate.wDay StandardDate.wHour StandardDate.wMinute
    #   StandardDate.wSecond StandardDate.wMilliseconds
    #   DaylightDate.wYear DaylightDate.wMonth DaylightDate.wDayOfWeek
    #   DaylightDate.wDay DaylightDate.wHour DaylightDate.wMinute
    #   DaylightDate.wSecond DaylightDate.wMilliseconds
    # The values are the names of time zones where those rules apply.  There







|







288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
    # Translation table to map Windows TZI onto cities, so that the Olson
    # rules can apply.  In some cases the mapping is ambiguous, so it's wise
    # to specify $::env(TCL_TZ) rather than simply depending on the system
    # time zone.

    # The keys are long lists of values obtained from the time zone
    # information in the Registry.  In order, the list elements are:
    #   Bias StandardBias DaylightBias
    #   StandardDate.wYear StandardDate.wMonth StandardDate.wDayOfWeek
    #   StandardDate.wDay StandardDate.wHour StandardDate.wMinute
    #   StandardDate.wSecond StandardDate.wMilliseconds
    #   DaylightDate.wYear DaylightDate.wMonth DaylightDate.wDayOfWeek
    #   DaylightDate.wDay DaylightDate.wHour DaylightDate.wMinute
    #   DaylightDate.wSecond DaylightDate.wMilliseconds
    # The values are the names of time zones where those rules apply.  There
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
	{-3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Atlantic/Cape_Verde
	{0 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}       :UTC
	{0 0 3600 0 10 0 5 2 0 0 0 0 3 0 5 1 0 0 0}      :Europe/London
	{3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}    :Africa/Kinshasa
	{3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0}   :CET
	{7200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}    :Africa/Harare
	{7200 0 3600 0 9 4 5 23 59 59 0 0 4 4 5 23 59 59 0}
			      				 :Africa/Cairo
	{7200 0 3600 0 10 0 5 4 0 0 0 0 3 0 5 3 0 0 0}   :Europe/Helsinki
	{7200 0 3600 0 9 0 3 2 0 0 0 0 3 5 5 2 0 0 0}    :Asia/Jerusalem
	{7200 0 3600 0 9 0 5 1 0 0 0 0 3 0 5 0 0 0 0}    :Europe/Bucharest
	{7200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0}   :Europe/Athens
	{7200 0 3600 0 9 5 5 1 0 0 0 0 3 4 5 0 0 0 0}    :Asia/Amman
	{7200 0 3600 0 10 6 5 23 59 59 999 0 3 0 5 0 0 0 0}
							 :Asia/Beirut







|







335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
	{-3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Atlantic/Cape_Verde
	{0 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}       :UTC
	{0 0 3600 0 10 0 5 2 0 0 0 0 3 0 5 1 0 0 0}      :Europe/London
	{3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}    :Africa/Kinshasa
	{3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0}   :CET
	{7200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}    :Africa/Harare
	{7200 0 3600 0 9 4 5 23 59 59 0 0 4 4 5 23 59 59 0}
							 :Africa/Cairo
	{7200 0 3600 0 10 0 5 4 0 0 0 0 3 0 5 3 0 0 0}   :Europe/Helsinki
	{7200 0 3600 0 9 0 3 2 0 0 0 0 3 5 5 2 0 0 0}    :Asia/Jerusalem
	{7200 0 3600 0 9 0 5 1 0 0 0 0 3 0 5 0 0 0 0}    :Europe/Bucharest
	{7200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0}   :Europe/Athens
	{7200 0 3600 0 9 5 5 1 0 0 0 0 3 4 5 0 0 0 0}    :Asia/Amman
	{7200 0 3600 0 10 6 5 23 59 59 999 0 3 0 5 0 0 0 0}
							 :Asia/Beirut
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
    ]

    # Caches

    variable LocFmtMap [dict create];	# Dictionary with localized format maps

    variable TimeZoneBad [dict create]; # Dictionary whose keys are time zone
    					# names and whose values are 1 if
					# the time zone is unknown and 0
    					# if it is known.
    variable TZData;			# Array whose keys are time zone names
					# and whose values are lists of quads
					# comprising start time, UTC offset,
					# Daylight Saving Time indicator, and
					# time zone abbreviation.

    variable mcLocales	 [dict create];	# Dictionary with loaded locales







|

|







476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
    ]

    # Caches

    variable LocFmtMap [dict create];	# Dictionary with localized format maps

    variable TimeZoneBad [dict create]; # Dictionary whose keys are time zone
					# names and whose values are 1 if
					# the time zone is unknown and 0
					# if it is known.
    variable TZData;			# Array whose keys are time zone names
					# and whose values are lists of quads
					# comprising start time, UTC offset,
					# Daylight Saving Time indicator, and
					# time zone abbreviation.

    variable mcLocales	 [dict create];	# Dictionary with loaded locales
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
    variable mcMergedCat
    switch -- $loc system {
	set loc [GetSystemLocale]
    } current {
	set loc [mclocale]
    }
    if {$loc ne {}} {
    	set loc [string tolower $loc]
    }

    # try to retrieve now if already available:
    if {[dict exists $mcMergedCat $loc]} {
	return [dict get $mcMergedCat $loc]
    }








|







514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
    variable mcMergedCat
    switch -- $loc system {
	set loc [GetSystemLocale]
    } current {
	set loc [mclocale]
    }
    if {$loc ne {}} {
	set loc [string tolower $loc]
    }

    # try to retrieve now if already available:
    if {[dict exists $mcMergedCat $loc]} {
	return [dict get $mcMergedCat $loc]
    }

647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
# Side effects:
#	Does [mclocale].  If necessary, loades the designated locale's files.
#
#----------------------------------------------------------------------

proc ::tcl::clock::EnterLocale { locale } {
    switch -- $locale system {
    	set locale [GetSystemLocale]
    } current {
	set locale [mclocale]
    }
    # Select the locale, eventually load it
    mcpackagelocale set $locale
    return $locale
}







|







647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
# Side effects:
#	Does [mclocale].  If necessary, loades the designated locale's files.
#
#----------------------------------------------------------------------

proc ::tcl::clock::EnterLocale { locale } {
    switch -- $locale system {
	set locale [GetSystemLocale]
    } current {
	set locale [mclocale]
    }
    # Select the locale, eventually load it
    mcpackagelocale set $locale
    return $locale
}
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
	    if {
		[catch {
		    LoadTimeZoneFile [string range $timezone 1 end]
		}] && [catch {
		    LoadZoneinfoFile [string range $timezone 1 end]
		}]
	    } then {
	    	dict set TimeZoneBad $timezone 1
		return -code error \
		    -errorcode [list CLOCK badTimeZone $timezone] \
		    "time zone \"$timezone\" not found"
	    }
	} elseif { ![catch {ParsePosixTimeZone $timezone} tzfields] } {
	    # This looks like a POSIX time zone - try to process it








|







997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
	    if {
		[catch {
		    LoadTimeZoneFile [string range $timezone 1 end]
		}] && [catch {
		    LoadZoneinfoFile [string range $timezone 1 end]
		}]
	    } then {
		dict set TimeZoneBad $timezone 1
		return -code error \
		    -errorcode [list CLOCK badTimeZone $timezone] \
		    "time zone \"$timezone\" not found"
	    }
	} elseif { ![catch {ParsePosixTimeZone $timezone} tzfields] } {
	    # This looks like a POSIX time zone - try to process it

Changes to library/history.tcl.

85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
#	Add an item to the history, and optionally eval it at the global scope
#
# Parameters:
#	event		the command to add
#	exec		(optional) a substring of "exec" causes the command to
#			be evaled.
# Results:
# 	If executing, then the results of the command are returned
#
# Side Effects:
#	Adds to the history list

proc ::tcl::HistAdd {event {exec {}}} {
    variable history








|







85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
#	Add an item to the history, and optionally eval it at the global scope
#
# Parameters:
#	event		the command to add
#	exec		(optional) a substring of "exec" causes the command to
#			be evaled.
# Results:
#	If executing, then the results of the command are returned
#
# Side Effects:
#	Adds to the history list

proc ::tcl::HistAdd {event {exec {}}} {
    variable history

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
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
	# later, OR https handshake error, which may be discovered as late as
	# the "flush" command above...
	Log "WARNING - if testing, pay special attention to this\
		case (GI) which is seldom executed - token $token"
	if {[info exists state(reusing)] && $state(reusing)} {
	    # The socket was closed at the server end, and closed at
	    # this end by http::CheckEof.
    	    if {[TestForReplay $token write $err a]} {
		return
	    } else {
		Finish $token {failed to re-use socket}
	    }

	    # else:
	    # This is NOT a persistent socket that has been closed since its







|







2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
	# later, OR https handshake error, which may be discovered as late as
	# the "flush" command above...
	Log "WARNING - if testing, pay special attention to this\
		case (GI) which is seldom executed - token $token"
	if {[info exists state(reusing)] && $state(reusing)} {
	    # The socket was closed at the server end, and closed at
	    # this end by http::CheckEof.
	    if {[TestForReplay $token write $err a]} {
		return
	    } else {
		Finish $token {failed to re-use socket}
	    }

	    # else:
	    # This is NOT a persistent socket that has been closed since its
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
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
	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
}

# http::Connect
#
#	This callback is made when an asynchronous connection completes.
#
# Arguments
#	token	The token returned from http::geturl
#
# Side Effects
#	Sets the status of the connection, which unblocks
# 	the waiting geturl call

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.







|
|
|
















|







|

|

|







3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
	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
}

# http::Connect
#
#	This callback is made when an asynchronous connection completes.
#
# Arguments
#	token	The token returned from http::geturl
#
# Side Effects
#	Sets the status of the connection, which unblocks
#	the waiting geturl call

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
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
	    catch {chan event $chan readable {}}
	    return
	}
    }
}

# http::SplitCommaSeparatedFieldValue --
# 	Return the individual values of a comma-separated field value.
#
# Arguments:
#	fieldValue	Comma-separated header field value.
#
# Results:
#       List of values.
proc http::SplitCommaSeparatedFieldValue {fieldValue} {
    set r {}
    foreach el [split $fieldValue ,] {
	lappend r [string trim $el]
    }
    return $r
}


# http::GetFieldValue --
# 	Return the value of a header field.
#
# Arguments:
#	headers	Headers key-value list
#	fieldName	Name of header field whose value to return.
#
# Results:
#       The value of the fieldName header field







|
















|







4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
	    catch {chan event $chan readable {}}
	    return
	}
    }
}

# http::SplitCommaSeparatedFieldValue --
#	Return the individual values of a comma-separated field value.
#
# Arguments:
#	fieldValue	Comma-separated header field value.
#
# Results:
#       List of values.
proc http::SplitCommaSeparatedFieldValue {fieldValue} {
    set r {}
    foreach el [split $fieldValue ,] {
	lappend r [string trim $el]
    }
    return $r
}


# http::GetFieldValue --
#	Return the value of a header field.
#
# Arguments:
#	headers	Headers key-value list
#	fieldName	Name of header field whose value to return.
#
# Results:
#       The value of the fieldName header field
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
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
			# $file was not readable; silently ignore
			continue
		    } on error msg {
			if {[regexp {version conflict for package} $msg]} {
			    # In case of version conflict, silently ignore
			    continue
			}
    			tclLog "error reading package index file $file: $msg"
		    } on ok {} {
			set procdDirs($dir) 1
		    }
		}
	    }
	}
	set dir [lindex $use_path end]







|







500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
			# $file was not readable; silently ignore
			continue
		    } on error msg {
			if {[regexp {version conflict for package} $msg]} {
			    # In case of version conflict, silently ignore
			    continue
			}
			tclLog "error reading package index file $file: $msg"
		    } on ok {} {
			set procdDirs($dir) 1
		    }
		}
	    }
	}
	set dir [lindex $use_path end]
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
		try {
		    ::tcl::Pkg::source $file
		} trap {POSIX EACCES} {} {
		    # $file was not readable; silently ignore
		    continue
		} on error msg {
		    if {[regexp {version conflict for package} $msg]} {
		 	# In case of version conflict, silently ignore
			continue
		    }
		    tclLog "error reading package index file $file: $msg"
		} on ok {} {
		    set procdDirs($dir) 1
		}
	    }







|







608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
		try {
		    ::tcl::Pkg::source $file
		} trap {POSIX EACCES} {} {
		    # $file was not readable; silently ignore
		    continue
		} on error msg {
		    if {[regexp {version conflict for package} $msg]} {
			# In case of version conflict, silently ignore
			continue
		    }
		    tclLog "error reading package index file $file: $msg"
		} on ok {} {
		    set procdDirs($dir) 1
		}
	    }

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
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
    set maxtries 10
    set access [list RDWR CREAT EXCL TRUNC]
    set permission 0600
    set channel ""
    set checked_dir_writable 0
    set mypid [pid]
    for {set i 0} {$i < $maxtries} {incr i} {
 	set newname $prefix
 	for {set j 0} {$j < $nrand_chars} {incr j} {
 	    append newname [string index $chars \
		    [expr {int(rand()*62)}]]
 	}
	set newname [file join $tmpdir $newname]
 	if {[file exists $newname]} {
 	    after 1
 	} else {
 	    if {[catch {open $newname $access $permission} channel]} {
 		if {!$checked_dir_writable} {
 		    set dirname [file dirname $newname]
 		    if {![file writable $dirname]} {
 			return -code error "Directory $dirname is not writable"
 		    }
 		    set checked_dir_writable 1
 		}
 	    } else {
 		# Success
		close $channel
 		return [file normalize $newname]
 	    }
 	}
    }
    if {$channel ne ""} {
 	return -code error "Failed to open a temporary file: $channel"
    } else {
 	return -code error "Failed to find an unused temporary file name"
    }
}

proc ::platform::shell::DIR {} {
    # This code is copied out of Tcllib's fileutil package.
    # (TempDir/tempdir)








|
|
|

|

|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|


|

|







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
    set maxtries 10
    set access [list RDWR CREAT EXCL TRUNC]
    set permission 0600
    set channel ""
    set checked_dir_writable 0
    set mypid [pid]
    for {set i 0} {$i < $maxtries} {incr i} {
	set newname $prefix
	for {set j 0} {$j < $nrand_chars} {incr j} {
	    append newname [string index $chars \
		    [expr {int(rand()*62)}]]
	}
	set newname [file join $tmpdir $newname]
	if {[file exists $newname]} {
	    after 1
	} else {
	    if {[catch {open $newname $access $permission} channel]} {
		if {!$checked_dir_writable} {
		set dirname [file dirname $newname]
		    if {![file writable $dirname]} {
			return -code error "Directory $dirname is not writable"
		    }
		    set checked_dir_writable 1
		}
	    } else {
		# Success
		close $channel
		return [file normalize $newname]
	    }
	}
    }
    if {$channel ne ""} {
	return -code error "Failed to open a temporary file: $channel"
    } else {
	return -code error "Failed to find an unused temporary file name"
    }
}

proc ::platform::shell::DIR {} {
    # This code is copied out of Tcllib's fileutil package.
    # (TempDir/tempdir)

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.

511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
		    return -code error $msg
		} else {
		    set Option($option) $msg
		}
		unset $varName
	    }
	    namespace eval [namespace current] \
	    	    [list upvar 0 Option($option) $varName]
	    # Workaround for Bug (now Feature Request) 572889.  Grrrr....
	    # Track all the variables tied to options
	    lappend OptionControlledVariables $varName
	    # Later, set auto-configure read traces on all
	    # of them, since a single trace on Option does not work.
	    proc $varName {{value {}}} [subst -nocommands {
		if {[llength [info level 0]] == 2} {







|







511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
		    return -code error $msg
		} else {
		    set Option($option) $msg
		}
		unset $varName
	    }
	    namespace eval [namespace current] \
		    [list upvar 0 Option($option) $varName]
	    # Workaround for Bug (now Feature Request) 572889.  Grrrr....
	    # Track all the variables tied to options
	    lappend OptionControlledVariables $varName
	    # Later, set auto-configure read traces on all
	    # of them, since a single trace on Option does not work.
	    proc $varName {{value {}}} [subst -nocommands {
		if {[llength [info level 0]] == 2} {
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
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 --
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
#			previously registered by a call to [customMatch].
#			The strings exact, glob, and regexp are preregistered
#			by the tcltest package.  Default value is exact.
#
# Arguments:
#   name -		Name of test, in the form foo-1.2.
#   description -	Short textual description of the test, to
#  		  	help humans understand what it does.
#
# Results:
#	None.
#
# Side effects:
#       Just about anything is possible depending on the test.
#







|







1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
#			previously registered by a call to [customMatch].
#			The strings exact, glob, and regexp are preregistered
#			by the tcltest package.  Default value is exact.
#
# Arguments:
#   name -		Name of test, in the form foo-1.2.
#   description -	Short textual description of the test, to
#			help humans understand what it does.
#
# Results:
#	None.
#
# Side effects:
#       Just about anything is possible depending on the 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
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
	    set errorFailure 1
	}
    }

    # check if the answer matched the expected answer
    # Only check if we ran the body of the test (no setup failure)
    if {!$processTest} {
    	set scriptFailure 0
    } elseif {$setupFailure || $codeFailure} {
	set scriptFailure 0
    } elseif {[set scriptCompare [catch {
	CompareStrings $actualAnswer $result $match
    } scriptMatch]] == 0} {
	set scriptFailure [expr {!$scriptMatch}]
    } else {







|







2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
	    set errorFailure 1
	}
    }

    # check if the answer matched the expected answer
    # Only check if we ran the body of the test (no setup failure)
    if {!$processTest} {
	set scriptFailure 0
    } elseif {$setupFailure || $codeFailure} {
	set scriptFailure 0
    } elseif {[set scriptCompare [catch {
	CompareStrings $actualAnswer $result $match
    } scriptMatch]] == 0} {
	set scriptFailure [expr {!$scriptMatch}]
    } else {
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 macosx/tclMacOSXNotify.c.

1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
    if (tsdPtr->runLoop) {
	CFTimeInterval waitTime;
	CFRunLoopTimerRef runLoopTimer = tsdPtr->runLoopTimer;
	CFAbsoluteTime nextTimerFire = 0, waitEnd, now;
	SInt32 runLoopStatus;

	waitTime = vdelay.sec + 1.0e-6 * vdelay.usec;
 	now = CFAbsoluteTimeGetCurrent();
	waitEnd = now + waitTime;

	if (runLoopTimer) {
	    nextTimerFire = CFRunLoopTimerGetNextFireDate(runLoopTimer);
	    if (nextTimerFire < waitEnd) {
		CFRunLoopTimerSetNextFireDate(runLoopTimer, now +
			CF_TIMEINTERVAL_FOREVER);







|







1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
    if (tsdPtr->runLoop) {
	CFTimeInterval waitTime;
	CFRunLoopTimerRef runLoopTimer = tsdPtr->runLoopTimer;
	CFAbsoluteTime nextTimerFire = 0, waitEnd, now;
	SInt32 runLoopStatus;

	waitTime = vdelay.sec + 1.0e-6 * vdelay.usec;
	now = CFAbsoluteTimeGetCurrent();
	waitEnd = now + waitTime;

	if (runLoopTimer) {
	    nextTimerFire = CFRunLoopTimerGetNextFireDate(runLoopTimer);
	    if (nextTimerFire < waitEnd) {
		CFRunLoopTimerSetNextFireDate(runLoopTimer, now +
			CF_TIMEINTERVAL_FOREVER);
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
		break;
	    case kCFRunLoopRunTimedOut:
		waitTime = 0;
		break;
	    }
	} while (waitTime > 0);
	tsdPtr->sleeping = 0;
 	if (runLoopTimer) {
	    CFRunLoopTimerSetNextFireDate(runLoopTimer, nextTimerFire);
	}
    } else {
	struct timespec waitTime;

	waitTime.tv_sec = vdelay.sec;
	waitTime.tv_nsec = vdelay.usec * 1000;







|







1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
		break;
	    case kCFRunLoopRunTimedOut:
		waitTime = 0;
		break;
	    }
	} while (waitTime > 0);
	tsdPtr->sleeping = 0;
	if (runLoopTimer) {
	    CFRunLoopTimerSetNextFireDate(runLoopTimer, nextTimerFire);
	}
    } else {
	struct timespec waitTime;

	waitTime.tv_sec = vdelay.sec;
	waitTime.tv_nsec = vdelay.usec * 1000;

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/indexObj.test.

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]

testConstraint testindexobj [llength [info commands testindexobj]]
testConstraint testgetintforindex [llength [info commands testgetintforindex]]
testConstraint testparseargs [llength [info commands testparseargs]]
testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}]
testConstraint has32BitLengths [expr {$tcl_platform(pointerSize) == 4}]

test indexObj-1.1 {exact match} testindexobj {
    testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} testindexobj {
    testindexobj 1 1 abc abc def xyz alm
} {0}







<







16
17
18
19
20
21
22

23
24
25
26
27
28
29
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]

testConstraint testindexobj [llength [info commands testindexobj]]
testConstraint testgetintforindex [llength [info commands testgetintforindex]]
testConstraint testparseargs [llength [info commands testparseargs]]
testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}]


test indexObj-1.1 {exact match} testindexobj {
    testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} testindexobj {
    testindexobj 1 1 abc abc def xyz alm
} {0}
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
} -3
test indexObj-8.12 {Tcl_GetIntForIndex end} testgetintforindex {
    testgetintforindex end -1
} -1
test indexObj-8.13 {Tcl_GetIntForIndex end} testgetintforindex {
    testgetintforindex end -2
} -2
test indexObj-8.14 {Tcl_GetIntForIndex end+1} -constraints {
    testgetintforindex has64BitLengths



} -body {

    testgetintforindex end+1 -1
} -result 9223372036854775807
test indexObj-8.14.32bits {Tcl_GetIntForIndex end+1} -constraints {
    testgetintforindex has32BitLengths
} -body {


    testgetintforindex end+1 -1
} -result 2147483647
test indexObj-8.15 {Tcl_GetIntForIndex end+1} testgetintforindex {
    testgetintforindex end+1 -2
} -1

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:







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









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
} -3
test indexObj-8.12 {Tcl_GetIntForIndex end} testgetintforindex {
    testgetintforindex end -1
} -1
test indexObj-8.13 {Tcl_GetIntForIndex end} testgetintforindex {
    testgetintforindex end -2
} -2
test indexObj-8.14 {Tcl_GetIntForIndex end+1} testgetintforindex {
    testgetintforindex end+1 -1
} [expr {[testConstraint has64BitLengths] ? 9223372036854775807 : 2147483647}]
test indexObj-8.15 {Tcl_GetIntForIndex end+1} testgetintforindex {
    testgetintforindex end+1 -2
} -1
test indexObj-8.16 {Tcl_GetIntForIndex integer} testgetintforindex {
    testgetintforindex -1 -1
} [expr {[testConstraint has64BitLengths] ? -9223372036854775808 : -2147483648}]
test indexObj-8.17 {Tcl_GetIntForIndex integer} testgetintforindex {
    testgetintforindex -2 -1

} [expr {[testConstraint has64BitLengths] ? -9223372036854775808 : -2147483648}]
test indexObj-8.18 {Tcl_GetIntForIndex n-m} testgetintforindex {
    testgetintforindex 2-3 -1
} [expr {[testConstraint has64BitLengths] ? -9223372036854775808 : -2147483648}]
test indexObj-8.19 {Tcl_GetIntForIndex n-m} testgetintforindex {
    testgetintforindex 2-3 0
} -1

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to tests/interp.test.

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

::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]

testConstraint testinterpdelete [llength [info commands testinterpdelete]]

set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload}

proc _ms_limit_args {ms {t0 {}}} {
    if {$t0 eq {}} { set t0 [clock milliseconds] }
    incr t0 $ms
    list -seconds [expr {$t0 / 1000}] -milliseconds [expr {$t0 % 1000}]
}








|







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

::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]

testConstraint testinterpdelete [llength [info commands testinterpdelete]]

set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:home tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:tildeexpand tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload}

proc _ms_limit_args {ms {t0 {}}} {
    if {$t0 eq {}} { set t0 [clock milliseconds] }
    incr t0 $ms
    list -seconds [expr {$t0 / 1000}] -milliseconds [expr {$t0 % 1000}]
}

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/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 tools/index.tcl.

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

# Global variables used by these scripts:
#
# state -	state variable that controls action of text proc.
#
# topics -	array indexed by (package,section,topic) with value
# 		of topic ID.
#
# keywords -	array indexed by keyword string with value of topic ID.
#
# curID - 	current topic ID, starts at 0 and is incremented for
# 		each new topic file.
#
# curPkg -	current package name (e.g. Tcl).
#
# curSect -	current section title (e.g. "Tcl Built-In Commands").
#

# getPackages --







|



|
|







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

# Global variables used by these scripts:
#
# state -	state variable that controls action of text proc.
#
# topics -	array indexed by (package,section,topic) with value
#		of topic ID.
#
# keywords -	array indexed by keyword string with value of topic ID.
#
# curID -	current topic ID, starts at 0 and is incremented for
#		each new topic file.
#
# curPkg -	current package name (e.g. Tcl).
#
# curSect -	current section title (e.g. "Tcl Built-In Commands").
#

# getPackages --

Changes to tools/makeTestCases.tcl.

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
proc testcases2 { f2 } {

    listYears startOfYear

    # Define the roman numerals

    set roman {
 	? i ii iii iv v vi vii viii ix
	x xi xii xiii xiv xv xvi xvii xviii xix
	xx xxi xxii xxiii xxiv xxv xxvi xxvii xxviii xxix
	xxx xxxi xxxii xxxiii xxxiv xxxv xxxvi xxxvii xxxviii xxxix
	xl xli xlii xliii xliv xlv xlvi xlvii xlviii xlix
	l li lii liii liv lv lvi lvii lviii lix
	lx lxi lxii lxiii lxiv lxv lxvi lxvii lxviii lxix
	lxx lxxi lxxii lxxiii lxxiv lxxv lxxvi lxxvii lxxviii lxxix
	lxxx lxxxi lxxxii lxxxiii lxxxiv lxxxv lxxxvi lxxxvii lxxxviii lxxxix
	xc xci xcii xciii xciv xcv xcvi xcvii xcviii xcix
	c
    }
    set romanc {
 	? c cc ccc cd d dc dcc dccc cm
	m mc mcc mccc mcd md mdc mdcc mdccc mcm
	mm mmc mmcc mmccc mmcd mmd mmdc mmdcc mmdccc mmcm
	mmm mmmc mmmcc mmmccc mmmcd mmmd mmmdc mmmdcc mmmdccc mmmcm
    }

    # Names of the months








|












|







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
proc testcases2 { f2 } {

    listYears startOfYear

    # Define the roman numerals

    set roman {
	? i ii iii iv v vi vii viii ix
	x xi xii xiii xiv xv xvi xvii xviii xix
	xx xxi xxii xxiii xxiv xxv xxvi xxvii xxviii xxix
	xxx xxxi xxxii xxxiii xxxiv xxxv xxxvi xxxvii xxxviii xxxix
	xl xli xlii xliii xliv xlv xlvi xlvii xlviii xlix
	l li lii liii liv lv lvi lvii lviii lix
	lx lxi lxii lxiii lxiv lxv lxvi lxvii lxviii lxix
	lxx lxxi lxxii lxxiii lxxiv lxxv lxxvi lxxvii lxxviii lxxix
	lxxx lxxxi lxxxii lxxxiii lxxxiv lxxxv lxxxvi lxxxvii lxxxviii lxxxix
	xc xci xcii xciii xciv xcv xcvi xcvii xcviii xcix
	c
    }
    set romanc {
	? c cc ccc cd d dc dcc dccc cm
	m mc mcc mccc mcd md mdc mdcc mdccc mcm
	mm mmc mmcc mmccc mmcd mmd mmdc mmdcc mmdccc mmcm
	mmm mmmc mmmcc mmmccc mmmcd mmmd mmmdc mmmdcc mmmdccc mmmcm
    }

    # Names of the months

Changes to tools/tclOOScript.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
# tclOOScript.h --
#
# 	This file contains support scripts for TclOO. They are defined here so
# 	that the code can be definitely run even in safe interpreters; TclOO's
# 	core setup is safe.
#
# Copyright © 2012-2019 Donal K. Fellows
# Copyright © 2013 Andreas Kupries
# Copyright © 2017 Gerald Lester
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.


|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
# tclOOScript.h --
#
#	This file contains support scripts for TclOO. They are defined here so
#	that the code can be definitely run even in safe interpreters; TclOO's
#	core setup is safe.
#
# Copyright © 2012-2019 Donal K. Fellows
# Copyright © 2013 Andreas Kupries
# Copyright © 2017 Gerald Lester
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

Changes to tools/tcltk-man2html.tcl.

606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
    wide()      mathfunc
    packagens   pkg::create
    pkgMkIndex  pkg_mkIndex
    pkg_mkIndex pkg_mkIndex
    Tcl_Obj     Tcl_NewObj
    Tcl_ObjType Tcl_RegisterObjType
    Tcl_OpenFileChannelProc Tcl_FSOpenFileChannel
    errorinfo 	env
    errorcode 	env
    tcl_pkgpath env
    Tcl_Command Tcl_CreateObjCommand
    Tcl_CmdProc Tcl_CreateObjCommand
    Tcl_CmdDeleteProc Tcl_CreateObjCommand
    Tcl_ObjCmdProc Tcl_CreateObjCommand
    Tcl_Channel Tcl_OpenFileChannel
    Tcl_WideInt Tcl_NewIntObj







|
|







606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
    wide()      mathfunc
    packagens   pkg::create
    pkgMkIndex  pkg_mkIndex
    pkg_mkIndex pkg_mkIndex
    Tcl_Obj     Tcl_NewObj
    Tcl_ObjType Tcl_RegisterObjType
    Tcl_OpenFileChannelProc Tcl_FSOpenFileChannel
    errorinfo	env
    errorcode	env
    tcl_pkgpath env
    Tcl_Command Tcl_CreateObjCommand
    Tcl_CmdProc Tcl_CreateObjCommand
    Tcl_CmdDeleteProc Tcl_CreateObjCommand
    Tcl_ObjCmdProc Tcl_CreateObjCommand
    Tcl_Channel Tcl_OpenFileChannel
    Tcl_WideInt Tcl_NewIntObj

Changes to unix/Makefile.in.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
#
# This file is a Makefile for Tcl. If it has the name "Makefile.in" then it is
# a template for a Makefile; to generate the actual Makefile, run
# "./configure", which is a configuration script generated by the "autoconf"
# program (constructs like "@foo@" will get replaced in the actual Makefile.

VERSION 		= @TCL_VERSION@
MAJOR_VERSION		= @TCL_MAJOR_VERSION@
MINOR_VERSION		= @TCL_MINOR_VERSION@
PATCH_LEVEL		= @TCL_PATCH_LEVEL@

#--------------------------------------------------------------------------
# Things you can change to personalize the Makefile for your own site (you can
# make these changes in either Makefile.in or Makefile, but changes to






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
#
# This file is a Makefile for Tcl. If it has the name "Makefile.in" then it is
# a template for a Makefile; to generate the actual Makefile, run
# "./configure", which is a configuration script generated by the "autoconf"
# program (constructs like "@foo@" will get replaced in the actual Makefile.

VERSION		= @TCL_VERSION@
MAJOR_VERSION		= @TCL_MAJOR_VERSION@
MINOR_VERSION		= @TCL_MINOR_VERSION@
PATCH_LEVEL		= @TCL_PATCH_LEVEL@

#--------------------------------------------------------------------------
# Things you can change to personalize the Makefile for your own site (you can
# make these changes in either Makefile.in or Makefile, but changes to
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/configure.

5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
		# AIX requires the _r compiler when gcc isn't being used
		case "${CC}" in
		    *_r|*_r\ *)
			# ok ...
			;;
		    *)
			# Make sure only first arg gets _r
		    	CC=`echo "$CC" | sed -e 's/^\([^ ]*\)/\1_r/'`
			;;
		esac
		{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Using $CC for compiling with threads" >&5
printf "%s\n" "Using $CC for compiling with threads" >&6; }

fi
	    LIBS="$LIBS -lc"







|







5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
		# AIX requires the _r compiler when gcc isn't being used
		case "${CC}" in
		    *_r|*_r\ *)
			# ok ...
			;;
		    *)
			# Make sure only first arg gets _r
			CC=`echo "$CC" | sed -e 's/^\([^ ]*\)/\1_r/'`
			;;
		esac
		{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Using $CC for compiling with threads" >&5
printf "%s\n" "Using $CC for compiling with threads" >&6; }

fi
	    LIBS="$LIBS -lc"
10012
10013
10014
10015
10016
10017
10018
10019
10020
10021
10022
10023
10024
10025
10026
	#include <sys/types.h>
	#include <sys/socket.h>

int
main (void)
{

    	socklen_t foo;

  ;
  return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :







|







10012
10013
10014
10015
10016
10017
10018
10019
10020
10021
10022
10023
10024
10025
10026
	#include <sys/types.h>
	#include <sys/socket.h>

int
main (void)
{

	socklen_t foo;

  ;
  return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :

Changes to unix/configure.ac.

400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
AC_TYPE_UID_T

AC_CACHE_CHECK([for socklen_t], tcl_cv_type_socklen_t, [
    AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
	#include <sys/types.h>
	#include <sys/socket.h>
    ]], [[
    	socklen_t foo;
    ]])],[tcl_cv_type_socklen_t=yes],[tcl_cv_type_socklen_t=no])])
if test $tcl_cv_type_socklen_t = no; then
    AC_DEFINE(socklen_t, int, [Define as int if socklen_t is not available])
fi

AC_CHECK_TYPES([intptr_t, uintptr_t],,,[[
#include <stdint.h>







|







400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
AC_TYPE_UID_T

AC_CACHE_CHECK([for socklen_t], tcl_cv_type_socklen_t, [
    AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
	#include <sys/types.h>
	#include <sys/socket.h>
    ]], [[
	socklen_t foo;
    ]])],[tcl_cv_type_socklen_t=yes],[tcl_cv_type_socklen_t=no])])
if test $tcl_cv_type_socklen_t = no; then
    AC_DEFINE(socklen_t, int, [Define as int if socklen_t is not available])
fi

AC_CHECK_TYPES([intptr_t, uintptr_t],,,[[
#include <stdint.h>

Changes to unix/dltest/embtest.c.

30
31
32
33
34
35
36
37
38
39
40
	printf("Tcl_FindExecutable gives version %s\n", version);
    }
    if (tclStubsPtr == NULL) {
	printf("ERROR: Tcl_FindExecutable does not initialize the stub table\n");
	exitcode = 1;
    }
    if (!exitcode) {
    	printf("All OK!\n");
    }
    return exitcode;
}







|



30
31
32
33
34
35
36
37
38
39
40
	printf("Tcl_FindExecutable gives version %s\n", version);
    }
    if (tclStubsPtr == NULL) {
	printf("ERROR: Tcl_FindExecutable does not initialize the stub table\n");
	exitcode = 1;
    }
    if (!exitcode) {
	printf("All OK!\n");
    }
    return exitcode;
}

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/tcl.m4.

986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
		# AIX requires the _r compiler when gcc isn't being used
		case "${CC}" in
		    *_r|*_r\ *)
			# ok ...
			;;
		    *)
			# Make sure only first arg gets _r
		    	CC=`echo "$CC" | sed -e 's/^\([[^ ]]*\)/\1_r/'`
			;;
		esac
		AC_MSG_RESULT([Using $CC for compiling with threads])
	    ])
	    LIBS="$LIBS -lc"
	    SHLIB_CFLAGS=""
	    SHLIB_SUFFIX=".so"







|







986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
		# AIX requires the _r compiler when gcc isn't being used
		case "${CC}" in
		    *_r|*_r\ *)
			# ok ...
			;;
		    *)
			# Make sure only first arg gets _r
			CC=`echo "$CC" | sed -e 's/^\([[^ ]]*\)/\1_r/'`
			;;
		esac
		AC_MSG_RESULT([Using $CC for compiling with threads])
	    ])
	    LIBS="$LIBS -lc"
	    SHLIB_CFLAGS=""
	    SHLIB_SUFFIX=".so"

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
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
 *	above operations are protected by tsdPtr->notifierMutex, which is
 *	destroyed thereafter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 * 	While tsdPtr->notifierMutex is held:
 *	- The per-thread eventfd(2) is closed, if non-zero, and set to -1.
 *	- The per-thread epoll(7) fd is closed, if non-zero, and set to 0.
 *	- The per-thread epoll_event structs are freed, if any, and set to 0.
 *
 *	tsdPtr->notifierMutex is destroyed.
 *
 *----------------------------------------------------------------------







|







259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
 *	above operations are protected by tsdPtr->notifierMutex, which is
 *	destroyed thereafter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	While tsdPtr->notifierMutex is held:
 *	- The per-thread eventfd(2) is closed, if non-zero, and set to -1.
 *	- The per-thread epoll(7) fd is closed, if non-zero, and set to 0.
 *	- The per-thread epoll_event structs are freed, if any, and set to 0.
 *
 *	tsdPtr->notifierMutex is destroyed.
 *
 *----------------------------------------------------------------------
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/tclKqueueNotfy.c.

257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
 *	operations are protected by tsdPtr->notifierMutex, which is destroyed
 *	thereafter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 * 	While tsdPtr->notifierMutex is held:
 *	The per-thread pipe(2) fds are closed, if non-zero, and set to -1.
 *	The per-thread kqueue(2) fd is closed, if non-zero, and set to 0.
 *	The per-thread kevent structs are freed, if any, and set to 0.
 *
 *	tsdPtr->notifierMutex is destroyed.
 *
 *----------------------------------------------------------------------







|







257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
 *	operations are protected by tsdPtr->notifierMutex, which is destroyed
 *	thereafter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	While tsdPtr->notifierMutex is held:
 *	The per-thread pipe(2) fds are closed, if non-zero, and set to -1.
 *	The per-thread kqueue(2) fd is closed, if non-zero, and set to 0.
 *	The per-thread kevent structs are freed, if any, and set to 0.
 *
 *	tsdPtr->notifierMutex is destroyed.
 *
 *----------------------------------------------------------------------

Changes to unix/tclLoadDl.c.

84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
     */

    native = (const char *)Tcl_FSGetNativePath(pathPtr);
    /*
     * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
     */
    if (flags & TCL_LOAD_GLOBAL) {
    	dlopenflags |= RTLD_GLOBAL;
    } else {
    	dlopenflags |= RTLD_LOCAL;
    }
    if (flags & TCL_LOAD_LAZY) {
    	dlopenflags |= RTLD_LAZY;
    } else {
    	dlopenflags |= RTLD_NOW;
    }
    handle = dlopen(native, dlopenflags);
    if (handle == NULL) {
	/*
	 * 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.







|

|


|

|







84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
     */

    native = (const char *)Tcl_FSGetNativePath(pathPtr);
    /*
     * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
     */
    if (flags & TCL_LOAD_GLOBAL) {
	dlopenflags |= RTLD_GLOBAL;
    } else {
	dlopenflags |= RTLD_LOCAL;
    }
    if (flags & TCL_LOAD_LAZY) {
	dlopenflags |= RTLD_LAZY;
    } else {
	dlopenflags |= RTLD_NOW;
    }
    handle = dlopen(native, dlopenflags);
    if (handle == NULL) {
	/*
	 * 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.

Changes to unix/tclLoadDyld.c.

193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214

#if TCL_DYLD_USE_DLFCN
    /*
     * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
     */

    if (flags & TCL_LOAD_GLOBAL) {
    	dlopenflags |= RTLD_GLOBAL;
    } else {
    	dlopenflags |= RTLD_LOCAL;
    }
    if (flags & TCL_LOAD_LAZY) {
    	dlopenflags |= RTLD_LAZY;
    } else {
    	dlopenflags |= RTLD_NOW;
    }
    dlHandle = dlopen(nativePath, dlopenflags);
    if (!dlHandle) {
	/*
	 * Let the OS loader examine the binary search path for whatever string
	 * the user gave us which hopefully refers to a file on the binary
	 * path.







|

|


|

|







193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214

#if TCL_DYLD_USE_DLFCN
    /*
     * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
     */

    if (flags & TCL_LOAD_GLOBAL) {
	dlopenflags |= RTLD_GLOBAL;
    } else {
	dlopenflags |= RTLD_LOCAL;
    }
    if (flags & TCL_LOAD_LAZY) {
	dlopenflags |= RTLD_LAZY;
    } else {
	dlopenflags |= RTLD_NOW;
    }
    dlHandle = dlopen(nativePath, dlopenflags);
    if (!dlHandle) {
	/*
	 * Let the OS loader examine the binary search path for whatever string
	 * the user gave us which hopefully refers to a file on the binary
	 * path.

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/tclUnixChan.c.

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

/*
 * This structure describes the channel type structure for file based IO:
 */

static const Tcl_ChannelType fileChannelType = {
    "file",			/* Type name. */
    TCL_CHANNEL_VERSION_5,	/* v5 channel */
    NULL,		/* Close proc. */
    FileInputProc,		/* Input proc. */
    FileOutputProc,		/* Output proc. */
	NULL,
    NULL,			/* Set option proc. */
    FileGetOptionProc,		/* Get option proc. */
    FileWatchProc,		/* Initialize notifier. */
    FileGetHandleProc,		/* Get OS handles out of channel. */
    FileCloseProc,		/* close2proc. */
    FileBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    FileWideSeekProc,		/* wide seek proc. */
    NULL,
    FileTruncateProc		/* truncate proc. */
};

#ifdef SUPPORTS_TTY
/*
 * This structure describes the channel type structure for serial IO.
 * Note that this type is a subclass of the "file" type.
 */

static const Tcl_ChannelType ttyChannelType = {
    "tty",			/* Type name. */
    TCL_CHANNEL_VERSION_5,	/* v5 channel */
    NULL,		/* Close proc. */
    FileInputProc,		/* Input proc. */
    FileOutputProc,		/* Output proc. */
    NULL,			/* Seek proc. */
    TtySetOptionProc,		/* Set option proc. */
    TtyGetOptionProc,		/* Get option proc. */
    FileWatchProc,		/* Initialize notifier. */
    FileGetHandleProc,		/* Get OS handles out of channel. */
    TtyCloseProc,			/* close2proc. */
    FileBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    NULL,			/* wide seek proc. */
    NULL,			/* thread action proc. */
    NULL			/* truncate proc. */
};
#endif	/* SUPPORTS_TTY */

/*
 *----------------------------------------------------------------------
 *
 * FileBlockModeProc --







|
|
|
|
|

|
|
|
|
|
|
|
|
|
|









|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







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

/*
 * This structure describes the channel type structure for file based IO:
 */

static const Tcl_ChannelType fileChannelType = {
    "file",			/* Type name. */
    TCL_CHANNEL_VERSION_5,
    NULL,			/* Deprecated. */
    FileInputProc,
    FileOutputProc,
    NULL,			/* Deprecated. */
    NULL,			/* Set option proc. */
    FileGetOptionProc,
    FileWatchProc,
    FileGetHandleProc,
    FileCloseProc,
    FileBlockModeProc,
    NULL,			/* Flush proc. */
    NULL,			/* Bubbled event handler proc. */
    FileWideSeekProc,
    NULL,			/* Thread action proc. */
    FileTruncateProc
};

#ifdef SUPPORTS_TTY
/*
 * This structure describes the channel type structure for serial IO.
 * Note that this type is a subclass of the "file" type.
 */

static const Tcl_ChannelType ttyChannelType = {
    "tty",
    TCL_CHANNEL_VERSION_5,
    NULL,			/* Deprecated. */
    FileInputProc,
    FileOutputProc,
    NULL,			/* Deprecated. */
    TtySetOptionProc,
    TtyGetOptionProc,
    FileWatchProc,
    FileGetHandleProc,
    TtyCloseProc,
    FileBlockModeProc,
    NULL,			/* Flush proc. */
    NULL,			/* Bubbled event handler proc. */
    NULL,			/* Seek proc. */
    NULL,			/* Thread action proc. */
    NULL			/* Truncate proc. */
};
#endif	/* SUPPORTS_TTY */

/*
 *----------------------------------------------------------------------
 *
 * FileBlockModeProc --
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
 *	Sets the device into blocking or non-blocking mode.
 *
 *----------------------------------------------------------------------
 */

static int
FileBlockModeProc(
    void *instanceData,	/* File state. */
    int mode)			/* The mode to set. Can be TCL_MODE_BLOCKING
				 * or TCL_MODE_NONBLOCKING. */
{
    FileState *fsPtr = (FileState *)instanceData;

    if (TclUnixSetBlockingMode(fsPtr->fd, mode) < 0) {
	return errno;







|







221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
 *	Sets the device into blocking or non-blocking mode.
 *
 *----------------------------------------------------------------------
 */

static int
FileBlockModeProc(
    void *instanceData,		/* File state. */
    int mode)			/* The mode to set. Can be TCL_MODE_BLOCKING
				 * or TCL_MODE_NONBLOCKING. */
{
    FileState *fsPtr = (FileState *)instanceData;

    if (TclUnixSetBlockingMode(fsPtr->fd, mode) < 0) {
	return errno;
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
 *	Reads input from the input device of the channel.
 *
 *----------------------------------------------------------------------
 */

static int
FileInputProc(
    void *instanceData,	/* File state. */
    char *buf,			/* Where to store data read. */
    int toRead,			/* How much space is available in the
				 * buffer? */
    int *errorCodePtr)		/* Where to store error code. */
{
    FileState *fsPtr = (FileState *)instanceData;
    int bytesRead;		/* How many bytes were actually read from the







|







254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
 *	Reads input from the input device of the channel.
 *
 *----------------------------------------------------------------------
 */

static int
FileInputProc(
    void *instanceData,		/* File state. */
    char *buf,			/* Where to store data read. */
    int toRead,			/* How much space is available in the
				 * buffer? */
    int *errorCodePtr)		/* Where to store error code. */
{
    FileState *fsPtr = (FileState *)instanceData;
    int bytesRead;		/* How many bytes were actually read from the
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
 *	Writes output on the output device of the channel.
 *
 *----------------------------------------------------------------------
 */

static int
FileOutputProc(
    void *instanceData,	/* File state. */
    const char *buf,		/* The data buffer. */
    int toWrite,		/* How many bytes to write? */
    int *errorCodePtr)		/* Where to store error code. */
{
    FileState *fsPtr = (FileState *)instanceData;
    int written;








|







304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
 *	Writes output on the output device of the channel.
 *
 *----------------------------------------------------------------------
 */

static int
FileOutputProc(
    void *instanceData,		/* File state. */
    const char *buf,		/* The data buffer. */
    int toWrite,		/* How many bytes to write? */
    int *errorCodePtr)		/* Where to store error code. */
{
    FileState *fsPtr = (FileState *)instanceData;
    int written;

351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
 *	Closes the device of the channel.
 *
 *----------------------------------------------------------------------
 */

static int
FileCloseProc(
    void *instanceData,	/* File state. */
    TCL_UNUSED(Tcl_Interp *),
    int flags)
{
    FileState *fsPtr = (FileState *)instanceData;
    int errorCode = 0;

    if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {







|







351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
 *	Closes the device of the channel.
 *
 *----------------------------------------------------------------------
 */

static int
FileCloseProc(
    void *instanceData,		/* File state. */
    TCL_UNUSED(Tcl_Interp *),
    int flags)
{
    FileState *fsPtr = (FileState *)instanceData;
    int errorCode = 0;

    if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
 *	operations.
 *
 *----------------------------------------------------------------------
 */

static long long
FileWideSeekProc(
    void *instanceData,	/* File state. */
    long long offset,		/* Offset to seek to. */
    int mode,			/* Relative to where should we seek? Can be
				 * one of SEEK_START, SEEK_CUR or SEEK_END. */
    int *errorCodePtr)		/* To store error code. */
{
    FileState *fsPtr = (FileState *)instanceData;
    long long newLoc;







|







444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
 *	operations.
 *
 *----------------------------------------------------------------------
 */

static long long
FileWideSeekProc(
    void *instanceData,		/* File state. */
    long long offset,		/* Offset to seek to. */
    int mode,			/* Relative to where should we seek? Can be
				 * one of SEEK_START, SEEK_CUR or SEEK_END. */
    int *errorCodePtr)		/* To store error code. */
{
    FileState *fsPtr = (FileState *)instanceData;
    long long newLoc;
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
{
    Tcl_Channel channel = (Tcl_Channel)clientData;
    Tcl_NotifyChannel(channel, mask);
}

static void
FileWatchProc(
    void *instanceData,	/* The file state. */
    int mask)			/* Events of interest; an OR-ed combination of
				 * TCL_READABLE, TCL_WRITABLE and
				 * TCL_EXCEPTION. */
{
    FileState *fsPtr = (FileState *)instanceData;

    /*







|







492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
{
    Tcl_Channel channel = (Tcl_Channel)clientData;
    Tcl_NotifyChannel(channel, mask);
}

static void
FileWatchProc(
    void *instanceData,		/* The file state. */
    int mask)			/* Events of interest; an OR-ed combination of
				 * TCL_READABLE, TCL_WRITABLE and
				 * TCL_EXCEPTION. */
{
    FileState *fsPtr = (FileState *)instanceData;

    /*
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
FileGetHandleProc(
    void *instanceData,	/* The file state. */
    int direction,		/* TCL_READABLE or TCL_WRITABLE */
    void **handlePtr)	/* Where to store the handle. */
{
    FileState *fsPtr = (FileState *)instanceData;

    if (direction & fsPtr->validMask) {
	*handlePtr = INT2PTR(fsPtr->fd);
	return TCL_OK;
    }







|

|







532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
FileGetHandleProc(
    void *instanceData,		/* The file state. */
    int direction,		/* TCL_READABLE or TCL_WRITABLE */
    void **handlePtr)		/* Where to store the handle. */
{
    FileState *fsPtr = (FileState *)instanceData;

    if (direction & fsPtr->validMask) {
	*handlePtr = INT2PTR(fsPtr->fd);
	return TCL_OK;
    }
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
 *	calling Tcl_BadChannelOption).
 *
 *----------------------------------------------------------------------
 */

static int
TtySetOptionProc(
    void *instanceData,	/* File state. */
    Tcl_Interp *interp,		/* For error reporting - can be NULL. */
    const char *optionName,	/* Which option to set? */
    const char *value)		/* New value for option. */
{
    TtyState *fsPtr = (TtyState *)instanceData;
    size_t len, vlen;
    TtyAttrs tty;







|







754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
 *	calling Tcl_BadChannelOption).
 *
 *----------------------------------------------------------------------
 */

static int
TtySetOptionProc(
    void *instanceData,		/* File state. */
    Tcl_Interp *interp,		/* For error reporting - can be NULL. */
    const char *optionName,	/* Which option to set? */
    const char *value)		/* New value for option. */
{
    TtyState *fsPtr = (TtyState *)instanceData;
    size_t len, vlen;
    TtyAttrs tty;
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
 *	(by calling Tcl_BadChannelOption).
 *
 *----------------------------------------------------------------------
 */

static int
TtyGetOptionProc(
    void *instanceData,	/* File state. */
    Tcl_Interp *interp,		/* For error reporting - can be NULL. */
    const char *optionName,	/* Option to get. */
    Tcl_DString *dsPtr)		/* Where to store value(s). */
{
    TtyState *fsPtr = (TtyState *)instanceData;
    size_t len;
    char buf[3*TCL_INTEGER_SPACE + 16];







|







1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
 *	(by calling Tcl_BadChannelOption).
 *
 *----------------------------------------------------------------------
 */

static int
TtyGetOptionProc(
    void *instanceData,		/* File state. */
    Tcl_Interp *interp,		/* For error reporting - can be NULL. */
    const char *optionName,	/* Option to get. */
    Tcl_DString *dsPtr)		/* Where to store value(s). */
{
    TtyState *fsPtr = (TtyState *)instanceData;
    size_t len;
    char buf[3*TCL_INTEGER_SPACE + 16];
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
     * sure to allow for the case where strchr is a macro. [Bug: 5089]
     *
     * We cannot if/else/endif the strchr arguments, it has to be the whole
     * function. On AIX this function is apparently a macro, and macros do
     * not allow preprocessor directives in their arguments.
     */

    if (
#if defined(PAREXT)
        strchr("noems", parity)

#else
        strchr("noe", parity)

#endif /* PAREXT */

                               == NULL) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "%s parity: should be %s", bad,
#if defined(PAREXT)
		    "n, o, e, m, or s"
#else
		    "n, o, or e"
#endif /* PAREXT */
		    ));
	    Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (char *)NULL);
	}
	return TCL_ERROR;
    }
    ttyPtr->parity = parity;
    if ((ttyPtr->data < 5) || (ttyPtr->data > 8)) {
	if (interp != NULL) {







<
|
|
>

|
>

>
|


|
<
<
<
<
<
<







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
     * sure to allow for the case where strchr is a macro. [Bug: 5089]
     *
     * We cannot if/else/endif the strchr arguments, it has to be the whole
     * function. On AIX this function is apparently a macro, and macros do
     * not allow preprocessor directives in their arguments.
     */


#ifdef PAREXT
#define PARITY_CHARS	"noems"
#define PARITY_MSG	"n, o, e, m, or s"
#else
#define PARITY_CHARS	"noe"
#define PARITY_MSG	"n, o, or e"
#endif /* PAREXT */

    if (strchr(PARITY_CHARS, parity) == NULL) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "%s parity: should be %s", bad, PARITY_MSG));






	    Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (char *)NULL);
	}
	return TCL_ERROR;
    }
    ttyPtr->parity = parity;
    if ((ttyPtr->data < 5) || (ttyPtr->data > 8)) {
	if (interp != NULL) {
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
    const char *chanID,		/* String that identifies file. */
    int forWriting,		/* 1 means the file is going to be used for
				 * writing, 0 means for reading. */
    TCL_UNUSED(int),		/* Obsolete argument.
				 * Ignored, we always check that
				 * the channel is open for the requested
				 * mode. */
    void **filePtr)	/* Store pointer to FILE structure here. */
{
    Tcl_Channel chan;
    int chanMode, fd;
    const Tcl_ChannelType *chanTypePtr;
    void *data;
    FILE *f;








|







2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
    const char *chanID,		/* String that identifies file. */
    int forWriting,		/* 1 means the file is going to be used for
				 * writing, 0 means for reading. */
    TCL_UNUSED(int),		/* Obsolete argument.
				 * Ignored, we always check that
				 * the channel is open for the requested
				 * mode. */
    void **filePtr)		/* Store pointer to FILE structure here. */
{
    Tcl_Channel chan;
    int chanMode, fd;
    const Tcl_ChannelType *chanTypePtr;
    void *data;
    FILE *f;

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/tclUnixFCmd.c.

805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
 *	the pathname of the file that caused the error is stored in errorPtr.
 *	Some possible values for errno are:
 *
 *	EACCES:	    path directory can't be read and/or written.
 *	EEXIST:	    path is a non-empty directory.
 *	EINVAL:	    path is a root directory.
 *	ENOENT:	    path doesn't exist or is "".
 * 	ENOTDIR:    path is not a directory.
 *
 * Side effects:
 *	Directory removed. If an error occurs, the error will be returned
 *	immediately, and remaining files will not be deleted.
 *
 *---------------------------------------------------------------------------
 */







|







805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
 *	the pathname of the file that caused the error is stored in errorPtr.
 *	Some possible values for errno are:
 *
 *	EACCES:	    path directory can't be read and/or written.
 *	EEXIST:	    path is a non-empty directory.
 *	EINVAL:	    path is a root directory.
 *	ENOENT:	    path doesn't exist or is "".
 *	ENOTDIR:    path is not a directory.
 *
 * Side effects:
 *	Directory removed. If an error occurs, the error will be returned
 *	immediately, and remaining files will not be deleted.
 *
 *---------------------------------------------------------------------------
 */
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
				 * traversed (native). */
    Tcl_DString *targetPtr,	/* Pathname of directory to traverse in
				 * parallel with source directory (native). */
    Tcl_DString *errorPtr,	/* If non-NULL, uninitialized or free DString
				 * filled with UTF-8 name of file causing
				 * error. */
    int doRewind)		/* Flag indicating that to ensure complete
    				 * traversal of source hierarchy, the readdir
    				 * loop should be rewound whenever
    				 * traverseProc has returned TCL_OK; this is
    				 * required when traverseProc modifies the
    				 * source hierarchy, e.g. by deleting
    				 * files. */
{
    Tcl_StatBuf statBuf;
    const char *source, *errfile;
    int result;
    size_t targetLen, sourceLen;
#ifndef HAVE_FTS
    int numProcessed = 0;







|
|
|
|
|
|







949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
				 * traversed (native). */
    Tcl_DString *targetPtr,	/* Pathname of directory to traverse in
				 * parallel with source directory (native). */
    Tcl_DString *errorPtr,	/* If non-NULL, uninitialized or free DString
				 * filled with UTF-8 name of file causing
				 * error. */
    int doRewind)		/* Flag indicating that to ensure complete
				 * traversal of source hierarchy, the readdir
				 * loop should be rewound whenever
				 * traverseProc has returned TCL_OK; this is
				 * required when traverseProc modifies the
				 * source hierarchy, e.g. by deleting
				 * files. */
{
    Tcl_StatBuf statBuf;
    const char *source, *errfile;
    int result;
    size_t targetLen, sourceLen;
#ifndef HAVE_FTS
    int numProcessed = 0;

Changes to unix/tclUnixFile.c.

9
10
11
12
13
14
15
16

17
18
19
20
21
22
23
24
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include "tclFileSystem.h"

static int NativeMatchType(Tcl_Interp *interp, const char* nativeEntry,

	const char* nativeName, Tcl_GlobTypeData *types);

/*
 *---------------------------------------------------------------------------
 *
 * TclpFindExecutable --
 *
 *	This function computes the absolute path name of the current







|
>
|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include "tclFileSystem.h"

static int		NativeMatchType(Tcl_Interp *interp,
			    const char* nativeEntry, const char* nativeName,
			    Tcl_GlobTypeData *types);

/*
 *---------------------------------------------------------------------------
 *
 * TclpFindExecutable --
 *
 *	This function computes the absolute path name of the current

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/tclUnixNotfy.c.

356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
	 * Remove the ThreadSpecificData structure of this thread from the
	 * waiting list. This prevents us from continuously spinning on
	 * epoll_wait until the other threads runs and services the file
	 * event.
	 */

	if (tsdPtr->prevPtr) {
    	    tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
	} else {
    	    waitingListPtr = tsdPtr->nextPtr;
	}
	if (tsdPtr->nextPtr) {
    	    tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
	}
	tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
	tsdPtr->onList = 0;
	tsdPtr->pollState = 0;
    }
#ifdef __CYGWIN__
    PostMessageW(tsdPtr->hwnd, 1024, 0, 0);







|

|


|







356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
	 * Remove the ThreadSpecificData structure of this thread from the
	 * waiting list. This prevents us from continuously spinning on
	 * epoll_wait until the other threads runs and services the file
	 * event.
	 */

	if (tsdPtr->prevPtr) {
	    tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
	} else {
	    waitingListPtr = tsdPtr->nextPtr;
	}
	if (tsdPtr->nextPtr) {
	    tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
	}
	tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
	tsdPtr->onList = 0;
	tsdPtr->pollState = 0;
    }
#ifdef __CYGWIN__
    PostMessageW(tsdPtr->hwnd, 1024, 0, 0);

Changes to unix/tclUnixPipe.c.

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

/*
 * This structure describes the channel type structure for command pipe based
 * I/O:
 */

static const Tcl_ChannelType pipeChannelType = {
    "pipe",			/* Type name. */
    TCL_CHANNEL_VERSION_5,	/* v5 channel */
    NULL,		/* Close proc. */
    PipeInputProc,		/* Input proc. */
    PipeOutputProc,		/* Output proc. */
    NULL,			/* Seek proc. */
    NULL,			/* Set option proc. */
    NULL,			/* Get option proc. */
    PipeWatchProc,		/* Initialize notifier. */
    PipeGetHandleProc,		/* Get OS handles out of channel. */
    PipeClose2Proc,		/* close2proc. */
    PipeBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    NULL,			/* wide seek proc */
    NULL,			/* thread action proc */
    NULL			/* truncation */
};

/*
 *----------------------------------------------------------------------
 *
 * TclpMakeFile --
 *







|
|
|
|
|
|


|
|
|
|
|
|
|
|
|







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

/*
 * This structure describes the channel type structure for command pipe based
 * I/O:
 */

static const Tcl_ChannelType pipeChannelType = {
    "pipe",
    TCL_CHANNEL_VERSION_5,
    NULL,			/* Deprecated. */
    PipeInputProc,
    PipeOutputProc,
    NULL,			/* Deprecated. */
    NULL,			/* Set option proc. */
    NULL,			/* Get option proc. */
    PipeWatchProc,
    PipeGetHandleProc,
    PipeClose2Proc,
    PipeBlockModeProc,
    NULL,			/* Flush proc. */
    NULL,			/* Bubbled event handler proc. */
    NULL,			/* Seek proc. */
    NULL,			/* Thread action proc. */
    NULL			/* Truncation proc. */
};

/*
 *----------------------------------------------------------------------
 *
 * TclpMakeFile --
 *
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;
}

/*
 *----------------------------------------------------------------------

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

/*
 * This structure describes the channel type structure for TCP socket
 * based IO:
 */

static const Tcl_ChannelType tcpChannelType = {
    "tcp",			/* Type name. */
    TCL_CHANNEL_VERSION_5,	/* v5 channel */
    NULL,		/* Close proc. */
    TcpInputProc,		/* Input proc. */
    TcpOutputProc,		/* Output proc. */
    NULL,			/* Seek proc. */
    TcpSetOptionProc,		/* Set option proc. */
    TcpGetOptionProc,		/* Get option proc. */
    TcpWatchProc,		/* Initialize notifier. */
    TcpGetHandleProc,		/* Get OS handles out of channel. */
    TcpClose2Proc,		/* Close2 proc. */
    TcpBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    NULL,			/* wide seek proc. */
    TcpThreadActionProc,	/* thread action proc. */
    NULL			/* truncate proc. */
};

/*
 * The following variable holds the network name of this host.
 */

static TclInitProcessGlobalValueProc InitializeHostName;







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







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

/*
 * This structure describes the channel type structure for TCP socket
 * based IO:
 */

static const Tcl_ChannelType tcpChannelType = {
    "tcp",
    TCL_CHANNEL_VERSION_5,
    NULL,			/* Deprecated. */
    TcpInputProc,
    TcpOutputProc,
    NULL,			/* Deprecated. */
    TcpSetOptionProc,
    TcpGetOptionProc,
    TcpWatchProc,
    TcpGetHandleProc,
    TcpClose2Proc,
    TcpBlockModeProc,
    NULL,			/* Flush proc. */
    NULL,			/* Bubbled event handler proc. */
    NULL,			/* Seek proc. */
    TcpThreadActionProc,
    NULL			/* Truncate proc. */
};

/*
 * The following variable holds the network name of this host.
 */

static TclInitProcessGlobalValueProc InitializeHostName;
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
}
#endif
/*
 * ----------------------------------------------------------------------
 *
 * InitializeHostName --
 *
 * 	This routine sets the process global value of the name of the local
 * 	host on which the process is running.
 *
 * Results:
 *	None.
 *
 * ----------------------------------------------------------------------
 */








|
|







199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
}
#endif
/*
 * ----------------------------------------------------------------------
 *
 * InitializeHostName --
 *
 *	This routine sets the process global value of the name of the local
 *	host on which the process is running.
 *
 * Results:
 *	None.
 *
 * ----------------------------------------------------------------------
 */

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;
}

396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
 *	     *	EWOULDBLOCK: if connect is still in progress
 *	     *	ENOTCONN: if connect failed. This would be the error message
 *		of a recv or sendto syscall so this is emulated here.
 *	 *  NULL: Called by a background operation. Do not block and do not
 *	    return any error code.
 *
 * Results:
 * 	0 if the connection has completed, -1 if still in progress or there is
 * 	an error.
 *
 * Side effects:
 *	Processes socket events off the system queue. May process
 *	asynchronous connects.
 *
 *----------------------------------------------------------------------
 */







|
|







395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
 *	     *	EWOULDBLOCK: if connect is still in progress
 *	     *	ENOTCONN: if connect failed. This would be the error message
 *		of a recv or sendto syscall so this is emulated here.
 *	 *  NULL: Called by a background operation. Do not block and do not
 *	    return any error code.
 *
 * Results:
 *	0 if the connection has completed, -1 if still in progress or there is
 *	an error.
 *
 * Side effects:
 *	Processes socket events off the system queue. May process
 *	asynchronous connects.
 *
 *----------------------------------------------------------------------
 */
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 unix/tclUnixTest.c.

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
 *
 *	Signal handler for the alarm command.
 *
 * Results:
 *	None.
 *
 * Side effects:
 * 	Calls the Tcl Async handler.
 *
 *----------------------------------------------------------------------
 */

static void
AlarmHandler(
    TCL_UNUSED(int) /*signum*/)
{
    gotsig = "1";
}

/*
 *----------------------------------------------------------------------
 *
 * TestgotsigCmd --
 *
 * 	Verify the signal was handled after the testalarm command.
 *
 * Results:
 *	None.
 *
 * Side Effects:
 *	Resets the value of gotsig back to '0'.
 *







|
















|







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
 *
 *	Signal handler for the alarm command.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Calls the Tcl Async handler.
 *
 *----------------------------------------------------------------------
 */

static void
AlarmHandler(
    TCL_UNUSED(int) /*signum*/)
{
    gotsig = "1";
}

/*
 *----------------------------------------------------------------------
 *
 * TestgotsigCmd --
 *
 *	Verify the signal was handled after the testalarm command.
 *
 * Results:
 *	None.
 *
 * Side Effects:
 *	Resets the value of gotsig back to '0'.
 *

Changes to unix/tclUnixTime.c.

242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
 * TclpWideClickInMicrosec --
 *
 *	This procedure return scale to convert click values from the
 *	TclpGetWideClicks native resolution to microsecond resolution
 *	and back.
 *
 * Results:
 * 	1 click in microseconds as double.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|







242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
 * TclpWideClickInMicrosec --
 *
 *	This procedure return scale to convert click values from the
 *	TclpGetWideClicks native resolution to microsecond resolution
 *	and back.
 *
 * Results:
 *	1 click in microseconds as double.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Changes to win/Makefile.in.

75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92

# The default switches for optimization or debugging
CFLAGS_DEBUG    = @CFLAGS_DEBUG@
CFLAGS_OPTIMIZE	= @CFLAGS_OPTIMIZE@

# To change the compiler switches, for example to change from optimization to
# debugging symbols, change the following line:
#CFLAGS = 		$(CFLAGS_DEBUG)
#CFLAGS = 		$(CFLAGS_OPTIMIZE)
#CFLAGS = 		$(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE)
CFLAGS = 		@CFLAGS@ @CFLAGS_DEFAULT@ -DMP_FIXED_CUTOFFS -D__USE_MINGW_ANSI_STDIO=0

# To compile without backward compatibility and deprecated code uncomment the
# following
NO_DEPRECATED_FLAGS	=
#NO_DEPRECATED_FLAGS	= -DTCL_NO_DEPRECATED

# To enable compilation debugging reverse the comment characters on one of the







|
|
|
|







75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92

# The default switches for optimization or debugging
CFLAGS_DEBUG    = @CFLAGS_DEBUG@
CFLAGS_OPTIMIZE	= @CFLAGS_OPTIMIZE@

# To change the compiler switches, for example to change from optimization to
# debugging symbols, change the following line:
#CFLAGS =		$(CFLAGS_DEBUG)
#CFLAGS =		$(CFLAGS_OPTIMIZE)
#CFLAGS =		$(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE)
CFLAGS =		@CFLAGS@ @CFLAGS_DEFAULT@ -DMP_FIXED_CUTOFFS -D__USE_MINGW_ANSI_STDIO=0

# To compile without backward compatibility and deprecated code uncomment the
# following
NO_DEPRECATED_FLAGS	=
#NO_DEPRECATED_FLAGS	= -DTCL_NO_DEPRECATED

# To enable compilation debugging reverse the comment characters on one of the
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
			  package ifneeded dde 1.4.5 [list load ${DDE_DLL_FILE}];\
			  package ifneeded registry 1.3.7 [list load ${REG_DLL_FILE}]
TEST_LOAD_FACILITIES	= package ifneeded tcl::test ${VERSION}@TCL_PATCH_LEVEL@ [list load ${TEST_DLL_FILE} Tcltest];\
			  $(TEST_LOAD_PRMS)
ZLIB_DLL_FILE		= zlib1.dll
TOMMATH_DLL_FILE	= libtommath.dll

SHARED_LIBRARIES 	= $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ @TOMMATH_DLL_FILE@
STATIC_LIBRARIES	= $(TCL_LIB_FILE)

TCLSH			= tclsh$(VER)${EXESUFFIX}
WINE			= @WINE@
CAT32			= cat32$(EXEEXT)

# For cross-compiled builds, TCL_EXE is the name of a tclsh executable that is







|







158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
			  package ifneeded dde 1.4.5 [list load ${DDE_DLL_FILE}];\
			  package ifneeded registry 1.3.7 [list load ${REG_DLL_FILE}]
TEST_LOAD_FACILITIES	= package ifneeded tcl::test ${VERSION}@TCL_PATCH_LEVEL@ [list load ${TEST_DLL_FILE} Tcltest];\
			  $(TEST_LOAD_PRMS)
ZLIB_DLL_FILE		= zlib1.dll
TOMMATH_DLL_FILE	= libtommath.dll

SHARED_LIBRARIES	= $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ @TOMMATH_DLL_FILE@
STATIC_LIBRARIES	= $(TCL_LIB_FILE)

TCLSH			= tclsh$(VER)${EXESUFFIX}
WINE			= @WINE@
CAT32			= cat32$(EXEEXT)

# For cross-compiled builds, TCL_EXE is the name of a tclsh executable that is
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
	@$(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 \







|







613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
	@$(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/makefile.vc.

53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
#
# Basic macros and options usable on the commandline (see rules.vc for more info):
#	OPTS=nomsvcrt,noembed,nothreads,pdbs,profile,static,symbols,thrdalloc,unchecked,none
#		Sets special options for the core.  The default is for none.
#		Any combination of the above may be used (comma separated).
#		'none' will over-ride everything to nothing.
#
# 		noembed   = Without this option, the Tcl core library scripts
#			    are embedded into the executable if "static" is
#			    specified in OPTS, or into the DLL otherwise. If
#			    "noembed" is specified, the scripts are not embedded
#			    but copied to the installation target (as in 8.6).
#		nomsvcrt  = Affects the static option only to switch it from
#			    using msvcrt(d) as the C runtime [by default] to
#			    libcmt(d). This is useful for static embedding







|







53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
#
# Basic macros and options usable on the commandline (see rules.vc for more info):
#	OPTS=nomsvcrt,noembed,nothreads,pdbs,profile,static,symbols,thrdalloc,unchecked,none
#		Sets special options for the core.  The default is for none.
#		Any combination of the above may be used (comma separated).
#		'none' will over-ride everything to nothing.
#
#		noembed   = Without this option, the Tcl core library scripts
#			    are embedded into the executable if "static" is
#			    specified in OPTS, or into the DLL otherwise. If
#			    "noembed" is specified, the scripts are not embedded
#			    but copied to the installation target (as in 8.6).
#		nomsvcrt  = Affects the static option only to switch it from
#			    using msvcrt(d) as the C runtime [by default] to
#			    libcmt(d). This is useful for static embedding

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/rules.vc.

1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
!if $(TK_MAJOR_VERSION) == 8
TKSTUBLIBNAME	= tkstub$(TK_VERSION).lib
!else
TKSTUBLIBNAME	= tkstub.lib
!endif

!if $(DOING_TK)
WISH 		= $(OUT_DIR)\$(WISHNAME)
TKSTUBLIB	= $(OUT_DIR)\$(TKSTUBLIBNAME)
TKIMPLIB	= $(OUT_DIR)\$(TKIMPLIBNAME)
TKLIB		= $(OUT_DIR)\$(TKLIBNAME)
TK_INCLUDES     = -I"$(WIN_DIR)" -I"$(GENERICDIR)"
TKSCRIPTZIP     = $(OUT_DIR)\$(TKSCRIPTZIPNAME)

!else # effectively NEED_TK







|







1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
!if $(TK_MAJOR_VERSION) == 8
TKSTUBLIBNAME	= tkstub$(TK_VERSION).lib
!else
TKSTUBLIBNAME	= tkstub.lib
!endif

!if $(DOING_TK)
WISH		= $(OUT_DIR)\$(WISHNAME)
TKSTUBLIB	= $(OUT_DIR)\$(TKSTUBLIBNAME)
TKIMPLIB	= $(OUT_DIR)\$(TKIMPLIBNAME)
TKLIB		= $(OUT_DIR)\$(TKLIBNAME)
TK_INCLUDES     = -I"$(WIN_DIR)" -I"$(GENERICDIR)"
TKSCRIPTZIP     = $(OUT_DIR)\$(TKSCRIPTZIPNAME)

!else # effectively NEED_TK

Changes to win/tcl.rc.

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

#define SUFFIX		    SUFFIX_DEBUG


LANGUAGE 0x9, 0x1	/* LANG_ENGLISH, SUBLANG_DEFAULT */

VS_VERSION_INFO VERSIONINFO
 FILEVERSION 	TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
 PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
 FILEFLAGSMASK 	0x3fL
#ifdef DEBUG
 FILEFLAGS 	VS_FF_DEBUG
#else
 FILEFLAGS 	0x0L
#endif
 FILEOS 	VOS__WINDOWS32
 FILETYPE 	VFT_DLL
 FILESUBTYPE 	0x0L
BEGIN
    BLOCK "StringFileInfo"
    BEGIN
        BLOCK "040904b0" /* LANG_ENGLISH/SUBLANG_ENGLISH_US, Unicode CP */
        BEGIN
            VALUE "FileDescription", "Tcl DLL\0"
            VALUE "OriginalFilename", "tcl" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".dll\0"







|

|

|

|

|
|
|







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

#define SUFFIX		    SUFFIX_DEBUG


LANGUAGE 0x9, 0x1	/* LANG_ENGLISH, SUBLANG_DEFAULT */

VS_VERSION_INFO VERSIONINFO
 FILEVERSION	TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
 PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
 FILEFLAGSMASK	0x3fL
#ifdef DEBUG
 FILEFLAGS	VS_FF_DEBUG
#else
 FILEFLAGS	0x0L
#endif
 FILEOS	VOS__WINDOWS32
 FILETYPE	VFT_DLL
 FILESUBTYPE	0x0L
BEGIN
    BLOCK "StringFileInfo"
    BEGIN
        BLOCK "040904b0" /* LANG_ENGLISH/SUBLANG_ENGLISH_US, Unicode CP */
        BEGIN
            VALUE "FileDescription", "Tcl DLL\0"
            VALUE "OriginalFilename", "tcl" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".dll\0"

Changes to win/tclWinChan.c.

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
			    int permissions, int appendMode);

/*
 * This structure describes the channel type structure for file based IO.
 */

static const Tcl_ChannelType fileChannelType = {
    "file",			/* Type name. */
    TCL_CHANNEL_VERSION_5,	/* v5 channel */
    NULL,			/* Close proc. */
    FileInputProc,		/* Input proc. */
    FileOutputProc,		/* Output proc. */
    NULL,
    NULL,			/* Set option proc. */
    FileGetOptionProc,		/* Get option proc. */
    FileWatchProc,		/* Set up the notifier to watch the channel. */
    FileGetHandleProc,		/* Get an OS handle from channel. */
    FileCloseProc,		/* close2proc. */
    FileBlockProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    FileWideSeekProc,		/* Wide seek proc. */
    FileThreadActionProc,	/* Thread action proc. */
    FileTruncateProc		/* Truncate proc. */
};

/*
 * General useful clarification macros.
 */

#define SET_FLAG(var, flag)	((var) |= (flag))







|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|







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
			    int permissions, int appendMode);

/*
 * This structure describes the channel type structure for file based IO.
 */

static const Tcl_ChannelType fileChannelType = {
    "file",
    TCL_CHANNEL_VERSION_5,
    NULL,			/* Deprecated. */
    FileInputProc,
    FileOutputProc,
    NULL,			/* Deprecated. */
    NULL,			/* Set option proc. */
    FileGetOptionProc,
    FileWatchProc,
    FileGetHandleProc,
    FileCloseProc,
    FileBlockProc,
    NULL,			/* Flush proc. */
    NULL,			/* Bubbled event handler proc. */
    FileWideSeekProc,
    FileThreadActionProc,
    FileTruncateProc
};

/*
 * General useful clarification macros.
 */

#define SET_FLAG(var, flag)	((var) |= (flag))

Changes to win/tclWinConsole.c.

172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
 *     opening and dropped on channel close. This also covers the reference
 *     from gWatchingChannelList since queueing / dequeuing from that list
 *     happens in conjunction with channel operations.
 *   - the Tcl event queue entries. This reference is added when the event
 *     is queued and dropped on receipt.
 */
typedef struct ConsoleChannelInfo {
    HANDLE handle; 		/* Console handle */
    Tcl_ThreadId threadId;	/* Id of owning thread */
    struct ConsoleChannelInfo *nextWatchingChannelPtr;
				/* Pointer to next channel watching events. */
    Tcl_Channel channel;	/* Pointer to channel structure. */
    DWORD initMode;		/* Initial console mode. */
    int numRefs;		/* See comments above */
    int permissions;            /* OR'ed combination of TCL_READABLE,







|







172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
 *     opening and dropped on channel close. This also covers the reference
 *     from gWatchingChannelList since queueing / dequeuing from that list
 *     happens in conjunction with channel operations.
 *   - the Tcl event queue entries. This reference is added when the event
 *     is queued and dropped on receipt.
 */
typedef struct ConsoleChannelInfo {
    HANDLE handle;		/* Console handle */
    Tcl_ThreadId threadId;	/* Id of owning thread */
    struct ConsoleChannelInfo *nextWatchingChannelPtr;
				/* Pointer to next channel watching events. */
    Tcl_Channel channel;	/* Pointer to channel structure. */
    DWORD initMode;		/* Initial console mode. */
    int numRefs;		/* See comments above */
    int permissions;            /* OR'ed combination of TCL_READABLE,
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

/*
 * This structure describes the channel type structure for command console
 * based IO.
 */

static const Tcl_ChannelType consoleChannelType = {
    "console",               /* Type name. */
    TCL_CHANNEL_VERSION_5,   /* v5 channel */
    NULL,                    /* Close proc. */
    ConsoleInputProc,        /* Input proc. */
    ConsoleOutputProc,       /* Output proc. */
    NULL,                    /* Seek proc. */
    ConsoleSetOptionProc,    /* Set option proc. */
    ConsoleGetOptionProc,    /* Get option proc. */
    ConsoleWatchProc,        /* Set up notifier to watch the channel. */
    ConsoleGetHandleProc,    /* Get an OS handle from channel. */
    ConsoleCloseProc,        /* close2proc. */
    ConsoleBlockModeProc,    /* Set blocking or non-blocking mode. */
    NULL,                    /* Flush proc. */
    NULL,                    /* Handler proc. */
    NULL,                    /* Wide seek proc. */
    ConsoleThreadActionProc, /* Thread action proc. */
    NULL                     /* Truncation proc. */
};

/*
 *------------------------------------------------------------------------
 *
 * RingBufferInit --
 *







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







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

/*
 * This structure describes the channel type structure for command console
 * based IO.
 */

static const Tcl_ChannelType consoleChannelType = {
    "console",
    TCL_CHANNEL_VERSION_5,
    NULL,			/* Deprecated. */
    ConsoleInputProc,
    ConsoleOutputProc,
    NULL,			/* Deprecated. */
    ConsoleSetOptionProc,
    ConsoleGetOptionProc,
    ConsoleWatchProc,
    ConsoleGetHandleProc,
    ConsoleCloseProc,
    ConsoleBlockModeProc,
    NULL,			/* Flush proc. */
    NULL,			/* Bubbled event handler proc. */
    NULL,			/* Seek proc. */
    ConsoleThreadActionProc,
    NULL			/* Truncation proc. */
};

/*
 *------------------------------------------------------------------------
 *
 * RingBufferInit --
 *
2063
2064
2065
2066
2067
2068
2069

2070
2071
2072
2073
2074
2075
2076
2077
 *
 * Side effects:
 *    None.
 *
 *------------------------------------------------------------------------
 */
static ConsoleHandleInfo *

FindConsoleInfo(const ConsoleChannelInfo *chanInfoPtr)
{
    ConsoleHandleInfo *handleInfoPtr;
    for (handleInfoPtr = gConsoleHandleInfoList; handleInfoPtr; handleInfoPtr = handleInfoPtr->nextPtr) {
	if (handleInfoPtr->console == chanInfoPtr->handle) {
	    return handleInfoPtr;
	}
    }







>
|







2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
 *
 * Side effects:
 *    None.
 *
 *------------------------------------------------------------------------
 */
static ConsoleHandleInfo *
FindConsoleInfo(
    const ConsoleChannelInfo *chanInfoPtr)
{
    ConsoleHandleInfo *handleInfoPtr;
    for (handleInfoPtr = gConsoleHandleInfoList; handleInfoPtr; handleInfoPtr = handleInfoPtr->nextPtr) {
	if (handleInfoPtr->console == chanInfoPtr->handle) {
	    return handleInfoPtr;
	}
    }

Changes to win/tclWinPipe.c.

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

/*
 * This structure describes the channel type structure for command pipe based
 * I/O.
 */

static const Tcl_ChannelType pipeChannelType = {
    "pipe",			/* Type name. */
    TCL_CHANNEL_VERSION_5,	/* v5 channel */
    NULL,		/* Close proc. */
    PipeInputProc,		/* Input proc. */
    PipeOutputProc,		/* Output proc. */
    NULL,			/* Seek proc. */
    NULL,			/* Set option proc. */
    NULL,			/* Get option proc. */
    PipeWatchProc,		/* Set up notifier to watch the channel. */
    PipeGetHandleProc,		/* Get an OS handle from channel. */
    PipeClose2Proc,		/* close2proc */
    PipeBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    NULL,			/* wide seek proc */
    PipeThreadActionProc,	/* thread action proc */
    NULL			/* truncate */
};

/*
 *----------------------------------------------------------------------
 *
 * PipeInit --
 *







|
|
|
|
|
|


|
|
|
|
|
|
|
|
|







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

/*
 * This structure describes the channel type structure for command pipe based
 * I/O.
 */

static const Tcl_ChannelType pipeChannelType = {
    "pipe",
    TCL_CHANNEL_VERSION_5,
    NULL,			/* Deprecated. */
    PipeInputProc,
    PipeOutputProc,
    NULL,			/* Deprecated. */
    NULL,			/* Set option proc. */
    NULL,			/* Get option proc. */
    PipeWatchProc,
    PipeGetHandleProc,
    PipeClose2Proc,
    PipeBlockModeProc,
    NULL,			/* Flush proc. */
    NULL,			/* Bubbled event handler proc. */
    NULL,			/* Seek proc. */
    PipeThreadActionProc,
    NULL			/* Truncate proc. */
};

/*
 *----------------------------------------------------------------------
 *
 * PipeInit --
 *
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
    const char *bspos)
{
    if (!bspos) {
	if (current > start) {	/* part before current (special) */
	    Tcl_DStringAppend(dsPtr, start, (int) (current - start));
	}
    } else {
    	if (bspos > start) {	/* part before first backslash */
	    Tcl_DStringAppend(dsPtr, start, (int) (bspos - start));
	}
	while (bspos++ < current) { /* each backslash twice */
	    TclDStringAppendLiteral(dsPtr, "\\\\");
	}
    }
}







|







1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
    const char *bspos)
{
    if (!bspos) {
	if (current > start) {	/* part before current (special) */
	    Tcl_DStringAppend(dsPtr, start, (int) (current - start));
	}
    } else {
	if (bspos > start) {	/* part before first backslash */
	    Tcl_DStringAppend(dsPtr, start, (int) (bspos - start));
	}
	while (bspos++ < current) { /* each backslash twice */
	    TclDStringAppendLiteral(dsPtr, "\\\\");
	}
    }
}
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
     * main quotes, so `\` remains `\`, but important - not at end of part,
     * because results as before the quote, so `%\%\` should be escaped as
     * `"%\%"\\`).
     */

    TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */
    do {
    	*bspos = NULL;
	special++;
	if (*special == '\\') {
	    /*
	     * Bypass backslashes (and mark first backslash position).
	     */

	    special = BuildCmdLineBypassBS(special, bspos);







|







1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
     * main quotes, so `\` remains `\`, but important - not at end of part,
     * because results as before the quote, so `%\%\` should be escaped as
     * `"%\%"\\`).
     */

    TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */
    do {
	*bspos = NULL;
	special++;
	if (*special == '\\') {
	    /*
	     * Bypass backslashes (and mark first backslash position).
	     */

	    special = BuildCmdLineBypassBS(special, bspos);
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
	infoPtr->readable = CreateEventW(NULL, TRUE, TRUE, NULL);
	infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread,
	    TclPipeThreadCreateTI(&infoPtr->readTI, infoPtr, infoPtr->readable),
	    0, NULL);
	SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
	infoPtr->validMask |= TCL_READABLE;
    } else {
    	infoPtr->readTI = NULL;
	infoPtr->readThread = 0;
    }
    if (writeFile != NULL) {
	/*
	 * Start the background writer thread.
	 */

	infoPtr->writable = CreateEventW(NULL, TRUE, TRUE, NULL);
	infoPtr->writeThread = CreateThread(NULL, 256, PipeWriterThread,
	    TclPipeThreadCreateTI(&infoPtr->writeTI, infoPtr, infoPtr->writable),
	    0, NULL);
	SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST);
	infoPtr->validMask |= TCL_WRITABLE;
    } else {
    	infoPtr->writeTI = NULL;
    	infoPtr->writeThread = 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". Use the pointer to keep the channel names
     * unique, in case channels share handles (stdin/stdout).







|














|
|







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
	infoPtr->readable = CreateEventW(NULL, TRUE, TRUE, NULL);
	infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread,
	    TclPipeThreadCreateTI(&infoPtr->readTI, infoPtr, infoPtr->readable),
	    0, NULL);
	SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
	infoPtr->validMask |= TCL_READABLE;
    } else {
	infoPtr->readTI = NULL;
	infoPtr->readThread = 0;
    }
    if (writeFile != NULL) {
	/*
	 * Start the background writer thread.
	 */

	infoPtr->writable = CreateEventW(NULL, TRUE, TRUE, NULL);
	infoPtr->writeThread = CreateThread(NULL, 256, PipeWriterThread,
	    TclPipeThreadCreateTI(&infoPtr->writeTI, infoPtr, infoPtr->writable),
	    0, NULL);
	SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST);
	infoPtr->validMask |= TCL_WRITABLE;
    } else {
	infoPtr->writeTI = NULL;
	infoPtr->writeThread = 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". Use the pointer to keep the channel names
     * unique, in case channels share handles (stdin/stdout).
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
    /*
     * End of work, check the owner of the TI structure.
     */

    if (state != PTI_STATE_STOP) {
	*pipeTIPtr = NULL;
    } else {
    	pipeTI->evWakeUp = NULL;
    }
    if (wakeEvent) {
    	SetEvent(wakeEvent);
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *







|


|







3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
    /*
     * End of work, check the owner of the TI structure.
     */

    if (state != PTI_STATE_STOP) {
	*pipeTIPtr = NULL;
    } else {
	pipeTI->evWakeUp = NULL;
    }
    if (wakeEvent) {
	SetEvent(wakeEvent);
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *

Changes to win/tclWinPort.h.

110
111
112
113
114
115
116
117
118
119
120
121
122
123
124

/*
 * The following defines redefine the Windows Socket errors as
 * BSD errors so Tcl_PosixError can do the right thing.
 */

#ifndef ENOTEMPTY
#   define ENOTEMPTY 	41	/* Directory not empty */
#endif
#ifndef EREMOTE
#   define EREMOTE	66	/* The object is remote */
#endif
#ifndef EPFNOSUPPORT
#   define EPFNOSUPPORT	96	/* Protocol family not supported */
#endif







|







110
111
112
113
114
115
116
117
118
119
120
121
122
123
124

/*
 * The following defines redefine the Windows Socket errors as
 * BSD errors so Tcl_PosixError can do the right thing.
 */

#ifndef ENOTEMPTY
#   define ENOTEMPTY	41	/* Directory not empty */
#endif
#ifndef EREMOTE
#   define EREMOTE	66	/* The object is remote */
#endif
#ifndef EPFNOSUPPORT
#   define EPFNOSUPPORT	96	/* Protocol family not supported */
#endif

Changes to win/tclWinSerial.c.

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

/*
 * This structure describes the channel type structure for command serial
 * based IO.
 */

static const Tcl_ChannelType serialChannelType = {
    "serial",			/* Type name. */
    TCL_CHANNEL_VERSION_5,	/* v5 channel */
    NULL,		/* Close proc. */
    SerialInputProc,		/* Input proc. */
    SerialOutputProc,		/* Output proc. */
    NULL,			/* Seek proc. */
    SerialSetOptionProc,	/* Set option proc. */
    SerialGetOptionProc,	/* Get option proc. */
    SerialWatchProc,		/* Set up notifier to watch the channel. */
    SerialGetHandleProc,	/* Get an OS handle from channel. */
    SerialCloseProc,		/* close2proc. */
    SerialBlockProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    NULL,			/* wide seek proc */
    SerialThreadActionProc,	/* thread action proc */
    NULL                       /* truncate */
};

/*
 *----------------------------------------------------------------------
 *
 * SerialInit --
 *







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







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

/*
 * This structure describes the channel type structure for command serial
 * based IO.
 */

static const Tcl_ChannelType serialChannelType = {
    "serial",
    TCL_CHANNEL_VERSION_5,
    NULL,			/* Deprecated. */
    SerialInputProc,
    SerialOutputProc,
    NULL,			/* Deprecated. */
    SerialSetOptionProc,
    SerialGetOptionProc,
    SerialWatchProc,
    SerialGetHandleProc,
    SerialCloseProc,
    SerialBlockProc,
    NULL,			/* Flush proc. */
    NULL,			/* Bubbled event handler proc. */
    NULL,			/* Seek proc. */
    SerialThreadActionProc,
    NULL			/* Truncate proc. */
};

/*
 *----------------------------------------------------------------------
 *
 * SerialInit --
 *
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
    if (serialPtr->validMask & TCL_READABLE) {
	PurgeComm(serialPtr->handle, PURGE_RXABORT | PURGE_RXCLEAR);
	CloseHandle(serialPtr->osRead.hEvent);
    }
    serialPtr->validMask &= ~TCL_READABLE;

    if (serialPtr->writeThread) {
    	TclPipeThreadStop(&serialPtr->writeTI, serialPtr->writeThread);

	CloseHandle(serialPtr->osWrite.hEvent);
	CloseHandle(serialPtr->evWritable);
	CloseHandle(serialPtr->writeThread);
	serialPtr->writeThread = NULL;

	PurgeComm(serialPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR);







|







616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
    if (serialPtr->validMask & TCL_READABLE) {
	PurgeComm(serialPtr->handle, PURGE_RXABORT | PURGE_RXCLEAR);
	CloseHandle(serialPtr->osRead.hEvent);
    }
    serialPtr->validMask &= ~TCL_READABLE;

    if (serialPtr->writeThread) {
	TclPipeThreadStop(&serialPtr->writeTI, serialPtr->writeThread);

	CloseHandle(serialPtr->osWrite.hEvent);
	CloseHandle(serialPtr->evWritable);
	CloseHandle(serialPtr->writeThread);
	serialPtr->writeThread = NULL;

	PurgeComm(serialPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR);

Changes to win/tclWinSock.c.

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

/*
 * This structure describes the channel type structure for TCP socket
 * based IO:
 */

static const Tcl_ChannelType tcpChannelType = {
    "tcp",			/* Type name. */
    TCL_CHANNEL_VERSION_5,	/* v5 channel */
    NULL,			/* Old close proc. Deprecated. */
    TcpInputProc,		/* Input proc. */
    TcpOutputProc,		/* Output proc. */
    NULL,			/* Seek proc. */
    TcpSetOptionProc,		/* Set option proc. */
    TcpGetOptionProc,		/* Get option proc. */
    TcpWatchProc,		/* Initialize notifier. */
    TcpGetHandleProc,		/* Get OS handles out of channel. */
    TcpClose2Proc,		/* New close2 proc. */
    TcpBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    NULL,			/* wide seek proc. */
    TcpThreadActionProc,	/* thread action proc. */
    NULL			/* truncate proc. */
};

/*
 * The following variable holds the network name of this host.
 */

static TclInitProcessGlobalValueProc InitializeHostName;







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







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

/*
 * This structure describes the channel type structure for TCP socket
 * based IO:
 */

static const Tcl_ChannelType tcpChannelType = {
    "tcp",
    TCL_CHANNEL_VERSION_5,
    NULL,			/* Deprecated. */
    TcpInputProc,
    TcpOutputProc,
    NULL,			/* Deprecated. */
    TcpSetOptionProc,
    TcpGetOptionProc,
    TcpWatchProc,
    TcpGetHandleProc,
    TcpClose2Proc,
    TcpBlockModeProc,
    NULL,			/* Flush proc. */
    NULL,			/* Bubbled event handler proc. */
    NULL,			/* Seek proc. */
    TcpThreadActionProc,
    NULL			/* Truncate proc. */
};

/*
 * The following variable holds the network name of this host.
 */

static TclInitProcessGlobalValueProc InitializeHostName;
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
 *	     *	EWOULDBLOCK: if connect is still in progress
 *	     *	ENOTCONN: if connect failed. This would be the error message
 *		of a recv or sendto syscall so this is emulated here.
 *	 *  Null: Called by a background operation. Do not block and don't
 *	    return any error code.
 *
 * Results:
 * 	0 if the connection has completed, -1 if still in progress or there is
 * 	an error.
 *
 * Side effects:
 *	Processes socket events off the system queue. May process
 *	asynchronous connect.
 *
 *----------------------------------------------------------------------
 */







|
|







614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
 *	     *	EWOULDBLOCK: if connect is still in progress
 *	     *	ENOTCONN: if connect failed. This would be the error message
 *		of a recv or sendto syscall so this is emulated here.
 *	 *  Null: Called by a background operation. Do not block and don't
 *	    return any error code.
 *
 * Results:
 *	0 if the connection has completed, -1 if still in progress or there is
 *	an error.
 *
 * Side effects:
 *	Processes socket events off the system queue. May process
 *	asynchronous connect.
 *
 *----------------------------------------------------------------------
 */

Changes to win/tclWinTime.c.

31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
    DWORD calibrationInterv;	/* Calibration interval in seconds (start 1
				 * sec) */
    HANDLE calibrationThread;	/* Handle to the thread that keeps the virtual
				 * clock calibrated. */
    HANDLE readyEvent;		/* System event used to trigger the requesting
				 * thread when the clock calibration procedure
				 * is initialized for the first time. */
    HANDLE exitEvent; 		/* Event to signal out of an exit handler to
				 * tell the calibration loop to terminate. */
    LARGE_INTEGER nominalFreq;	/* Nominal frequency of the system performance
				 * counter, that is, the value returned from
				 * QueryPerformanceFrequency. */
    /*
     * The following values are used for calculating virtual time. Virtual
     * time is always equal to:







|







31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
    DWORD calibrationInterv;	/* Calibration interval in seconds (start 1
				 * sec) */
    HANDLE calibrationThread;	/* Handle to the thread that keeps the virtual
				 * clock calibrated. */
    HANDLE readyEvent;		/* System event used to trigger the requesting
				 * thread when the clock calibration procedure
				 * is initialized for the first time. */
    HANDLE exitEvent;		/* Event to signal out of an exit handler to
				 * tell the calibration loop to terminate. */
    LARGE_INTEGER nominalFreq;	/* Nominal frequency of the system performance
				 * counter, that is, the value returned from
				 * QueryPerformanceFrequency. */
    /*
     * The following values are used for calculating virtual time. Virtual
     * time is always equal to:
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119

/*
 * Declarations for functions defined later in this file.
 */

static void		StopCalibration(void *clientData);
static DWORD WINAPI	CalibrationThread(LPVOID arg);
static void 		UpdateTimeEachSecond(void);
static void		ResetCounterSamples(unsigned long long fileTime,
			    long long perfCounter, long long perfFreq);
static long long	AccumulateSample(long long perfCounter,
			    unsigned long long fileTime);
static void		NativeScaleTime(Tcl_Time* timebuf,
			    void *clientData);
static long long	NativeGetMicroseconds(void);







|







105
106
107
108
109
110
111
112
113
114
115
116
117
118
119

/*
 * Declarations for functions defined later in this file.
 */

static void		StopCalibration(void *clientData);
static DWORD WINAPI	CalibrationThread(LPVOID arg);
static void		UpdateTimeEachSecond(void);
static void		ResetCounterSamples(unsigned long long fileTime,
			    long long perfCounter, long long perfFreq);
static long long	AccumulateSample(long long perfCounter,
			    unsigned long long fileTime);
static void		NativeScaleTime(Tcl_Time* timebuf,
			    void *clientData);
static long long	NativeGetMicroseconds(void);
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
	    return (long long)curCounter.QuadPart;
	}
	/* fallback using microseconds */
	wideClick.perfCounter = 0;
	wideClick.microsecsScale = 1;
	return TclpGetMicroseconds();
    } else {
    	return TclpGetMicroseconds();
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpWideClickInMicrosec --
 *
 *	This procedure return scale to convert wide click values from the
 *	TclpGetWideClicks native resolution to microsecond resolution
 *	and back.
 *
 * Results:
 * 	1 click in microseconds as double.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

double
TclpWideClickInMicrosec(void)
{
    if (!wideClick.initialized) {
    	(void) TclpGetWideClicks();	/* initialize */
    }
    return wideClick.microsecsScale;
}

/*
 *----------------------------------------------------------------------
 *







|













|











|







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
	    return (long long)curCounter.QuadPart;
	}
	/* fallback using microseconds */
	wideClick.perfCounter = 0;
	wideClick.microsecsScale = 1;
	return TclpGetMicroseconds();
    } else {
	return TclpGetMicroseconds();
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpWideClickInMicrosec --
 *
 *	This procedure return scale to convert wide click values from the
 *	TclpGetWideClicks native resolution to microsecond resolution
 *	and back.
 *
 * Results:
 *	1 click in microseconds as double.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

double
TclpWideClickInMicrosec(void)
{
    if (!wideClick.initialized) {
	(void) TclpGetWideClicks();	/* initialize */
    }
    return wideClick.microsecsScale;
}

/*
 *----------------------------------------------------------------------
 *
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880

    /*
     * If calibration still not needed (check for possible time switch)
     */

    if (curFileTime.QuadPart > lastFileTime.QuadPart && curFileTime.QuadPart <
	    lastFileTime.QuadPart + (timeInfo.calibrationInterv * 10000000)) {
    	/*
	 * Look again in next one second.
	 */

	return;
    }
    QueryPerformanceCounter(&curPerfCounter);








|







866
867
868
869
870
871
872
873
874
875
876
877
878
879
880

    /*
     * If calibration still not needed (check for possible time switch)
     */

    if (curFileTime.QuadPart > lastFileTime.QuadPart && curFileTime.QuadPart <
	    lastFileTime.QuadPart + (timeInfo.calibrationInterv * 10000000)) {
	/*
	 * Look again in next one second.
	 */

	return;
    }
    QueryPerformanceCounter(&curPerfCounter);

936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
     * If we've gotten more than a second away from system time, then drifting
     * the clock is going to be pretty hopeless. Just let it jump. Otherwise,
     * compute the drift frequency and fill in everything.
     */

    tdiff = vt0 - curFileTime.QuadPart;
    if (tdiff > 10000000 || tdiff < -10000000) {
    	/*
	 * Jump to current system time, use curent estimated frequency.
	 */

    	vt0 = curFileTime.QuadPart;
    } else {
    	/*
	 * Calculate new frequency and estimate drift to the next second.
	 */

	vt1 = 20000000 + curFileTime.QuadPart;
	driftFreq = (estFreq * 20000000 / (vt1 - vt0));

	/*







|



|

|







936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
     * If we've gotten more than a second away from system time, then drifting
     * the clock is going to be pretty hopeless. Just let it jump. Otherwise,
     * compute the drift frequency and fill in everything.
     */

    tdiff = vt0 - curFileTime.QuadPart;
    if (tdiff > 10000000 || tdiff < -10000000) {
	/*
	 * Jump to current system time, use curent estimated frequency.
	 */

	vt0 = curFileTime.QuadPart;
    } else {
	/*
	 * Calculate new frequency and estimate drift to the next second.
	 */

	vt1 = 20000000 + curFileTime.QuadPart;
	driftFreq = (estFreq * 20000000 / (vt1 - vt0));

	/*
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
	    /*
	     * If drift unavoidable (e. g. we had a time switch), then reset
	     * it.
	     */

	    vt1 = vt0 - curFileTime.QuadPart;
	    if (vt1 > 10000000 || vt1 < -10000000) {
	    	/*
		 * Larger jump resp. shift relative new file-time.
		 */

	    	vt0 = curFileTime.QuadPart;
	    }
	}
    }

    /*
     * In lock commit new values to timeInfo (hold lock as short as possible)
     */







|



|







1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
	    /*
	     * If drift unavoidable (e. g. we had a time switch), then reset
	     * it.
	     */

	    vt1 = vt0 - curFileTime.QuadPart;
	    if (vt1 > 10000000 || vt1 < -10000000) {
		/*
		 * Larger jump resp. shift relative new file-time.
		 */

		vt0 = curFileTime.QuadPart;
	    }
	}
    }

    /*
     * In lock commit new values to timeInfo (hold lock as short as possible)
     */

Changes to win/tclsh.rc.

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

#define SUFFIX		    SUFFIX_STATIC SUFFIX_DEBUG


LANGUAGE 0x9, 0x1	/* LANG_ENGLISH, SUBLANG_DEFAULT */

VS_VERSION_INFO VERSIONINFO
 FILEVERSION 	TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
 PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
 FILEFLAGSMASK 	0x3fL
#ifdef DEBUG
 FILEFLAGS 	VS_FF_DEBUG
#else
 FILEFLAGS 	0x0L
#endif
 FILEOS 	VOS__WINDOWS32
 FILETYPE 	VFT_APP
 FILESUBTYPE 	0x0L
BEGIN
    BLOCK "StringFileInfo"
    BEGIN
        BLOCK "040904b0"
        BEGIN
            VALUE "FileDescription", "Tclsh Application\0"
            VALUE "OriginalFilename", "tclsh" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".exe\0"







|

|

|

|

|
|
|







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

#define SUFFIX		    SUFFIX_STATIC SUFFIX_DEBUG


LANGUAGE 0x9, 0x1	/* LANG_ENGLISH, SUBLANG_DEFAULT */

VS_VERSION_INFO VERSIONINFO
 FILEVERSION	TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
 PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
 FILEFLAGSMASK	0x3fL
#ifdef DEBUG
 FILEFLAGS	VS_FF_DEBUG
#else
 FILEFLAGS	0x0L
#endif
 FILEOS	VOS__WINDOWS32
 FILETYPE	VFT_APP
 FILESUBTYPE	0x0L
BEGIN
    BLOCK "StringFileInfo"
    BEGIN
        BLOCK "040904b0"
        BEGIN
            VALUE "FileDescription", "Tclsh Application\0"
            VALUE "OriginalFilename", "tclsh" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".exe\0"

Changes to win/tcltest.rc.

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

#define SUFFIX		    SUFFIX_STATIC SUFFIX_DEBUG


LANGUAGE 0x9, 0x1	/* LANG_ENGLISH, SUBLANG_DEFAULT */

VS_VERSION_INFO VERSIONINFO
 FILEVERSION 	TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
 PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
 FILEFLAGSMASK 	0x3fL
#ifdef DEBUG
 FILEFLAGS 	VS_FF_DEBUG
#else
 FILEFLAGS 	0x0L
#endif
 FILEOS 	VOS__WINDOWS32
 FILETYPE 	VFT_APP
 FILESUBTYPE 	0x0L
BEGIN
    BLOCK "StringFileInfo"
    BEGIN
        BLOCK "040904b0"
        BEGIN
            VALUE "FileDescription", "Tcltest Application\0"
            VALUE "OriginalFilename", "tcltest" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".exe\0"







|

|

|

|

|
|
|







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

#define SUFFIX		    SUFFIX_STATIC SUFFIX_DEBUG


LANGUAGE 0x9, 0x1	/* LANG_ENGLISH, SUBLANG_DEFAULT */

VS_VERSION_INFO VERSIONINFO
 FILEVERSION	TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
 PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
 FILEFLAGSMASK	0x3fL
#ifdef DEBUG
 FILEFLAGS	VS_FF_DEBUG
#else
 FILEFLAGS	0x0L
#endif
 FILEOS	VOS__WINDOWS32
 FILETYPE	VFT_APP
 FILESUBTYPE	0x0L
BEGIN
    BLOCK "StringFileInfo"
    BEGIN
        BLOCK "040904b0"
        BEGIN
            VALUE "FileDescription", "Tcltest Application\0"
            VALUE "OriginalFilename", "tcltest" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".exe\0"