diff options
| -rw-r--r-- | ChangeLog | 4 | ||||
| -rw-r--r-- | generic/tclBasic.c | 10 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 328 | ||||
| -rw-r--r-- | generic/tclInt.h | 6 | ||||
| -rw-r--r-- | tests/info.test | 453 | ||||
| -rw-r--r-- | tests/namespace.test | 9 | ||||
| -rw-r--r-- | tests/trace.test | 4 |
7 files changed, 392 insertions, 422 deletions
@@ -1,5 +1,9 @@ 2007-06-12 Donal K. Fellows <donal.k.fellows@man.ac.uk> + * generic/tclBasic.c (Tcl_CreateInterp): Turn the [info] command into + * generic/tclCmdIL.c (TclInitInfoCmd): an ensemble, making it easier + for third-party code to plug into. + * generic/tclIndexObj.c (Tcl_WrongNumArgs): * generic/tclNamesp.c, generic/tclInt.h (tclEnsembleCmdType): Make Tcl_WrongNumArgs do replacement correctly with ensembles and other diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 8be21cc..69ddffb 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * 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.249 2007/06/10 23:15:05 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.250 2007/06/12 12:33:59 dkf Exp $ */ #include "tclInt.h" @@ -150,7 +150,6 @@ static const CmdInfo builtInCmds[] = { {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, 1}, {"if", Tcl_IfObjCmd, TclCompileIfCmd, 1}, {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, 1}, - {"info", Tcl_InfoObjCmd, NULL, 1}, {"join", Tcl_JoinObjCmd, NULL, 1}, {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, 1}, {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, 1}, @@ -581,8 +580,9 @@ Tcl_CreateInterp(void) } /* - * Register clock and chan subcommands. These *do* go through - * Tcl_CreateObjCommand, since they aren't in the global namespace. + * Register "clock", "chan" and "info" subcommands. These *do* go through + * Tcl_CreateObjCommand, since they aren't in the global namespace and + * involve ensembles. */ TclClockInit(interp); @@ -594,6 +594,8 @@ Tcl_CreateInterp(void) NULL, NULL); } + TclInitInfoCmd(interp); + /* TIP #208 */ Tcl_CreateObjCommand(interp, "::tcl::chan::Truncate", TclChanTruncateObjCmd, NULL, NULL); diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index cdda071..b7a26bf 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -16,7 +16,7 @@ * 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.115 2007/05/05 23:33:13 dkf Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.116 2007/06/12 12:34:00 dkf Exp $ */ #include "tclInt.h" @@ -153,6 +153,40 @@ static int SortCompare(Tcl_Obj *firstPtr, Tcl_Obj *second, SortInfo *infoPtr); static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr, SortInfo *infoPtr); + +/* + * Array of values describing how to implement each standard subcommand of the + * "info" command. + */ + +static const struct { + const char *name; /* The name of the subcommand. */ + Tcl_ObjCmdProc *proc; /* The implementation of the subcommand. */ +} defaultInfoMap[] = { + {"args", InfoArgsCmd}, + {"body", InfoBodyCmd}, + {"cmdcount", InfoCmdCountCmd}, + {"commands", InfoCommandsCmd}, + {"complete", InfoCompleteCmd}, + {"default", InfoDefaultCmd}, + {"exists", InfoExistsCmd}, + {"frame", InfoFrameCmd}, + {"functions", InfoFunctionsCmd}, + {"globals", InfoGlobalsCmd}, + {"hostname", InfoHostnameCmd}, + {"level", InfoLevelCmd}, + {"library", InfoLibraryCmd}, + {"loaded", InfoLoadedCmd}, + {"locals", InfoLocalsCmd}, + {"nameofexecutable",InfoNameOfExecutableCmd}, + {"patchlevel", InfoPatchLevelCmd}, + {"procs", InfoProcsCmd}, + {"script", InfoScriptCmd}, + {"sharedlibextension", InfoSharedlibCmd}, + {"tclversion", InfoTclVersionCmd}, + {"vars", InfoVarsCmd}, + {NULL, NULL} +}; /* *---------------------------------------------------------------------- @@ -345,124 +379,52 @@ Tcl_IncrObjCmd( /* *---------------------------------------------------------------------- * - * Tcl_InfoObjCmd -- + * TclInitInfoCmd -- * - * This procedure is invoked to process the "info" Tcl command. See the - * user documentation for details on what it does. + * This function is called to create the "info" Tcl command. See the user + * documentation for details on what it does. * * Results: - * A standard Tcl result. + * FIXME * * Side effects: - * See the user documentation. + * none * *---------------------------------------------------------------------- */ -int -Tcl_InfoObjCmd( - ClientData clientData, /* Arbitrary value passed to the command. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ +Tcl_Command +TclInitInfoCmd( + Tcl_Interp *interp) /* Current interpreter. */ { - static CONST char *subCmds[] = { - "args", "body", "cmdcount", "commands", - "complete", "default", "exists", "frame", "functions", - "globals", "hostname", "level", "library", "loaded", - "locals", "nameofexecutable", "patchlevel", "procs", - "script", "sharedlibextension", "tclversion", "vars", - NULL}; - enum ISubCmdIdx { - IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx, - ICompleteIdx, IDefaultIdx, IExistsIdx, IFrameIdx, IFunctionsIdx, - IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, - ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx, - IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx - }; - int index, result; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); - return TCL_ERROR; - } - - result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0, - (int *) &index); - if (result != TCL_OK) { - return result; - } - - switch (index) { - case IArgsIdx: - result = InfoArgsCmd(clientData, interp, objc, objv); - break; - case IBodyIdx: - result = InfoBodyCmd(clientData, interp, objc, objv); - break; - case ICmdCountIdx: - result = InfoCmdCountCmd(clientData, interp, objc, objv); - break; - case ICommandsIdx: - result = InfoCommandsCmd(clientData, interp, objc, objv); - break; - case ICompleteIdx: - result = InfoCompleteCmd(clientData, interp, objc, objv); - break; - case IDefaultIdx: - result = InfoDefaultCmd(clientData, interp, objc, objv); - break; - case IExistsIdx: - result = InfoExistsCmd(clientData, interp, objc, objv); - break; - case IFrameIdx: - /* TIP #280 - New method 'frame' */ - result = InfoFrameCmd(clientData, interp, objc, objv); - break; - case IFunctionsIdx: - result = InfoFunctionsCmd(clientData, interp, objc, objv); - break; - case IGlobalsIdx: - result = InfoGlobalsCmd(clientData, interp, objc, objv); - break; - case IHostnameIdx: - result = InfoHostnameCmd(clientData, interp, objc, objv); - break; - case ILevelIdx: - result = InfoLevelCmd(clientData, interp, objc, objv); - break; - case ILibraryIdx: - result = InfoLibraryCmd(clientData, interp, objc, objv); - break; - case ILoadedIdx: - result = InfoLoadedCmd(clientData, interp, objc, objv); - break; - case ILocalsIdx: - result = InfoLocalsCmd(clientData, interp, objc, objv); - break; - case INameOfExecutableIdx: - result = InfoNameOfExecutableCmd(clientData, interp, objc, objv); - break; - case IPatchLevelIdx: - result = InfoPatchLevelCmd(clientData, interp, objc, objv); - break; - case IProcsIdx: - result = InfoProcsCmd(clientData, interp, objc, objv); - break; - case IScriptIdx: - result = InfoScriptCmd(clientData, interp, objc, objv); - break; - case ISharedLibExtensionIdx: - result = InfoSharedlibCmd(clientData, interp, objc, objv); - break; - case ITclVersionIdx: - result = InfoTclVersionCmd(clientData, interp, objc, objv); - break; - case IVarsIdx: - result = InfoVarsCmd(clientData, interp, objc, objv); - break; + Tcl_Command ensemble; /* The overall ensemble. */ + Tcl_Namespace *tclNsPtr; /* Reference to the "::tcl" namespace. */ + + tclNsPtr = Tcl_FindNamespace(interp, "::tcl", NULL, + TCL_CREATE_NS_IF_UNKNOWN); + if (tclNsPtr == NULL) { + Tcl_Panic("unable to find or create ::tcl namespace!"); + } + ensemble = Tcl_CreateEnsemble(interp, "::info", tclNsPtr, + TCL_ENSEMBLE_PREFIX); + if (ensemble != NULL) { + Tcl_Obj *mapDict; + int i; + + TclNewObj(mapDict); + for (i=0 ; defaultInfoMap[i].name != NULL ; i++) { + Tcl_Obj *fromObj, *toObj; + + fromObj = Tcl_NewStringObj(defaultInfoMap[i].name, -1); + TclNewLiteralStringObj(toObj, "::tcl::Info_"); + Tcl_AppendToObj(toObj, defaultInfoMap[i].name, -1); + Tcl_DictObjPut(NULL, mapDict, fromObj, toObj); + Tcl_CreateObjCommand(interp, TclGetString(toObj), + defaultInfoMap[i].proc, NULL, NULL); + } + Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict); } - return result; + return ensemble; } /* @@ -498,12 +460,12 @@ InfoArgsCmd( CompiledLocal *localPtr; Tcl_Obj *listObjPtr; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "procname"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "procname"); return TCL_ERROR; } - name = TclGetString(objv[2]); + name = TclGetString(objv[1]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL); @@ -558,12 +520,12 @@ InfoBodyCmd( Proc *procPtr; Tcl_Obj *bodyPtr, *resultPtr; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "procname"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "procname"); return TCL_ERROR; } - name = TclGetString(objv[2]); + name = TclGetString(objv[1]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL); @@ -624,8 +586,8 @@ InfoCmdCountCmd( { Interp *iPtr = (Interp *) interp; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -681,11 +643,11 @@ InfoCommandsCmd( * commands. */ - if (objc == 2) { + if (objc == 1) { simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; - } else if (objc == 3) { + } else if (objc == 2) { /* * From the pattern, get the effective namespace and the simple * pattern (no namespace qualifiers or ::'s) at the end. If an error @@ -696,7 +658,7 @@ InfoCommandsCmd( Namespace *dummy1NsPtr, *dummy2NsPtr; - pattern = TclGetString(objv[2]); + pattern = TclGetString(objv[1]); TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); @@ -704,7 +666,7 @@ InfoCommandsCmd( specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } @@ -941,13 +903,13 @@ InfoCompleteCmd( int objc, /* Number of arguments. */ Tcl_Obj *CONST objv[]) /* Argument objects. */ { - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "command"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "command"); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - TclObjCommandComplete(objv[2]))); + TclObjCommandComplete(objv[1]))); return TCL_OK; } @@ -984,13 +946,13 @@ InfoDefaultCmd( CompiledLocal *localPtr; Tcl_Obj *valueObjPtr; - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname"); + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "procname arg varname"); return TCL_ERROR; } - procName = TclGetString(objv[2]); - argName = TclGetString(objv[3]); + procName = TclGetString(objv[1]); + argName = TclGetString(objv[2]); procPtr = TclFindProc(iPtr, procName); if (procPtr == NULL) { @@ -1003,7 +965,7 @@ InfoDefaultCmd( if (TclIsVarArgument(localPtr) && (strcmp(argName, localPtr->name) == 0)) { if (localPtr->defValuePtr != NULL) { - valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, + valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, localPtr->defValuePtr, 0); if (valueObjPtr == NULL) { goto defStoreError; @@ -1011,7 +973,7 @@ InfoDefaultCmd( Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); } else { Tcl_Obj *nullObjPtr = Tcl_NewObj(); - valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, + valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, nullObjPtr, 0); if (valueObjPtr == NULL) { goto defStoreError; @@ -1027,7 +989,7 @@ InfoDefaultCmd( return TCL_ERROR; defStoreError: - varName = TclGetString(objv[4]); + varName = TclGetString(objv[3]); Tcl_AppendResult(interp, "couldn't store default value in variable \"", varName, "\"", NULL); return TCL_ERROR; @@ -1063,12 +1025,12 @@ InfoExistsCmd( char *varName; Var *varPtr; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "varName"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "varName"); return TCL_ERROR; } - varName = TclGetString(objv[2]); + varName = TclGetString(objv[1]); varPtr = TclVarTraceExists(interp, varName); Tcl_SetObjResult(interp, Tcl_NewBooleanObj( @@ -1119,7 +1081,7 @@ InfoFrameCmd( }; Tcl_Obj *tmpObj; - if (objc == 2) { + if (objc == 1) { /* * Just "info frame". */ @@ -1129,8 +1091,8 @@ InfoFrameCmd( Tcl_SetIntObj(Tcl_GetObjResult(interp), levels); return TCL_OK; - } else if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?number?"); + } else if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?number?"); return TCL_ERROR; } @@ -1138,7 +1100,7 @@ InfoFrameCmd( * We've got "info frame level" and must parse the level first. */ - if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[1], &level) != TCL_OK) { return TCL_ERROR; } if (level <= 0) { @@ -1150,7 +1112,7 @@ InfoFrameCmd( if (iPtr->cmdFramePtr == NULL) { levelError: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad level \"", - TclGetString(objv[2]), "\"", NULL); + TclGetString(objv[1]), "\"", NULL); return TCL_ERROR; } @@ -1375,12 +1337,12 @@ InfoFunctionsCmd( { char *pattern; - if (objc == 2) { + if (objc == 1) { pattern = NULL; - } else if (objc == 3) { - pattern = TclGetString(objv[2]); + } else if (objc == 2) { + pattern = TclGetString(objv[1]); } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } @@ -1423,10 +1385,10 @@ InfoGlobalsCmd( Var *varPtr; Tcl_Obj *listPtr; - if (objc == 2) { + if (objc == 1) { pattern = NULL; - } else if (objc == 3) { - pattern = TclGetString(objv[2]); + } else if (objc == 2) { + pattern = TclGetString(objv[1]); /* * Strip leading global-namespace qualifiers. [Bug 1057461] @@ -1438,7 +1400,7 @@ InfoGlobalsCmd( } } } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } @@ -1505,8 +1467,8 @@ InfoHostnameCmd( { CONST char *name; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -1548,16 +1510,16 @@ InfoLevelCmd( { Interp *iPtr = (Interp *) interp; - if (objc == 2) { /* Just "info level" */ + if (objc == 1) { /* Just "info level" */ Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->varFramePtr->level)); return TCL_OK; } - if (objc == 3) { + if (objc == 2) { int level; CallFrame *framePtr, *rootFramePtr = iPtr->rootFramePtr; - if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[1], &level) != TCL_OK) { return TCL_ERROR; } if (level <= 0) { @@ -1581,11 +1543,11 @@ InfoLevelCmd( return TCL_OK; } - Tcl_WrongNumArgs(interp, 2, objv, "?number?"); + Tcl_WrongNumArgs(interp, 1, objv, "?number?"); return TCL_ERROR; levelError: - Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[2]), "\"", + Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"", NULL); return TCL_ERROR; } @@ -1620,8 +1582,8 @@ InfoLibraryCmd( { CONST char *libDirName; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -1665,15 +1627,15 @@ InfoLoadedCmd( char *interpName; int result; - if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?interp?"); + if ((objc != 1) && (objc != 2)) { + Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); return TCL_ERROR; } - if (objc == 2) { /* Get loaded pkgs in all interpreters. */ + if (objc == 1) { /* Get loaded pkgs in all interpreters. */ interpName = NULL; } else { /* Get pkgs just in specified interp. */ - interpName = TclGetString(objv[2]); + interpName = TclGetString(objv[1]); } result = TclGetLoadedPackages(interp, interpName); return result; @@ -1711,12 +1673,12 @@ InfoLocalsCmd( char *pattern; Tcl_Obj *listPtr; - if (objc == 2) { + if (objc == 1) { pattern = NULL; - } else if (objc == 3) { - pattern = TclGetString(objv[2]); + } else if (objc == 2) { + pattern = TclGetString(objv[1]); } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } @@ -1863,8 +1825,8 @@ InfoNameOfExecutableCmd( int objc, /* Number of arguments. */ Tcl_Obj *CONST objv[]) /* Argument objects. */ { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, TclGetObjNameOfExecutable()); @@ -1901,8 +1863,8 @@ InfoPatchLevelCmd( { CONST char *patchlevel; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -1964,11 +1926,11 @@ InfoProcsCmd( * procs. */ - if (objc == 2) { + if (objc == 1) { simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; - } else if (objc == 3) { + } else if (objc == 2) { /* * From the pattern, get the effective namespace and the simple * pattern (no namespace qualifiers or ::'s) at the end. If an error @@ -1979,7 +1941,7 @@ InfoProcsCmd( Namespace *dummy1NsPtr, *dummy2NsPtr; - pattern = TclGetString(objv[2]); + pattern = TclGetString(objv[1]); TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); @@ -1988,7 +1950,7 @@ InfoProcsCmd( specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } @@ -2135,16 +2097,16 @@ InfoScriptCmd( Tcl_Obj *CONST objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?filename?"); + if ((objc != 1) && (objc != 2)) { + Tcl_WrongNumArgs(interp, 1, objv, "?filename?"); return TCL_ERROR; } - if (objc == 3) { + if (objc == 2) { if (iPtr->scriptFile != NULL) { Tcl_DecrRefCount(iPtr->scriptFile); } - iPtr->scriptFile = objv[2]; + iPtr->scriptFile = objv[1]; Tcl_IncrRefCount(iPtr->scriptFile); } if (iPtr->scriptFile != NULL) { @@ -2181,8 +2143,8 @@ InfoSharedlibCmd( int objc, /* Number of arguments. */ Tcl_Obj *CONST objv[]) /* Argument objects. */ { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -2221,8 +2183,8 @@ InfoTclVersionCmd( { Tcl_Obj *version; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -2284,11 +2246,11 @@ InfoVarsCmd( * Tcl procedure frame. */ - if (objc == 2) { + if (objc == 1) { simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; - } else if (objc == 3) { + } else if (objc == 2) { /* * From the pattern, get the effective namespace and the simple * pattern (no namespace qualifiers or ::'s) at the end. If an error @@ -2299,7 +2261,7 @@ InfoVarsCmd( Namespace *dummy1NsPtr, *dummy2NsPtr; - pattern = TclGetString(objv[2]); + pattern = TclGetString(objv[1]); TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); @@ -2308,7 +2270,7 @@ InfoVarsCmd( specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 8b015b0..64d81dd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * 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.317 2007/06/12 12:29:05 dkf Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.318 2007/06/12 12:34:00 dkf Exp $ */ #ifndef _TCLINT @@ -2611,9 +2611,7 @@ MODULE_SCOPE int Tcl_IfObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_IncrObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); -MODULE_SCOPE int Tcl_InfoObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); +MODULE_SCOPE Tcl_Command TclInitInfoCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_InterpObjCmd(ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST objv[]); diff --git a/tests/info.test b/tests/info.test index 527d217..94db6e7 100644 --- a/tests/info.test +++ b/tests/info.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: info.test,v 1.44 2007/05/18 18:39:31 dgp Exp $ +# RCS: @(#) $Id: info.test,v 1.45 2007/06/12 12:34:04 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -43,13 +43,13 @@ test info-1.3 {info args option} { proc t1 "" {return foo} info args t1 } {} -test info-1.4 {info args option} { +test info-1.4 {info args option} -body { catch {rename t1 {}} - list [catch {info args t1} msg] $msg -} {1 {"t1" isn't a procedure}} -test info-1.5 {info args option} { - list [catch {info args set} msg] $msg -} {1 {"set" isn't a procedure}} + info args t1 +} -returnCodes error -result {"t1" isn't a procedure} +test info-1.5 {info args option} -body { + info args set +} -returnCodes error -result {"set" isn't a procedure} test info-1.6 {info args option} { proc t1 {a b} {set c 123; set d $c} t1 1 2 @@ -67,12 +67,12 @@ test info-2.1 {info body option} { proc t1 {} {body of t1} info body t1 } {body of t1} -test info-2.2 {info body option} { - list [catch {info body set} msg] $msg -} {1 {"set" isn't a procedure}} -test info-2.3 {info body option} { - list [catch {info args set 1} msg] $msg -} {1 {wrong # args: should be "info args procname"}} +test info-2.2 {info body option} -body { + info body set +} -returnCodes error -result {"set" isn't a procedure} +test info-2.3 {info body option} -body { + info args set 1 +} -returnCodes error -result {wrong # args: should be "info args procname"} test info-2.4 {info body option} { catch {namespace delete test_ns_info2} namespace eval test_ns_info2 { @@ -112,17 +112,17 @@ proc testinfocmdcount {} { } test info-3.1 {info cmdcount compiled} { testinfocmdcount -} 3 +} 4 test info-3.2 {info cmdcount evaled} { set x [info cmdcount] set y 12345 set z [info cm] expr $z-$x -} 3 -test info-3.3 {info cmdcount evaled} [info body testinfocmdcount] 3 -test info-3.4 {info cmdcount option} { - list [catch {info cmdcount 1} msg] $msg -} {1 {wrong # args: should be "info cmdcount"}} +} 4 +test info-3.3 {info cmdcount evaled} [info body testinfocmdcount] 4 +test info-3.4 {info cmdcount option} -body { + info cmdcount 1 +} -returnCodes error -result {wrong # args: should be "info cmdcount"} test info-4.1 {info commands option} { proc t1 {} {} @@ -149,14 +149,14 @@ test info-4.4 {info commands option} { } {_t1_ _t2_} catch {rename _t1_ {}} catch {rename _t2_ {}} -test info-4.5 {info commands option} { - list [catch {info commands a b} msg] $msg -} {1 {wrong # args: should be "info commands ?pattern?"}} +test info-4.5 {info commands option} -returnCodes error -body { + info commands a b +} -result {wrong # args: should be "info commands ?pattern?"} # Also some tests in namespace.test -test info-5.1 {info complete option} { - list [catch {info complete} msg] $msg -} {1 {wrong # args: should be "info complete command"}} +test info-5.1 {info complete option} -body { + info complete +} -returnCodes error -result {wrong # args: should be "info complete command"} test info-5.2 {info complete option} { info complete abc } 1 @@ -199,28 +199,30 @@ test info-6.5 {info default option} { set x [info default t1 e value] list $x $value } {1 {long default value}} -test info-6.6 {info default option} { - list [catch {info default a b} msg] $msg -} {1 {wrong # args: should be "info default procname arg varname"}} -test info-6.7 {info default option} { - list [catch {info default _nonexistent_ a b} msg] $msg -} {1 {"_nonexistent_" isn't a procedure}} -test info-6.8 {info default option} { +test info-6.6 {info default option} -returnCodes error -body { + info default a b +} -result {wrong # args: should be "info default procname arg varname"} +test info-6.7 {info default option} -returnCodes error -body { + info default _nonexistent_ a b +} -result {"_nonexistent_" isn't a procedure} +test info-6.8 {info default option} -returnCodes error -body { proc t1 {a b} {} - list [catch {info default t1 x value} msg] $msg -} {1 {procedure "t1" doesn't have an argument "x"}} -test info-6.9 {info default option} { + info default t1 x value +} -result {procedure "t1" doesn't have an argument "x"} +test info-6.9 {info default option} -returnCodes error -setup { catch {unset a} +} -body { set a(0) 88 proc t1 {a b} {} - list [catch {info default t1 a a} msg] $msg -} {1 {couldn't store default value in variable "a"}} -test info-6.10 {info default option} { + info default t1 a a +} -returnCodes error -result {couldn't store default value in variable "a"} +test info-6.10 {info default option} -setup { catch {unset a} +} -body { set a(0) 88 proc t1 {{a 18} b} {} - list [catch {info default t1 a a} msg] $msg -} {1 {couldn't store default value in variable "a"}} + info default t1 a a +} -returnCodes error -result {couldn't store default value in variable "a"} test info-6.11 {info default option} { catch {namespace delete test_ns_info2} namespace eval test_ns_info2 { @@ -260,18 +262,19 @@ test info-7.6 {info exists option} { proc t1 {x} {return [info exists value]} t1 2 } 0 -test info-7.7 {info exists option} { +test info-7.7 {info exists option} -setup { catch {unset x} +} -body { set x(2) 44 list [info exists x] [info exists x(1)] [info exists x(2)] -} {1 0 1} +} -result {1 0 1} catch {unset x} -test info-7.8 {info exists option} { - list [catch {info exists} msg] $msg -} {1 {wrong # args: should be "info exists varName"}} -test info-7.9 {info exists option} { - list [catch {info exists 1 2} msg] $msg -} {1 {wrong # args: should be "info exists varName"}} +test info-7.8 {info exists option} -body { + info exists +} -returnCodes error -result {wrong # args: should be "info exists varName"} +test info-7.9 {info exists option} -body { + info exists 1 2 +} -returnCodes error -result {wrong # args: should be "info exists varName"} test info-8.1 {info globals option} { set x 1 @@ -286,9 +289,9 @@ test info-8.2 {info globals option} { set _xxx2 2 lsort [info g _xxx*] } {_xxx1 _xxx2} -test info-8.3 {info globals option} { - list [catch {info globals 1 2} msg] $msg -} {1 {wrong # args: should be "info globals ?pattern?"}} +test info-8.3 {info globals option} -returnCodes error -body { + info globals 1 2 +} -result {wrong # args: should be "info globals ?pattern?"} test info-8.4 {info globals option: may have leading namespace qualifiers} { set x 0 list [info globals x] [info globals :x] [info globals ::x] [info globals :::x] [info globals ::::x] @@ -336,23 +339,23 @@ test info-9.4 {info level option} { } t1 } {1 t1} -test info-9.5 {info level option} { - list [catch {info level 1 2} msg] $msg -} {1 {wrong # args: should be "info level ?number?"}} -test info-9.6 {info level option} { - list [catch {info level 123a} msg] $msg -} {1 {expected integer but got "123a"}} -test info-9.7 {info level option} { - list [catch {info level 0} msg] $msg -} {1 {bad level "0"}} -test info-9.8 {info level option} { +test info-9.5 {info level option} -body { + info level 1 2 +} -returnCodes error -result {wrong # args: should be "info level ?number?"} +test info-9.6 {info level option} -body { + info level 123a +} -returnCodes error -result {expected integer but got "123a"} +test info-9.7 {info level option} -body { + info level 0 +} -returnCodes error -result {bad level "0"} +test info-9.8 {info level option} -body { proc t1 {} {info level -1} - list [catch {t1} msg] $msg -} {1 {bad level "-1"}} -test info-9.9 {info level option} { + t1 +} -returnCodes error -result {bad level "-1"} +test info-9.9 {info level option} -body { proc t1 {x} {info level $x} - list [catch {t1 -3} msg] $msg -} {1 {bad level "-3"}} + t1 -3 +} -returnCodes error -result {bad level "-3"} test info-9.10 {info level option, namespaces} { set msg [namespace eval t {info level 0}] namespace delete t @@ -378,22 +381,22 @@ test info-9.12 {info level option, ensembles} -constraints knownBug -setup { } -result {a foo 1 2 3} set savedLibrary $tcl_library -test info-10.1 {info library option} { - list [catch {info library x} msg] $msg -} {1 {wrong # args: should be "info library"}} +test info-10.1 {info library option} -body { + info library x +} -returnCodes error -result {wrong # args: should be "info library"} test info-10.2 {info library option} { set tcl_library 12345 info library } {12345} -test info-10.3 {info library option} { +test info-10.3 {info library option} -body { unset tcl_library - list [catch {info library} msg] $msg -} {1 {no library has been specified for Tcl}} + info library +} -returnCodes error -result {no library has been specified for Tcl} set tcl_library $savedLibrary -test info-11.1 {info loaded option} { - list [catch {info loaded a b} msg] $msg -} {1 {wrong # args: should be "info loaded ?interp?"}} +test info-11.1 {info loaded option} -body { + info loaded a b +} -returnCodes error -result {wrong # args: should be "info loaded ?interp?"} test info-11.2 {info loaded option} { list [catch {info loaded {}}] [catch {info loaded gorp} msg] $msg } {0 1 {could not find interpreter "gorp"}} @@ -419,9 +422,9 @@ test info-12.2 {info locals option} { } lsort [t1 2 3] } {x xx1 xx2} -test info-12.3 {info locals option} { - list [catch {info locals 1 2} msg] $msg -} {1 {wrong # args: should be "info locals ?pattern?"}} +test info-12.3 {info locals option} -body { + info locals 1 2 +} -returnCodes error -result {wrong # args: should be "info locals ?pattern?"} test info-12.4 {info locals option} { info locals } {} @@ -445,24 +448,25 @@ test info-12.7 {info locals with temporary variables} { t1 } {a} -test info-13.1 {info nameofexecutable option} { - list [catch {info nameofexecutable foo} msg] $msg -} {1 {wrong # args: should be "info nameofexecutable"}} +test info-13.1 {info nameofexecutable option} -returnCodes error -body { + info nameofexecutable foo +} -result {wrong # args: should be "info nameofexecutable"} test info-14.1 {info patchlevel option} { set a [info patchlevel] regexp {[0-9]+\.[0-9]+([p[0-9]+)?} $a } 1 -test info-14.2 {info patchlevel option} { - list [catch {info patchlevel a} msg] $msg -} {1 {wrong # args: should be "info patchlevel"}} -test info-14.3 {info patchlevel option} { +test info-14.2 {info patchlevel option} -returnCodes error -body { + info patchlevel a +} -result {wrong # args: should be "info patchlevel"} +test info-14.3 {info patchlevel option} -setup { set t $tcl_patchLevel +} -body { unset tcl_patchLevel - set result [list [catch {info patchlevel} msg] $msg] + info patchlevel +} -cleanup { set tcl_patchLevel $t - set result -} {1 {can't read "tcl_patchLevel": no such variable}} +} -returnCodes error -result {can't read "tcl_patchLevel": no such variable} test info-15.1 {info procs option} { proc t1 {} {} @@ -478,19 +482,21 @@ test info-15.2 {info procs option} { } {_tt1 _tt2} catch {rename _tt1 {}} catch {rename _tt2 {}} -test info-15.3 {info procs option} { - list [catch {info procs 2 3} msg] $msg -} {1 {wrong # args: should be "info procs ?pattern?"}} -test info-15.4 {info procs option} { +test info-15.3 {info procs option} -body { + info procs 2 3 +} -returnCodes error -result {wrong # args: should be "info procs ?pattern?"} +test info-15.4 {info procs option} -setup { catch {namespace delete test_ns_info2} +} -body { namespace eval test_ns_info2 { namespace import ::test_ns_info1::* proc r {} {} list [info procs] [info procs p*] } -} {{p q r} p} -test info-15.5 {info procs option with a proc in a namespace} { +} -result {{p q r} p} +test info-15.5 {info procs option with a proc in a namespace} -setup { catch {namespace delete test_ns_info2} +} -body { namespace eval test_ns_info2 { proc p1 { arg } { puts cmd @@ -500,9 +506,10 @@ test info-15.5 {info procs option with a proc in a namespace} { } } info procs ::test_ns_info2::p1 -} {::test_ns_info2::p1} -test info-15.6 {info procs option with a pattern in a namespace} { +} -result {::test_ns_info2::p1} +test info-15.6 {info procs option with a pattern in a namespace} -setup { catch {namespace delete test_ns_info2} +} -body { namespace eval test_ns_info2 { proc p1 { arg } { puts cmd @@ -512,9 +519,10 @@ test info-15.6 {info procs option with a pattern in a namespace} { } } lsort [info procs ::test_ns_info2::p*] -} [lsort [list ::test_ns_info2::p1 ::test_ns_info2::p2]] -test info-15.7 {info procs option with a global shadowing proc} { +} -result [lsort [list ::test_ns_info2::p1 ::test_ns_info2::p2]] +test info-15.7 {info procs option with a global shadowing proc} -setup { catch {namespace delete test_ns_info2} +} -body { proc string_cmd { arg } { puts cmd } @@ -524,12 +532,13 @@ test info-15.7 {info procs option with a global shadowing proc} { } } info procs test_ns_info2::string* -} {::test_ns_info2::string_cmd} +} -result {::test_ns_info2::string_cmd} # This regression test is currently commented out because it requires # that the implementation of "info procs" looks into the global namespace, # which it does not (in contrast to "info commands") -test info-15.8 {info procs option with a global shadowing proc} knownBug { +test info-15.8 {info procs option with a global shadowing proc} -setup { catch {namespace delete test_ns_info2} +} -constraints knownBug -body { proc string_cmd { arg } { puts cmd } @@ -544,11 +553,11 @@ test info-15.8 {info procs option with a global shadowing proc} knownBug { namespace eval test_ns_info2 { lsort [info procs string*] } -} [lsort [list string_cmd string_cmd2]] +} -result [lsort [list string_cmd string_cmd2]] -test info-16.1 {info script option} { - list [catch {info script x x} msg] $msg -} {1 {wrong # args: should be "info script ?filename?"}} +test info-16.1 {info script option} -returnCodes error -body { + info script x x +} -result {wrong # args: should be "info script ?filename?"} test info-16.2 {info script option} { file tail [info sc] } "info.test" @@ -583,24 +592,24 @@ test info-16.8 {info script option} { } [list [list $gorpfile foo.bar] info.test] removeFile gorp.info -test info-17.1 {info sharedlibextension option} { - list [catch {info sharedlibextension foo} msg] $msg -} {1 {wrong # args: should be "info sharedlibextension"}} +test info-17.1 {info sharedlibextension option} -returnCodes error -body { + info sharedlibextension foo +} -result {wrong # args: should be "info sharedlibextension"} test info-18.1 {info tclversion option} { - set x [info tclversion] - scan $x "%d.%d%c" a b c + scan [info tclversion] "%d.%d%c" a b c } 2 -test info-18.2 {info tclversion option} { - list [catch {info t 2} msg] $msg -} {1 {wrong # args: should be "info tclversion"}} -test info-18.3 {info tclversion option} { - set t $tcl_version +test info-18.2 {info tclversion option} -body { + info t 2 +} -returnCodes error -result {wrong # args: should be "info tclversion"} +test info-18.3 {info tclversion option} -body { unset tcl_version - set result [list [catch {info tclversion} msg] $msg] + info tclversion +} -returnCodes error -setup { + set t $tcl_version +} -cleanup { set tcl_version $t - set result -} {1 {can't read "tcl_version": no such variable}} +} -result {can't read "tcl_version": no such variable} test info-19.1 {info vars option} { set a 1 @@ -625,9 +634,9 @@ test info-19.2 {info vars option} { test info-19.3 {info vars option} { lsort [info vars] } [lsort [info globals]] -test info-19.4 {info vars option} { - list [catch {info vars a b} msg] $msg -} {1 {wrong # args: should be "info vars ?pattern?"}} +test info-19.4 {info vars option} -returnCodes error -body { + info vars a b +} -result {wrong # args: should be "info vars ?pattern?"} test info-19.5 {info vars with temporary variables} { proc t1 {} { foreach a {b c} {} @@ -657,25 +666,25 @@ test info-20.3 {info functions option} { test info-20.4 {info functions option} { lsort [info functions *tan*] } {atan atan2 tan tanh} -test info-20.5 {info functions option} { - list [catch {info functions raise an error} msg] $msg -} {1 {wrong # args: should be "info functions ?pattern?"}} - -test info-21.1 {miscellaneous error conditions} { - list [catch {info} msg] $msg -} {1 {wrong # args: should be "info option ?arg arg ...?"}} -test info-21.2 {miscellaneous error conditions} { - list [catch {info gorp} msg] $msg -} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} -test info-21.3 {miscellaneous error conditions} { - list [catch {info c} msg] $msg -} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} -test info-21.4 {miscellaneous error conditions} { - list [catch {info l} msg] $msg -} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} -test info-21.5 {miscellaneous error conditions} { - list [catch {info s} msg] $msg -} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +test info-20.5 {info functions option} -returnCodes error -body { + info functions raise an error +} -result {wrong # args: should be "info functions ?pattern?"} + +test info-21.1 {miscellaneous error conditions} -returnCodes error -body { + info +} -result {wrong # args: should be "info subcommand ?argument ...?"} +test info-21.2 {miscellaneous error conditions} -returnCodes error -body { + info gorp +} -result {unknown or ambiguous subcommand "gorp": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +test info-21.3 {miscellaneous error conditions} -returnCodes error -body { + info c +} -result {unknown or ambiguous subcommand "c": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +test info-21.4 {miscellaneous error conditions} -returnCodes error -body { + info l +} -result {unknown or ambiguous subcommand "l": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +test info-21.5 {miscellaneous error conditions} -returnCodes error -body { + info s +} -result {unknown or ambiguous subcommand "s": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars} ## # ### ### ### ######### ######### ######### @@ -727,82 +736,69 @@ proc etrace {} { test info-22.0 {info frame, levels} {!singleTestInterp} { info frame } 7 - test info-22.1 {info frame, bad level relative} {!singleTestInterp} { # catch is another level!, i.e. we have 8, not 7 catch {info frame -8} msg set msg } {bad level "-8"} - test info-22.2 {info frame, bad level absolute} {!singleTestInterp} { # catch is another level!, i.e. we have 8, not 7 catch {info frame 9} msg set msg } {bad level "9"} - test info-22.3 {info frame, current, relative} { info frame 0 } {type eval line 2 cmd {info frame 0}} - test info-22.4 {info frame, current, relative, nested} { set res [info frame 0] } {type eval line 2 cmd {info frame 0}} - test info-22.5 {info frame, current, absolute} {!singleTestInterp} { reduce [info frame 7] } {type eval line 2 cmd {info frame 7}} - test info-22.6 {info frame, global, relative} {!singleTestInterp} { reduce [info frame -6] -} {type source line 755 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{!singleTestInter level 0} - +} {type source line 758 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{!singleTestInter level 0} test info-22.7 {info frame, global, absolute} {!singleTestInterp} { reduce [info frame 1] -} {type source line 759 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0} - +} {type source line 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0} test info-22.8 {info frame, basic trace} {!singleTestInterp} { join [etrace] \n -} {8 {type source line 719 file info.test cmd {info frame $level} proc ::etrace level 0} +} {8 {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} 7 {type eval line 2 cmd etrace} 6 {type source line 2299 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest} 5 {type eval line 1 cmd {::tcltest::RunTest info-22}} 4 {type source line 1621 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval} 3 {type eval line 1 cmd ::tcltest::Eval\ \{::tcltest::RunTest\ info-22} 2 {type source line 1967 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test} -1 {type source line 763 file info.test cmd test\ info-22.8\ \{info\ frame,\ basic\ trace\}\ \{!singleTestInter level 1}} +1 {type source line 764 file info.test cmd test\ info-22.8\ \{info\ frame,\ basic\ trace\}\ \{!singleTestInter level 1}} + ## The line 1967 is off by 5 from the true value of 1972. This is a knownBug, see testcase 30.0 test info-23.0 {eval'd info frame} {!singleTestInterp} { eval {info frame} } 8 - test info-23.1 {eval'd info frame, semi-dynamic} {!singleTestInterp} { eval info frame } 8 - test info-23.2 {eval'd info frame, dynamic} {!singleTestInterp} { set script {info frame} eval $script } 8 - test info-23.3 {eval'd info frame, literal} { eval { info frame 0 } } {type eval line 2 cmd {info frame 0}} - test info-23.4 {eval'd info frame, semi-dynamic} { eval info frame 0 } {type eval line 1 cmd {info frame 0}} - test info-23.5 {eval'd info frame, dynamic} { set script {info frame 0} eval $script } {type eval line 1 cmd {info frame 0}} - test info-23.6 {eval'd info frame, trace} {!singleTestInterp} { set script {etrace} join [eval $script] \n -} {9 {type source line 719 file info.test cmd {info frame $level} proc ::etrace level 0} +} {9 {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} 8 {type eval line 1 cmd etrace} 7 {type eval line 3 cmd {eval $script}} 6 {type source line 2299 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest} @@ -810,7 +806,7 @@ test info-23.6 {eval'd info frame, trace} {!singleTestInterp} { 4 {type source line 1621 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval} 3 {type eval line 1 cmd ::tcltest::Eval\ \{::tcltest::RunTest\ info-23} 2 {type source line 1967 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test} -1 {type source line 802 file info.test cmd test\ info-23.6\ \{eval'd\ info\ frame,\ trace\}\ \{!singleTestInter level 1}} +1 {type source line 798 file info.test cmd test\ info-23.6\ \{eval'd\ info\ frame,\ trace\}\ \{!singleTestInter level 1}} ## The line 1967 is off by 5 from the true value of 1972. This is a knownBug, see testcase 30.0 # ------------------------------------------------------------------------- @@ -822,17 +818,19 @@ test info-23.6 {eval'd info frame, trace} {!singleTestInterp} { # causes the connection to the context to be lost. Currently only # procedure bodies are able to remember their context. +# NOTE THAT THESE DO NOT USE THE -setup OPTION TO [test] + # ------------------------------------------------------------------------- namespace eval foo { proc bar {} {info frame 0} } -test info-24.0 {info frame, interaction, namespace eval} { +test info-24.0 {info frame, interaction, namespace eval} -body { reduce [foo::bar] -} {type source line 828 file info.test cmd {info frame 0} proc ::foo::bar level 0} - -namespace delete foo +} -cleanup { + namespace delete foo +} -result {type source line 826 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -842,11 +840,11 @@ if {$flag} { proc ::foo::bar {} {info frame 0} } -test info-24.1 {info frame, interaction, if} { +test info-24.1 {info frame, interaction, if} -body { reduce [foo::bar] -} {type source line 842 file info.test cmd {info frame 0} proc ::foo::bar level 0} - -namespace delete foo +} -cleanup { + namespace delete foo +} -result {type source line 840 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -857,11 +855,11 @@ while {$flag} { set flag 0 } -test info-24.2 {info frame, interaction, while} { +test info-24.2 {info frame, interaction, while} -body { reduce [foo::bar] -} {type source line 856 file info.test cmd {info frame 0} proc ::foo::bar level 0} - -namespace delete foo +} -cleanup { + namespace delete foo +} -result {type source line 854 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -870,11 +868,11 @@ catch { proc ::foo::bar {} {info frame 0} } -test info-24.3 {info frame, interaction, catch} { +test info-24.3 {info frame, interaction, catch} -body { reduce [foo::bar] -} {type source line 870 file info.test cmd {info frame 0} proc ::foo::bar level 0} - -namespace delete foo +} -cleanup { + namespace delete foo +} -result {type source line 868 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -884,11 +882,11 @@ foreach var val { break } -test info-24.4 {info frame, interaction, foreach} { +test info-24.4 {info frame, interaction, foreach} -body { reduce [foo::bar] -} {type source line 883 file info.test cmd {info frame 0} proc ::foo::bar level 0} - -namespace delete foo +} -cleanup { + namespace delete foo +} -result {type source line 881 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -898,11 +896,11 @@ for {} {1} {} { break } -test info-24.5 {info frame, interaction, for} { +test info-24.5 {info frame, interaction, for} -body { reduce [foo::bar] -} {type source line 897 file info.test cmd {info frame 0} proc ::foo::bar level 0} - -namespace delete foo +} -cleanup { + namespace delete foo +} -result {type source line 895 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -912,12 +910,15 @@ eval { test info-25.0 {info frame, proc in eval} { reduce [bar] -} {type source line 910 file info.test cmd {info frame 0} proc ::bar level 0} +} {type source line 908 file info.test cmd {info frame 0} proc ::bar level 0} +# Don't need to clean up yet... proc bar {} {info frame 0} + test info-25.1 {info frame, regular proc} { reduce [bar] -} {type source line 917 file info.test cmd {info frame 0} proc ::bar level 0} +} {type source line 916 file info.test cmd {info frame 0} proc ::bar level 0} + rename bar {} # ------------------------------------------------------------------------- @@ -993,12 +994,12 @@ switch -exact -- $x { } } -test info-24.6.0 {info frame, interaction, switch, list body} { +test info-24.6.0 {info frame, interaction, switch, list body} -body { reduce [foo::bar] -} {type source line 992 file info.test cmd {info frame 0} proc ::foo::bar level 0} - -namespace delete foo -unset x +} -cleanup { + namespace delete foo + unset x +} -result {type source line 993 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -1008,12 +1009,12 @@ switch -exact -- $x foo { proc ::foo::bar {} {info frame 0} } -test info-24.6.1 {info frame, interaction, switch, multi-body} { +test info-24.6.1 {info frame, interaction, switch, multi-body} -body { reduce [foo::bar] -} {type source line 1008 file info.test cmd {info frame 0} proc ::foo::bar level 0} - -namespace delete foo -unset x +} -cleanup { + namespace delete foo + unset x +} -result {type source line 1009 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -1023,12 +1024,12 @@ switch -exact -- $x [list foo { proc ::foo::bar {} {info frame 0} }] -test info-24.6.2 {info frame, interaction, switch, list body, dynamic} { +test info-24.6.2 {info frame, interaction, switch, list body, dynamic} -body { reduce [foo::bar] -} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} - -namespace delete foo -unset x +} -cleanup { + namespace delete foo + unset x +} -result {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -1042,12 +1043,12 @@ namespace eval foo {} set x foo switch -exact -- $x $body -test info-31.7 {info frame, interaction, switch, dynamic} { +test info-31.7 {info frame, interaction, switch, dynamic} -body { reduce [foo::bar] -} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} - -namespace delete foo -unset x +} -cleanup { + namespace delete foo + unset x +} -result {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -1058,11 +1059,11 @@ set body { namespace eval foo {} eval $body -test info-32.0 {info frame, dynamic procedure} { +test info-32.0 {info frame, dynamic procedure} -body { reduce [foo::bar] -} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} - -namespace delete foo +} -cleanup { + namespace delete foo +} -result {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -1071,11 +1072,11 @@ namespace {*}{ foo {proc bar {} {info frame 0}} } -test info-33.0 {{*}, literal, direct} { +test info-33.0 {{*}, literal, direct} -body { reduce [foo::bar] -} {type source line 1072 file info.test cmd {info frame 0} proc ::foo::bar level 0} - -namespace delete foo +} -cleanup { + namespace delete foo +} -result {type source line 1073 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -1087,11 +1088,11 @@ proc foo::bar {} { {info frame 0} } } -test info-33.1 {{*}, literal, simple, bytecompiled} { +test info-33.1 {{*}, literal, simple, bytecompiled} -body { reduce [foo::bar] -} {type source line 1087 file info.test cmd {info frame 0} proc ::foo::bar level 0} - -namespace delete foo +} -cleanup { + namespace delete foo +} -result {type source line 1088 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -1138,7 +1139,7 @@ proc foo {} { } test info-35.0 {apply, literal} { reduce [foo] -} {type source line 1136 file info.test cmd {info frame 0} lambda { +} {type source line 1137 file info.test cmd {info frame 0} lambda { {x y} {info frame 0} } level 0} @@ -1165,7 +1166,7 @@ dict for {k v} {foo bar} { test info-24.7 {info frame, interaction, dict for} { reduce [foo::bar] -} {type source line 1163 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 1164 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -1179,7 +1180,7 @@ dict with thedict { test info-24.8 {info frame, interaction, dict with} { reduce [foo::bar] -} {type source line 1177 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 1178 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo unset thedict @@ -1194,7 +1195,7 @@ dict filter {foo bar} script {k v} { test info-24.9 {info frame, interaction, dict filter} { reduce [foo::bar] -} {type source line 1191 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 1192 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo unset x @@ -1210,7 +1211,7 @@ proc foo::bar {} { } test info-36.0 {info frame, dict for, bcc} { reduce [foo::bar] -} {type source line 1207 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 1208 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -1227,7 +1228,7 @@ proc foo::bar {} { test info-36.1.0 {switch, list literal, bcc} { reduce [foo::bar] -} {type source line 1223 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 1224 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -1242,7 +1243,7 @@ proc foo::bar {} { test info-36.1.1 {switch, multi-body literals, bcc} { reduce [foo::bar] -} {type source line 1239 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 1240 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -1255,7 +1256,7 @@ namespace {*}" " test info-33.2 {{*}, literal, direct} { reduce [foo::bar] -} {type source line 1254 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 1255 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -1281,7 +1282,7 @@ proc foo::bar {} { } test info-33.3 {{*}, literal, simple, bytecompiled} { reduce [foo::bar] -} {type source line 1279 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 1280 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo diff --git a/tests/namespace.test b/tests/namespace.test index f8433cc..3228d72 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: namespace.test,v 1.66 2007/03/12 19:10:50 dgp Exp $ +# RCS: @(#) $Id: namespace.test,v 1.67 2007/06/12 12:34:04 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -172,7 +172,10 @@ test namespace-7.6 {recursive Tcl_DeleteNamespace, no active call frames in ns} } {} test namespace-7.7 {Bug 1655305} -setup { interp create slave - slave hide info + # Can't invoke through the ensemble, since deleting the global namespace + # (indirectly, via deleting ::tcl) deletes the ensemble. + slave eval {rename ::tcl::Info_commands ::infocommands} + slave hide infocommands slave eval { proc foo {} { namespace delete :: @@ -180,7 +183,7 @@ test namespace-7.7 {Bug 1655305} -setup { } } -body { slave eval foo - slave invokehidden info commands + slave invokehidden infocommands } -cleanup { interp delete slave } -result {} diff --git a/tests/trace.test b/tests/trace.test index 5ab6a72..f549a4b 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: trace.test,v 1.51 2006/11/03 23:24:43 msofer Exp $ +# RCS: @(#) $Id: trace.test,v 1.52 2007/06/12 12:34:04 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -2249,7 +2249,7 @@ test trace-29.1 {Tcl_CreateTrace, correct command and argc/argv arguments of tra } {{expr 14 + 16} {expr 14 + 16} {set stuff [expr 14 + 16]} {set stuff 30}} test trace-29.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} { testcmdtrace tracetest {set stuff [info tclversion]} -} [list {info tclversion} {info tclversion} {set stuff [info tclversion]} "set stuff [info tclversion]"] +} [concat {{info tclversion} {info tclversion} ::tcl::Info_tclversion {::tcl::Info_tclversion} {set stuff [info tclversion]}} [list "set stuff [info tclversion]"]] test trace-29.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} { testcmdtrace deletetest {set stuff [info tclversion]} } [info tclversion] |