Tcl Source Code

Check-in [29cc0feeb2]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

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

Overview
Comment:merge updates from HEAD
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | kennykb-numerics-branch
Files: files | file ages | folders
SHA1: 29cc0feeb262c62f98476658f71677b1de5197d5
User & Date: dgp 2005-09-15 20:58:38
Context
2005-09-16
15:35
[kennykb-numerics-branch]
* generic/tclTomMath.h: Added mp_cmp_d to routines from ...
check-in: f5324453ec user: dgp tags: kennykb-numerics-branch
2005-09-15
20:58
merge updates from HEAD check-in: 29cc0feeb2 user: dgp tags: kennykb-numerics-branch
2005-09-12
19:39
uninitialized vars are bad, mm'kay? check-in: 948d18b8f7 user: dgp tags: kennykb-numerics-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.








































































1
2
3
4
5
6
7






































































2005-09-12  Don Porter  <[email protected]>

	[kennykb-numerics-branch]	Merge updates from HEAD.

	* generic/tclCmdAH.c:		Added support for the "ll" width	
	* generic/tclStringObj.c:	specifier to [format].

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







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
2005-09-15  Don Porter  <[email protected]>

	[kennykb-numerics-branch]	Merge updates from HEAD.

	* generic/tclStringObj.c (TclAppendFormattedObjs):	Revision
	to eliminate one round of string copying.

	* generic/tclBasic.c:	More callers of TclObjPrintf and
	* generic/tclCkalloc.c:	TclFormatToErrorInfo.
	* generic/tclCmdMZ.c:
	* generic/tclExecute.c:
	* generic/tclIORChan.c:
	* generic/tclMain.c:
	* generic/tclProc.c:
	* generic/tclTimer.c:
	* generic/tclUtil.c:
	* unix/tclUnixFCmd.c

	* unix/configure:	autoconf-2.59

2005-09-15  Donal K. Fellows  <[email protected]>

	* unix/tcl.m4 (SC_TCL_EARLY_FLAGS): Added extra hack to allow Tcl
	to transparently open large files on RHEL 3. [Bug 1287638]

2005-09-14  Don Porter  <[email protected]>

	* generic/tclStringObj.c:	Bug fixes: ObjPrintfVA needed to
	support "*" fields and needed to interpret precision limits on
	%s conversions as a maximum number of bytes, not Tcl_UniChars, to
	take from the (char *) argument.

	* generic/tclBasic.c:	Updated several callers to use
	* generic/tclCkalloc.c: TclFormatToErrorInfo() and/or
	* generic/tclCmdAH.c:	TclObjPrintf().
	* generic/tclCmdIL.c:	
	* generic/tclCmdMZ.c:	
	* generic/tclDictObj.c:
	* generic/tclExecute.c:
	* generic/tclIORChan.c:	
	* generic/tclIOUtil.c:	
	* generic/tclNamesp.c:
	* generic/tclProc.c:

	* library/init.tcl:	Keep [unknown] in sync with errorInfo
	formatting rules.

2005-09-13  Don Porter  <[email protected]>

	* generic/tclBasic.c:	First caller of TclFormatToErrorInfo.

	* generic/tclInt.h:		Using stdarg.h conventions, add more
	* generic/tclStringObj.c:	fixed arguments to TclFormatObj() and
	TclObjPrintf().  Added new routine TclFormatToErrorInfo().

	* generic/tcl.h:	Explicitly standardized on the use of stdarg.h
	* generic/tclBasic.c:	conventions for functions with variable number
	* generic/tclInt.h:	of arguments.  Support for varargs.h has been
	* generic/tclPanic.c:	implicitly gone for some time now.  All
	* generic/tclResult.c:	TCL_VARARGS* macros purged from Tcl sources,
	* generic/tclStringObj.c:	leaving only some deprecated #define's
	* tools/genStubs.tcl:	in tcl.h for the sake of older extensions.

	* generic/tclDecls.h:	make genstubs

	* doc/AddErrInfo.3:	Replaced all documented requirement for use
	* doc/Eval.3:		of TCL_VARARGS_START() with requirement for
	* doc/Panic.3:		use of va_start().
	* doc/SetResult.3:
	* doc/StringObj.3:

2005-09-12  Don Porter  <[email protected]>

	[kennykb-numerics-branch]	Merge updates from HEAD.

	* generic/tclCmdAH.c:		Added support for the "ll" width	
	* generic/tclStringObj.c:	specifier to [format].

Changes to doc/AddErrInfo.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: AddErrInfo.3,v 1.13.2.1 2005/08/15 18:13:58 dgp Exp $
'\" 
.so man.macros
.TH Tcl_AddErrorInfo 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.VS 8.5
................................................................................
.AP Tcl_Obj *errorObjPtr in
The \fB-errorcode\fR return option will be set to this value.
.AP char *element in
String to record as one element of the \fB-errorcode\fR return option.
Last \fIelement\fR argument must be NULL.
.AP va_list argList in
An argument list which must have been initialized using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.AP "const char" *script in
Pointer to first character in script containing command (must be <= command)
.AP "const char" *command in
Pointer to first character in command that generated the error
.AP int commandLength in
Number of bytes in command; -1 means use all bytes up to first null byte
.BE






|


|







 







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: AddErrInfo.3,v 1.13.2.2 2005/09/15 20:58:38 dgp Exp $
'\" 
.so man.macros
.TH Tcl_AddErrorInfo 3 8.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.VS 8.5
................................................................................
.AP Tcl_Obj *errorObjPtr in
The \fB-errorcode\fR return option will be set to this value.
.AP char *element in
String to record as one element of the \fB-errorcode\fR return option.
Last \fIelement\fR argument must be NULL.
.AP va_list argList in
An argument list which must have been initialized using
\fBva_start\fR, and cleared using \fBva_end\fR.
.AP "const char" *script in
Pointer to first character in script containing command (must be <= command)
.AP "const char" *command in
Pointer to first character in command that generated the error
.AP int commandLength in
Number of bytes in command; -1 means use all bytes up to first null byte
.BE

Changes to doc/Eval.3.

2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
..
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Eval.3,v 1.18.2.2 2005/05/05 17:55:20 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA \- execute Tcl scripts
.SH SYNOPSIS
................................................................................
first null byte are used.
.AP "const char" *script in
Points to first byte of script to execute (null-terminated and UTF-8).
.AP char *part in
String forming part of a Tcl script.
.AP va_list argList in
An argument list which must have been initialized using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.BE

.SH DESCRIPTION
.PP
The procedures described here are invoked to execute Tcl scripts in
various forms.
\fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others.






|







 







|







2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
..
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Eval.3,v 1.18.2.3 2005/09/15 20:58:38 dgp Exp $
'\" 
.so man.macros
.TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA \- execute Tcl scripts
.SH SYNOPSIS
................................................................................
first null byte are used.
.AP "const char" *script in
Points to first byte of script to execute (null-terminated and UTF-8).
.AP char *part in
String forming part of a Tcl script.
.AP va_list argList in
An argument list which must have been initialized using
\fBva_start\fR, and cleared using \fBva_end\fR.
.BE

.SH DESCRIPTION
.PP
The procedures described here are invoked to execute Tcl scripts in
various forms.
\fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others.

Changes to doc/Panic.3.

1
2
3
4
5
6
7
8
9
10
11
12
..
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Panic.3,v 1.7 2004/10/07 15:15:47 dkf Exp $
'\" 
.so man.macros
.TH Tcl_Panic 3 8.4 Tcl "Tcl Library Procedures"
.BS
'\"  Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_Panic, Tcl_PanicVA, Tcl_SetPanicProc \- report fatal error and abort
................................................................................
.AS Tcl_PanicProc *panicProc
.AP "const char*" format in
A printf-style format string.
.AP "" arg in
Arguments matching the format string.
.AP va_list argList in
An argument list of arguments matching the format string.
Must have been initialized using \fBTCL_VARARGS_START\fR,
and cleared using \fBva_end\fR.
.AP Tcl_PanicProc *panicProc in
Procedure to report fatal error message and abort.

.BE

.SH DESCRIPTION



|







 







|







1
2
3
4
5
6
7
8
9
10
11
12
..
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Panic.3,v 1.7.2.1 2005/09/15 20:58:38 dgp Exp $
'\" 
.so man.macros
.TH Tcl_Panic 3 8.4 Tcl "Tcl Library Procedures"
.BS
'\"  Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_Panic, Tcl_PanicVA, Tcl_SetPanicProc \- report fatal error and abort
................................................................................
.AS Tcl_PanicProc *panicProc
.AP "const char*" format in
A printf-style format string.
.AP "" arg in
Arguments matching the format string.
.AP va_list argList in
An argument list of arguments matching the format string.
Must have been initialized using \fBva_start\fR,
and cleared using \fBva_end\fR.
.AP Tcl_PanicProc *panicProc in
Procedure to report fatal error message and abort.

.BE

.SH DESCRIPTION

Changes to doc/SetResult.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
..
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: SetResult.3,v 1.11.2.1 2005/05/05 17:55:23 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_SetResult 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendResultVA, Tcl_AppendElement, Tcl_ResetResult, Tcl_FreeResult \- manipulate Tcl result
.SH SYNOPSIS
................................................................................
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 va_list argList in
An argument list which must have been initialized using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.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 object or a string.






|







 







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
..
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: SetResult.3,v 1.11.2.2 2005/09/15 20:58:38 dgp Exp $
'\" 
.so man.macros
.TH Tcl_SetResult 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendResultVA, Tcl_AppendElement, Tcl_ResetResult, Tcl_FreeResult \- manipulate Tcl result
.SH SYNOPSIS
................................................................................
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 va_list argList in
An argument list which must have been initialized using
\fBva_start\fR, and cleared using \fBva_end\fR.
.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 object or a string.

Changes to doc/StringObj.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
...
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
'\"
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: StringObj.3,v 1.17.2.1 2005/04/10 23:14:42 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendObjToObj, Tcl_SetObjLength, Tcl_ConcatObj, Tcl_AttemptSetObjLength \- manipulate Tcl objects as strings
.SH SYNOPSIS
................................................................................
.AP int *lengthPtr out
If non-NULL, the location where \fBTcl_GetStringFromObj\fR will store
the length of an object's string representation.
.AP "const char" *string in
Null-terminated string value to append to \fIobjPtr\fR.
.AP va_list argList in
An argument list which must have been initialised using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.AP int newLength in
New length for the string value of \fIobjPtr\fR, not including the
final null character.
.AP int objc in
The number of elements to concatenate.
.AP Tcl_Obj *objv[] in
The array of objects to concatenate.





|







 







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
...
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
'\"
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: StringObj.3,v 1.17.2.2 2005/09/15 20:58:39 dgp Exp $
'\" 
.so man.macros
.TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendObjToObj, Tcl_SetObjLength, Tcl_ConcatObj, Tcl_AttemptSetObjLength \- manipulate Tcl objects as strings
.SH SYNOPSIS
................................................................................
.AP int *lengthPtr out
If non-NULL, the location where \fBTcl_GetStringFromObj\fR will store
the length of an object's string representation.
.AP "const char" *string in
Null-terminated string value to append to \fIobjPtr\fR.
.AP va_list argList in
An argument list which must have been initialised using
\fBva_start\fR, and cleared using \fBva_end\fR.
.AP int newLength in
New length for the string value of \fIobjPtr\fR, not including the
final null character.
.AP int objc in
The number of elements to concatenate.
.AP Tcl_Obj *objv[] in
The array of objects to concatenate.

Changes to generic/tcl.h.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
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
...
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tcl.h,v 1.191.2.9 2005/09/09 18:48:40 dgp Exp $
 */

#ifndef _TCL
#define _TCL

/*
 * For C++ compilers, use extern "C"
................................................................................
 * should, so also for their sake, we keep the #include to be consistent with
 * prior Tcl releases.
 */

#include <stdio.h>

/*
 * Definitions that allow Tcl functions with variable numbers of arguments to
 * be used with either varargs.h or stdarg.h. TCL_VARARGS is used in function

 * prototypes. TCL_VARARGS_DEF is used to declare the arguments in a function
 * definiton: it takes the type and name of the first argument and supplies
 * the appropriate argument declaration string for use in the function
 * definition. TCL_VARARGS_START initializes the va_list data structure and

 * returns the first argument.
 */

#if !defined(NO_STDARG)
#   include <stdarg.h>

#   define TCL_VARARGS(type, name) (type name, ...)
#   define TCL_VARARGS_DEF(type, name) (type name, ...)
#   define TCL_VARARGS_START(type, name, list) (va_start(list, name), name)
#else
#   include <varargs.h>
#   define TCL_VARARGS(type, name) ()
#   define TCL_VARARGS_DEF(type, name) (va_alist)
#   define TCL_VARARGS_START(type, name, list) \
	(va_start(list), va_arg(list, type))
#endif

/*
 * Macros used to declare a function to be exported by a DLL. Used by Windows,
 * maps to no-op declarations on non-Windows systems. The default build on
 * windows is for a DLL, which causes the DLLIMPORT and DLLEXPORT macros to be
 * nonempty. To build a static library, the macro STATIC_BUILD should be
................................................................................
	Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr));
typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv));
typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
typedef int (Tcl_PackageUnloadProc) _ANSI_ARGS_((Tcl_Interp *interp,
	int flags));
typedef void (Tcl_PanicProc) _ANSI_ARGS_(TCL_VARARGS(CONST char *, format));
typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData,
	Tcl_Channel chan, char *address, int port));
typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp,
	struct Tcl_Obj *objPtr));
typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,






|







 







|
<
>
|
|
|
<
>
|


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







 







|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
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
...
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tcl.h,v 1.191.2.10 2005/09/15 20:58:39 dgp Exp $
 */

#ifndef _TCL
#define _TCL

/*
 * For C++ compilers, use extern "C"
................................................................................
 * should, so also for their sake, we keep the #include to be consistent with
 * prior Tcl releases.
 */

#include <stdio.h>

/*
 * Support for functions with a variable number of arguments.

 *
 * The following TCL_VARARGS* macros are to support old extensions
 * written for older versions of Tcl where the macros permitted
 * support for the varargs.h system as well as stdarg.h .  

 *
 * New code should just directly be written to use stdarg.h conventions.
 */


#include <stdarg.h>
#ifndef TCL_NO_DEPRECATED
#    define TCL_VARARGS(type, name) (type name, ...)
#    define TCL_VARARGS_DEF(type, name) (type name, ...)
#    define TCL_VARARGS_START(type, name, list) (va_start(list, name), name)






#endif

/*
 * Macros used to declare a function to be exported by a DLL. Used by Windows,
 * maps to no-op declarations on non-Windows systems. The default build on
 * windows is for a DLL, which causes the DLLIMPORT and DLLEXPORT macros to be
 * nonempty. To build a static library, the macro STATIC_BUILD should be
................................................................................
	Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr));
typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv));
typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
typedef int (Tcl_PackageUnloadProc) _ANSI_ARGS_((Tcl_Interp *interp,
	int flags));
typedef void (Tcl_PanicProc) _ANSI_ARGS_((CONST char *format, ...));
typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData,
	Tcl_Channel chan, char *address, int port));
typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp,
	struct Tcl_Obj *objPtr));
typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,

Changes to generic/tclBasic.c.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
....
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
....
3620
3621
3622
3623
3624
3625
3626


3627
3628
3629
3630
3631
3632
3633
3634
3635
3636

3637
3638
3639
3640
3641
3642
3643
....
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849

3850
3851
3852
3853
3854
3855
3856
....
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
....
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBasic.c,v 1.136.2.33 2005/09/09 18:48:40 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include <float.h>
#include <math.h>
#include "tommath.h"
................................................................................
    CONST char *command;	/* First character in command that generated
				 * the error. */
    int length;			/* Number of bytes in command (-1 means use
				 * all bytes up to first null byte). */
{
    register CONST char *p;
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *message;

    if (iPtr->flags & ERR_ALREADY_LOGGED) {
	/*
	 * Someone else has already logged error information for this command;
	 * we shouldn't add anything more.
	 */

................................................................................
    iPtr->errorLine = 1;
    for (p = script; p != command; p++) {
	if (*p == '\n') {
	    iPtr->errorLine++;
	}
    }



    if (iPtr->errorInfo == NULL) {
	message = Tcl_NewStringObj("\n    while executing\n\"", -1);
    } else {
	message = Tcl_NewStringObj("\n    invoked from within\n\"", -1);
    }
    Tcl_IncrRefCount(message);
    TclAppendLimitedToObj(message, command, length, 153, NULL);
    Tcl_AppendToObj(message, "\"", -1);
    TclAppendObjToErrorInfo(interp, message);
    Tcl_DecrRefCount(message);

}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalTokensStandard --
 *
................................................................................
		Tcl_IncrRefCount(objv[objectsUsed]);
		if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
		    int numElements;

		    code = Tcl_ListObjLength(interp,
			    objv[objectsUsed], &numElements);
		    if (code == TCL_ERROR) {
			/*
			 * Attempt to expand a non-list.
			 */

			Tcl_Obj *msg;
			Tcl_Obj *wordNum;

			msg = Tcl_NewStringObj("\n    (expanding word ", -1);
			TclNewIntObj(wordNum, objectsUsed);
			Tcl_IncrRefCount(wordNum);
			Tcl_IncrRefCount(msg);
			Tcl_AppendObjToObj(msg, wordNum);
			Tcl_DecrRefCount(wordNum);
			Tcl_AppendToObj(msg, ")", -1);
			TclAppendObjToErrorInfo(interp, msg);
			Tcl_DecrRefCount(msg);

			Tcl_DecrRefCount(objv[objectsUsed]);
			goto error;
		    }
		    expandRequested = 1;
		    expand[objectsUsed] = 1;
		    objectsNeeded += (numElements ? numElements : 1);
		} else {
................................................................................
    if (returnCode == TCL_BREAK) {
	Tcl_AppendResult(interp,
		"invoked \"break\" outside of a loop", (char *) NULL);
    } else if (returnCode == TCL_CONTINUE) {
	Tcl_AppendResult(interp,
		"invoked \"continue\" outside of a loop", (char *) NULL);
    } else {
	char buf[30 + TCL_INTEGER_SPACE];

	sprintf(buf, "command returned bad code: %d", returnCode);
	Tcl_SetResult(interp, buf, TCL_VOLATILE);
    }
}
 
/*
 *---------------------------------------------------------------------------
 *
 * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
................................................................................
 *	left in interp->result.
 *
 * Side effects:
 *	Depends on what was done by the command.
 *
 *----------------------------------------------------------------------
 */
	/* VARARGS2 */ /* ARGSUSED */
int
Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
    Tcl_Interp *interp;
    va_list argList;
    int result;

    interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
    result = Tcl_VarEvalVA(interp, argList);
    va_end(argList);

    return result;
}
 
/*






|







 







|







 







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







 







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







 







|
<
|
|







 







|

|

<



|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
....
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
....
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629


3630






3631
3632
3633
3634
3635
3636
3637
3638
....
3822
3823
3824
3825
3826
3827
3828

3829












3830

3831
3832
3833
3834
3835
3836
3837
3838
....
4214
4215
4216
4217
4218
4219
4220
4221

4222
4223
4224
4225
4226
4227
4228
4229
4230
....
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828

4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBasic.c,v 1.136.2.34 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include <float.h>
#include <math.h>
#include "tommath.h"
................................................................................
    CONST char *command;	/* First character in command that generated
				 * the error. */
    int length;			/* Number of bytes in command (-1 means use
				 * all bytes up to first null byte). */
{
    register CONST char *p;
    Interp *iPtr = (Interp *) interp;
    int overflow, limit = 150;

    if (iPtr->flags & ERR_ALREADY_LOGGED) {
	/*
	 * Someone else has already logged error information for this command;
	 * we shouldn't add anything more.
	 */

................................................................................
    iPtr->errorLine = 1;
    for (p = script; p != command; p++) {
	if (*p == '\n') {
	    iPtr->errorLine++;
	}
    }

    overflow = (length > limit);
    TclFormatToErrorInfo(interp, "\n    %s\n\"%.*s%s\"",
	    ((iPtr->errorInfo == NULL)


	    ? "while executing" : "invoked from within"),






	    (overflow ? limit : length), command, (overflow ? "..." : ""));
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalTokensStandard --
 *
................................................................................
		Tcl_IncrRefCount(objv[objectsUsed]);
		if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
		    int numElements;

		    code = Tcl_ListObjLength(interp,
			    objv[objectsUsed], &numElements);
		    if (code == TCL_ERROR) {

			/* Attempt to expand a non-list. */












			TclFormatToErrorInfo(interp,

				"\n    (expanding word %d)", objectsUsed);
			Tcl_DecrRefCount(objv[objectsUsed]);
			goto error;
		    }
		    expandRequested = 1;
		    expand[objectsUsed] = 1;
		    objectsNeeded += (numElements ? numElements : 1);
		} else {
................................................................................
    if (returnCode == TCL_BREAK) {
	Tcl_AppendResult(interp,
		"invoked \"break\" outside of a loop", (char *) NULL);
    } else if (returnCode == TCL_CONTINUE) {
	Tcl_AppendResult(interp,
		"invoked \"continue\" outside of a loop", (char *) NULL);
    } else {
	Tcl_Obj *objPtr = Tcl_NewObj();

	TclObjPrintf(NULL, objPtr, "command returned bad code: %d", returnCode);
	Tcl_SetObjResult(interp, objPtr);
    }
}
 
/*
 *---------------------------------------------------------------------------
 *
 * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
................................................................................
 *	left in interp->result.
 *
 * Side effects:
 *	Depends on what was done by the command.
 *
 *----------------------------------------------------------------------
 */
	/* ARGSUSED */
int
Tcl_VarEval(Tcl_Interp *interp, ...)
{

    va_list argList;
    int result;

    va_start(argList, interp);
    result = Tcl_VarEvalVA(interp, argList);
    va_end(argList);

    return result;
}
 
/*

Changes to generic/tclCkalloc.c.

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * This code contributed by Karl Lehenbauer and Mark Diekhans
 *
 * RCS: @(#) $Id: tclCkalloc.c,v 1.22.2.1 2005/08/02 18:15:12 dgp Exp $
 */

#include "tclInt.h"

#define FALSE	0
#define TRUE	1

................................................................................
	}
	if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
	    return TCL_ERROR;
	}
	return TCL_OK;
    }
    if (strcmp(argv[1],"info") == 0) {
	char buf[400];
	sprintf(buf, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n",
		"total mallocs", total_mallocs, "total frees", total_frees,
		"current packets allocated", current_malloc_packets,
		"current bytes allocated", current_bytes_malloced,
		"maximum packets allocated", maximum_malloc_packets,
		"maximum bytes allocated", maximum_bytes_malloced);
	Tcl_SetResult(interp, buf, TCL_VOLATILE);
	return TCL_OK;
    }
    if (strcmp(argv[1],"init") == 0) {
	if (argc != 3) {
	    goto bad_suboption;
	}
	init_malloced_bodies = (strcmp(argv[2],"on") == 0);






|







 







|
|





|







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * This code contributed by Karl Lehenbauer and Mark Diekhans
 *
 * RCS: @(#) $Id: tclCkalloc.c,v 1.22.2.2 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"

#define FALSE	0
#define TRUE	1

................................................................................
	}
	if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
	    return TCL_ERROR;
	}
	return TCL_OK;
    }
    if (strcmp(argv[1],"info") == 0) {
	Tcl_Obj *objPtr = Tcl_NewObj();
	TclObjPrintf(NULL, objPtr, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n",
		"total mallocs", total_mallocs, "total frees", total_frees,
		"current packets allocated", current_malloc_packets,
		"current bytes allocated", current_bytes_malloced,
		"maximum packets allocated", maximum_malloc_packets,
		"maximum bytes allocated", maximum_bytes_malloced);
	Tcl_SetObjResult(interp, objPtr);
	return TCL_OK;
    }
    if (strcmp(argv[1],"init") == 0) {
	if (argc != 3) {
	    goto bad_suboption;
	}
	init_malloced_bodies = (strcmp(argv[2],"on") == 0);

Changes to generic/tclCmdAH.c.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
...
249
250
251
252
253
254
255
256
257
258
259

260
261
262
263
264
265
266
...
659
660
661
662
663
664
665
666
667
668
669

670
671
672
673
674
675
676
....
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635

1636
1637
1638
1639
1640
1641
1642
....
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdAH.c,v 1.57.2.9 2005/09/12 19:12:27 dgp Exp $
 */

#include "tclInt.h"
#include <locale.h>

#define NEW_FORMAT 1

................................................................................
    }

  match:
    if (body != -1) {
	armPtr = caseObjv[body - 1];
	result = Tcl_EvalObjEx(interp, caseObjv[body], 0);
	if (result == TCL_ERROR) {
	    char msg[100 + TCL_INTEGER_SPACE];

	    arg = TclGetString(armPtr);
	    sprintf(msg, "\n    (\"%.50s\" arm line %d)", arg,
		    interp->errorLine);
	    Tcl_AddObjErrorInfo(interp, msg, -1);
	}
	return result;
    }

    /*
     * Nothing matched: return nothing.
     */
................................................................................
    result = Tcl_EvalObjEx(interp, objv[1], 0);

    /*
     * We disable catch in interpreters where the limit has been exceeded.
     */

    if (Tcl_LimitExceeded(interp)) {
	char msg[32 + TCL_INTEGER_SPACE];

	sprintf(msg, "\n    (\"catch\" body line %d)", interp->errorLine);
	Tcl_AddErrorInfo(interp, msg);

	return TCL_ERROR;
    }

    if (objc >= 3) {
	if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL,
		Tcl_GetObjResult(interp), 0)) {
	    Tcl_ResetResult(interp);
................................................................................
	 * object when it decrements its refcount after eval'ing it.
	 */

	objPtr = Tcl_ConcatObj(objc-1, objv+1);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }
    if (result == TCL_ERROR) {
	char msg[32 + TCL_INTEGER_SPACE];

	sprintf(msg, "\n    (\"eval\" body line %d)", interp->errorLine);
	Tcl_AddObjErrorInfo(interp, msg, -1);

    }
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
	}
	if (!value) {
	    break;
	}
	result = Tcl_EvalObjEx(interp, objv[4], 0);
	if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
	    if (result == TCL_ERROR) {
		char msg[32 + TCL_INTEGER_SPACE];

		sprintf(msg, "\n    (\"for\" body line %d)",interp->errorLine);
		Tcl_AddErrorInfo(interp, msg);

	    }
	    break;
	}
	result = Tcl_EvalObjEx(interp, objv[3], 0);
	if (result == TCL_BREAK) {
	    break;
	} else if (result != TCL_OK) {
................................................................................
	if (result != TCL_OK) {
	    if (result == TCL_CONTINUE) {
		result = TCL_OK;
	    } else if (result == TCL_BREAK) {
		result = TCL_OK;
		break;
	    } else if (result == TCL_ERROR) {
		char msg[32 + TCL_INTEGER_SPACE];

		sprintf(msg, "\n    (\"foreach\" body line %d)",
			interp->errorLine);
		Tcl_AddObjErrorInfo(interp, msg, -1);
		break;
	    } else {
		break;
	    }
	}
    }
    if (result == TCL_OK) {






|







 







<
<
<
|
|
<







 







<
<
|
<
>







 







<
<
|
<
>







 







<
<
|
<
>







 







|
<
|
<
<







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
183
184
185
186
187
188
189



190
191

192
193
194
195
196
197
198
...
245
246
247
248
249
250
251


252

253
254
255
256
257
258
259
260
...
653
654
655
656
657
658
659


660

661
662
663
664
665
666
667
668
....
1617
1618
1619
1620
1621
1622
1623


1624

1625
1626
1627
1628
1629
1630
1631
1632
....
1832
1833
1834
1835
1836
1837
1838
1839

1840


1841
1842
1843
1844
1845
1846
1847
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdAH.c,v 1.57.2.10 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#include <locale.h>

#define NEW_FORMAT 1

................................................................................
    }

  match:
    if (body != -1) {
	armPtr = caseObjv[body - 1];
	result = Tcl_EvalObjEx(interp, caseObjv[body], 0);
	if (result == TCL_ERROR) {



	    TclFormatToErrorInfo(interp, "\n    (\"%.50s\" arm line %d)",
		    TclGetString(armPtr), interp->errorLine);

	}
	return result;
    }

    /*
     * Nothing matched: return nothing.
     */
................................................................................
    result = Tcl_EvalObjEx(interp, objv[1], 0);

    /*
     * We disable catch in interpreters where the limit has been exceeded.
     */

    if (Tcl_LimitExceeded(interp)) {


	TclFormatToErrorInfo(interp, "\n    (\"catch\" body line %d)",

		interp->errorLine);
	return TCL_ERROR;
    }

    if (objc >= 3) {
	if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL,
		Tcl_GetObjResult(interp), 0)) {
	    Tcl_ResetResult(interp);
................................................................................
	 * object when it decrements its refcount after eval'ing it.
	 */

	objPtr = Tcl_ConcatObj(objc-1, objv+1);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }
    if (result == TCL_ERROR) {


	TclFormatToErrorInfo(interp,"\n    (\"eval\" body line %d)",

		interp->errorLine);
    }
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
	}
	if (!value) {
	    break;
	}
	result = Tcl_EvalObjEx(interp, objv[4], 0);
	if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
	    if (result == TCL_ERROR) {


		TclFormatToErrorInfo(interp, "\n    (\"for\" body line %d)",

			interp->errorLine);
	    }
	    break;
	}
	result = Tcl_EvalObjEx(interp, objv[3], 0);
	if (result == TCL_BREAK) {
	    break;
	} else if (result != TCL_OK) {
................................................................................
	if (result != TCL_OK) {
	    if (result == TCL_CONTINUE) {
		result = TCL_OK;
	    } else if (result == TCL_BREAK) {
		result = TCL_OK;
		break;
	    } else if (result == TCL_ERROR) {
		TclFormatToErrorInfo(interp,

			"\n    (\"foreach\" body line %d)", interp->errorLine);


		break;
	    } else {
		break;
	    }
	}
    }
    if (result == TCL_OK) {

Changes to generic/tclCmdIL.c.

12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
....
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
....
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2005 Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdIL.c,v 1.70.2.8 2005/08/29 18:38:45 dgp Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"

/*
 * During execution of the "lsort" command, structures of the following type
................................................................................
	     * their scale is sensible yet, but we at least perform the
	     * syntactic check here.
	     */

	    for (j=0 ; j<sortInfo.indexc ; j++) {
		if (TclGetIntForIndex(interp, indices[j], SORTIDX_END,
			&sortInfo.indexv[j]) != TCL_OK) {
		    char buffer[TCL_INTEGER_SPACE];

		    if (sortInfo.indexc > 1) {
			ckfree((char *) sortInfo.indexv);
		    }
		    sprintf(buffer, "%d", j);
		    Tcl_AddErrorInfo(interp,
			    "\n    (-index option item number ");
		    Tcl_AddErrorInfo(interp, buffer);
		    Tcl_AddErrorInfo(interp, ")");
		    return TCL_ERROR;
		}
	    }
	    break;
	}
	}
    }
................................................................................
	     * their scale is sensible yet, but we at least perform the
	     * syntactic check here.
	     */

	    for (j=0 ; j<sortInfo.indexc ; j++) {
		if (TclGetIntForIndex(interp, indices[j], SORTIDX_END,
			&sortInfo.indexv[j]) != TCL_OK) {
		    char buffer[TCL_INTEGER_SPACE];

		    if (sortInfo.indexc > 1) {
			ckfree((char *) sortInfo.indexv);
		    }
		    sprintf(buffer, "%d", j);
		    Tcl_AddErrorInfo(interp,
			    "\n    (-index option item number ");
		    Tcl_AddErrorInfo(interp, buffer);
		    Tcl_AddErrorInfo(interp, ")");
		    return TCL_ERROR;
		}
	    }
	    i++;
	    break;
	}
	case LSORT_INTEGER:






|







 







<
<



<
|
|
<
<







 







<
<



<
|
|
<
<







12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
....
3415
3416
3417
3418
3419
3420
3421


3422
3423
3424

3425
3426


3427
3428
3429
3430
3431
3432
3433
....
4025
4026
4027
4028
4029
4030
4031


4032
4033
4034

4035
4036


4037
4038
4039
4040
4041
4042
4043
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2005 Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdIL.c,v 1.70.2.9 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"

/*
 * During execution of the "lsort" command, structures of the following type
................................................................................
	     * their scale is sensible yet, but we at least perform the
	     * syntactic check here.
	     */

	    for (j=0 ; j<sortInfo.indexc ; j++) {
		if (TclGetIntForIndex(interp, indices[j], SORTIDX_END,
			&sortInfo.indexv[j]) != TCL_OK) {


		    if (sortInfo.indexc > 1) {
			ckfree((char *) sortInfo.indexv);
		    }

		    TclFormatToErrorInfo(interp,
			    "\n    (-index option item number %d)", j);


		    return TCL_ERROR;
		}
	    }
	    break;
	}
	}
    }
................................................................................
	     * their scale is sensible yet, but we at least perform the
	     * syntactic check here.
	     */

	    for (j=0 ; j<sortInfo.indexc ; j++) {
		if (TclGetIntForIndex(interp, indices[j], SORTIDX_END,
			&sortInfo.indexv[j]) != TCL_OK) {


		    if (sortInfo.indexc > 1) {
			ckfree((char *) sortInfo.indexv);
		    }

		    TclFormatToErrorInfo(interp,
			    "\n    (-index option item number %d)", j);


		    return TCL_ERROR;
		}
	    }
	    i++;
	    break;
	}
	case LSORT_INTEGER:

Changes to generic/tclCmdMZ.c.

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
....
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
....
2530
2531
2532
2533
2534
2535
2536

2537
2538
2539
2540
2541
2542
2543
....
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
....
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
....
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
 * Copyright (c) 1998-2000 Scriptics Corporation.
 * Copyright (c) 2002 ActiveState Corporation.
 * Copyright (c) 2003 Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdMZ.c,v 1.115.2.12 2005/08/29 18:38:45 dgp Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"
 
/*
 *----------------------------------------------------------------------
................................................................................
		 * with back-division. [Bug #714106]
		 */

		Tcl_Obj *resultPtr;

		length2 = length1 * count;
		if ((length2 / count) != length1) {
		    char buf[TCL_INTEGER_SPACE+1];

		    sprintf(buf, "%d", INT_MAX);
		    Tcl_AppendResult(interp,
			    "string size overflow, must be less than ",
			    buf, (char *) NULL);
		    return TCL_ERROR;
		}

		/*
		 * Include space for the NULL.
		 */

................................................................................
Tcl_SwitchObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int i,j, index, mode, foundmode, result, splitObjs, numMatchesSaved, noCase;

    char *pattern;
    Tcl_Obj *stringObj, *indexVarObj, *matchVarObj;
    Tcl_Obj *CONST *savedObjv = objv;
    Tcl_RegExp regExpr = NULL;

    /*
     * If you add options that make -e and -g not unique prefixes of -exact or
................................................................................
    }

    for (i = 0; i < objc; i += 2) {
	/*
	 * See if the pattern matches the string.
	 */

	pattern = TclGetString(objv[i]);

	if ((i == objc - 2) && (*pattern == 'd')
		&& (strcmp(pattern, "default") == 0)) {
	    Tcl_Obj *emptyObj = NULL;

	    /*
	     * If either indexVarObj or matchVarObj are non-NULL, we're in
................................................................................
    result = Tcl_EvalObjEx(interp, objv[j], 0);

    /*
     * Generate an error message if necessary.
     */

    if (result == TCL_ERROR) {
	Tcl_Obj *msg = Tcl_NewStringObj("\n    (\"", -1);
	Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);

	Tcl_IncrRefCount(msg);
	Tcl_IncrRefCount(errorLine);
	TclAppendLimitedToObj(msg, pattern, -1, 50, "");
	Tcl_AppendToObj(msg,"\" arm line ", -1);
	Tcl_AppendObjToObj(msg, errorLine);
	Tcl_DecrRefCount(errorLine);
	Tcl_AppendToObj(msg,")", -1);
	TclAppendObjToErrorInfo(interp, msg);
	Tcl_DecrRefCount(msg);


    }
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
	}
	if (!value) {
	    break;
	}
	result = Tcl_EvalObjEx(interp, objv[2], 0);
	if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
	    if (result == TCL_ERROR) {
		char msg[32 + TCL_INTEGER_SPACE];

		sprintf(msg, "\n    (\"while\" body line %d)",
			interp->errorLine);
		Tcl_AddErrorInfo(interp, msg);
	    }
	    break;
	}
    }
    if (result == TCL_BREAK) {
	result = TCL_OK;
    }






|







 







|
|
|
|
|
<







 







>







 







|







 







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







 







<
<
|

<







11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
....
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133

2134
2135
2136
2137
2138
2139
2140
....
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
....
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
....
2884
2885
2886
2887
2888
2889
2890
2891
2892








2893

2894
2895
2896
2897
2898
2899
2900
2901
2902
....
3021
3022
3023
3024
3025
3026
3027


3028
3029

3030
3031
3032
3033
3034
3035
3036
 * Copyright (c) 1998-2000 Scriptics Corporation.
 * Copyright (c) 2002 ActiveState Corporation.
 * Copyright (c) 2003 Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdMZ.c,v 1.115.2.13 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"
 
/*
 *----------------------------------------------------------------------
................................................................................
		 * with back-division. [Bug #714106]
		 */

		Tcl_Obj *resultPtr;

		length2 = length1 * count;
		if ((length2 / count) != length1) {
		    resultPtr = Tcl_NewObj();
		    TclObjPrintf(NULL, resultPtr,
			    "string size overflow, must be less than %d",
			    INT_MAX);
		    Tcl_SetObjResult(interp, resultPtr);

		    return TCL_ERROR;
		}

		/*
		 * Include space for the NULL.
		 */

................................................................................
Tcl_SwitchObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int i,j, index, mode, foundmode, result, splitObjs, numMatchesSaved, noCase;
    int patternLength;
    char *pattern;
    Tcl_Obj *stringObj, *indexVarObj, *matchVarObj;
    Tcl_Obj *CONST *savedObjv = objv;
    Tcl_RegExp regExpr = NULL;

    /*
     * If you add options that make -e and -g not unique prefixes of -exact or
................................................................................
    }

    for (i = 0; i < objc; i += 2) {
	/*
	 * See if the pattern matches the string.
	 */

	pattern = Tcl_GetStringFromObj(objv[i], &patternLength);

	if ((i == objc - 2) && (*pattern == 'd')
		&& (strcmp(pattern, "default") == 0)) {
	    Tcl_Obj *emptyObj = NULL;

	    /*
	     * If either indexVarObj or matchVarObj are non-NULL, we're in
................................................................................
    result = Tcl_EvalObjEx(interp, objv[j], 0);

    /*
     * Generate an error message if necessary.
     */

    if (result == TCL_ERROR) {
	int limit = 50;
	int overflow = (patternLength > limit);








	TclFormatToErrorInfo(interp, "\n    (\"%.*s%s\" arm line %d)",

		(overflow ? limit : patternLength), pattern,
		(overflow ? "..." : ""), interp->errorLine);
    }
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
	}
	if (!value) {
	    break;
	}
	result = Tcl_EvalObjEx(interp, objv[2], 0);
	if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
	    if (result == TCL_ERROR) {


		TclFormatToErrorInfo(interp, "\n    (\"while\" body line %d)",
			interp->errorLine);

	    }
	    break;
	}
    }
    if (result == TCL_BREAK) {
	result = TCL_OK;
    }

Changes to generic/tclDecls.h.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
...
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
...
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
....
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
....
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
....
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
....
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
....
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
....
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
....
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
 *	Declarations of functions in the platform independent public Tcl API.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclDecls.h,v 1.107.2.7 2005/08/25 15:46:30 dgp Exp $
 */

#ifndef _TCLDECLS
#define _TCLDECLS

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
................................................................................
				Tcl_Interp * interp, CONST char * name, 
				CONST char * version, int exact, 
				ClientData * clientDataPtr));
#endif
#ifndef Tcl_Panic_TCL_DECLARED
#define Tcl_Panic_TCL_DECLARED
/* 2 */
EXTERN void		Tcl_Panic _ANSI_ARGS_(TCL_VARARGS(CONST char *,format));
#endif
#ifndef Tcl_Alloc_TCL_DECLARED
#define Tcl_Alloc_TCL_DECLARED
/* 3 */
EXTERN char *		Tcl_Alloc _ANSI_ARGS_((unsigned int size));
#endif
#ifndef Tcl_Free_TCL_DECLARED
................................................................................
/* 14 */
EXTERN int		Tcl_AppendAllObjTypes _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * objPtr));
#endif
#ifndef Tcl_AppendStringsToObj_TCL_DECLARED
#define Tcl_AppendStringsToObj_TCL_DECLARED
/* 15 */
EXTERN void		Tcl_AppendStringsToObj _ANSI_ARGS_(TCL_VARARGS(Tcl_Obj *,objPtr));
#endif
#ifndef Tcl_AppendToObj_TCL_DECLARED
#define Tcl_AppendToObj_TCL_DECLARED
/* 16 */
EXTERN void		Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj* objPtr, 
				CONST char* bytes, int length));
#endif
................................................................................
/* 69 */
EXTERN void		Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * element));
#endif
#ifndef Tcl_AppendResult_TCL_DECLARED
#define Tcl_AppendResult_TCL_DECLARED
/* 70 */
EXTERN void		Tcl_AppendResult _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
#endif
#ifndef Tcl_AsyncCreate_TCL_DECLARED
#define Tcl_AsyncCreate_TCL_DECLARED
/* 71 */
EXTERN Tcl_AsyncHandler	 Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc * proc, 
				ClientData clientData));
#endif
................................................................................
#define Tcl_SetErrno_TCL_DECLARED
/* 227 */
EXTERN void		Tcl_SetErrno _ANSI_ARGS_((int err));
#endif
#ifndef Tcl_SetErrorCode_TCL_DECLARED
#define Tcl_SetErrorCode_TCL_DECLARED
/* 228 */
EXTERN void		Tcl_SetErrorCode _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
#endif
#ifndef Tcl_SetMaxBlockTime_TCL_DECLARED
#define Tcl_SetMaxBlockTime_TCL_DECLARED
/* 229 */
EXTERN void		Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time * timePtr));
#endif
#ifndef Tcl_SetPanicProc_TCL_DECLARED
................................................................................
				CONST char * frameName, CONST char * part1, 
				CONST char * part2, CONST char * localName, 
				int flags));
#endif
#ifndef Tcl_VarEval_TCL_DECLARED
#define Tcl_VarEval_TCL_DECLARED
/* 260 */
EXTERN int		Tcl_VarEval _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
#endif
#ifndef Tcl_VarTraceInfo_TCL_DECLARED
#define Tcl_VarTraceInfo_TCL_DECLARED
/* 261 */
EXTERN ClientData	Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * varName, int flags, 
				Tcl_VarTraceProc * procPtr, 
................................................................................

typedef struct TclStubs {
    int magic;
    struct TclStubHooks *hooks;

    int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* name, CONST char* version, ClientData clientData)); /* 0 */
    CONST84_RETURN char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 1 */
    void (*tcl_Panic) _ANSI_ARGS_(TCL_VARARGS(CONST char *,format)); /* 2 */
    char * (*tcl_Alloc) _ANSI_ARGS_((unsigned int size)); /* 3 */
    void (*tcl_Free) _ANSI_ARGS_((char * ptr)); /* 4 */
    char * (*tcl_Realloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 5 */
    char * (*tcl_DbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char * file, int line)); /* 6 */
    int (*tcl_DbCkfree) _ANSI_ARGS_((char * ptr, CONST char * file, int line)); /* 7 */
    char * (*tcl_DbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, CONST char * file, int line)); /* 8 */
#if !defined(__WIN32__) /* UNIX */
................................................................................
#ifdef __WIN32__
    void *reserved10;
#endif /* __WIN32__ */
    void (*tcl_SetTimer) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 11 */
    void (*tcl_Sleep) _ANSI_ARGS_((int ms)); /* 12 */
    int (*tcl_WaitForEvent) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 13 */
    int (*tcl_AppendAllObjTypes) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 14 */
    void (*tcl_AppendStringsToObj) _ANSI_ARGS_(TCL_VARARGS(Tcl_Obj *,objPtr)); /* 15 */
    void (*tcl_AppendToObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 16 */
    Tcl_Obj * (*tcl_ConcatObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 17 */
    int (*tcl_ConvertToType) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_ObjType * typePtr)); /* 18 */
    void (*tcl_DbDecrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 19 */
    void (*tcl_DbIncrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 20 */
    int (*tcl_DbIsShared) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 21 */
    Tcl_Obj * (*tcl_DbNewBooleanObj) _ANSI_ARGS_((int boolValue, CONST char * file, int line)); /* 22 */
................................................................................
    void (*tcl_SetLongObj) _ANSI_ARGS_((Tcl_Obj * objPtr, long longValue)); /* 63 */
    void (*tcl_SetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 64 */
    void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 65 */
    void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message)); /* 66 */
    void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message, int length)); /* 67 */
    void (*tcl_AllowExceptions) _ANSI_ARGS_((Tcl_Interp * interp)); /* 68 */
    void (*tcl_AppendElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * element)); /* 69 */
    void (*tcl_AppendResult) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 70 */
    Tcl_AsyncHandler (*tcl_AsyncCreate) _ANSI_ARGS_((Tcl_AsyncProc * proc, ClientData clientData)); /* 71 */
    void (*tcl_AsyncDelete) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 72 */
    int (*tcl_AsyncInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int code)); /* 73 */
    void (*tcl_AsyncMark) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 74 */
    int (*tcl_AsyncReady) _ANSI_ARGS_((void)); /* 75 */
    void (*tcl_BackgroundError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 76 */
    char (*tcl_Backslash) _ANSI_ARGS_((CONST char * src, int * readPtr)); /* 77 */
................................................................................
    int (*tcl_ServiceAll) _ANSI_ARGS_((void)); /* 221 */
    int (*tcl_ServiceEvent) _ANSI_ARGS_((int flags)); /* 222 */
    void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */
    void (*tcl_SetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan, int sz)); /* 224 */
    int (*tcl_SetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, CONST char * newValue)); /* 225 */
    int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST Tcl_CmdInfo * infoPtr)); /* 226 */
    void (*tcl_SetErrno) _ANSI_ARGS_((int err)); /* 227 */
    void (*tcl_SetErrorCode) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 228 */
    void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 229 */
    void (*tcl_SetPanicProc) _ANSI_ARGS_((Tcl_PanicProc * panicProc)); /* 230 */
    int (*tcl_SetRecursionLimit) _ANSI_ARGS_((Tcl_Interp * interp, int depth)); /* 231 */
    void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * result, Tcl_FreeProc * freeProc)); /* 232 */
    int (*tcl_SetServiceMode) _ANSI_ARGS_((int mode)); /* 233 */
    void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * errorObjPtr)); /* 234 */
    void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 235 */
................................................................................
    int (*tcl_UnsetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 253 */
    int (*tcl_UnsetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 254 */
    void (*tcl_UntraceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 255 */
    void (*tcl_UntraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 256 */
    void (*tcl_UpdateLinkedVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 257 */
    int (*tcl_UpVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * varName, CONST char * localName, int flags)); /* 258 */
    int (*tcl_UpVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * part1, CONST char * part2, CONST char * localName, int flags)); /* 259 */
    int (*tcl_VarEval) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 260 */
    ClientData (*tcl_VarTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 261 */
    ClientData (*tcl_VarTraceInfo2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 262 */
    int (*tcl_Write) _ANSI_ARGS_((Tcl_Channel chan, CONST char * s, int slen)); /* 263 */
    void (*tcl_WrongNumArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], CONST char * message)); /* 264 */
    int (*tcl_DumpActiveMemory) _ANSI_ARGS_((CONST char * fileName)); /* 265 */
    void (*tcl_ValidateAllMemory) _ANSI_ARGS_((CONST char * file, int line)); /* 266 */
    void (*tcl_AppendResultVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 267 */






|







 







|







 







|







 







|







 







|







 







|







 







|







 







|







 







|







 







|







 







|







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
...
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
...
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
....
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
....
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
....
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
....
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
....
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
....
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
....
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
 *	Declarations of functions in the platform independent public Tcl API.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclDecls.h,v 1.107.2.8 2005/09/15 20:58:39 dgp Exp $
 */

#ifndef _TCLDECLS
#define _TCLDECLS

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
................................................................................
				Tcl_Interp * interp, CONST char * name, 
				CONST char * version, int exact, 
				ClientData * clientDataPtr));
#endif
#ifndef Tcl_Panic_TCL_DECLARED
#define Tcl_Panic_TCL_DECLARED
/* 2 */
EXTERN void		Tcl_Panic _ANSI_ARGS_((CONST char *format, ...));
#endif
#ifndef Tcl_Alloc_TCL_DECLARED
#define Tcl_Alloc_TCL_DECLARED
/* 3 */
EXTERN char *		Tcl_Alloc _ANSI_ARGS_((unsigned int size));
#endif
#ifndef Tcl_Free_TCL_DECLARED
................................................................................
/* 14 */
EXTERN int		Tcl_AppendAllObjTypes _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * objPtr));
#endif
#ifndef Tcl_AppendStringsToObj_TCL_DECLARED
#define Tcl_AppendStringsToObj_TCL_DECLARED
/* 15 */
EXTERN void		Tcl_AppendStringsToObj _ANSI_ARGS_((Tcl_Obj *objPtr, ...));
#endif
#ifndef Tcl_AppendToObj_TCL_DECLARED
#define Tcl_AppendToObj_TCL_DECLARED
/* 16 */
EXTERN void		Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj* objPtr, 
				CONST char* bytes, int length));
#endif
................................................................................
/* 69 */
EXTERN void		Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * element));
#endif
#ifndef Tcl_AppendResult_TCL_DECLARED
#define Tcl_AppendResult_TCL_DECLARED
/* 70 */
EXTERN void		Tcl_AppendResult _ANSI_ARGS_((Tcl_Interp *interp, ...));
#endif
#ifndef Tcl_AsyncCreate_TCL_DECLARED
#define Tcl_AsyncCreate_TCL_DECLARED
/* 71 */
EXTERN Tcl_AsyncHandler	 Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc * proc, 
				ClientData clientData));
#endif
................................................................................
#define Tcl_SetErrno_TCL_DECLARED
/* 227 */
EXTERN void		Tcl_SetErrno _ANSI_ARGS_((int err));
#endif
#ifndef Tcl_SetErrorCode_TCL_DECLARED
#define Tcl_SetErrorCode_TCL_DECLARED
/* 228 */
EXTERN void		Tcl_SetErrorCode _ANSI_ARGS_((Tcl_Interp *interp, ...));
#endif
#ifndef Tcl_SetMaxBlockTime_TCL_DECLARED
#define Tcl_SetMaxBlockTime_TCL_DECLARED
/* 229 */
EXTERN void		Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time * timePtr));
#endif
#ifndef Tcl_SetPanicProc_TCL_DECLARED
................................................................................
				CONST char * frameName, CONST char * part1, 
				CONST char * part2, CONST char * localName, 
				int flags));
#endif
#ifndef Tcl_VarEval_TCL_DECLARED
#define Tcl_VarEval_TCL_DECLARED
/* 260 */
EXTERN int		Tcl_VarEval _ANSI_ARGS_((Tcl_Interp *interp, ...));
#endif
#ifndef Tcl_VarTraceInfo_TCL_DECLARED
#define Tcl_VarTraceInfo_TCL_DECLARED
/* 261 */
EXTERN ClientData	Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * varName, int flags, 
				Tcl_VarTraceProc * procPtr, 
................................................................................

typedef struct TclStubs {
    int magic;
    struct TclStubHooks *hooks;

    int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* name, CONST char* version, ClientData clientData)); /* 0 */
    CONST84_RETURN char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 1 */
    void (*tcl_Panic) _ANSI_ARGS_((CONST char *format, ...)); /* 2 */
    char * (*tcl_Alloc) _ANSI_ARGS_((unsigned int size)); /* 3 */
    void (*tcl_Free) _ANSI_ARGS_((char * ptr)); /* 4 */
    char * (*tcl_Realloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 5 */
    char * (*tcl_DbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char * file, int line)); /* 6 */
    int (*tcl_DbCkfree) _ANSI_ARGS_((char * ptr, CONST char * file, int line)); /* 7 */
    char * (*tcl_DbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, CONST char * file, int line)); /* 8 */
#if !defined(__WIN32__) /* UNIX */
................................................................................
#ifdef __WIN32__
    void *reserved10;
#endif /* __WIN32__ */
    void (*tcl_SetTimer) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 11 */
    void (*tcl_Sleep) _ANSI_ARGS_((int ms)); /* 12 */
    int (*tcl_WaitForEvent) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 13 */
    int (*tcl_AppendAllObjTypes) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 14 */
    void (*tcl_AppendStringsToObj) _ANSI_ARGS_((Tcl_Obj *objPtr, ...)); /* 15 */
    void (*tcl_AppendToObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 16 */
    Tcl_Obj * (*tcl_ConcatObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 17 */
    int (*tcl_ConvertToType) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_ObjType * typePtr)); /* 18 */
    void (*tcl_DbDecrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 19 */
    void (*tcl_DbIncrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 20 */
    int (*tcl_DbIsShared) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 21 */
    Tcl_Obj * (*tcl_DbNewBooleanObj) _ANSI_ARGS_((int boolValue, CONST char * file, int line)); /* 22 */
................................................................................
    void (*tcl_SetLongObj) _ANSI_ARGS_((Tcl_Obj * objPtr, long longValue)); /* 63 */
    void (*tcl_SetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 64 */
    void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 65 */
    void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message)); /* 66 */
    void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message, int length)); /* 67 */
    void (*tcl_AllowExceptions) _ANSI_ARGS_((Tcl_Interp * interp)); /* 68 */
    void (*tcl_AppendElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * element)); /* 69 */
    void (*tcl_AppendResult) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 70 */
    Tcl_AsyncHandler (*tcl_AsyncCreate) _ANSI_ARGS_((Tcl_AsyncProc * proc, ClientData clientData)); /* 71 */
    void (*tcl_AsyncDelete) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 72 */
    int (*tcl_AsyncInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int code)); /* 73 */
    void (*tcl_AsyncMark) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 74 */
    int (*tcl_AsyncReady) _ANSI_ARGS_((void)); /* 75 */
    void (*tcl_BackgroundError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 76 */
    char (*tcl_Backslash) _ANSI_ARGS_((CONST char * src, int * readPtr)); /* 77 */
................................................................................
    int (*tcl_ServiceAll) _ANSI_ARGS_((void)); /* 221 */
    int (*tcl_ServiceEvent) _ANSI_ARGS_((int flags)); /* 222 */
    void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */
    void (*tcl_SetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan, int sz)); /* 224 */
    int (*tcl_SetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, CONST char * newValue)); /* 225 */
    int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST Tcl_CmdInfo * infoPtr)); /* 226 */
    void (*tcl_SetErrno) _ANSI_ARGS_((int err)); /* 227 */
    void (*tcl_SetErrorCode) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 228 */
    void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 229 */
    void (*tcl_SetPanicProc) _ANSI_ARGS_((Tcl_PanicProc * panicProc)); /* 230 */
    int (*tcl_SetRecursionLimit) _ANSI_ARGS_((Tcl_Interp * interp, int depth)); /* 231 */
    void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * result, Tcl_FreeProc * freeProc)); /* 232 */
    int (*tcl_SetServiceMode) _ANSI_ARGS_((int mode)); /* 233 */
    void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * errorObjPtr)); /* 234 */
    void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 235 */
................................................................................
    int (*tcl_UnsetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 253 */
    int (*tcl_UnsetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 254 */
    void (*tcl_UntraceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 255 */
    void (*tcl_UntraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 256 */
    void (*tcl_UpdateLinkedVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 257 */
    int (*tcl_UpVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * varName, CONST char * localName, int flags)); /* 258 */
    int (*tcl_UpVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * part1, CONST char * part2, CONST char * localName, int flags)); /* 259 */
    int (*tcl_VarEval) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 260 */
    ClientData (*tcl_VarTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 261 */
    ClientData (*tcl_VarTraceInfo2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 262 */
    int (*tcl_Write) _ANSI_ARGS_((Tcl_Channel chan, CONST char * s, int slen)); /* 263 */
    void (*tcl_WrongNumArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], CONST char * message)); /* 264 */
    int (*tcl_DumpActiveMemory) _ANSI_ARGS_((CONST char * fileName)); /* 265 */
    void (*tcl_ValidateAllMemory) _ANSI_ARGS_((CONST char * file, int line)); /* 266 */
    void (*tcl_AppendResultVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 267 */

Changes to generic/tclDictObj.c.

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
....
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
....
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
....
2706
2707
2708
2709
2710
2711
2712

2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
 *	type and its accessor command.
 *
 * Copyright (c) 2002 by Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclDictObj.c,v 1.27.2.4 2005/08/18 18:18:45 dgp Exp $
 */

#include "tclInt.h"
#include "tommath.h"

/*
 * Forward declaration.
................................................................................
	result = Tcl_EvalObjEx(interp, scriptObj, 0);
	if (result == TCL_CONTINUE) {
	    result = TCL_OK;
	} else if (result != TCL_OK) {
	    if (result == TCL_BREAK) {
		result = TCL_OK;
	    } else if (result == TCL_ERROR) {
		char msg[32 + TCL_INTEGER_SPACE];

		sprintf(msg, "\n    (\"dict for\" body line %d)",
			interp->errorLine);
		Tcl_AddObjErrorInfo(interp, msg, -1);
	    }
	    break;
	}

	Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
    }

................................................................................
	FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES
    };
    Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
    Tcl_Obj **varv, *keyObj, *valueObj, *resultObj, *boolObj;
    Tcl_DictSearch search;
    int index, varc, done, result, satisfied;
    char *pattern;
    char msg[32 + TCL_INTEGER_SPACE];

    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 2, objv, "dictionary filterType ...");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[3], filters, "filterType",
	     0, &index) != TCL_OK) {
................................................................................
		 */
		Tcl_ResetResult(interp);
		Tcl_DictObjDone(&search);
	    case TCL_CONTINUE:
		result = TCL_OK;
		break;
	    case TCL_ERROR:

		sprintf(msg, "\n    (\"dict filter\" script line %d)",
			interp->errorLine);
		Tcl_AddObjErrorInfo(interp, msg, -1);
	    default:
		goto abnormalResult;
	    }

	    TclDecrRefCount(keyObj);
	    TclDecrRefCount(valueObj);







|







 







|
<
|
<
<







 







<







 







>
|

<







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
....
2358
2359
2360
2361
2362
2363
2364
2365

2366


2367
2368
2369
2370
2371
2372
2373
....
2538
2539
2540
2541
2542
2543
2544

2545
2546
2547
2548
2549
2550
2551
....
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711

2712
2713
2714
2715
2716
2717
2718
 *	type and its accessor command.
 *
 * Copyright (c) 2002 by Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclDictObj.c,v 1.27.2.5 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#include "tommath.h"

/*
 * Forward declaration.
................................................................................
	result = Tcl_EvalObjEx(interp, scriptObj, 0);
	if (result == TCL_CONTINUE) {
	    result = TCL_OK;
	} else if (result != TCL_OK) {
	    if (result == TCL_BREAK) {
		result = TCL_OK;
	    } else if (result == TCL_ERROR) {
		TclFormatToErrorInfo(interp,

			"\n    (\"dict for\" body line %d)", interp->errorLine);


	    }
	    break;
	}

	Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
    }

................................................................................
	FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES
    };
    Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
    Tcl_Obj **varv, *keyObj, *valueObj, *resultObj, *boolObj;
    Tcl_DictSearch search;
    int index, varc, done, result, satisfied;
    char *pattern;


    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 2, objv, "dictionary filterType ...");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[3], filters, "filterType",
	     0, &index) != TCL_OK) {
................................................................................
		 */
		Tcl_ResetResult(interp);
		Tcl_DictObjDone(&search);
	    case TCL_CONTINUE:
		result = TCL_OK;
		break;
	    case TCL_ERROR:
		TclFormatToErrorInfo(interp,
			"\n    (\"dict filter\" script line %d)",
			interp->errorLine);

	    default:
		goto abnormalResult;
	    }

	    TclDecrRefCount(keyObj);
	    TclDecrRefCount(valueObj);

Changes to generic/tclExecute.c.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
6889
6890
6891
6892
6893
6894
6895
6896
6897
6898
6899
6900

6901
6902
6903
6904
6905
6906
6907
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2002-2005 by Miguel Sofer.
 * Copyright (c) 2005 by Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclExecute.c,v 1.167.2.38 2005/08/25 21:21:33 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include "tommath.h"

#include <math.h>
................................................................................
	    Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL);
	} else {
	    s = "floating-point value too large to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL);
	}
    } else {
	char msg[64 + TCL_INTEGER_SPACE];

	sprintf(msg, "unknown floating-point error, errno = %d", errno);
	Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
	Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL);

    }
}
 
#ifdef TCL_COMPILE_STATS
/*
 *----------------------------------------------------------------------
 *






|







 







|
|
|
|
|
>







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
6889
6890
6891
6892
6893
6894
6895
6896
6897
6898
6899
6900
6901
6902
6903
6904
6905
6906
6907
6908
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2002-2005 by Miguel Sofer.
 * Copyright (c) 2005 by Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclExecute.c,v 1.167.2.39 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include "tommath.h"

#include <math.h>
................................................................................
	    Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL);
	} else {
	    s = "floating-point value too large to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL);
	}
    } else {
	Tcl_Obj *objPtr = Tcl_NewObj();
	TclObjPrintf(NULL, objPtr,
		"unknown floating-point error, errno = %d", errno);
	Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", 
		Tcl_GetString(objPtr), (char *) NULL);
	Tcl_SetObjResult(interp, objPtr);
    }
}
 
#ifdef TCL_COMPILE_STATS
/*
 *----------------------------------------------------------------------
 *

Changes to generic/tclIORChan.c.

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
....
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
....
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
 *      See TIP #219 for the specification of this functionality.
 *
 * Copyright (c) 2004-2005 ActiveState, a divison of Sophos
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIORChan.c,v 1.1.2.4 2005/09/12 14:47:16 dgp Exp $
 */

#include <tclInt.h>
#include <tclIO.h>
#include <assert.h>

#ifndef EINVAL
................................................................................
        Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	return res;
    }

    if ((listc % 2) == 1) {
        /* Odd number of elements is wrong.
	 */

        char buf [20];

	sprintf (buf, "%d", listc);
	Tcl_ResetResult  (interp);
	Tcl_AppendResult (interp,
			  "Expected list with even number of elements, got ",
			  buf, (listc == 1 ? " element" : " elements"),
			  " instead", (char*) NULL);

	Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	return TCL_ERROR;
    }


    {
        int len;
................................................................................
     */

#ifdef TCL_THREADS
    TCL_DECLARE_MUTEX (rcCounterMutex)
#endif
    static unsigned long rcCounter = 0;

    char     channelName [50];
    Tcl_Obj* res = Tcl_NewStringObj ("rc", -1);

#ifdef TCL_THREADS
    Tcl_MutexLock (&rcCounterMutex);
#endif

    sprintf (channelName, "%lu", (unsigned long) rcCounter);
    rcCounter ++;

#ifdef TCL_THREADS
    Tcl_MutexUnlock (&rcCounterMutex);
#endif

    Tcl_AppendStringsToObj (res, channelName, (char*) NULL);
    return res;
}
 

static void
RcFree (rcPtr)
     ReflectingChannel* rcPtr;






|







 







|
|
|
|
|
|
<
<
<
<







 







<
|





|






<







11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
....
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731




1732
1733
1734
1735
1736
1737
1738
....
1957
1958
1959
1960
1961
1962
1963

1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976

1977
1978
1979
1980
1981
1982
1983
 *      See TIP #219 for the specification of this functionality.
 *
 * Copyright (c) 2004-2005 ActiveState, a divison of Sophos
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIORChan.c,v 1.1.2.5 2005/09/15 20:58:39 dgp Exp $
 */

#include <tclInt.h>
#include <tclIO.h>
#include <assert.h>

#ifndef EINVAL
................................................................................
        Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	return res;
    }

    if ((listc % 2) == 1) {
        /* Odd number of elements is wrong.
	 */
	Tcl_Obj *objPtr = Tcl_NewObj();
	Tcl_ResetResult(interp);
	TclObjPrintf(NULL, objPtr, "Expected list with even number of "
		"elements, got %d element%s instead", listc, 
		(listc == 1 ? "" : "s"));
	Tcl_SetObjResult(interp, objPtr);




	Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	return TCL_ERROR;
    }


    {
        int len;
................................................................................
     */

#ifdef TCL_THREADS
    TCL_DECLARE_MUTEX (rcCounterMutex)
#endif
    static unsigned long rcCounter = 0;


    Tcl_Obj* res = Tcl_NewObj ();

#ifdef TCL_THREADS
    Tcl_MutexLock (&rcCounterMutex);
#endif

    TclObjPrintf(NULL, res, "rc%lu", rcCounter);
    rcCounter ++;

#ifdef TCL_THREADS
    Tcl_MutexUnlock (&rcCounterMutex);
#endif


    return res;
}
 

static void
RcFree (rcPtr)
     ReflectingChannel* rcPtr;

Changes to generic/tclIOUtil.c.

13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
....
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
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2001-2004 Vincent Darley.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOUtil.c,v 1.113.2.6 2005/09/09 18:48:40 dgp Exp $
 */

#include "tclInt.h"
#ifdef __WIN32__
#   include "tclWinInt.h"
#endif
#include "tclFileSystem.h"
................................................................................

    if (result == TCL_RETURN) {
	result = TclUpdateReturnInfo(iPtr);
    } else if (result == TCL_ERROR) {
	/*
	 * Record information telling where the error occurred.
	 */

	Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);
	Tcl_Obj *msg = Tcl_NewStringObj("\n    (file \"", -1);
	CONST char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
	Tcl_IncrRefCount(msg);
	Tcl_IncrRefCount(errorLine);
	TclAppendLimitedToObj(msg, pathString, length, 150, "");
	Tcl_AppendToObj(msg, "\" line ", -1);
	Tcl_AppendObjToObj(msg, errorLine);
	Tcl_DecrRefCount(errorLine);
	Tcl_AppendToObj(msg, ")", -1);
	TclAppendObjToErrorInfo(interp, msg);
	Tcl_DecrRefCount(msg);
    }

  end:
    Tcl_DecrRefCount(objPtr);
    return result;
}
 






|







 







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







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
....
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821






1822
1823
1824
1825
1826
1827
1828
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2001-2004 Vincent Darley.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOUtil.c,v 1.113.2.7 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#ifdef __WIN32__
#   include "tclWinInt.h"
#endif
#include "tclFileSystem.h"
................................................................................

    if (result == TCL_RETURN) {
	result = TclUpdateReturnInfo(iPtr);
    } else if (result == TCL_ERROR) {
	/*
	 * Record information telling where the error occurred.
	 */
	CONST char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
	int limit = 150;
	int overflow = (length > limit);

	TclFormatToErrorInfo(interp, "\n    (file \"%.*s%s\" line %d)",
		(overflow ? limit : length), pathString,
		(overflow ? "..." : ""), interp->errorLine);






    }

  end:
    Tcl_DecrRefCount(objPtr);
    return result;
}
 

Changes to generic/tclInt.h.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
2034
2035
2036
2037
2038
2039
2040
2041



2042
2043
2044
2045
2046
2047
2048
....
2092
2093
2094
2095
2096
2097
2098
2099

2100
2101
2102
2103
2104
2105
2106
....
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-19/99 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.202.2.38 2005/09/09 18:48:40 dgp Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options
................................................................................
MODULE_SCOPE void	TclFinalizeNotifier(void);
MODULE_SCOPE void	TclFinalizeObjects(void);
MODULE_SCOPE void	TclFinalizePreserve(void);
MODULE_SCOPE void	TclFinalizeSynchronization(void);
MODULE_SCOPE void	TclFinalizeThreadData(void);
MODULE_SCOPE double	TclFloor(mp_int* a);
MODULE_SCOPE void	TclFormatNaN(double value, char* buffer);
MODULE_SCOPE int	TclFormatObj TCL_VARARGS(Tcl_Interp *, arg1);



MODULE_SCOPE int	TclFSFileAttrIndex(Tcl_Obj *pathPtr,
			    CONST char *attributeName, int *indexPtr);
MODULE_SCOPE Tcl_Obj *	TclGetBgErrorHandler(Tcl_Interp *interp);
MODULE_SCOPE int	TclGetEncodingFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr);
MODULE_SCOPE int	TclGetNamespaceFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
................................................................................
			    Tcl_Obj* valuePtr);
MODULE_SCOPE int	TclMergeReturnOptions(Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[], Tcl_Obj **optionsPtrPtr,
			    int *codePtr, int *levelPtr);
MODULE_SCOPE int	TclObjInvokeNamespace(Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[],
			    Tcl_Namespace *nsPtr, int flags);
MODULE_SCOPE int	TclObjPrintf TCL_VARARGS(Tcl_Interp *, arg1);

MODULE_SCOPE int	TclParseBackslash(CONST char *src,
			    int numBytes, int *readPtr, char *dst);
MODULE_SCOPE int	TclParseHex(CONST char *src, int numBytes,
			    Tcl_UniChar *resultPtr);
MODULE_SCOPE int	TclParseNumber(Tcl_Interp* interp, Tcl_Obj* objPtr,
			    CONST char* type, CONST char* string,
			    size_t length, CONST char** endPtrPtr, int flags);
................................................................................
MODULE_SCOPE ClientData	TclpGetNativeCwd(ClientData clientData);
MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep;
MODULE_SCOPE Tcl_Obj*	TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr,
			    int linkType);
MODULE_SCOPE int	TclpObjChdir(Tcl_Obj *pathPtr);
MODULE_SCOPE Tcl_Obj *	TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    Tcl_PathPart portion);
MODULE_SCOPE void	TclpPanic TCL_VARARGS(CONST char *, format);
MODULE_SCOPE char *	TclpReadlink(CONST char *fileName,
			    Tcl_DString *linkPtr);
MODULE_SCOPE void	TclpReleaseFile(TclFile file);
MODULE_SCOPE void	TclpSetInterfaces(void);
MODULE_SCOPE void	TclpSetVariables(Tcl_Interp *interp);
MODULE_SCOPE void	TclpUnloadFile(Tcl_LoadHandle loadHandle);
MODULE_SCOPE VOID *	TclpThreadDataKeyGet(Tcl_ThreadDataKey *keyPtr);






|







 







|
>
>
>







 







|
>







 







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
....
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
....
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-19/99 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.202.2.39 2005/09/15 20:58:39 dgp Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options
................................................................................
MODULE_SCOPE void	TclFinalizeNotifier(void);
MODULE_SCOPE void	TclFinalizeObjects(void);
MODULE_SCOPE void	TclFinalizePreserve(void);
MODULE_SCOPE void	TclFinalizeSynchronization(void);
MODULE_SCOPE void	TclFinalizeThreadData(void);
MODULE_SCOPE double	TclFloor(mp_int* a);
MODULE_SCOPE void	TclFormatNaN(double value, char* buffer);
MODULE_SCOPE int	TclFormatObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    CONST char *format, ...);
MODULE_SCOPE int	TclFormatToErrorInfo(Tcl_Interp *interp,
			    CONST char *format, ...);
MODULE_SCOPE int	TclFSFileAttrIndex(Tcl_Obj *pathPtr,
			    CONST char *attributeName, int *indexPtr);
MODULE_SCOPE Tcl_Obj *	TclGetBgErrorHandler(Tcl_Interp *interp);
MODULE_SCOPE int	TclGetEncodingFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr);
MODULE_SCOPE int	TclGetNamespaceFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
................................................................................
			    Tcl_Obj* valuePtr);
MODULE_SCOPE int	TclMergeReturnOptions(Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[], Tcl_Obj **optionsPtrPtr,
			    int *codePtr, int *levelPtr);
MODULE_SCOPE int	TclObjInvokeNamespace(Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[],
			    Tcl_Namespace *nsPtr, int flags);
MODULE_SCOPE int	TclObjPrintf(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    CONST char *format, ...);
MODULE_SCOPE int	TclParseBackslash(CONST char *src,
			    int numBytes, int *readPtr, char *dst);
MODULE_SCOPE int	TclParseHex(CONST char *src, int numBytes,
			    Tcl_UniChar *resultPtr);
MODULE_SCOPE int	TclParseNumber(Tcl_Interp* interp, Tcl_Obj* objPtr,
			    CONST char* type, CONST char* string,
			    size_t length, CONST char** endPtrPtr, int flags);
................................................................................
MODULE_SCOPE ClientData	TclpGetNativeCwd(ClientData clientData);
MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep;
MODULE_SCOPE Tcl_Obj*	TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr,
			    int linkType);
MODULE_SCOPE int	TclpObjChdir(Tcl_Obj *pathPtr);
MODULE_SCOPE Tcl_Obj *	TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    Tcl_PathPart portion);
MODULE_SCOPE void	TclpPanic(CONST char *format, ...);
MODULE_SCOPE char *	TclpReadlink(CONST char *fileName,
			    Tcl_DString *linkPtr);
MODULE_SCOPE void	TclpReleaseFile(TclFile file);
MODULE_SCOPE void	TclpSetInterfaces(void);
MODULE_SCOPE void	TclpSetVariables(Tcl_Interp *interp);
MODULE_SCOPE void	TclpUnloadFile(Tcl_LoadHandle loadHandle);
MODULE_SCOPE VOID *	TclpThreadDataKeyGet(Tcl_ThreadDataKey *keyPtr);

Changes to generic/tclMain.c.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
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
 * Copyright (c) 1988-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2000 Ajuba Solutions.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMain.c,v 1.30.2.1 2005/08/02 18:16:01 dgp Exp $
 */

#include "tclInt.h"

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT

................................................................................
    if (commandPtr != NULL) {
	Tcl_DecrRefCount(commandPtr);
    }

    /*
     * Rather than calling exit, invoke the "exit" command so that users can
     * replace "exit" with some other command to do additional cleanup on
     * exit. The Tcl_Eval call should never return.
     */

    if (!Tcl_InterpDeleted(interp)) {
	if (!Tcl_LimitExceeded(interp)) {
	    char buffer[TCL_INTEGER_SPACE + 5];

	    sprintf(buffer, "exit %d", exitCode);

	    Tcl_Eval(interp, buffer);

	}

	/*
	 * If Tcl_Eval returns, trying to eval [exit], something unusual is
	 * happening. Maybe interp has been deleted; maybe [exit] was
	 * redefined, maybe we've blown up because of an exceeded limit. We
	 * still want to cleanup and exit.
	 */

	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_DeleteInterp(interp);
	}






|







 







|




|
<
|
>
|
>



|
|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
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
 * Copyright (c) 1988-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2000 Ajuba Solutions.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMain.c,v 1.30.2.2 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT

................................................................................
    if (commandPtr != NULL) {
	Tcl_DecrRefCount(commandPtr);
    }

    /*
     * Rather than calling exit, invoke the "exit" command so that users can
     * replace "exit" with some other command to do additional cleanup on
     * exit. The Tcl_EvalObjEx call should never return.
     */

    if (!Tcl_InterpDeleted(interp)) {
	if (!Tcl_LimitExceeded(interp)) {
	    Tcl_Obj *cmd = Tcl_NewObj();

	    TclObjPrintf(NULL, cmd, "exit %d", exitCode);
	    Tcl_IncrRefCount(cmd);
	    Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
	    Tcl_DecrRefCount(cmd);
	}

	/*
	 * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual
	 * is happening. Maybe interp has been deleted; maybe [exit] was
	 * redefined, maybe we've blown up because of an exceeded limit. We
	 * still want to cleanup and exit.
	 */

	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_DeleteInterp(interp);
	}

Changes to generic/tclNamesp.c.

17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
....
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
....
3812
3813
3814
3815
3816
3817
3818
3819
3820

3821
3822
3823

3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
 *   Michael J. McLennan
 *   Bell Labs Innovations for Lucent Technologies
 *   [email protected]
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclNamesp.c,v 1.66.2.9 2005/08/29 18:38:45 dgp Exp $
 */

#include "tclInt.h"

/*
 * Initial size of stack allocated space for tail list - used when resetting
 * shadowed command references in the functin: TclResetShadowedCmdRefs.
................................................................................
	 */

	objPtr = Tcl_ConcatObj(objc-3, objv+3);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }

    if (result == TCL_ERROR) {
	Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);
	Tcl_Obj *msg = Tcl_NewStringObj("\n    (in namespace eval \"", -1);
	Tcl_IncrRefCount(errorLine);
	Tcl_IncrRefCount(msg);
	TclAppendLimitedToObj(msg, namespacePtr->fullName, -1, 200, "");
	Tcl_AppendToObj(msg, "\" script line ", -1);
	Tcl_AppendObjToObj(msg, errorLine);
	Tcl_DecrRefCount(errorLine);
	Tcl_AppendToObj(msg, ")", -1);
	TclAppendObjToErrorInfo(interp, msg);
	Tcl_DecrRefCount(msg);
    }

    /*
     * Restore the previous "current" namespace.
     */

    TclPopStackFrame(interp);
................................................................................
	concatObjv[1] = listPtr;
	cmdObjPtr = Tcl_ConcatObj(2, concatObjv);
	result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT);
	Tcl_DecrRefCount(listPtr);    /* we're done with the list object */
    }

    if (result == TCL_ERROR) {
	Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);
	Tcl_Obj *msg = Tcl_NewStringObj("\n    (in namespace inscope \"", -1);


	Tcl_IncrRefCount(errorLine);
	Tcl_IncrRefCount(msg);

	TclAppendLimitedToObj(msg, namespacePtr->fullName, -1, 200, "");
	Tcl_AppendToObj(msg, "\" script line ", -1);
	Tcl_AppendObjToObj(msg, errorLine);
	Tcl_DecrRefCount(errorLine);
	Tcl_AppendToObj(msg, ")", -1);
	TclAppendObjToErrorInfo(interp, msg);
	Tcl_DecrRefCount(msg);
    }

    /*
     * Restore the previous "current" namespace.
     */

    TclPopStackFrame(interp);






|







 







|
|
|
|
|
|
|
|
<
<
<







 







|
|
>

<
|
>
|
<
|
<
<
<
<







17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
....
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413



3414
3415
3416
3417
3418
3419
3420
....
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819

3820
3821
3822

3823




3824
3825
3826
3827
3828
3829
3830
 *   Michael J. McLennan
 *   Bell Labs Innovations for Lucent Technologies
 *   [email protected]
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclNamesp.c,v 1.66.2.10 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"

/*
 * Initial size of stack allocated space for tail list - used when resetting
 * shadowed command references in the functin: TclResetShadowedCmdRefs.
................................................................................
	 */

	objPtr = Tcl_ConcatObj(objc-3, objv+3);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }

    if (result == TCL_ERROR) {
	int length = strlen(namespacePtr->fullName);
	int limit = 200;
	int overflow = (length > limit);

	TclFormatToErrorInfo(interp,
		"\n    (in namespace eval \"%.*s%s\" script line %d)",
		(overflow ? limit : length), namespacePtr->fullName,
		(overflow ? "..." : ""), interp->errorLine);



    }

    /*
     * Restore the previous "current" namespace.
     */

    TclPopStackFrame(interp);
................................................................................
	concatObjv[1] = listPtr;
	cmdObjPtr = Tcl_ConcatObj(2, concatObjv);
	result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT);
	Tcl_DecrRefCount(listPtr);    /* we're done with the list object */
    }

    if (result == TCL_ERROR) {
	int length = strlen(namespacePtr->fullName);
	int limit = 200;
	int overflow = (length > limit);


	TclFormatToErrorInfo(interp,
		"\n    (in namespace inscope \"%.*s%s\" script line %d)",
		(overflow ? limit : length), namespacePtr->fullName,

		(overflow ? "..." : ""), interp->errorLine);




    }

    /*
     * Restore the previous "current" namespace.
     */

    TclPopStackFrame(interp);

Changes to generic/tclPanic.c.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
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
 * Copyright (c) 1988-1993 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPanic.c,v 1.5.2.1 2005/08/02 18:16:04 dgp Exp $
 */

#include "tclInt.h"

/*
 * The panicProc variable contains a pointer to an application specific panic
 * procedure.
................................................................................
 *
 * Side effects:
 *	The process dies, entering the debugger if possible.
 *
 *----------------------------------------------------------------------
 */

	/* VARARGS ARGSUSED */
void
Tcl_Panic TCL_VARARGS_DEF(CONST char *,arg1)
{
    va_list argList;
    CONST char *format;

    format = TCL_VARARGS_START(CONST char *,arg1,argList);

    Tcl_PanicVA(format, argList);
    va_end (argList);
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */






|







 







|

|


<

<
>











8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
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
 * Copyright (c) 1988-1993 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPanic.c,v 1.5.2.2 2005/09/15 20:58:40 dgp Exp $
 */

#include "tclInt.h"

/*
 * The panicProc variable contains a pointer to an application specific panic
 * procedure.
................................................................................
 *
 * Side effects:
 *	The process dies, entering the debugger if possible.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
void
Tcl_Panic(CONST char *format, ...)
{
    va_list argList;



    va_start(argList, format);
    Tcl_PanicVA(format, argList);
    va_end (argList);
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclProc.c.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
333
334
335
336
337
338
339
340


341
342
343
344
345
346
347
348
349
350
351
...
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
...
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
....
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
....
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
....
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclProc.c,v 1.66.2.6 2005/08/19 21:55:21 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Prototypes for static functions in this file
................................................................................
    result = Tcl_SplitList(interp, args, &numArgs, &argArray);
    if (result != TCL_OK) {
	goto procError;
    }

    if (precompiled) {
	if (numArgs > procPtr->numArgs) {
	    char buf[40 + TCL_INTEGER_SPACE + TCL_INTEGER_SPACE];


	    sprintf(buf, "%d entries, precompiled header expects %d",
		    numArgs, procPtr->numArgs);
	    Tcl_AppendResult(interp, "procedure \"", procName,
		    "\": arg list contains ", buf, NULL);
	    goto procError;
	}
	localPtr = procPtr->firstLocalPtr;
    } else {
	procPtr->numArgs = numArgs;
	procPtr->numCompiledLocals = numArgs;
    }
................................................................................
	    if ((localPtr->nameLength != nameLength)
		    || (strcmp(localPtr->name, fieldValues[0]))
		    || (localPtr->frameIndex != i)
		    || ((localPtr->flags & ~VAR_UNDEFINED)
			    != (VAR_SCALAR | VAR_ARGUMENT))
		    || (localPtr->defValuePtr == NULL && fieldCount == 2)
		    || (localPtr->defValuePtr != NULL && fieldCount != 2)) {
		char buf[40 + TCL_INTEGER_SPACE];


		ckfree((char *) fieldValues);
		sprintf(buf, "%d is inconsistent with precompiled body", i);
		Tcl_AppendResult(interp, "procedure \"", procName,
			"\": formal parameter ", buf, (char *) NULL);
		goto procError;
	    }

	    /*
	     * compare the default value if any
	     */

	    if (localPtr->defValuePtr != NULL) {
		int tmpLength;
		char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr,
			&tmpLength);
		if ((valueLength != tmpLength) ||
			strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) {
		    Tcl_AppendResult(interp, "procedure \"", procName,


			    "\": formal parameter \"", fieldValues[0],
			    "\" has default value inconsistent with ",
			    "precompiled body", (char *) NULL);


		    ckfree((char *) fieldValues);
		    goto procError;
		}
		if ((i == numArgs - 1)
			&& (localPtr->nameLength == 4)
			&& (localPtr->name[0] == 'a')
			&& (strcmp(localPtr->name, "args") == 0)) {
................................................................................

	Tcl_Obj *objPtr;

	objPtr = Tcl_ConcatObj(objc, objv);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }
    if (result == TCL_ERROR) {
	char msg[32 + TCL_INTEGER_SPACE];
	sprintf(msg, "\n    (\"uplevel\" body line %d)", interp->errorLine);
	Tcl_AddObjErrorInfo(interp, msg, -1);
    }

    /*
     * Restore the variable frame, and return.
     */

    iPtr->varFramePtr = savedVarFramePtr;
................................................................................
	    TclPopStackFrame(interp);
	}

 	iPtr->compiledProcPtr = saveProcPtr;

 	if (result != TCL_OK) {
 	    if (result == TCL_ERROR) {
		Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);
		Tcl_Obj *message =
			Tcl_NewStringObj("\n    (compiling ", -1);

		Tcl_IncrRefCount(message);
		Tcl_AppendStringsToObj(message, description, " \"", NULL);
		TclAppendLimitedToObj(message, procName, -1, 50, NULL);
		Tcl_AppendToObj(message, "\", line ", -1);
		Tcl_AppendObjToObj(message, errorLine);
		Tcl_DecrRefCount(errorLine);
		Tcl_AppendToObj(message, ")", -1);
 		TclAppendObjToErrorInfo(interp, message);
		Tcl_DecrRefCount(message);



	    }
 	    return result;
 	}
    } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
	/*
	 * The resolver epoch has changed, but we only need to invalidate the
	 * resolver cache.
................................................................................
				 * called and returned returnCode. */
    char *procName;		/* Name of the procedure. Used for error
				 * messages and trace information. */
    int nameLen;		/* Number of bytes in procedure's name. */
    int returnCode;		/* The unexpected result code. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *message, *errorLine;

    if (returnCode == TCL_OK) {
	return TCL_OK;
    }
    if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) {
	return returnCode;
    }
................................................................................
    }
    if (returnCode != TCL_ERROR) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "invoked \"",
		((returnCode == TCL_BREAK) ? "break" : "continue"),
		"\" outside of a loop", NULL);
    }
    errorLine = Tcl_NewIntObj(interp->errorLine);
    message = Tcl_NewStringObj("\n    (procedure \"", -1);
    Tcl_IncrRefCount(message);
    TclAppendLimitedToObj(message, procName, nameLen, 60, NULL);
    Tcl_AppendToObj(message, "\" line ", -1);
    Tcl_AppendObjToObj(message, errorLine);
    Tcl_DecrRefCount(errorLine);
    Tcl_AppendToObj(message, ")", -1);
    TclAppendObjToErrorInfo(interp, message);
    Tcl_DecrRefCount(message);
    return TCL_ERROR;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclProcDeleteProc --






|







 







|
>
>
|
|
|
<







 







|
<
>
|
|
|
|













|
>
>
|
|
<
>
>







 







|
|
<







 







|
|
|

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







 







|







 







|
|
|
|
<
<
<
<
<
<







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
333
334
335
336
337
338
339
340
341
342
343
344
345

346
347
348
349
350
351
352
...
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
...
818
819
820
821
822
823
824
825
826

827
828
829
830
831
832
833
....
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505







1506

1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
....
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
....
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575






1576
1577
1578
1579
1580
1581
1582
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclProc.c,v 1.66.2.7 2005/09/15 20:58:40 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Prototypes for static functions in this file
................................................................................
    result = Tcl_SplitList(interp, args, &numArgs, &argArray);
    if (result != TCL_OK) {
	goto procError;
    }

    if (precompiled) {
	if (numArgs > procPtr->numArgs) {
	    Tcl_Obj *objPtr = Tcl_NewObj();
	    TclObjPrintf(NULL, objPtr,
		    "procedure \"%s\": arg list contains %d entries, "
		    "precompiled header expects %d", procName, numArgs,
		    procPtr->numArgs);
	    Tcl_SetObjResult(interp, objPtr);

	    goto procError;
	}
	localPtr = procPtr->firstLocalPtr;
    } else {
	procPtr->numArgs = numArgs;
	procPtr->numCompiledLocals = numArgs;
    }
................................................................................
	    if ((localPtr->nameLength != nameLength)
		    || (strcmp(localPtr->name, fieldValues[0]))
		    || (localPtr->frameIndex != i)
		    || ((localPtr->flags & ~VAR_UNDEFINED)
			    != (VAR_SCALAR | VAR_ARGUMENT))
		    || (localPtr->defValuePtr == NULL && fieldCount == 2)
		    || (localPtr->defValuePtr != NULL && fieldCount != 2)) {
		Tcl_Obj *objPtr = Tcl_NewObj();

		TclObjPrintf(NULL, objPtr,
			"procedure \"%s\": formal parameter %d is "
			"inconsistent with precompiled body", procName, i);
		Tcl_SetObjResult(interp, objPtr);
		ckfree((char *) fieldValues);
		goto procError;
	    }

	    /*
	     * compare the default value if any
	     */

	    if (localPtr->defValuePtr != NULL) {
		int tmpLength;
		char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr,
			&tmpLength);
		if ((valueLength != tmpLength) ||
			strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) {
		    Tcl_Obj *objPtr = Tcl_NewObj();

		    TclObjPrintf(NULL, objPtr,
			    "procedure \"%s\": formal parameter \"%s\" has "
			    "default value inconsistent with precompiled body",

			    procName, fieldValues[0]);
		    Tcl_SetObjResult(interp, objPtr);
		    ckfree((char *) fieldValues);
		    goto procError;
		}
		if ((i == numArgs - 1)
			&& (localPtr->nameLength == 4)
			&& (localPtr->name[0] == 'a')
			&& (strcmp(localPtr->name, "args") == 0)) {
................................................................................

	Tcl_Obj *objPtr;

	objPtr = Tcl_ConcatObj(objc, objv);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }
    if (result == TCL_ERROR) {
	TclFormatToErrorInfo(interp, "\n    (\"uplevel\" body line %d)",
		interp->errorLine);

    }

    /*
     * Restore the variable frame, and return.
     */

    iPtr->varFramePtr = savedVarFramePtr;
................................................................................
	    TclPopStackFrame(interp);
	}

 	iPtr->compiledProcPtr = saveProcPtr;

 	if (result != TCL_OK) {
 	    if (result == TCL_ERROR) {
		int length = strlen(procName);
		int limit = 50;
		int overflow = (length > limit);








		TclFormatToErrorInfo(interp,

			"\n    (compiling %s \"%.*s%s\", line %d)",
			description, (overflow ? limit : length), procName,
			(overflow ? "..." : ""), interp->errorLine);
	    }
 	    return result;
 	}
    } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
	/*
	 * The resolver epoch has changed, but we only need to invalidate the
	 * resolver cache.
................................................................................
				 * called and returned returnCode. */
    char *procName;		/* Name of the procedure. Used for error
				 * messages and trace information. */
    int nameLen;		/* Number of bytes in procedure's name. */
    int returnCode;		/* The unexpected result code. */
{
    Interp *iPtr = (Interp *) interp;
    int overflow, limit = 60;

    if (returnCode == TCL_OK) {
	return TCL_OK;
    }
    if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) {
	return returnCode;
    }
................................................................................
    }
    if (returnCode != TCL_ERROR) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "invoked \"",
		((returnCode == TCL_BREAK) ? "break" : "continue"),
		"\" outside of a loop", NULL);
    }
    overflow = (nameLen > limit);
    TclFormatToErrorInfo(interp, "\n    (procedure \"%.*s%s\" line %d)",
	    (overflow ? limit : nameLen), procName,
	    (overflow ? "..." : ""), interp->errorLine);






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

Changes to generic/tclResult.c.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
659
660
661
662
663
664
665
666
667
668
669
670
671

672
673
674
675
676
677
678
....
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
 *	This file contains code to manage the interpreter result.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclResult.c,v 1.23.2.4 2005/09/09 18:48:40 dgp Exp $
 */

#include "tclInt.h"

/*
 * Indices of the standard return options dictionary keys.
 */
................................................................................
 *	If the string result is non-empty, the object result forced to be a
 *	duplicate of it first. There will be a string result afterwards.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
    Tcl_Interp *interp;
    va_list argList;

    interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);

    Tcl_AppendResultVA(interp, argList);
    va_end(argList);
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
 *	The errorCode field of the interp is modified to hold all of the
 *	arguments to this function, in a list form with each argument becoming
 *	one element of the list.
 *
 *----------------------------------------------------------------------
 */

	/* VARARGS2 */
void
Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)

{
    Tcl_Interp *interp;
    va_list argList;

    /*
     * Scan through the arguments one at a time, appending them to the
     * errorCode field as list elements.
     */

    interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
    Tcl_SetErrorCodeVA(interp, argList);
    va_end(argList);
}
 
/*
 *----------------------------------------------------------------------
 *






|







 







|

<


<
>







 







<

<
>

<







|







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
659
660
661
662
663
664
665
666
667

668
669

670
671
672
673
674
675
676
677
....
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
 *	This file contains code to manage the interpreter result.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclResult.c,v 1.23.2.5 2005/09/15 20:58:40 dgp Exp $
 */

#include "tclInt.h"

/*
 * Indices of the standard return options dictionary keys.
 */
................................................................................
 *	If the string result is non-empty, the object result forced to be a
 *	duplicate of it first. There will be a string result afterwards.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendResult(Tcl_Interp *interp, ...)
{

    va_list argList;


    va_start(argList, interp);
    Tcl_AppendResultVA(interp, argList);
    va_end(argList);
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
 *	The errorCode field of the interp is modified to hold all of the
 *	arguments to this function, in a list form with each argument becoming
 *	one element of the list.
 *
 *----------------------------------------------------------------------
 */


void

Tcl_SetErrorCode(Tcl_Interp *interp, ...)
{

    va_list argList;

    /*
     * Scan through the arguments one at a time, appending them to the
     * errorCode field as list elements.
     */

    va_start(argList, interp);
    Tcl_SetErrorCodeVA(interp, argList);
    va_end(argList);
}
 
/*
 *----------------------------------------------------------------------
 *

Changes to generic/tclStringObj.c.

29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
..
50
51
52
53
54
55
56

57
58

59
60
61
62
63
64
65
....
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673

1674
1675
1676
1677
1678
1679
1680
....
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720

1721
1722
1723
1724
1725
1726
1727
1728
1729
....
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
....
2262
2263
2264
2265
2266
2267
2268
2269
2270


2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
....
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319

2320
2321
2322
2323
2324
2325
2326
....
2330
2331
2332
2333
2334
2335
2336
2337
2338


2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358


2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
















2376

2377
2378
2379
2380
2381
2382
2383
....
2399
2400
2401
2402
2403
2404
2405















2406
2407
2408
2409
2410
2411
2412
....
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442


2443
2444
2445
2446






























2447
2448
2449
2450
2451
2452
2453
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStringObj.c,v 1.35.2.8 2005/09/12 19:39:01 dgp Exp $ */

#include "tclInt.h"
#include "tommath.h"

/*
 * Prototypes for functions defined later in this file:
 */
................................................................................
			    int numChars));
static void		AppendUtfToUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    CONST char *bytes, int numBytes));
static void		AppendUtfToUtfRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    CONST char *bytes, int numBytes));
static void		FillUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static int		FormatObjVA _ANSI_ARGS_((Tcl_Interp *interp,

			    va_list argList));
static int		ObjPrintfVA _ANSI_ARGS_((Tcl_Interp *interp,

			    va_list argList));
static void		FreeStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static void		DupStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    Tcl_Obj *copyPtr));
static int		SetStringFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static void		UpdateStringOfString _ANSI_ARGS_((Tcl_Obj *objPtr));
................................................................................
 *	The contents of all the string arguments are appended to the string
 *	representation of objPtr.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendStringsToObj TCL_VARARGS_DEF(Tcl_Obj *,arg1)
{
    register Tcl_Obj *objPtr;
    va_list argList;

    objPtr = TCL_VARARGS_START(Tcl_Obj *,arg1,argList);

    Tcl_AppendStringsToObjVA(objPtr, argList);
    va_end(argList);
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclAppendFormattedObjs(interp, baseObj, format, objc, objv)
    Tcl_Interp *interp;
    Tcl_Obj *baseObj;
    CONST char *format;
    int objc;
    Tcl_Obj *CONST objv[];
{
    CONST char *span = format;
    int numBytes = 0;
    int objIndex = 0;
    int gotXpg = 0, gotSequential = 0;
    Tcl_Obj *appendObj = Tcl_NewObj();
    CONST char *msg;
    CONST char *mixedXPG = "cannot mix \"%\" and \"%n$\" conversion specifiers";
    CONST char *badIndex[2] = {
	"not enough arguments for all format specifiers",
	"\"%n$\" argument index out of range"
    };

    if (Tcl_IsShared(baseObj)) {
	Tcl_Panic("TclAppendFormattedObjs called with shared object");
    }


    Tcl_IncrRefCount(appendObj);
    /* format string is NUL-terminated */
    while (*format != '\0') {
	char *end;
	int gotMinus, gotHash, gotZero, gotSpace, gotPlus, sawFlag;
	int width, gotPrecision, precision, useShort, useWide, useBig;
	int newXpg, numChars, allocSegment = 0;
	Tcl_Obj *segment;
................................................................................
	objIndex += gotSequential;
    }
    if (numBytes) {
	Tcl_AppendToObj(appendObj, span, numBytes);
	numBytes = 0;
    }

    Tcl_AppendObjToObj(baseObj, appendObj);
    Tcl_DecrRefCount(appendObj);
    return TCL_OK;

  errorMsg:
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
    }
  error:
    Tcl_DecrRefCount(appendObj);
    return TCL_ERROR;
}
 
/*
 *---------------------------------------------------------------------------
 *
 * FormatObjVA --
................................................................................
 * Side effects:
 *	Reallocates the String internal rep.
 *
 *---------------------------------------------------------------------------
 */

static int
FormatObjVA(interp, argList)
    Tcl_Interp *interp;


    va_list argList;
{
    int code, objc;
    Tcl_Obj **objv, *element, *list = Tcl_NewObj();
    CONST char *format;
    Tcl_Obj *objPtr = va_arg(argList, Tcl_Obj *);

    if (objPtr == NULL) {
	Tcl_Panic("TclFormatObj: no Tcl_Obj to append to");
    }

    format = va_arg(argList, CONST char *);
    if (format == NULL) {
	Tcl_Panic("TclFormatObj: no format string argument");
    }

    Tcl_IncrRefCount(list);
    element = va_arg(argList, Tcl_Obj *);
    while (element != NULL) {
	Tcl_ListObjAppendElement(NULL, list, element);
	element = va_arg(argList, Tcl_Obj *);
    }
................................................................................
 * Side effects:
 * 	None.
 *
 *---------------------------------------------------------------------------
 */

int
TclFormatObj TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
    va_list argList;
    int result;
    Tcl_Interp *interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
    result = FormatObjVA(interp, argList);

    va_end(argList);
    return result;
}
 
/*
 *---------------------------------------------------------------------------
 *
................................................................................
 *
 * Side effects:
 *
 *---------------------------------------------------------------------------
 */

static int
ObjPrintfVA(interp, argList)
    Tcl_Interp *interp;


    va_list argList;
{
    int code, objc;
    Tcl_Obj **objv, *list = Tcl_NewObj();
    CONST char *format, *p;
    Tcl_Obj *objPtr = va_arg(argList, Tcl_Obj *);

    if (objPtr == NULL) {
	Tcl_Panic("TclObjPrintf: no Tcl_Obj to append to");
    }

    p = format = va_arg(argList, CONST char *);
    if (format == NULL) {
	Tcl_Panic("TclObjPrintf: no format string argument");
    }

    Tcl_IncrRefCount(list);
    while (*p != '\0') {
	int size = 0;
	int seekingConversion = 1;


	if (*p++ != '%') {
	    continue;
	}
	if (*p == '%') {
	    p++;
	    continue;
	}
	do {
	    switch (*p) {

	    case '\0':
		seekingConversion = 0;
		break;
	    case 's':
		Tcl_ListObjAppendElement(NULL, list, Tcl_NewStringObj(
			va_arg(argList, char *), -1));
		seekingConversion = 0;
















		break;

	    case 'c':
	    case 'i':
	    case 'u':
	    case 'd':
	    case 'o':
	    case 'x':
	    case 'X':
................................................................................
	    case 'f':
	    case 'g':
	    case 'G':
		Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
			va_arg(argList, double)));
		seekingConversion = 0;
		break;















	    case 'l':
		size = 1;
		p++;
		break;
	    case 'h':
		size = -1;
	    default:
................................................................................
 * Side effects:
 * 	None.
 *
 *---------------------------------------------------------------------------
 */

int
TclObjPrintf TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
    va_list argList;
    int result;
    Tcl_Interp *interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);


    result = ObjPrintfVA(interp, argList);
    va_end(argList);
    return result;
}






























 
/*
 *---------------------------------------------------------------------------
 *
 * FillUnicodeRep --
 *
 *	Populate the Unicode internal rep with the Unicode form of its string






|







 







>


>







 







|

<


<
>







 







|

|








|







|


>

<







 







<
<







|







 







<
|
>
>
|



<
<
<
<
<
<
<
<
<
<
<







 







|



|
|
>







 







|
|
>
>
|



|
|

<
<
<
<
|
<
<
<
<


<
|
>
>













|
<
|

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

>







 







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







 







|



<
>
>
|



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







29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
..
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
....
1663
1664
1665
1666
1667
1668
1669
1670
1671

1672
1673

1674
1675
1676
1677
1678
1679
1680
1681
....
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723

1724
1725
1726
1727
1728
1729
1730
....
2232
2233
2234
2235
2236
2237
2238


2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
....
2261
2262
2263
2264
2265
2266
2267

2268
2269
2270
2271
2272
2273
2274











2275
2276
2277
2278
2279
2280
2281
....
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
....
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337




2338




2339
2340

2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357

2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
....
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
....
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457

2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStringObj.c,v 1.35.2.9 2005/09/15 20:58:40 dgp Exp $ */

#include "tclInt.h"
#include "tommath.h"

/*
 * Prototypes for functions defined later in this file:
 */
................................................................................
			    int numChars));
static void		AppendUtfToUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    CONST char *bytes, int numBytes));
static void		AppendUtfToUtfRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    CONST char *bytes, int numBytes));
static void		FillUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static int		FormatObjVA _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr, CONST char *format,
			    va_list argList));
static int		ObjPrintfVA _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr, CONST char *format,
			    va_list argList));
static void		FreeStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static void		DupStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    Tcl_Obj *copyPtr));
static int		SetStringFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static void		UpdateStringOfString _ANSI_ARGS_((Tcl_Obj *objPtr));
................................................................................
 *	The contents of all the string arguments are appended to the string
 *	representation of objPtr.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...)
{

    va_list argList;


    va_start(argList, objPtr);
    Tcl_AppendStringsToObjVA(objPtr, argList);
    va_end(argList);
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclAppendFormattedObjs(interp, appendObj, format, objc, objv)
    Tcl_Interp *interp;
    Tcl_Obj *appendObj;
    CONST char *format;
    int objc;
    Tcl_Obj *CONST objv[];
{
    CONST char *span = format;
    int numBytes = 0;
    int objIndex = 0;
    int gotXpg = 0, gotSequential = 0;
    int originalLength;
    CONST char *msg;
    CONST char *mixedXPG = "cannot mix \"%\" and \"%n$\" conversion specifiers";
    CONST char *badIndex[2] = {
	"not enough arguments for all format specifiers",
	"\"%n$\" argument index out of range"
    };

    if (Tcl_IsShared(appendObj)) {
	Tcl_Panic("TclAppendFormattedObjs called with shared object");
    }
    Tcl_GetStringFromObj(appendObj, &originalLength);


    /* format string is NUL-terminated */
    while (*format != '\0') {
	char *end;
	int gotMinus, gotHash, gotZero, gotSpace, gotPlus, sawFlag;
	int width, gotPrecision, precision, useShort, useWide, useBig;
	int newXpg, numChars, allocSegment = 0;
	Tcl_Obj *segment;
................................................................................
	objIndex += gotSequential;
    }
    if (numBytes) {
	Tcl_AppendToObj(appendObj, span, numBytes);
	numBytes = 0;
    }



    return TCL_OK;

  errorMsg:
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
    }
  error:
    Tcl_SetObjLength(appendObj, originalLength);
    return TCL_ERROR;
}
 
/*
 *---------------------------------------------------------------------------
 *
 * FormatObjVA --
................................................................................
 * Side effects:
 *	Reallocates the String internal rep.
 *
 *---------------------------------------------------------------------------
 */

static int

FormatObjVA(Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    CONST char *format,
    va_list argList)
{
    int code, objc;
    Tcl_Obj **objv, *element, *list = Tcl_NewObj();












    Tcl_IncrRefCount(list);
    element = va_arg(argList, Tcl_Obj *);
    while (element != NULL) {
	Tcl_ListObjAppendElement(NULL, list, element);
	element = va_arg(argList, Tcl_Obj *);
    }
................................................................................
 * Side effects:
 * 	None.
 *
 *---------------------------------------------------------------------------
 */

int
TclFormatObj(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, ...)
{
    va_list argList;
    int result;

    va_start(argList, format);
    result = FormatObjVA(interp, objPtr, format, argList);
    va_end(argList);
    return result;
}
 
/*
 *---------------------------------------------------------------------------
 *
................................................................................
 *
 * Side effects:
 *
 *---------------------------------------------------------------------------
 */

static int
ObjPrintfVA(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    CONST char *format,
    va_list argList)
{
    int code, objc;
    Tcl_Obj **objv, *list = Tcl_NewObj();
    CONST char *p;
    char *end;





    p = format;




    Tcl_IncrRefCount(list);
    while (*p != '\0') {

	int size = 0, seekingConversion = 1, gotPrecision = 0;
	int lastNum = -1, numBytes = -1;

	if (*p++ != '%') {
	    continue;
	}
	if (*p == '%') {
	    p++;
	    continue;
	}
	do {
	    switch (*p) {

	    case '\0':
		seekingConversion = 0;
		break;
	    case 's': {

		char *bytes = va_arg(argList, char *);
		seekingConversion = 0;
		if (gotPrecision) {
		    char *end = bytes + lastNum;
		    char *q = bytes;
		    while ((q < end) && (*q != '\0')) {
			q++;
		    }
		    numBytes = (int)(q - bytes);
		}
		Tcl_ListObjAppendElement(NULL, list,
			Tcl_NewStringObj(bytes , numBytes));
		/* We took no more than numBytes bytes from the (char *).
		 * In turn, [format] will take no more than numBytes
		 * characters from the Tcl_Obj.  Since numBytes characters
		 * must be no less than numBytes bytes, the character limit
		 * will have no effect and we can just pass it through.
		 */
		break;
	    }
	    case 'c':
	    case 'i':
	    case 'u':
	    case 'd':
	    case 'o':
	    case 'x':
	    case 'X':
................................................................................
	    case 'f':
	    case 'g':
	    case 'G':
		Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
			va_arg(argList, double)));
		seekingConversion = 0;
		break;
	    case '*':
		lastNum = (int)va_arg(argList, int);
		Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(lastNum));
		p++;
		break;
	    case '0': case '1': case '2': case '3': case '4':
	    case '5': case '6': case '7': case '8': case '9':
		lastNum = (int) strtoul(p, &end, 10);
		p = end;
		break;
	    case '.':
		gotPrecision = 1;
		p++;
		break;
	    /* TODO: support for wide (and bignum?) arguments */
	    case 'l':
		size = 1;
		p++;
		break;
	    case 'h':
		size = -1;
	    default:
................................................................................
 * Side effects:
 * 	None.
 *
 *---------------------------------------------------------------------------
 */

int
TclObjPrintf(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, ...)
{
    va_list argList;
    int result;


    va_start(argList, format);
    result = ObjPrintfVA(interp, objPtr, format, argList);
    va_end(argList);
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclFormatToErrorInfo --
 *
 * Results:
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

int
TclFormatToErrorInfo(Tcl_Interp *interp, CONST char *format, ...)
{
    int code;
    va_list argList;
    Tcl_Obj *objPtr = Tcl_NewObj();

    va_start(argList, format);
    code = ObjPrintfVA(interp, objPtr, format, argList);
    va_end(argList);
    if (code != TCL_OK) {
        return code;
    }
    TclAppendObjToErrorInfo(interp, objPtr);
    Tcl_DecrRefCount(objPtr);
    return TCL_OK;
}
 
/*
 *---------------------------------------------------------------------------
 *
 * FillUnicodeRep --
 *
 *	Populate the Unicode internal rep with the Unicode form of its string

Changes to generic/tclTimer.c.

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
777
778
779
780
781
782
783

784
785
786
787
788
789
790
...
844
845
846
847
848
849
850

851
852
853
854
855
856
857
858
859
...
922
923
924
925
926
927
928

929
930
931
932
933
934
935
936
937
 *	including the "after" command.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTimer.c,v 1.12.2.4 2005/08/02 18:16:10 dgp Exp $
 */

#include "tclInt.h"

/*
 * For each timer callback that's pending there is one record of the following
 * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained
................................................................................
    int length;
    char *argString;
    int index;
    char buf[16 + TCL_INTEGER_SPACE];
    static CONST char *afterSubCmds[] = {
	"cancel", "idle", "info", (char *) NULL
    };

    enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
    ThreadSpecificData *tsdPtr = InitTimer();

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

	afterPtr->id = tsdPtr->afterId;
	tsdPtr->afterId += 1;
	afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc,
		(ClientData) afterPtr);
	afterPtr->nextPtr = assocPtr->firstAfterPtr;
	assocPtr->firstAfterPtr = afterPtr;

	sprintf(buf, "after#%d", afterPtr->id);
	Tcl_AppendResult(interp, buf, (char *) NULL);
	return TCL_OK;
    }

    /*
     * If it's not a number it must be a subcommand. Note that we're using a
     * custom error message here, so we do not pass an interpreter to T_GIFO.
     */
................................................................................
	Tcl_IncrRefCount(afterPtr->commandPtr);
	afterPtr->id = tsdPtr->afterId;
	tsdPtr->afterId += 1;
	afterPtr->token = NULL;
	afterPtr->nextPtr = assocPtr->firstAfterPtr;
	assocPtr->firstAfterPtr = afterPtr;
	Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);

	sprintf(buf, "after#%d", afterPtr->id);
	Tcl_AppendResult(interp, buf, (char *) NULL);
	break;
    case AFTER_INFO: {
	Tcl_Obj *resultListPtr;

	if (objc == 2) {
	    for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
		    afterPtr = afterPtr->nextPtr) {






|







 







>







 







>
|
|







 







>
|
|







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
...
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
...
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
 *	including the "after" command.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTimer.c,v 1.12.2.5 2005/09/15 20:58:40 dgp Exp $
 */

#include "tclInt.h"

/*
 * For each timer callback that's pending there is one record of the following
 * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained
................................................................................
    int length;
    char *argString;
    int index;
    char buf[16 + TCL_INTEGER_SPACE];
    static CONST char *afterSubCmds[] = {
	"cancel", "idle", "info", (char *) NULL
    };
    Tcl_Obj *objPtr;
    enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
    ThreadSpecificData *tsdPtr = InitTimer();

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

	afterPtr->id = tsdPtr->afterId;
	tsdPtr->afterId += 1;
	afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc,
		(ClientData) afterPtr);
	afterPtr->nextPtr = assocPtr->firstAfterPtr;
	assocPtr->firstAfterPtr = afterPtr;
	objPtr = Tcl_NewObj();
	TclObjPrintf(NULL, objPtr, "after#%d", afterPtr->id);
	Tcl_SetObjResult(interp, objPtr);
	return TCL_OK;
    }

    /*
     * If it's not a number it must be a subcommand. Note that we're using a
     * custom error message here, so we do not pass an interpreter to T_GIFO.
     */
................................................................................
	Tcl_IncrRefCount(afterPtr->commandPtr);
	afterPtr->id = tsdPtr->afterId;
	tsdPtr->afterId += 1;
	afterPtr->token = NULL;
	afterPtr->nextPtr = assocPtr->firstAfterPtr;
	assocPtr->firstAfterPtr = afterPtr;
	Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);
	objPtr = Tcl_NewObj();
	TclObjPrintf(NULL, objPtr, "after#%d", afterPtr->id);
	Tcl_SetObjResult(interp, objPtr);
	break;
    case AFTER_INFO: {
	Tcl_Obj *resultListPtr;

	if (objc == 2) {
	    for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
		    afterPtr = afterPtr->nextPtr) {

Changes to generic/tclUtil.c.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
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
...
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
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 *  RCS: @(#) $Id: tclUtil.c,v 1.51.2.19 2005/09/09 18:48:40 dgp Exp $
 */

#include "tclInt.h"
#include <float.h>
#include <math.h>

/*
................................................................................
		}

		/*
		 * Garbage after the closing brace; return an error.
		 */

		if (interp != NULL) {
		    char buf[100];

		    p2 = p;
		    while ((p2 < limit)
			    && (!isspace(UCHAR(*p2)))	/* INTL: ISO space. */
			    && (p2 < p+20)) {
			p2++;
		    }
		    sprintf(buf,
			    "list element in braces followed by \"%.*s\" instead of space",
			    (int) (p2-p), p);
		    Tcl_SetResult(interp, buf, TCL_VOLATILE);
		}
		return TCL_ERROR;
	    }
	    break;

	    /*
	     * Backslash: skip over everything up to the end of the backslash
................................................................................
		}

		/*
		 * Garbage after the closing quote; return an error.
		 */

		if (interp != NULL) {
		    char buf[100];

		    p2 = p;
		    while ((p2 < limit)
			    && (!isspace(UCHAR(*p2)))	/* INTL: ISO space */
			    && (p2 < p+20)) {
			p2++;
		    }
		    sprintf(buf,
			    "list element in quotes followed by \"%.*s\" %s",
			    (int) (p2-p), p, "instead of space");
		    Tcl_SetResult(interp, buf, TCL_VOLATILE);
		}
		return TCL_ERROR;
	    }
	    break;
	}
	p++;
    }






|







 







|
<






|
|
|
|







 







|
<






|
|
|
|







7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
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
...
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
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 *  RCS: @(#) $Id: tclUtil.c,v 1.51.2.20 2005/09/15 20:58:40 dgp Exp $
 */

#include "tclInt.h"
#include <float.h>
#include <math.h>

/*
................................................................................
		}

		/*
		 * Garbage after the closing brace; return an error.
		 */

		if (interp != NULL) {
		    Tcl_Obj *objPtr = Tcl_NewObj();

		    p2 = p;
		    while ((p2 < limit)
			    && (!isspace(UCHAR(*p2)))	/* INTL: ISO space. */
			    && (p2 < p+20)) {
			p2++;
		    }
		    TclObjPrintf(NULL, objPtr,
			    "list element in braces followed by \"%.*s\" "
			    "instead of space", (int) (p2-p), p);
		    Tcl_SetObjResult(interp, objPtr);
		}
		return TCL_ERROR;
	    }
	    break;

	    /*
	     * Backslash: skip over everything up to the end of the backslash
................................................................................
		}

		/*
		 * Garbage after the closing quote; return an error.
		 */

		if (interp != NULL) {
		    Tcl_Obj *objPtr = Tcl_NewObj();

		    p2 = p;
		    while ((p2 < limit)
			    && (!isspace(UCHAR(*p2)))	/* INTL: ISO space */
			    && (p2 < p+20)) {
			p2++;
		    }
		    TclObjPrintf(NULL, objPtr,
			    "list element in quotes followed by \"%.*s\" "
			    "instead of space", (int) (p2-p), p);
		    Tcl_SetObjResult(interp, objPtr);
		}
		return TCL_ERROR;
	    }
	    break;
	}
	p++;
    }

Changes to library/init.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
...
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
# init.tcl --
#
# Default system startup file for Tcl-based applications.  Defines
# "unknown" procedure and auto-load facilities.
#
# RCS: @(#) $Id: init.tcl,v 1.69.2.5 2005/08/25 15:46:31 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
# Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
................................................................................
		# Compute stack trace contribution from the [uplevel].
		# Note the dependence on how Tcl_AddErrorInfo, etc. 
		# construct the stack trace.
		#
		set errorInfo [dict get $opts -errorinfo]
		set errorCode [dict get $opts -errorcode]
		set cinfo $args
		if {[string bytelength $cinfo] > 153} {
		    set cinfo [string range $cinfo 0 152]
		    while {[string bytelength $cinfo] > 150} {
			set cinfo [string range $cinfo 0 end-1]
		    }
		    append cinfo ...
		}
		append cinfo "\"\n    (\"uplevel\" body line 1)"
		append cinfo "\n    invoked from within"




|







 







|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
...
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
# init.tcl --
#
# Default system startup file for Tcl-based applications.  Defines
# "unknown" procedure and auto-load facilities.
#
# RCS: @(#) $Id: init.tcl,v 1.69.2.6 2005/09/15 20:58:40 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
# Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
................................................................................
		# Compute stack trace contribution from the [uplevel].
		# Note the dependence on how Tcl_AddErrorInfo, etc. 
		# construct the stack trace.
		#
		set errorInfo [dict get $opts -errorinfo]
		set errorCode [dict get $opts -errorcode]
		set cinfo $args
		if {[string bytelength $cinfo] > 150} {
		    set cinfo [string range $cinfo 0 150]
		    while {[string bytelength $cinfo] > 150} {
			set cinfo [string range $cinfo 0 end-1]
		    }
		    append cinfo ...
		}
		append cinfo "\"\n    (\"uplevel\" body line 1)"
		append cinfo "\n    invoked from within"

Changes to tools/genStubs.tcl.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
...
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
...
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
#	interface.  
#	
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: genStubs.tcl,v 1.17 2004/03/17 18:14:18 das Exp $

package require Tcl 8

namespace eval genStubs {
    # libraryName --
    #
    #	The name of the entire library.  This value is used to compute
................................................................................
    set arg1 [lindex $args 0]
    switch -exact $arg1 {
	void {
	    append line "(void)"
	}
	TCL_VARARGS {
	    set arg [lindex $args 1]
	    append line "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])"
	}
	default {
	    set sep "("
	    foreach arg $args {
		append line $sep
		set next {}
		append next [lindex $arg 0] " " [lindex $arg 1] \
................................................................................

    append text "/* Slot $index */\n" $rtype "\n" $fname

    set arg1 [lindex $args 0]

    if {![string compare $arg1 "TCL_VARARGS"]} {
	lassign [lindex $args 1] type argName 
	append text " TCL_VARARGS_DEF($type,$argName)\n\{\n"
	append text "    " $type " var;\n    va_list argList;\n"
	if {[string compare $rtype "void"]} {
	    append text "    " $rtype " resultValue;\n"
	}
	append text "\n    var = (" $type ") TCL_VARARGS_START(" \
		$type "," $argName ",argList);\n\n    "
	if {[string compare $rtype "void"]} {
	    append text "resultValue = "
	}
	append text "(" $name "StubsPtr->" $lfname "VA)(var, argList);\n"
	append text "    va_end(argList);\n"
	if {[string compare $rtype "void"]} {
	    append text "return resultValue;\n"
................................................................................
    set arg1 [lindex $args 0]
    switch -exact $arg1 {
	void {
	    append text "(void)"
	}
	TCL_VARARGS {
	    set arg [lindex $args 1]
	    append text "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])"
	}
	default {
	    set sep "("
	    foreach arg $args {
		append text $sep [lindex $arg 0] " " [lindex $arg 1] \
			[lindex $arg 2]
		set sep ", "






|







 







|







 







|




|
|







 







|







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
...
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
...
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
#	interface.  
#	
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: genStubs.tcl,v 1.17.2.1 2005/09/15 20:58:40 dgp Exp $

package require Tcl 8

namespace eval genStubs {
    # libraryName --
    #
    #	The name of the entire library.  This value is used to compute
................................................................................
    set arg1 [lindex $args 0]
    switch -exact $arg1 {
	void {
	    append line "(void)"
	}
	TCL_VARARGS {
	    set arg [lindex $args 1]
	    append line "([lindex $arg 0][lindex $arg 1], ...)"
	}
	default {
	    set sep "("
	    foreach arg $args {
		append line $sep
		set next {}
		append next [lindex $arg 0] " " [lindex $arg 1] \
................................................................................

    append text "/* Slot $index */\n" $rtype "\n" $fname

    set arg1 [lindex $args 0]

    if {![string compare $arg1 "TCL_VARARGS"]} {
	lassign [lindex $args 1] type argName 
	append text " ($type$argName, ...)\n\{\n"
	append text "    " $type " var;\n    va_list argList;\n"
	if {[string compare $rtype "void"]} {
	    append text "    " $rtype " resultValue;\n"
	}
	append text "\n    var = (" $type ") (va_start(argList, " \
		$argName "), " $argName ");\n\n    "
	if {[string compare $rtype "void"]} {
	    append text "resultValue = "
	}
	append text "(" $name "StubsPtr->" $lfname "VA)(var, argList);\n"
	append text "    va_end(argList);\n"
	if {[string compare $rtype "void"]} {
	    append text "return resultValue;\n"
................................................................................
    set arg1 [lindex $args 0]
    switch -exact $arg1 {
	void {
	    append text "(void)"
	}
	TCL_VARARGS {
	    set arg [lindex $args 1]
	    append text "([lindex $arg 0][lindex $arg 1], ...)"
	}
	default {
	    set sep "("
	    foreach arg $args {
		append text $sep [lindex $arg 0] " " [lindex $arg 1] \
			[lindex $arg 2]
		set sep ", "

Changes to unix/configure.

8948
8949
8950
8951
8952
8953
8954








































































































8955
8956
8957
8958
8959
8960
8961
cat >>confdefs.h <<\_ACEOF
#define _LARGEFILE64_SOURCE 1
_ACEOF

	tcl_flags="$tcl_flags _LARGEFILE64_SOURCE"
    fi








































































































    if test "x${tcl_flags}" = "x" ; then
	echo "$as_me:$LINENO: result: none" >&5
echo "${ECHO_T}none" >&6
    else
	echo "$as_me:$LINENO: result: ${tcl_flags}" >&5
echo "${ECHO_T}${tcl_flags}" >&6
    fi






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







8948
8949
8950
8951
8952
8953
8954
8955
8956
8957
8958
8959
8960
8961
8962
8963
8964
8965
8966
8967
8968
8969
8970
8971
8972
8973
8974
8975
8976
8977
8978
8979
8980
8981
8982
8983
8984
8985
8986
8987
8988
8989
8990
8991
8992
8993
8994
8995
8996
8997
8998
8999
9000
9001
9002
9003
9004
9005
9006
9007
9008
9009
9010
9011
9012
9013
9014
9015
9016
9017
9018
9019
9020
9021
9022
9023
9024
9025
9026
9027
9028
9029
9030
9031
9032
9033
9034
9035
9036
9037
9038
9039
9040
9041
9042
9043
9044
9045
9046
9047
9048
9049
9050
9051
9052
9053
9054
9055
9056
9057
9058
9059
9060
9061
9062
9063
9064
9065
cat >>confdefs.h <<\_ACEOF
#define _LARGEFILE64_SOURCE 1
_ACEOF

	tcl_flags="$tcl_flags _LARGEFILE64_SOURCE"
    fi

    if test "${tcl_cv_flag__largefile_source64+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/stat.h>
int
main ()
{
char *p = (char *)open64;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_flag__largefile_source64=no
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#define _LARGEFILE_SOURCE64 1
#include <sys/stat.h>
int
main ()
{
char *p = (char *)open64;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_flag__largefile_source64=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_flag__largefile_source64=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi

    if test "x${tcl_cv_flag__largefile_source64}" = "xyes" ; then

cat >>confdefs.h <<\_ACEOF
#define _LARGEFILE_SOURCE64 1
_ACEOF

	tcl_flags="$tcl_flags _LARGEFILE_SOURCE64"
    fi
    if test "x${tcl_flags}" = "x" ; then
	echo "$as_me:$LINENO: result: none" >&5
echo "${ECHO_T}none" >&6
    else
	echo "$as_me:$LINENO: result: ${tcl_flags}" >&5
echo "${ECHO_T}${tcl_flags}" >&6
    fi

Changes to unix/tcl.m4.

2518
2519
2520
2521
2522
2523
2524


2525
2526
2527
2528
2529
2530
2531
AC_DEFUN(SC_TCL_EARLY_FLAGS,[
    AC_MSG_CHECKING([for required early compiler flags])
    tcl_flags=""
    SC_TCL_EARLY_FLAG(_ISOC99_SOURCE,[#include <stdlib.h>],
	[char *p = (char *)strtoll; char *q = (char *)strtoull;])
    SC_TCL_EARLY_FLAG(_LARGEFILE64_SOURCE,[#include <sys/stat.h>],
	[struct stat64 buf; int i = stat64("/", &buf);])


    if test "x${tcl_flags}" = "x" ; then
	AC_MSG_RESULT(none)
    else
	AC_MSG_RESULT(${tcl_flags})
    fi])

#--------------------------------------------------------------------






>
>







2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
AC_DEFUN(SC_TCL_EARLY_FLAGS,[
    AC_MSG_CHECKING([for required early compiler flags])
    tcl_flags=""
    SC_TCL_EARLY_FLAG(_ISOC99_SOURCE,[#include <stdlib.h>],
	[char *p = (char *)strtoll; char *q = (char *)strtoull;])
    SC_TCL_EARLY_FLAG(_LARGEFILE64_SOURCE,[#include <sys/stat.h>],
	[struct stat64 buf; int i = stat64("/", &buf);])
    SC_TCL_EARLY_FLAG(_LARGEFILE_SOURCE64,[#include <sys/stat.h>],
	[char *p = (char *)open64;])
    if test "x${tcl_flags}" = "x" ; then
	AC_MSG_RESULT(none)
    else
	AC_MSG_RESULT(${tcl_flags})
    fi])

#--------------------------------------------------------------------

Changes to unix/tclUnixFCmd.c.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
 *	already be translated to native format.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixFCmd.c,v 1.40.2.3 2005/08/02 18:16:56 dgp Exp $
 *
 * Portions of this code were derived from NetBSD source code which has the
 * following copyright notice:
 *
 * Copyright (c) 1988, 1993, 1994
 *      The Regents of the University of California.  All rights reserved.
 *
................................................................................
GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr)
    Tcl_Interp *interp;		    /* The interp we are using for errors. */
    int objIndex;		    /* The index of the attribute. */
    Tcl_Obj *fileName;  	    /* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr;	    /* A pointer to return the object with. */
{
    Tcl_StatBuf statBuf;
    char returnString[7];
    int result;

    result = TclpObjStat(fileName, &statBuf);

    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not read \"",
		    Tcl_GetString(fileName), "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	return TCL_ERROR;
    }

    sprintf(returnString, "%0#5lo", (long) (statBuf.st_mode & 0x00007FFF));

    *attributePtrPtr = Tcl_NewStringObj(returnString, -1);

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






|







 







<













|
|
|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
1282
1283
1284
1285
1286
1287
1288

1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
 *	already be translated to native format.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixFCmd.c,v 1.40.2.4 2005/09/15 20:58:40 dgp Exp $
 *
 * Portions of this code were derived from NetBSD source code which has the
 * following copyright notice:
 *
 * Copyright (c) 1988, 1993, 1994
 *      The Regents of the University of California.  All rights reserved.
 *
................................................................................
GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr)
    Tcl_Interp *interp;		    /* The interp we are using for errors. */
    int objIndex;		    /* The index of the attribute. */
    Tcl_Obj *fileName;  	    /* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr;	    /* A pointer to return the object with. */
{
    Tcl_StatBuf statBuf;

    int result;

    result = TclpObjStat(fileName, &statBuf);

    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not read \"",
		    Tcl_GetString(fileName), "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	return TCL_ERROR;
    }

    *attributePtrPtr = Tcl_NewObj();
    TclObjPrintf(NULL, *attributePtrPtr, "%0#5lo",
	    (long) (statBuf.st_mode & 0x00007FFF));

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