diff options
| -rw-r--r-- | doc/CrtAlias.3 | 15 | ||||
| -rw-r--r-- | generic/tcl.decls | 10 | ||||
| -rw-r--r-- | generic/tclDecls.h | 33 | ||||
| -rw-r--r-- | generic/tclInterp.c | 62 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 4 | ||||
| -rw-r--r-- | generic/tclOOScript.h | 30 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 20 | ||||
| -rw-r--r-- | tests/ooProp.test | 2 | ||||
| -rw-r--r-- | tools/tclOOScript.tcl | 30 |
9 files changed, 45 insertions, 161 deletions
diff --git a/doc/CrtAlias.3 b/doc/CrtAlias.3 index 879e07c..ca84694 100644 --- a/doc/CrtAlias.3 +++ b/doc/CrtAlias.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_IsSafe, Tcl_CreateChild, Tcl_GetChild, Tcl_GetParent, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands +Tcl_IsSafe, Tcl_CreateChild, Tcl_GetChild, Tcl_GetParent, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -37,10 +37,6 @@ int objc, objv\fR) .sp int -\fBTcl_GetAlias\fR(\fIinterp, childCmd, targetInterpPtr, targetCmdPtr, - argcPtr, argvPtr\fR) -.sp -int \fBTcl_GetAliasObj\fR(\fIinterp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objvPtr\fR) .sp @@ -176,17 +172,14 @@ restrictions on how they are related. that it takes a vector of values to pass as additional arguments instead of a vector of strings. .PP -\fBTcl_GetAlias\fR returns information about an alias \fIaliasName\fR +\fBTcl_GetAliasObj\fR returns information in the form of a pointer to a vector +of Tcl_Obj structures about an alias \fIaliasName\fR in \fIinterp\fR. Any of the result fields can be \fBNULL\fR, in which case the corresponding datum is not returned. If a result field is non\-\fBNULL\fR, the address indicated is set to the corresponding datum. -For example, if \fItargetNamePtr\fR is non\-\fBNULL\fR it is set to a +For example, if \fItargetCmdPtr\fR is non\-\fBNULL\fR it is set to a pointer to the string containing the name of the target command. .PP -\fBTcl_GetAliasObj\fR is similar to \fBTcl_GetAlias\fR except that it -returns a pointer to a vector of Tcl_Obj structures instead of a vector of -strings. -.PP \fBTcl_ExposeCommand\fR moves the command named \fIhiddenCmdName\fR from the set of hidden commands to the set of exposed commands, putting it under the name diff --git a/generic/tcl.decls b/generic/tcl.decls index bdc581c..2bc1934 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -463,11 +463,6 @@ declare 142 { declare 143 { void Tcl_Finalize(void) } -declare 144 { - int Tcl_GetAlias(Tcl_Interp *interp, const char *childCmd, - Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, - Tcl_Size *argcPtr, const char ***argvPtr) -} declare 145 { Tcl_HashEntry *Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr) @@ -480,11 +475,6 @@ declare 147 { Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr) } -declare 148 { - int TclGetAlias(Tcl_Interp *interp, const char *childCmd, - Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, - int *argcPtr, const char ***argvPtr) -} declare 149 { int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 307699b..49ac320 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -420,12 +420,7 @@ EXTERN int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, EXTERN int Tcl_ExprString(Tcl_Interp *interp, const char *expr); /* 143 */ EXTERN void Tcl_Finalize(void); -/* 144 */ -EXTERN int Tcl_GetAlias(Tcl_Interp *interp, - const char *childCmd, - Tcl_Interp **targetInterpPtr, - const char **targetCmdPtr, Tcl_Size *argcPtr, - const char ***argvPtr); +/* Slot 144 is reserved */ /* 145 */ EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); @@ -437,11 +432,7 @@ EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); -/* 148 */ -EXTERN int TclGetAlias(Tcl_Interp *interp, const char *childCmd, - Tcl_Interp **targetInterpPtr, - const char **targetCmdPtr, int *argcPtr, - const char ***argvPtr); +/* Slot 148 is reserved */ /* 149 */ EXTERN int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd, @@ -2032,11 +2023,11 @@ typedef struct TclStubs { int (*tcl_ExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 141 */ int (*tcl_ExprString) (Tcl_Interp *interp, const char *expr); /* 142 */ void (*tcl_Finalize) (void); /* 143 */ - int (*tcl_GetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, Tcl_Size *argcPtr, const char ***argvPtr); /* 144 */ + void (*reserved144)(void); Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */ int (*tcl_Flush) (Tcl_Channel chan); /* 146 */ int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); /* 147 */ - int (*tclGetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */ + void (*reserved148)(void); int (*tclGetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 149 */ void * (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */ @@ -2863,16 +2854,14 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ExprString) /* 142 */ #define Tcl_Finalize \ (tclStubsPtr->tcl_Finalize) /* 143 */ -#define Tcl_GetAlias \ - (tclStubsPtr->tcl_GetAlias) /* 144 */ +/* Slot 144 is reserved */ #define Tcl_FirstHashEntry \ (tclStubsPtr->tcl_FirstHashEntry) /* 145 */ #define Tcl_Flush \ (tclStubsPtr->tcl_Flush) /* 146 */ #define Tcl_GetAliasObj \ (tclStubsPtr->tcl_GetAliasObj) /* 147 */ -#define TclGetAlias \ - (tclStubsPtr->tclGetAlias) /* 148 */ +/* Slot 148 is reserved */ #define TclGetAliasObj \ (tclStubsPtr->tclGetAliasObj) /* 149 */ #define Tcl_GetAssocData \ @@ -4229,9 +4218,6 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_ParseArgsObjv # define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) \ tclStubsPtr->tclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) -# undef Tcl_GetAlias -# define Tcl_GetAlias(interp, childCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr) \ - tclStubsPtr->tclGetAlias((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (argcPtr), (argvPtr)) # undef Tcl_GetAliasObj # define Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) \ tclStubsPtr->tclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv)) @@ -4247,7 +4233,6 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_SplitPath # undef Tcl_FSSplitPath # undef Tcl_ParseArgsObjv -# undef Tcl_GetAlias # undef Tcl_GetAliasObj # if !defined(USE_TCL_STUBS) # define Tcl_GetByteArrayFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ @@ -4283,9 +4268,6 @@ extern const TclStubs *tclStubsPtr; # define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ TclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) : \ (Tcl_ParseArgsObjv)((interp), (argTable), (Tcl_Size *)(void *)(objcPtr), (objv), (remObjv))) -# define Tcl_GetAlias(interp, childCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \ - TclGetAlias((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (argcPtr), (argvPtr)) : \ - (Tcl_GetAlias)((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (Tcl_Size *)(void *)(argcPtr), (argvPtr))) # define Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ TclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv)) : \ (Tcl_GetAliasObj)((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (Tcl_Size *)(void *)(objcPtr), (objv))) @@ -4323,9 +4305,6 @@ extern const TclStubs *tclStubsPtr; # define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ tclStubsPtr->tclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) : \ tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (Tcl_Size *)(void *)(objcPtr), (objv), (remObjv))) -# define Tcl_GetAlias(interp, childCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \ - tclStubsPtr->tclGetAlias((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (argcPtr), (argvPtr)) : \ - tclStubsPtr->tcl_GetAlias((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (Tcl_Size *)(void *)(argcPtr), (argvPtr))) # define Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv)) : \ tclStubsPtr->tcl_GetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (Tcl_Size *)(void *)(objcPtr), (objv))) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 5d949cf..410a6bd 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -1276,68 +1276,6 @@ Tcl_CreateAliasObj( /* *---------------------------------------------------------------------- * - * Tcl_GetAlias -- - * - * Gets information about an alias. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetAlias( - Tcl_Interp *interp, /* Interp to start search from. */ - const char *aliasName, /* Name of alias to find. */ - Tcl_Interp **targetInterpPtr, - /* (Return) target interpreter. */ - const char **targetNamePtr, /* (Return) name of target command. */ - Tcl_Size *argcPtr, /* (Return) count of addnl args. */ - const char ***argvPtr) /* (Return) additional arguments. */ -{ - InterpInfo *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; - Tcl_HashEntry *hPtr; - Alias *aliasPtr; - Tcl_Size i, objc; - Tcl_Obj **objv; - - hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName); - if (hPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "alias \"%s\" not found", aliasName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, (void *)NULL); - return TCL_ERROR; - } - aliasPtr = (Alias *)Tcl_GetHashValue(hPtr); - objc = aliasPtr->objc; - objv = &aliasPtr->objPtr; - - if (targetInterpPtr != NULL) { - *targetInterpPtr = aliasPtr->targetInterp; - } - if (targetNamePtr != NULL) { - *targetNamePtr = TclGetString(objv[0]); - } - if (argcPtr != NULL) { - *argcPtr = objc - 1; - } - if (argvPtr != NULL) { - *argvPtr = (const char **) - Tcl_Alloc(sizeof(const char *) * (objc - 1)); - for (i = 1; i < objc; i++) { - (*argvPtr)[i - 1] = TclGetString(objv[i]); - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_GetAliasObj -- * * Object version: Gets information about an alias. diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 6b57e6c..1e9b182 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -2376,7 +2376,7 @@ TclGetNamespaceForQualName( Tcl_Panic("Could not create namespace '%s'", nsName); } } else { - /* + /* * Namespace not found and was not created. * Remember last found namespace for TCL_FIND_IF_NOT_SIMPLE. */ @@ -2414,7 +2414,7 @@ TclGetNamespaceForQualName( if ((nsPtr == NULL) && (altNsPtr == NULL)) { if (flags & TCL_FIND_IF_NOT_SIMPLE) { - /* + /* * return last found NS, regardless simple name or not, * e. g. ::A::B::C::D -> ::A::B and C::D, if namespace C * cannot be found in ::A::B diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index eb6a96e..a763092 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -64,7 +64,7 @@ static const char *tclOOSetupScript = "\t\t\t\t\tlassign $link src\n" "\t\t\t\t\tset dst $src\n" "\t\t\t\t} else {\n" -"\t\t\t\t\treturn -code error -errorcode {TCLOO CMDLINK FORMAT} \\\n" +"\t\t\t\t\treturn -code error -errorcode {TCL OO CMDLINK_FORMAT} \\\n" "\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n" "\t\t\t\t}\n" "\t\t\t\tif {![string match ::* $src]} {\n" @@ -142,10 +142,10 @@ static const char *tclOOSetupScript = "\t}\n" "\tdefine Slot {\n" "\t\tmethod Get -unexport {} {\n" -"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" +"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n" "\t\t}\n" "\t\tmethod Set -unexport list {\n" -"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" +"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n" "\t\t}\n" "\t\tmethod Resolve -unexport list {\n" "\t\t\treturn $list\n" @@ -242,11 +242,11 @@ static const char *tclOOSetupScript = "\t\t\t\tset object [next {*}$args]\n" "\t\t\t\t::oo::objdefine $object {\n" "\t\t\t\t\tmethod destroy {} {\n" -"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n" +"\t\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n" "\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n" "\t\t\t\t\t}\n" "\t\t\t\t\tmethod <cloned> -unexport {originObject} {\n" -"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n" +"\t\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n" "\t\t\t\t\t\t\t\"may not clone a singleton object\"\n" "\t\t\t\t\t}\n" "\t\t\t\t}\n" @@ -265,22 +265,22 @@ static const char *tclOOSetupScript = "\t\t\t\tset prop [lindex $args $i]\n" "\t\t\t\tif {[string match \"-*\" $prop]} {\n" "\t\t\t\t\treturn -code error -level 2 \\\n" -"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n" +"\t\t\t\t\t\t-errorcode {TCL OO PROPERTY_FORMAT} \\\n" "\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not begin with -\"\n" "\t\t\t\t}\n" "\t\t\t\tif {$prop ne [list $prop]} {\n" "\t\t\t\t\treturn -code error -level 2 \\\n" -"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n" +"\t\t\t\t\t\t-errorcode {TCL OO PROPERTY_FORMAT} \\\n" "\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must be a simple word\"\n" "\t\t\t\t}\n" "\t\t\t\tif {[string first \"::\" $prop] != -1} {\n" "\t\t\t\t\treturn -code error -level 2 \\\n" -"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n" +"\t\t\t\t\t\t-errorcode {TCL OO PROPERTY_FORMAT} \\\n" "\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not contain namespace separators\"\n" "\t\t\t\t}\n" "\t\t\t\tif {[string match {*[()]*} $prop]} {\n" "\t\t\t\t\treturn -code error -level 2 \\\n" -"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n" +"\t\t\t\t\t\t-errorcode {TCL OO PROPERTY_FORMAT} \\\n" "\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not contain parentheses\"\n" "\t\t\t\t}\n" "\t\t\t\tset realprop [string cat \"-\" $prop]\n" @@ -376,10 +376,10 @@ static const char *tclOOSetupScript = "\t\t\t\t\tdict incr opt -level 2\n" "\t\t\t\t\treturn -options $opt $msg\n" "\t\t\t\t} on break {} {\n" -"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n" +"\t\t\t\t\treturn -code error -level 2 -errorcode {TCL OO SHENANIGANS} \\\n" "\t\t\t\t\t\t\"property getter for $prop did a break\"\n" "\t\t\t\t} on continue {} {\n" -"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n" +"\t\t\t\t\treturn -code error -level 2 -errorcode {TCL OO SHENANIGANS} \\\n" "\t\t\t\t\t\t\"property getter for $prop did a continue\"\n" "\t\t\t\t}\n" "\t\t\t}\n" @@ -407,10 +407,10 @@ static const char *tclOOSetupScript = "\t\t\t\tdict incr opt -level 2\n" "\t\t\t\treturn -options $opt $msg\n" "\t\t\t} on break {} {\n" -"\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n" +"\t\t\t\treturn -code error -level 2 -errorcode {TCL OO SHENANIGANS} \\\n" "\t\t\t\t\t\"property getter for $prop did a break\"\n" "\t\t\t} on continue {} {\n" -"\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n" +"\t\t\t\treturn -code error -level 2 -errorcode {TCL OO SHENANIGANS} \\\n" "\t\t\t\t\t\"property getter for $prop did a continue\"\n" "\t\t\t}\n" "\t\t\treturn $value\n" @@ -438,10 +438,10 @@ static const char *tclOOSetupScript = "\t\t\t\t\tdict incr opt -level 2\n" "\t\t\t\t\treturn -options $opt $msg\n" "\t\t\t\t} on break {} {\n" -"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n" +"\t\t\t\t\treturn -code error -level 2 -errorcode {TCL OO SHENANIGANS} \\\n" "\t\t\t\t\t\t\"property setter for $prop did a break\"\n" "\t\t\t\t} on continue {} {\n" -"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n" +"\t\t\t\t\treturn -code error -level 2 -errorcode {TCL OO SHENANIGANS} \\\n" "\t\t\t\t\t\t\"property setter for $prop did a continue\"\n" "\t\t\t\t}\n" "\t\t\t}\n" diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 58b0465..a4427b7 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -194,22 +194,6 @@ int TclParseArgsObjv(Tcl_Interp *interp, *(int *)objcPtr = (int)n; return result; } -int TclGetAlias(Tcl_Interp *interp, const char *childCmd, - Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, - int *argcPtr, const char ***argvPtr) { - Tcl_Size n = TCL_INDEX_NONE; - int result = Tcl_GetAlias(interp, childCmd, targetInterpPtr, targetCmdPtr, &n, argvPtr); - if (argcPtr) { - if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) { - if (interp) { - Tcl_AppendResult(interp, "List too large to be processed", NULL); - } - return TCL_ERROR; - } - *argcPtr = (int)n; - } - return result; -} int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv) { @@ -973,11 +957,11 @@ const TclStubs tclStubs = { Tcl_ExprObj, /* 141 */ Tcl_ExprString, /* 142 */ Tcl_Finalize, /* 143 */ - Tcl_GetAlias, /* 144 */ + 0, /* 144 */ Tcl_FirstHashEntry, /* 145 */ Tcl_Flush, /* 146 */ Tcl_GetAliasObj, /* 147 */ - TclGetAlias, /* 148 */ + 0, /* 148 */ TclGetAliasObj, /* 149 */ Tcl_GetAssocData, /* 150 */ Tcl_GetChannel, /* 151 */ diff --git a/tests/ooProp.test b/tests/ooProp.test index 8120f88..fa3b1e7 100644 --- a/tests/ooProp.test +++ b/tests/ooProp.test @@ -768,7 +768,7 @@ test ooProp-4.1 {TIP 558: properties: error details} -setup { "property -x" (in definition script for class "::Point" line 1) invoked from within -"oo::define Point {property -x}"} {TCLOO PROPERTY_FORMAT}} +"oo::define Point {property -x}"} {TCL OO PROPERTY_FORMAT}} test ooProp-4.2 {TIP 558: properties: error details} -setup { oo::class create parent unset -nocomplain msg opt diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 4591a1b..0b75882 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -88,7 +88,7 @@ lassign $link src set dst $src } else { - return -code error -errorcode {TCLOO CMDLINK FORMAT} \ + return -code error -errorcode {TCL OO CMDLINK_FORMAT} \ "bad link description; must only have one or two elements" } if {![string match ::* $src]} { @@ -258,7 +258,7 @@ # ------------------------------------------------------------------ method Get -unexport {} { - return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented" + return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented" } # ------------------------------------------------------------------ @@ -271,7 +271,7 @@ # ------------------------------------------------------------------ method Set -unexport list { - return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented" + return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented" } # ------------------------------------------------------------------ @@ -431,11 +431,11 @@ set object [next {*}$args] ::oo::objdefine $object { method destroy {} { - ::return -code error -errorcode {TCLOO SINGLETON} \ + ::return -code error -errorcode {TCL OO SINGLETON} \ "may not destroy a singleton object" } method <cloned> -unexport {originObject} { - ::return -code error -errorcode {TCLOO SINGLETON} \ + ::return -code error -errorcode {TCL OO SINGLETON} \ "may not clone a singleton object" } } @@ -492,22 +492,22 @@ set prop [lindex $args $i] if {[string match "-*" $prop]} { return -code error -level 2 \ - -errorcode {TCLOO PROPERTY_FORMAT} \ + -errorcode {TCL OO PROPERTY_FORMAT} \ "bad property name \"$prop\": must not begin with -" } if {$prop ne [list $prop]} { return -code error -level 2 \ - -errorcode {TCLOO PROPERTY_FORMAT} \ + -errorcode {TCL OO PROPERTY_FORMAT} \ "bad property name \"$prop\": must be a simple word" } if {[string first "::" $prop] != -1} { return -code error -level 2 \ - -errorcode {TCLOO PROPERTY_FORMAT} \ + -errorcode {TCL OO PROPERTY_FORMAT} \ "bad property name \"$prop\": must not contain namespace separators" } if {[string match {*[()]*} $prop]} { return -code error -level 2 \ - -errorcode {TCLOO PROPERTY_FORMAT} \ + -errorcode {TCL OO PROPERTY_FORMAT} \ "bad property name \"$prop\": must not contain parentheses" } set realprop [string cat "-" $prop] @@ -630,10 +630,10 @@ dict incr opt -level 2 return -options $opt $msg } on break {} { - return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \ + return -code error -level 2 -errorcode {TCL OO SHENANIGANS} \ "property getter for $prop did a break" } on continue {} { - return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \ + return -code error -level 2 -errorcode {TCL OO SHENANIGANS} \ "property getter for $prop did a continue" } } @@ -671,10 +671,10 @@ dict incr opt -level 2 return -options $opt $msg } on break {} { - return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \ + return -code error -level 2 -errorcode {TCL OO SHENANIGANS} \ "property getter for $prop did a break" } on continue {} { - return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \ + return -code error -level 2 -errorcode {TCL OO SHENANIGANS} \ "property getter for $prop did a continue" } return $value @@ -711,10 +711,10 @@ dict incr opt -level 2 return -options $opt $msg } on break {} { - return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \ + return -code error -level 2 -errorcode {TCL OO SHENANIGANS} \ "property setter for $prop did a break" } on continue {} { - return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \ + return -code error -level 2 -errorcode {TCL OO SHENANIGANS} \ "property setter for $prop did a continue" } } |