Tcl Source Code

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

'\"
'\" 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

'\"
'\" 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.

'\"
'\" 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

'\"
'\" 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.

'\"
'\" 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.

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

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

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

/*
 * tclCmdAH.c --
 *
 *	This file contains the top-level command routines for most of the Tcl
 *	built-in commands whose names begin with the letters A to H.
 *
 * 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) {

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

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

/*
 * tclDecls.h --
 *
 *	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 */

/* 
 * tclDictObj.c --
 *
 *	This file contains procedures that implement the Tcl dict object
 *	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);

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

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

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

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

/*
 * tclMain.c --
 *
 *	Main program for Tcl shells and other Tcl-based applications.
 *
 * 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);
	}

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

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

/*
 * tclProc.c --
 *
 *	This file contains routines that implement Tcl procedures, including
 *	the "proc" and "uplevel" commands.
 *
 * 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_RETURN) {
	return TclUpdateReturnInfo(iPtr);
    }
    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 --

/*
 * tclResult.c --
 *
 *	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);
}

/*
 *----------------------------------------------------------------------
 *

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

static void		AppendUnicodeToUnicodeRep _ANSI_ARGS_((
			    Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
			    int appendNumChars));
static void		AppendUnicodeToUtfRep _ANSI_ARGS_((
			    Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
			    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;
}

/*
 *---------------------------------------------------------------------------
 *
 * ObjPrintfVA --
 *
 * Results:
 *
 * 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

/*
 * tclTimer.c --
 *
 *	This file provides timer event management facilities for Tcl,
 *	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) {

/*
 * tclUtil.c --
 *
 *	This file contains utility functions that are used by many Tcl
 *	commands.
 *
 * 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++;
    }

# 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"

# genStubs.tcl --
#
#	This script generates a set of stub files for a given
#	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 ", "

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

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

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

/*
 * tclUnixFCmd.c
 *
 *	This file implements the unix specific portion of file manipulation
 *	subcommands of the "file" command.  All filename arguments should
 *	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;
}

/*
 *---------------------------------------------------------------------------
 *