summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog4
-rw-r--r--generic/tclBasic.c10
-rw-r--r--generic/tclCmdIL.c328
-rw-r--r--generic/tclInt.h6
-rw-r--r--tests/info.test453
-rw-r--r--tests/namespace.test9
-rw-r--r--tests/trace.test4
7 files changed, 392 insertions, 422 deletions
diff --git a/ChangeLog b/ChangeLog
index 3a71b72..5b4874b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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]