diff options
34 files changed, 210 insertions, 910 deletions
diff --git a/doc/Encoding.3 b/doc/Encoding.3 index 7bcb285..8432d61 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -8,7 +8,7 @@ .TH Tcl_GetEncoding 3 "8.1" Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_GetEncodingFromObj, Tcl_ExternalToUtfDString, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternal, Tcl_WinTCharToUtf, Tcl_WinUtfToTChar, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNameFromEnvironment, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetEncodingSearchPath, Tcl_SetEncodingSearchPath, Tcl_GetDefaultEncodingDir, Tcl_SetDefaultEncodingDir \- procedures for creating and using encodings +Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_GetEncodingFromObj, Tcl_ExternalToUtfDString, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternal, Tcl_WinTCharToUtf, Tcl_WinUtfToTChar, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNameFromEnvironment, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetEncodingSearchPath, Tcl_SetEncodingSearchPath \- procedures for creating and using encodings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -62,12 +62,6 @@ Tcl_Obj * .sp int \fBTcl_SetEncodingSearchPath\fR(\fIsearchPath\fR) -.sp -const char * -\fBTcl_GetDefaultEncodingDir\fR(\fIvoid\fR) -.sp -void -\fBTcl_SetDefaultEncodingDir\fR(\fIpath\fR) .SH ARGUMENTS .AS "const Tcl_EncodingType" *dstWrotePtr in/out .AP Tcl_Interp *interp in @@ -325,7 +319,7 @@ the encoding name to it. The \fBTcl_DStringValue\fR is returned. \fBTcl_GetEncodingNames\fR sets the \fIinterp\fR result to a list consisting of the names of all the encodings that are currently defined or can be dynamically loaded, searching the encoding path specified by -\fBTcl_SetDefaultEncodingDir\fR. This procedure does not ensure that the +\fBTcl_SetEncodingSearchPath\fR. This procedure does not ensure that the dynamically-loadable encoding files contain valid data, but merely that they exist. .PP @@ -440,15 +434,6 @@ are not verified as existing readable filesystem directories. When searching for encoding data files takes place, and non-existent or non-readable filesystem directories on the \fIsearchPath\fR are silently ignored. -.PP -\fBTcl_GetDefaultEncodingDir\fR and \fBTcl_SetDefaultEncodingDir\fR -are obsolete interfaces best replaced with calls to -\fBTcl_GetEncodingSearchPath\fR and \fBTcl_SetEncodingSearchPath\fR. -They are called to access and set the first element of the \fIsearchPath\fR -list. Since Tcl searches \fIsearchPath\fR for encoding data files in -list order, these routines establish the -.QW default -directory in which to find encoding data files. .SH "ENCODING FILES" Space would prohibit precompiling into Tcl every possible encoding algorithm, so many encodings are stored on disk as dynamically-loadable diff --git a/doc/Interp.3 b/doc/Interp.3 index d908057..d5006f9 100644 --- a/doc/Interp.3 +++ b/doc/Interp.3 @@ -33,19 +33,6 @@ the pointer as described below is no longer supported. The supported public routines \fBTcl_SetResult\fR, \fBTcl_GetResult\fR, \fBTcl_SetErrorLine\fR, \fBTcl_GetErrorLine\fR must be used instead. .PP -For legacy programs and extensions no longer being maintained, compiles -against the Tcl 8.6 header files are only possible with the compiler -directives -.CS -#define USE_INTERP_RESULT -.CE -and/or -.CS -#define USE_INTERP_ERRORLINE -.CE -depending on which fields of the \fBTcl_Interp\fR struct are accessed. -These directives may be embedded in code or supplied via compiler options. -.PP The \fIresult\fR and \fIfreeProc\fR fields are used to return results or error messages from commands. This information is returned by command procedures back to \fBTcl_Eval\fR, diff --git a/doc/SetResult.3 b/doc/SetResult.3 index bbeedf1..c863c5a 100644 --- a/doc/SetResult.3 +++ b/doc/SetResult.3 @@ -199,17 +199,11 @@ change \fIinterp->result\fR or clear error state. is about to replace one result value with another. .SS "DIRECT ACCESS TO INTERP->RESULT" .PP -It used to be legal for programs to -directly read and write \fIinterp->result\fR -to manipulate the interpreter result. The Tcl headers no longer -permit this access by default, and C code still doing this must -be updated to use supported routines \fBTcl_GetObjResult\fR, +It used to be legal for programs to directly read and write +\fIinterp->result\fR to manipulate the interpreter result. +The Tcl headers no longer permit this access, and C code still +doing this must be updated to use supported routines \fBTcl_GetObjResult\fR, \fBTcl_GetStringResult\fR, \fBTcl_SetObjResult\fR, and \fBTcl_SetResult\fR. -As a migration aid, access can be restored with the compiler directive -.CS -#define USE_INTERP_RESULT -.CE -but this is meant only to offer life support to otherwise dead code. .SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT" .PP \fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how @@ -44,11 +44,6 @@ The remaining pattern arguments, after option processing, are treated as a single pattern obtained by joining the arguments with directory separators. .TP -\fB\-nocomplain\fR -. -Allows an empty list to be returned without error; without this -switch an error is returned if the result list would be empty. -.TP \fB\-path\fR \fIpathPrefix\fR . Search for files with the given \fIpathPrefix\fR where the rest of the name diff --git a/generic/tcl.decls b/generic/tcl.decls index ec7864d..ad725f5 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -515,7 +515,7 @@ declare 142 { declare 143 { void Tcl_Finalize(void) } -# Removed in 9.0: +# Removed (from stubtable only) in 9.0: #declare 144 { # void Tcl_FindExecutable(const char *argv0) #} @@ -1217,12 +1217,14 @@ declare 339 { declare 340 { char *Tcl_GetString(Tcl_Obj *objPtr) } -declare 341 { - const char *Tcl_GetDefaultEncodingDir(void) -} -declare 342 { - void Tcl_SetDefaultEncodingDir(const char *path) -} +# Removed in 9.0 +#declare 341 { +# const char *Tcl_GetDefaultEncodingDir(void) +#} +# Removed in 9.0 +#declare 342 { +# void Tcl_SetDefaultEncodingDir(const char *path) +#} declare 343 { void Tcl_AlertNotifier(ClientData clientData) } diff --git a/generic/tcl.h b/generic/tcl.h index 33bf149..162983b 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -122,7 +122,6 @@ extern "C" { */ #include <stdio.h> -#include <stddef.h> /* *---------------------------------------------------------------------------- @@ -525,8 +524,6 @@ typedef struct stat *Tcl_OldStat_; #define TCL_BREAK 3 #define TCL_CONTINUE 4 -#define TCL_RESULT_SIZE 200 - /* *---------------------------------------------------------------------------- * Flags to control what substitutions are performed by Tcl_SubstObj(): @@ -702,13 +699,7 @@ int Tcl_IsShared(Tcl_Obj *objPtr); */ typedef struct Tcl_SavedResult { - char *result; - Tcl_FreeProc *freeProc; Tcl_Obj *objResultPtr; - char *appendResult; - int appendAvl; - int appendUsed; - char resultSpace[TCL_RESULT_SIZE+1]; } Tcl_SavedResult; /* @@ -2200,7 +2191,7 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp, * stubs tables. */ -#define TCL_STUB_MAGIC ((int) (0xFCA3BACB + sizeof(size_t))) +#define TCL_STUB_MAGIC ((int) 0xFCA3BACF) /* * The following function is required to be defined in all stubs aware @@ -2210,7 +2201,7 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp, */ const char * TclInitStubs(Tcl_Interp *interp, const char *version, - int exact, int magic); + int exact, const char *tclversion, int magic); const char * TclTomMathInitializeStubs(Tcl_Interp *interp, const char *version, int epoch, int revision); @@ -2220,7 +2211,7 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp, #ifdef USE_TCL_STUBS #define Tcl_InitStubs(interp, version, exact) \ - TclInitStubs(interp, version, exact, TCL_STUB_MAGIC) + TclInitStubs(interp, version, exact, TCL_VERSION, TCL_STUB_MAGIC) #else #define Tcl_InitStubs(interp, version, exact) \ Tcl_PkgInitStubsCheck(interp, version, exact) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 146247e..7202184 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -431,14 +431,6 @@ TclFinalizeEvaluation(void) *---------------------------------------------------------------------- */ -/* Template for internal Interp structure: the stubTable entry cannot move! */ -typedef struct { - char *dumm1; - Tcl_FreeProc *dummy2; - int dummy3; - const struct TclStubs *stubTable; -} InterpTemplate; - Tcl_Interp * Tcl_CreateInterp(void) { @@ -474,21 +466,6 @@ Tcl_CreateInterp(void) /*NOTREACHED*/ Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame"); } - if ((void *) tclStubs.tcl_SetObjResult - != (void *)((&(tclStubs.tcl_PkgProvideEx))[235])) { - /*NOTREACHED*/ - Tcl_Panic("Tcl_SetObjResult entry in the stub table must be kept"); - } - if ((void *) tclStubs.tcl_NewStringObj - != (void *)((&(tclStubs.tcl_PkgProvideEx))[56])) { - /*NOTREACHED*/ - Tcl_Panic("Tcl_NewStringObj entry in the stub table must be kept"); - } - if (TclOffset(InterpTemplate, stubTable) - != TclOffset(Interp, stubTable)) { - /*NOTREACHED*/ - Tcl_Panic("stubsTable entry in the Interp structure must be kept"); - } if (cancelTableInitialized == 0) { Tcl_MutexLock(&cancelLock); @@ -508,9 +485,12 @@ Tcl_CreateInterp(void) iPtr = ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = NULL; + iPtr->legacyResult = NULL; + /* Special invalid value: Any attempt to free the legacy result + * will cause a crash. */ + iPtr->legacyFreeProc = (void (*) (void))-1; iPtr->errorLine = 0; + iPtr->stubTable = &tclStubs; iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); iPtr->handle = TclHandleCreate(iPtr); @@ -565,10 +545,6 @@ Tcl_CreateInterp(void) iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */ iPtr->lookupNsPtr = NULL; - iPtr->appendResult = NULL; - iPtr->appendAvl = 0; - iPtr->appendUsed = 0; - Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; @@ -596,7 +572,6 @@ Tcl_CreateInterp(void) iPtr->emptyObjPtr = Tcl_NewObj(); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); - iPtr->resultSpace[0] = 0; iPtr->threadId = Tcl_GetCurrentThread(); /* TIP #378 */ @@ -710,12 +685,6 @@ Tcl_CreateInterp(void) #endif /* TCL_COMPILE_STATS */ /* - * Initialise the stub table pointer. - */ - - iPtr->stubTable = &tclStubs; - - /* * Initialize the ensemble error message rewriting support. */ @@ -1498,7 +1467,6 @@ DeleteInterpProc( */ Tcl_FreeResult(interp); - iPtr->result = NULL; Tcl_DecrRefCount(iPtr->objResultPtr); iPtr->objResultPtr = NULL; Tcl_DecrRefCount(iPtr->ecVar); @@ -1520,10 +1488,6 @@ DeleteInterpProc( if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } - if (iPtr->appendResult != NULL) { - ckfree(iPtr->appendResult); - iPtr->appendResult = NULL; - } TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr); @@ -2397,7 +2361,7 @@ TclInvokeStringCommand( * in the Command structure. * * Results: - * A standard Tcl string result value. + * A standard Tcl result value. * * Side effects: * Besides those side effects of the called Tcl_CmdProc, @@ -2438,13 +2402,6 @@ TclInvokeObjectCommand( } /* - * Move the interpreter's object result to the string result, then reset - * the object result. - */ - - (void) Tcl_GetStringResult(interp); - - /* * Decrement the ref counts for the argument objects created above, then * free the objv array if malloc'ed storage was used. */ @@ -3446,7 +3403,7 @@ TclCleanupCommand( * otherwise. * * Side effects: - * The interpreters object and string results are cleared. + * The interpreter's result is cleared. * *---------------------------------------------------------------------- */ @@ -3458,8 +3415,8 @@ TclInterpReady( register Interp *iPtr = (Interp *) interp; /* - * Reset both the interpreter's string and object results and clear out - * any previous error information. + * Reset the interpreter's result and clear out any previous error + * information. */ Tcl_ResetResult(interp); @@ -3977,24 +3934,9 @@ TclNRRunCallbacks( /* All callbacks down to rootPtr not inclusive * are to be run. */ { - Interp *iPtr = (Interp *) interp; NRE_callback *callbackPtr; Tcl_NRPostProc *procPtr; - /* - * If the interpreter has a non-empty string result, the result object is - * either empty or stale because some function set interp->result - * directly. If so, move the string result to the result object, then - * reset the string result. - * - * This only needs to be done for the first item in the list: all other - * are for NR function calls, and those are Tcl_Obj based. - */ - - if (*(iPtr->result) != 0) { - (void) Tcl_GetObjResult(interp); - } - while (TOP_CB(interp) != rootPtr) { callbackPtr = TOP_CB(interp); procPtr = callbackPtr->procPtr; @@ -5424,16 +5366,7 @@ Tcl_Eval( * previous call to Tcl_CreateInterp). */ const char *script) /* Pointer to TCL command to execute. */ { - int code = Tcl_EvalEx(interp, script, -1, 0); - - /* - * For backwards compatibility with old C code that predates the object - * system in Tcl 8.0, we have to mirror the object result back into the - * string result (some callers may expect it there). - */ - - (void) Tcl_GetStringResult(interp); - return code; + return Tcl_EvalEx(interp, script, -1, 0); } /* @@ -5923,9 +5856,6 @@ Tcl_ExprLong( Tcl_IncrRefCount(exprPtr); result = Tcl_ExprLongObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); - if (result != TCL_OK) { - (void) Tcl_GetStringResult(interp); - } } return result; } @@ -5952,9 +5882,6 @@ Tcl_ExprDouble( result = Tcl_ExprDoubleObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); /* Discard the expression object. */ - if (result != TCL_OK) { - (void) Tcl_GetStringResult(interp); - } } return result; } @@ -5980,14 +5907,6 @@ Tcl_ExprBoolean( Tcl_IncrRefCount(exprPtr); result = Tcl_ExprBooleanObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); - if (result != TCL_OK) { - /* - * Move the interpreter's object result to the string result, then - * reset the object result. - */ - - (void) Tcl_GetStringResult(interp); - } return result; } } @@ -6313,12 +6232,6 @@ Tcl_ExprString( Tcl_DecrRefCount(resultPtr); } } - - /* - * Force the string rep of the interp result. - */ - - (void) Tcl_GetStringResult(interp); return code; } @@ -6422,19 +6335,7 @@ Tcl_AddObjErrorInfo( iPtr->flags |= ERR_LEGACY_COPY; if (iPtr->errorInfo == NULL) { - if (iPtr->result[0] != 0) { - /* - * The interp's string result is set, apparently by some extension - * making a deprecated direct write to it. That extension may - * expect interp->result to continue to be set, so we'll take - * special pains to avoid clearing it, until we drop support for - * interp->result completely. - */ - - iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1); - } else { - iPtr->errorInfo = iPtr->objResultPtr; - } + iPtr->errorInfo = iPtr->objResultPtr; Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { Tcl_SetErrorCode(interp, "NONE", NULL); @@ -6512,7 +6413,7 @@ Tcl_VarEvalVA( * * Results: * A standard Tcl return result. An error message or other result may be - * left in interp->result. + * left in the interp. * * Side effects: * Depends on what was done by the command. diff --git a/generic/tclDecls.h b/generic/tclDecls.h index d152ea8..d38296d 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -964,10 +964,8 @@ TCLAPI int Tcl_WriteChars(Tcl_Channel chan, const char *src, TCLAPI int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 340 */ TCLAPI char * Tcl_GetString(Tcl_Obj *objPtr); -/* 341 */ -TCLAPI const char * Tcl_GetDefaultEncodingDir(void); -/* 342 */ -TCLAPI void Tcl_SetDefaultEncodingDir(const char *path); +/* Slot 341 is reserved */ +/* Slot 342 is reserved */ /* 343 */ TCLAPI void Tcl_AlertNotifier(ClientData clientData); /* 344 */ @@ -2146,8 +2144,8 @@ typedef struct TclStubs { int (*tcl_WriteChars) (Tcl_Channel chan, const char *src, int srcLen); /* 338 */ int (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */ - const char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */ - void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */ + void (*reserved341)(void); + void (*reserved342)(void); void (*tcl_AlertNotifier) (ClientData clientData); /* 343 */ void (*tcl_ServiceModeHook) (int mode); /* 344 */ int (*tcl_UniCharIsAlnum) (int ch); /* 345 */ @@ -3142,10 +3140,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_WriteObj) /* 339 */ #define Tcl_GetString \ (tclStubsPtr->tcl_GetString) /* 340 */ -#define Tcl_GetDefaultEncodingDir \ - (tclStubsPtr->tcl_GetDefaultEncodingDir) /* 341 */ -#define Tcl_SetDefaultEncodingDir \ - (tclStubsPtr->tcl_SetDefaultEncodingDir) /* 342 */ +/* Slot 341 is reserved */ +/* Slot 342 is reserved */ #define Tcl_AlertNotifier \ (tclStubsPtr->tcl_AlertNotifier) /* 343 */ #define Tcl_ServiceModeHook \ @@ -3744,7 +3740,7 @@ extern const TclStubs *tclStubsPtr; #if defined(_WIN32) && defined(UNICODE) # define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg))) # define Tcl_MainEx Tcl_MainExW - EXTERN void Tcl_MainExW(int argc, wchar_t **argv, +TCLAPI void Tcl_MainExW(int argc, wchar_t **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); #endif diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 7a55724..d2c7bc8 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -672,68 +672,6 @@ TclFinalizeEncodingSubsystem(void) /* *------------------------------------------------------------------------- * - * Tcl_GetDefaultEncodingDir -- - * - * Legacy public interface to retrieve first directory in the encoding - * searchPath. - * - * Results: - * The directory pathname, as a string, or NULL for an empty encoding - * search path. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -const char * -Tcl_GetDefaultEncodingDir(void) -{ - int numDirs; - Tcl_Obj *first, *searchPath = Tcl_GetEncodingSearchPath(); - - Tcl_ListObjLength(NULL, searchPath, &numDirs); - if (numDirs == 0) { - return NULL; - } - Tcl_ListObjIndex(NULL, searchPath, 0, &first); - - return Tcl_GetString(first); -} - -/* - *------------------------------------------------------------------------- - * - * Tcl_SetDefaultEncodingDir -- - * - * Legacy public interface to set the first directory in the encoding - * search path. - * - * Results: - * None. - * - * Side effects: - * Modifies the encoding search path. - * - *------------------------------------------------------------------------- - */ - -void -Tcl_SetDefaultEncodingDir( - const char *path) -{ - Tcl_Obj *searchPath = Tcl_GetEncodingSearchPath(); - Tcl_Obj *directory = Tcl_NewStringObj(path, -1); - - searchPath = Tcl_DuplicateObj(searchPath); - Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory); - Tcl_SetEncodingSearchPath(searchPath); -} - -/* - *------------------------------------------------------------------------- - * * Tcl_GetEncoding -- * * Given the name of a encoding, find the corresponding Tcl_Encoding diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 5d4702b..a519f0e 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -37,6 +37,15 @@ static Tcl_Obj * SplitUnixPath(const char *path); static int DoGlob(Tcl_Interp *interp, Tcl_Obj *resultPtr, const char *separators, Tcl_Obj *pathPtr, int flags, char *pattern, Tcl_GlobTypeData *types); +static int TclGlob(Tcl_Interp *interp, char *pattern, + Tcl_Obj *pathPrefix, int globFlags, + Tcl_GlobTypeData *types); + +/* Flag values used by TclGlob() */ + +#define TCL_GLOBMODE_JOIN 2 +#define TCL_GLOBMODE_DIR 4 +#define TCL_GLOBMODE_TAILS 8 /* * When there is no support for getting the block size of a file in a stat() @@ -1270,7 +1279,10 @@ Tcl_GlobObjCmd( switch (index) { case GLOB_NOCOMPLAIN: /* -nocomplain */ - globFlags |= TCL_GLOBMODE_NO_COMPLAIN; + /* + * Do nothing; This is normal operations in Tcl 9. + * Keep accepting as a no-op option to accommodate old scripts. + */ break; case GLOB_DIR: /* -dir */ if (i == (objc-1)) { @@ -1620,41 +1632,6 @@ Tcl_GlobObjCmd( } } - if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) { - if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp), - &length) != TCL_OK) { - /* - * This should never happen. Maybe we should be more dramatic. - */ - - result = TCL_ERROR; - goto endOfGlob; - } - - if (length == 0) { - Tcl_Obj *errorMsg = - Tcl_ObjPrintf("no files matched glob pattern%s \"", - (join || (objc == 1)) ? "" : "s"); - - if (join) { - Tcl_AppendToObj(errorMsg, Tcl_DStringValue(&prefix), -1); - } else { - const char *sep = ""; - - for (i = 0; i < objc; i++) { - Tcl_AppendPrintfToObj(errorMsg, "%s%s", - sep, Tcl_GetString(objv[i])); - sep = " "; - } - } - Tcl_AppendToObj(errorMsg, "\"", -1); - Tcl_SetObjResult(interp, errorMsg); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH", - NULL); - result = TCL_ERROR; - } - } - endOfGlob: if (join || (dir == PATH_GENERAL)) { Tcl_DStringFree(&prefix); @@ -1705,7 +1682,7 @@ Tcl_GlobObjCmd( */ /* ARGSUSED */ -int +static int TclGlob( Tcl_Interp *interp, /* Interpreter for returning error message or * appending list of matching file names. */ diff --git a/generic/tclHistory.c b/generic/tclHistory.c index b10d423..c44ba4c 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -75,13 +75,6 @@ Tcl_RecordAndEval( result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); /* - * Move the interpreter's object result to the string result, then - * reset the object result. - */ - - (void) Tcl_GetStringResult(interp); - - /* * Discard the Tcl object created to hold the command. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index d548a16..0efb1b6 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1799,42 +1799,33 @@ typedef struct AllocCache { */ typedef struct Interp { + /* - * Note: the first three fields must match exactly the fields in a - * Tcl_Interp struct (see tcl.h). If you change one, be sure to change the - * other. - * - * The interpreter's result is held in both the string and the - * objResultPtr fields. These fields hold, respectively, the result's - * string or object value. The interpreter's result is always in the - * result field if that is non-empty, otherwise it is in objResultPtr. - * The two fields are kept consistent unless some C code sets - * interp->result directly. Programs should not access result and - * objResultPtr directly; instead, they should always get and set the - * result using procedures such as Tcl_SetObjResult, Tcl_GetObjResult, and - * Tcl_GetStringResult. See the SetResult man page for details. + * The first two fields were named "result" and "freeProc" in earlier + * versions of Tcl. They are no longer used within Tcl, and are no + * longer available to be accessed by extensions. However, they cannot + * be removed. Why? There is a deployed base of stub-enabled extensions + * that query the value of iPtr->stubTable. For them to continue to work, + * the location of the field "stubTable" within the Interp struct cannot + * change. The most robust way to assure that is to leave all fields up to + * that one undisturbed. */ - char *result; /* If the last command returned a string - * result, this points to it. Should not be - * accessed directly; see comment above. */ - Tcl_FreeProc *freeProc; /* Zero means a string result is statically - * allocated. TCL_DYNAMIC means string result - * was allocated with ckalloc and should be - * freed with ckfree. Other values give - * address of procedure to invoke to free the - * string result. Tcl_Eval must free it before - * executing next command. */ + const char *legacyResult; + void (*legacyFreeProc) (void); int errorLine; /* When TCL_ERROR is returned, this gives the * line number in the command where the error * occurred (1 means first line). */ const struct TclStubs *stubTable; - /* Pointer to the exported Tcl stub table. On - * previous versions of Tcl this is a pointer - * to the objResultPtr or a pointer to a - * buckets array in a hash table. We therefore - * have to do some careful checking before we - * can use this. */ + /* Pointer to the exported Tcl stub table. In + * ancient pre-8.1 versions of Tcl this was a + * pointer to the objResultPtr or a pointer to a + * buckets array in a hash table. Deployed stubs + * enabled extensions check for a NULL pointer value + * and for a TCL_STUBS_MAGIC value to verify they + * are not [load]ing into one of those pre-stubs + * interps. + */ TclHandle handle; /* Handle used to keep track of when this * interp is deleted. */ @@ -1847,8 +1838,6 @@ typedef struct Interp { ClientData interpInfo; /* Information used by tclInterp.c to keep * track of master/slave interps on a * per-interp basis. */ - Tcl_HashTable unused2; /* No longer used (was mathFuncTable) */ - /* * Information related to procedures and variables. See tclProc.c and * tclVar.c for usage. @@ -1878,19 +1867,6 @@ typedef struct Interp { * TCL_EVAL_INVOKE call to Tcl_EvalObjv. */ /* - * Information used by Tcl_AppendResult to keep track of partial results. - * See Tcl_AppendResult code for details. - */ - - char *appendResult; /* Storage space for results generated by - * Tcl_AppendResult. Ckalloc-ed. NULL means - * not yet allocated. */ - int appendAvl; /* Total amount of space available at - * partialResult. */ - int appendUsed; /* Number of non-null bytes currently stored - * at partialResult. */ - - /* * Information about packages. Used only in tclPkg.c. */ @@ -1912,7 +1888,6 @@ typedef struct Interp { * Normally zero, but may be set before * calling Tcl_Eval. See below for valid * values. */ - int unused1; /* No longer used (was termOffset) */ LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl * objects holding literals of scripts * compiled by the interpreter. Indexed by the @@ -1950,8 +1925,6 @@ typedef struct Interp { * string. Returned by Tcl_ObjSetVar2 when * variable traces change a variable in a * gross way. */ - char resultSpace[TCL_RESULT_SIZE+1]; - /* Static space holding small results. */ Tcl_Obj *objResultPtr; /* If the last command returned an object * result, this points to it. Should not be * accessed directly; see comment above. */ @@ -2592,16 +2565,6 @@ typedef struct TclFileAttrProcs { typedef struct TclFile_ *TclFile; -/* - * The "globParameters" argument of the function TclGlob is an or'ed - * combination of the following values: - */ - -#define TCL_GLOBMODE_NO_COMPLAIN 1 -#define TCL_GLOBMODE_JOIN 2 -#define TCL_GLOBMODE_DIR 4 -#define TCL_GLOBMODE_TAILS 8 - typedef enum Tcl_PathPart { TCL_PATH_DIRNAME, TCL_PATH_TAIL, @@ -2982,9 +2945,6 @@ MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, int *binaryPtr); MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE const char *TclGetSrcInfoForCmd(Interp *iPtr, int *lenPtr); -MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, - Tcl_Obj *unquotedPrefix, int globFlags, - Tcl_GlobTypeData *types); MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 6f5b9cf..75e513d 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -470,10 +470,15 @@ Tcl_LoadObjCmd( if (code != TCL_OK) { Interp *iPtr = (Interp *) target; - if (iPtr->result != NULL && iPtr->result[0] != '\0') { - /* We have an Tcl 8.x extension with incompatible stub table. */ - Tcl_Obj *obj = Tcl_NewStringObj(iPtr->result, -1); - Tcl_SetObjResult(interp, obj); + if (iPtr->legacyResult && !iPtr->legacyFreeProc) { + /* + * A call to Tcl_InitStubs() determined the caller extension and + * this interp are incompatible in their stubs mechanisms, and + * recorded the error in the oldest legacy place we have to do so. + */ + Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->legacyResult, -1)); + iPtr->legacyResult = NULL; + iPtr->legacyFreeProc = (void (*) (void))-1; } Tcl_TransferResult(target, code, interp); goto done; diff --git a/generic/tclParse.c b/generic/tclParse.c index 309e232..08615a7 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -42,7 +42,7 @@ * TYPE_BRACE - Character is a curly brace (either left or right). */ -const char charTypeTable[] = { +const char tclCharTypeTable[] = { /* * Negative character values, from -128 to -1: */ diff --git a/generic/tclParse.h b/generic/tclParse.h index be1ab15..20c609c 100644 --- a/generic/tclParse.h +++ b/generic/tclParse.h @@ -12,6 +12,6 @@ #define TYPE_CLOSE_BRACK 0x20 #define TYPE_BRACE 0x40 -#define CHAR_TYPE(c) (charTypeTable+128)[(int)(c)] +#define CHAR_TYPE(c) (tclCharTypeTable+128)[(int)(c)] -MODULE_SCOPE const char charTypeTable[]; +MODULE_SCOPE const char tclCharTypeTable[]; diff --git a/generic/tclResult.c b/generic/tclResult.c index 9707f20..618b7d8 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -27,7 +27,6 @@ enum returnKeys { static Tcl_Obj ** GetKeys(void); static void ReleaseKeys(ClientData clientData); static void ResetObjResult(Interp *iPtr); -static void SetupAppendBuffer(Interp *iPtr, int newSpace); /* * This structure is used to take a snapshot of the interpreter state in @@ -246,44 +245,6 @@ Tcl_SaveResult( statePtr->objResultPtr = iPtr->objResultPtr; iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); - - /* - * Save the string result. - */ - - statePtr->freeProc = iPtr->freeProc; - if (iPtr->result == iPtr->resultSpace) { - /* - * Copy the static string data out of the interp buffer. - */ - - statePtr->result = statePtr->resultSpace; - strcpy(statePtr->result, iPtr->result); - statePtr->appendResult = NULL; - } else if (iPtr->result == iPtr->appendResult) { - /* - * Move the append buffer out of the interp. - */ - - statePtr->appendResult = iPtr->appendResult; - statePtr->appendAvl = iPtr->appendAvl; - statePtr->appendUsed = iPtr->appendUsed; - statePtr->result = statePtr->appendResult; - iPtr->appendResult = NULL; - iPtr->appendAvl = 0; - iPtr->appendUsed = 0; - } else { - /* - * Move the dynamic or static string out of the interpreter. - */ - - statePtr->result = iPtr->result; - statePtr->appendResult = NULL; - } - - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; - iPtr->freeProc = 0; } /* @@ -314,39 +275,6 @@ Tcl_RestoreResult( Tcl_ResetResult(interp); /* - * Restore the string result. - */ - - iPtr->freeProc = statePtr->freeProc; - if (statePtr->result == statePtr->resultSpace) { - /* - * Copy the static string data into the interp buffer. - */ - - iPtr->result = iPtr->resultSpace; - strcpy(iPtr->result, statePtr->result); - } else if (statePtr->result == statePtr->appendResult) { - /* - * Move the append buffer back into the interp. - */ - - if (iPtr->appendResult != NULL) { - ckfree(iPtr->appendResult); - } - - iPtr->appendResult = statePtr->appendResult; - iPtr->appendAvl = statePtr->appendAvl; - iPtr->appendUsed = statePtr->appendUsed; - iPtr->result = iPtr->appendResult; - } else { - /* - * Move the dynamic or static string back into the interpreter. - */ - - iPtr->result = statePtr->result; - } - - /* * Restore the object result. */ @@ -377,14 +305,6 @@ Tcl_DiscardResult( Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ { TclDecrRefCount(statePtr->objResultPtr); - - if (statePtr->result == statePtr->appendResult) { - ckfree(statePtr->appendResult); - } else if (statePtr->freeProc == TCL_DYNAMIC) { - ckfree(statePtr->result); - } else if (statePtr->freeProc) { - statePtr->freeProc(statePtr->result); - } } /* @@ -414,49 +334,15 @@ Tcl_SetResult( * TCL_STATIC, TCL_VOLATILE, or the address of * a Tcl_FreeProc such as free. */ { - Interp *iPtr = (Interp *) interp; - register Tcl_FreeProc *oldFreeProc = iPtr->freeProc; - char *oldResult = iPtr->result; - - if (result == NULL) { - iPtr->resultSpace[0] = 0; - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = 0; - } else if (freeProc == TCL_VOLATILE) { - int length = strlen(result); - - if (length > TCL_RESULT_SIZE) { - iPtr->result = ckalloc(length + 1); - iPtr->freeProc = TCL_DYNAMIC; - } else { - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = 0; - } - memcpy(iPtr->result, result, (unsigned) length+1); - } else { - iPtr->result = (char *) result; - iPtr->freeProc = freeProc; + Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); + if (result == NULL || freeProc == NULL || freeProc == TCL_VOLATILE) { + return; } - - /* - * If the old result was dynamically-allocated, free it up. Do it here, - * rather than at the beginning, in case the new result value was part of - * the old result value. - */ - - if (oldFreeProc != 0) { - if (oldFreeProc == TCL_DYNAMIC) { - ckfree(oldResult); - } else { - oldFreeProc(oldResult); - } + if (freeProc == TCL_DYNAMIC) { + ckfree(result); + } else { + (*freeProc)(result); } - - /* - * Reset the object result since we just set the string result. - */ - - ResetObjResult(iPtr); } /* @@ -480,18 +366,9 @@ const char * Tcl_GetStringResult( register Tcl_Interp *interp)/* Interpreter whose result to return. */ { - /* - * If the string result is empty, move the object result to the string - * result, then reset the object result. - */ - Interp *iPtr = (Interp *) interp; - if (*(iPtr->result) == 0) { - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - TCL_VOLATILE); - } - return iPtr->result; + return Tcl_GetString(iPtr->objResultPtr); } /* @@ -532,21 +409,6 @@ Tcl_SetObjResult( */ TclDecrRefCount(oldObjResult); - - /* - * Reset the string result since we just set the result object. - */ - - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - ckfree(iPtr->result); - } else { - iPtr->freeProc(iPtr->result); - } - iPtr->freeProc = 0; - } - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; } /* @@ -575,32 +437,7 @@ Tcl_GetObjResult( Tcl_Interp *interp) /* Interpreter whose result to return. */ { register Interp *iPtr = (Interp *) interp; - Tcl_Obj *objResultPtr; - int length; - - /* - * If the string result is non-empty, move the string result to the object - * result, then reset the string result. - */ - if (iPtr->result[0] != 0) { - ResetObjResult(iPtr); - - objResultPtr = iPtr->objResultPtr; - length = strlen(iPtr->result); - TclInitStringRep(objResultPtr, iPtr->result, length); - - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - ckfree(iPtr->result); - } else { - iPtr->freeProc(iPtr->result); - } - iPtr->freeProc = 0; - } - iPtr->result = iPtr->resultSpace; - iPtr->result[0] = 0; - } return iPtr->objResultPtr; } @@ -637,23 +474,6 @@ Tcl_AppendResultVA( } Tcl_AppendStringsToObjVA(objPtr, argList); Tcl_SetObjResult(interp, objPtr); - - /* - * Strictly we should call Tcl_GetStringResult(interp) here to make sure - * that interp->result is correct according to the old contract, but that - * makes the performance of much code (e.g. in Tk) absolutely awful. So we - * leave it out; code that really wants interp->result can just insert the - * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion] - */ - -#ifdef USE_INTERP_RESULT - /* - * Ensure that the interp->result is legal so old Tcl 7.* code still - * works. There's still embarrasingly much of it about... - */ - - (void) Tcl_GetStringResult(interp); -#endif /* USE_INTERP_RESULT */ } /* @@ -719,129 +539,20 @@ Tcl_AppendElement( * to result. */ { Interp *iPtr = (Interp *) interp; - char *dst; - int size; - int flags; - - /* - * If the string result is empty, move the object result to the string - * result, then reset the object result. - */ - - (void) Tcl_GetStringResult(interp); - - /* - * See how much space is needed, and grow the append buffer if needed to - * accommodate the list element. - */ - - size = Tcl_ScanElement(element, &flags) + 1; - if ((iPtr->result != iPtr->appendResult) - || (iPtr->appendResult[iPtr->appendUsed] != 0) - || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { - SetupAppendBuffer(iPtr, size+iPtr->appendUsed); - } - - /* - * Convert the string into a list element and copy it to the buffer that's - * forming, with a space separator if needed. - */ - - dst = iPtr->appendResult + iPtr->appendUsed; - if (TclNeedSpace(iPtr->appendResult, dst)) { - iPtr->appendUsed++; - *dst = ' '; - dst++; - - /* - * If we need a space to separate this element from preceding stuff, - * then this element will not lead a list, and need not have it's - * leading '#' quoted. - */ - - flags |= TCL_DONT_QUOTE_HASH; - } - iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags); -} - -/* - *---------------------------------------------------------------------- - * - * SetupAppendBuffer -- - * - * This function makes sure that there is an append buffer properly - * initialized, if necessary, from the interpreter's result, and that it - * has at least enough room to accommodate newSpace new bytes of - * information. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -SetupAppendBuffer( - Interp *iPtr, /* Interpreter whose result is being set up. */ - int newSpace) /* Make sure that at least this many bytes of - * new information may be added. */ -{ - int totalSpace; - - /* - * Make the append buffer larger, if that's necessary, then copy the - * result into the append buffer and make the append buffer the official - * Tcl result. - */ - - if (iPtr->result != iPtr->appendResult) { - /* - * If an oversized buffer was used recently, then free it up so we go - * back to a smaller buffer. This avoids tying up memory forever after - * a large operation. - */ - - if (iPtr->appendAvl > 500) { - ckfree(iPtr->appendResult); - iPtr->appendResult = NULL; - iPtr->appendAvl = 0; - } - iPtr->appendUsed = strlen(iPtr->result); - } else if (iPtr->result[iPtr->appendUsed] != 0) { - /* - * Most likely someone has modified a result created by - * Tcl_AppendResult et al. so that it has a different size. Just - * recompute the size. - */ - - iPtr->appendUsed = strlen(iPtr->result); - } - - totalSpace = newSpace + iPtr->appendUsed; - if (totalSpace >= iPtr->appendAvl) { - char *new; - - if (totalSpace < 100) { - totalSpace = 200; - } else { - totalSpace *= 2; - } - new = ckalloc(totalSpace); - strcpy(new, iPtr->result); - if (iPtr->appendResult != NULL) { - ckfree(iPtr->appendResult); - } - iPtr->appendResult = new; - iPtr->appendAvl = totalSpace; - } else if (iPtr->result != iPtr->appendResult) { - strcpy(iPtr->appendResult, iPtr->result); + Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1); + Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr); + int length; + const char *bytes; + + if (Tcl_IsShared(iPtr->objResultPtr)) { + Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr)); + } + bytes = Tcl_GetStringFromObj(iPtr->objResultPtr, &length); + if (TclNeedSpace(bytes, bytes+length)) { + Tcl_AppendToObj(iPtr->objResultPtr, " ", 1); } - - Tcl_FreeResult((Tcl_Interp *) iPtr); - iPtr->result = iPtr->appendResult; + Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr); + Tcl_DecrRefCount(listPtr); } /* @@ -850,18 +561,17 @@ SetupAppendBuffer( * Tcl_FreeResult -- * * This function frees up the memory associated with an interpreter's - * string result. It also resets the interpreter's result object. - * Tcl_FreeResult is most commonly used when a function is about to - * replace one result value with another. + * result, resetting the interpreter's result object. Tcl_FreeResult is + * most commonly used when a function is about to replace one result + * value with another. * * Results: * None. * * Side effects: - * Frees the memory associated with interp's string result and sets - * interp->freeProc to zero, but does not change interp->result or clear - * error state. Resets interp's result object to an unshared empty - * object. + * Frees the memory associated with interp's result but does not change + * any part of the error dictionary (i.e., the errorinfo and errorcode + * remain the same). * *---------------------------------------------------------------------- */ @@ -872,15 +582,6 @@ Tcl_FreeResult( { register Interp *iPtr = (Interp *) interp; - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - ckfree(iPtr->result); - } else { - iPtr->freeProc(iPtr->result); - } - iPtr->freeProc = 0; - } - ResetObjResult(iPtr); } @@ -910,16 +611,6 @@ Tcl_ResetResult( register Interp *iPtr = (Interp *) interp; ResetObjResult(iPtr); - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - ckfree(iPtr->result); - } else { - iPtr->freeProc(iPtr->result); - } - iPtr->freeProc = 0; - } - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; if (iPtr->errorCode) { /* Legacy support */ if (iPtr->flags & ERR_LEGACY_COPY) { diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 7106d3d..6718ef8 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -983,8 +983,8 @@ const TclStubs tclStubs = { Tcl_WriteChars, /* 338 */ Tcl_WriteObj, /* 339 */ Tcl_GetString, /* 340 */ - Tcl_GetDefaultEncodingDir, /* 341 */ - Tcl_SetDefaultEncodingDir, /* 342 */ + 0, /* 341 */ + 0, /* 342 */ Tcl_AlertNotifier, /* 343 */ Tcl_ServiceModeHook, /* 344 */ Tcl_UniCharIsAlnum, /* 345 */ diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index bd80ec1..9a2e063 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -35,28 +35,21 @@ const TclIntPlatStubs *tclIntPlatStubsPtr = NULL; static const TclStubs * HasStubSupport( Tcl_Interp *interp, + const char *tclversion, int magic) { + /* TODO: Whatever additional checks using tclversion + * and/or magic should be done here. */ + Interp *iPtr = (Interp *) interp; - if (!iPtr->stubTable) { - /* No stub table at all? Nothing we can do. */ - return NULL; - } - if (iPtr->stubTable->magic != magic) { - /* - * The iPtr->stubTable entry from Tcl_Interp and the - * Tcl_NewStringObj() and Tcl_SetObjResult() entries - * in the stub table cannot change in Tcl 9 compared - * to Tcl 8.x. Otherwise the lines below won't work. - * TODO: add a test case for that. - */ - iPtr->stubTable->tcl_SetObjResult(interp, - iPtr->stubTable->tcl_NewStringObj( - "This extension is compiled for Tcl 9.x", -1)); - return NULL; + if (iPtr->stubTable && iPtr->stubTable->magic == magic) { + return iPtr->stubTable; } - return iPtr->stubTable; + iPtr->legacyResult + = "interpreter uses an incompatible stubs mechanism"; + iPtr->legacyFreeProc = 0; /* TCL_STATIC */ + return NULL; } /* @@ -91,6 +84,7 @@ TclInitStubs( Tcl_Interp *interp, const char *version, int exact, + const char *tclversion, int magic) { const char *actualVersion = NULL; @@ -102,7 +96,7 @@ TclInitStubs( * times. [Bug 615304] */ - tclStubsPtr = HasStubSupport(interp, magic); + tclStubsPtr = HasStubSupport(interp, tclversion, magic); if (!tclStubsPtr) { return NULL; } diff --git a/generic/tclStubLibCompat.c b/generic/tclStubLibCompat.c deleted file mode 100644 index 7d8c5c3..0000000 --- a/generic/tclStubLibCompat.c +++ /dev/null @@ -1,57 +0,0 @@ -/* - * tclStubLibCompat.c -- - * - * Stub object that will be statically linked into extensions that want - * to access Tcl. - * - * Copyright (c) 2012 Jan Nijtmans - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -/* - * Small wrapper, which allows Tcl8 extensions to use the same stub - * library as Tcl 9. - */ - -#include "tclInt.h" - - -/* - *---------------------------------------------------------------------- - * - * Tcl_InitStubs -- - * - * Tries to initialise the stub table pointers and ensures that the - * correct version of Tcl is loaded. - * - * Results: - * The actual version of Tcl that satisfies the request, or NULL to - * indicate that an error occurred. - * - * Side effects: - * Sets the stub table pointers. - * - *---------------------------------------------------------------------- - */ -#undef Tcl_InitStubs - -MODULE_SCOPE const char * -Tcl_InitStubs( - Tcl_Interp *interp, - const char *version, - int exact) -{ - /* Use the hardcoded Tcl8 magic value here. */ - return TclInitStubs(interp, version, exact, (int) 0xFCA3BACF); -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ - diff --git a/generic/tclTest.c b/generic/tclTest.c index 07be9e9..9b958dd 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -108,13 +108,6 @@ typedef struct TclEncoding { } TclEncoding; /* - * The counter below is used to determine if the TestsaveresultFree routine - * was called for a result. - */ - -static int freeCount; - -/* * Boolean flag used by the "testsetmainloop" and "testexitmainloop" commands. */ @@ -4869,7 +4862,6 @@ TestsaveresultCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - Interp* iPtr = (Interp*) interp; int discard, result, index; Tcl_SavedResult state; Tcl_Obj *objPtr; @@ -4920,7 +4912,6 @@ TestsaveresultCmd( break; } - freeCount = 0; Tcl_SaveResult(interp, &state); if (((enum options) index) == RESULT_OBJECT) { @@ -4937,14 +4928,10 @@ TestsaveresultCmd( } switch ((enum options) index) { - case RESULT_DYNAMIC: { - int present = iPtr->freeProc == TestsaveresultFree; - int called = freeCount; - - Tcl_AppendElement(interp, called ? "called" : "notCalled"); - Tcl_AppendElement(interp, present ? "present" : "missing"); + case RESULT_DYNAMIC: + Tcl_AppendElement(interp, discard ? "called" : "notCalled"); + Tcl_AppendElement(interp, !discard ? "present" : "missing"); break; - } case RESULT_OBJECT: Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr ? "same" : "different"); @@ -4975,7 +4962,7 @@ static void TestsaveresultFree( char *blockPtr) { - freeCount++; + /* empty... */ } /* diff --git a/generic/tclUtil.c b/generic/tclUtil.c index cad6e4a..4b69628 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2762,7 +2762,6 @@ Tcl_DStringResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the * result of interp. */ { - Tcl_ResetResult(interp); Tcl_SetObjResult(interp, TclDStringToObj(dsPtr)); } @@ -2792,77 +2791,12 @@ Tcl_DStringGetResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the result * of interp. */ { - Interp *iPtr = (Interp *) interp; - - if (dsPtr->string != dsPtr->staticSpace) { - ckfree(dsPtr->string); - } - - /* - * Do more efficient transfer when we know the result is a Tcl_Obj. When - * there's no st`ring result, we only have to deal with two cases: - * - * 1. When the string rep is the empty string, when we don't copy but - * instead use the staticSpace in the DString to hold an empty string. - - * 2. When the string rep is not there or there's a real string rep, when - * we use Tcl_GetString to fetch (or generate) the string rep - which - * we know to have been allocated with ckalloc() - and use it to - * populate the DString space. Then, we free the internal rep. and set - * the object's string representation back to the canonical empty - * string. - */ - - if (!iPtr->result[0] && iPtr->objResultPtr - && !Tcl_IsShared(iPtr->objResultPtr)) { - if (iPtr->objResultPtr->bytes == tclEmptyStringRep) { - dsPtr->string = dsPtr->staticSpace; - dsPtr->string[0] = 0; - dsPtr->length = 0; - dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - } else { - dsPtr->string = Tcl_GetString(iPtr->objResultPtr); - dsPtr->length = iPtr->objResultPtr->length; - dsPtr->spaceAvl = dsPtr->length + 1; - TclFreeIntRep(iPtr->objResultPtr); - iPtr->objResultPtr->bytes = tclEmptyStringRep; - iPtr->objResultPtr->length = 0; - } - return; - } - - /* - * If the string result is empty, move the object result to the string - * result, then reset the object result. - */ - - (void) Tcl_GetStringResult(interp); - - dsPtr->length = strlen(iPtr->result); - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - dsPtr->string = iPtr->result; - dsPtr->spaceAvl = dsPtr->length+1; - } else { - dsPtr->string = ckalloc(dsPtr->length+1); - memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); - iPtr->freeProc(iPtr->result); - } - dsPtr->spaceAvl = dsPtr->length+1; - iPtr->freeProc = NULL; - } else { - if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { - dsPtr->string = dsPtr->staticSpace; - dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - } else { - dsPtr->string = ckalloc(dsPtr->length+1); - dsPtr->spaceAvl = dsPtr->length + 1; - } - memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); - } + int length; + char *bytes = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; + Tcl_DStringFree(dsPtr); + Tcl_DStringAppend(dsPtr, bytes, length); + Tcl_ResetResult(interp); } /* diff --git a/library/package.tcl b/library/package.tcl index c30431c..5b99a69 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -137,6 +137,9 @@ proc pkg_mkIndex {args} { } on error {msg opt} { return -options $opt $msg } + if {[llength $fileList] == 0} { + return -code error "no files matched glob pattern \"$patternList\"" + } foreach file $fileList { # For each file, figure out what commands and packages it provides. # To do this, create a child interpreter, load the file into the diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index 3769155..fabddb0 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5-]} {return} -package ifneeded tcltest 2.3.4 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.3.5 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 12692bb..07d0a51 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.3.4 + variable Version 2.3.5 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -601,7 +601,9 @@ namespace eval tcltest { } } proc configure args { - RemoveAutoConfigureTraces + if {[llength $args] > 1} { + RemoveAutoConfigureTraces + } set code [catch {Configure {*}$args} msg] return -code $code $msg } diff --git a/pkgs/package.list.txt b/pkgs/package.list.txt index 5020506..f12111d 100644 --- a/pkgs/package.list.txt +++ b/pkgs/package.list.txt @@ -19,3 +19,8 @@ thread Thread tdbc TDBC Tdbc TDBC TDBC TDBC +# Drivers for TDBC +tdbcmysql tdbc::mysql +tdbcodbc tdbc::odbc +tdbcpostgres tdbc::postgres +tdbcsqlite3- tdbc::sqlite3 diff --git a/tests/fCmd.test b/tests/fCmd.test index 325b374..9fae2c5 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -745,12 +745,12 @@ test fCmd-7.4 {FileForceOption: bad option} -constraints {notRoot} -setup { } -result {bad option "-tf1": must be -force or --} test fCmd-7.5 {FileForceOption: multiple times through loop} -setup { cleanup -} -constraints {notRoot} -returnCodes error -body { +} -constraints {notRoot} -body { createfile -- createfile -force file delete -force -force -- -- -force glob -- -- -force -} -result {no files matched glob patterns "-- -force"} +} -result {} test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \ -constraints {unix notRoot knownBug} -body { @@ -938,9 +938,9 @@ test fCmd-9.10 {file rename: comprehensive: file to new name and dir} -setup { testchmod 444 tf2 file rename tf1 [file join td1 tf3] file rename tf2 [file join td1 tf4] - list [catch {glob tf*}] [lsort [glob -directory td1 t*]] \ + list [glob tf*] [lsort [glob -directory td1 t*]] \ [file writable [file join td1 tf3]] [file writable [file join td1 tf4]] -} -result [subst {1 {[file join td1 tf3] [file join td1 tf4]} 1 0}] +} -result [subst {{} {[file join td1 tf3] [file join td1 tf4]} 1 0}] test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} -setup { cleanup } -constraints {notRoot testchmod} -body { diff --git a/tests/fileName.test b/tests/fileName.test index 51f00d1..2dac0df 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -696,9 +696,9 @@ test filename-10.24 {Tcl_TranslateFileName} -body { testtranslatefilename ~ouster/foo } -result {/home/ouster/foo} -constraints {nonPortable testtranslatefilename} -test filename-11.1 {Tcl_GlobCmd} -returnCodes error -body { +test filename-11.1 {Tcl_GlobCmd} -body { glob -} -result {no files matched glob patterns ""} +} -result {} test filename-11.2 {Tcl_GlobCmd} -returnCodes error -body { glob -gorp } -result {bad option "-gorp": must be -directory, -join, -nocomplain, -path, -tails, -types, or --} @@ -714,9 +714,9 @@ test filename-11.5 {Tcl_GlobCmd} -returnCodes error -body { test filename-11.6 {Tcl_GlobCmd} -returnCodes error -body { glob ~xyqrszzz } -result {user "xyqrszzz" doesn't exist} -test filename-11.7 {Tcl_GlobCmd} -returnCodes error -body { +test filename-11.7 {Tcl_GlobCmd} -body { glob -- -nocomplain -} -result {no files matched glob pattern "-nocomplain"} +} -result {} test filename-11.8 {Tcl_GlobCmd} -body { glob -nocomplain -- -nocomplain } -result {} @@ -1085,7 +1085,7 @@ test filename-12.1 {simple globbing} {unixOrPc} { } {.} test filename-12.1.1 {simple globbing} -constraints {unixOrPc} -body { glob -types f {} -} -returnCodes error -result {no files matched glob pattern ""} +} -result {} test filename-12.1.2 {simple globbing} {unixOrPc} { glob -types d {} } {.} @@ -1247,10 +1247,10 @@ test filename-14.20 {asterisks, question marks, and brackets} { } {} test filename-14.21 {asterisks, question marks, and brackets} -body { glob globTest/*/gorp -} -returnCodes error -result {no files matched glob pattern "globTest/*/gorp"} +} -result {} test filename-14.22 {asterisks, question marks, and brackets} -body { glob goo/* x*z foo?q -} -returnCodes error -result {no files matched glob patterns "goo/* x*z foo?q"} +} -result {} test filename-14.23 {slash globbing} {unix} { glob / } / diff --git a/unix/Makefile.in b/unix/Makefile.in index 9a7d6db..df05759 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -335,11 +335,7 @@ TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \ bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \ bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o -STUB_LIB_OBJS = tclStubLib.o \ - tclStubLibCompat.o \ - tclTomMathStubLib.o \ - tclOOStubLib.o \ - ${COMPAT_OBJS} +STUB_LIB_OBJS = tclStubLib.o tclTomMathStubLib.o tclOOStubLib.o ${COMPAT_OBJS} UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \ tclUnixFile.o tclUnixPipe.o tclUnixSock.o \ @@ -472,7 +468,6 @@ OO_SRCS = \ STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c \ - $(GENERIC_DIR)/tclStubLibCompat.c \ $(GENERIC_DIR)/tclTomMathStubLib.c \ $(GENERIC_DIR)/tclOOStubLib.c @@ -853,8 +848,8 @@ install-libraries: libraries done; @echo "Installing package msgcat 1.5.0 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.0.tm; - @echo "Installing package tcltest 2.3.4 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.4.tm; + @echo "Installing package tcltest 2.3.5 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.5.tm; @echo "Installing package platform 1.0.10 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.10.tm; @@ -1661,9 +1656,6 @@ Zzutil.o: $(ZLIB_DIR)/zutil.c tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLib.c -tclStubLibCompat.o: $(GENERIC_DIR)/tclStubLibCompat.c - $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLibCompat.c - tclTomMathStubLib.o: $(GENERIC_DIR)/tclTomMathStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclTomMathStubLib.c diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index 46fc972..c0c05f0 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -67,10 +67,10 @@ static Tcl_CmdProc TestchmodCmd; static Tcl_CmdProc TestfilehandlerCmd; static Tcl_CmdProc TestfilewaitCmd; static Tcl_CmdProc TestfindexecutableCmd; -static Tcl_CmdProc TestgetdefencdirCmd; +static Tcl_ObjCmdProc TestgetdefencdirCmd; static Tcl_CmdProc TestgetopenfileCmd; static Tcl_CmdProc TestgotsigCmd; -static Tcl_CmdProc TestsetdefencdirCmd; +static Tcl_ObjCmdProc TestsetdefencdirCmd; static Tcl_FileProc TestFileHandlerProc; static void AlarmHandler(int signum); @@ -105,9 +105,9 @@ TclplatformtestInit( NULL, NULL); Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd, NULL, NULL); - Tcl_CreateCommand(interp, "testgetdefenc", TestgetdefencdirCmd, + Tcl_CreateObjCommand(interp, "testgetdefenc", TestgetdefencdirCmd, NULL, NULL); - Tcl_CreateCommand(interp, "testsetdefenc", TestsetdefencdirCmd, + Tcl_CreateObjCommand(interp, "testsetdefenc", TestsetdefencdirCmd, NULL, NULL); Tcl_CreateCommand(interp, "testalarm", TestalarmCmd, NULL, NULL); @@ -514,16 +514,22 @@ static int TestsetdefencdirCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv) /* Argument strings. */ { - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " defaultDir\"", NULL); + Tcl_Obj *searchPath; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "defaultDir"); return TCL_ERROR; } - Tcl_SetDefaultEncodingDir(argv[1]); + searchPath = Tcl_GetEncodingSearchPath(); + + searchPath = Tcl_DuplicateObj(searchPath); + Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &objv[1]); + Tcl_SetEncodingSearchPath(searchPath); + return TCL_OK; } @@ -548,15 +554,25 @@ static int TestgetdefencdirCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv) /* Argument strings. */ { - if (argc != 1) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], NULL); - return TCL_ERROR; + int numDirs; + Tcl_Obj *first, *searchPath; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + searchPath = Tcl_GetEncodingSearchPath(); + Tcl_ListObjLength(interp, searchPath, &numDirs); + if (numDirs == 0) { + return TCL_ERROR; } + Tcl_ListObjIndex(NULL, searchPath, 0, &first); - Tcl_AppendResult(interp, Tcl_GetDefaultEncodingDir(), NULL); + Tcl_SetObjResult(interp, first); return TCL_OK; } diff --git a/win/Makefile.in b/win/Makefile.in index 6b9685d..8cfb68c 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -378,7 +378,6 @@ REG_OBJS = tclWinReg.$(OBJEXT) STUB_OBJS = \ tclStubLib.$(OBJEXT) \ - tclStubLibCompat.$(OBJEXT) \ tclTomMathStubLib.$(OBJEXT) \ tclOOStubLib.$(OBJEXT) @@ -506,9 +505,6 @@ tclPkgConfig.${OBJEXT}: tclPkgConfig.c # The following objects are part of the stub library and should not be built # as DLL objects but none of the symbols should be exported -tclStubLibCompat.${OBJEXT}: tclStubLibCompat.c - $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) - tclStubLib.${OBJEXT}: tclStubLib.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) @@ -647,8 +643,8 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing package msgcat 1.5.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.0.tm; - @echo "Installing package tcltest 2.3.4 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.4.tm; + @echo "Installing package tcltest 2.3.5 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.5.tm; @echo "Installing package platform 1.0.10 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.10.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; diff --git a/win/makefile.vc b/win/makefile.vc index 823142f..2784140 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -448,7 +448,6 @@ TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ $(TMP_DIR)\tclStubLib.obj \ - $(TMP_DIR)\tclStubLibCompat.obj \ $(TMP_DIR)\tclTomMathStubLib.obj \ $(TMP_DIR)\tclOOStubLib.obj @@ -2,7 +2,7 @@ // #include <winver.h> -#include <tcl.h> +#include "tclWinInt.h" // // build-up the name suffix that defines the type of build this is. diff --git a/win/tclWinInt.h b/win/tclWinInt.h index 22ad8e9..b3753f4 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -15,6 +15,20 @@ #include "tclInt.h" /* + * Utility macros: STRINGIFY takes an argument and wraps it in "" (double + * quotation marks), JOIN joins two arguments. + */ + +#ifndef STRINGIFY +# define STRINGIFY(x) STRINGIFY1(x) +# define STRINGIFY1(x) #x +#endif +#ifndef JOIN +# define JOIN(a,b) JOIN1(a,b) +# define JOIN1(a,b) a##b +#endif + +/* * Some versions of Borland C have a define for the OSVERSIONINFO for * Win32s and for NT, but not for Windows 95. * Define VER_PLATFORM_WIN32_CE for those without newer headers. diff --git a/win/tclsh.rc b/win/tclsh.rc index 16eaf83..6e1114d 100644 --- a/win/tclsh.rc +++ b/win/tclsh.rc @@ -2,7 +2,7 @@ // #include <winver.h> -#include <tcl.h> +#include "tclWinInt.h" // // build-up the name suffix that defines the type of build this is. |