From 558cb6ad68272433faff4c01314fad2d63c1bfc3 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 2 Feb 2009 06:02:41 +0000 Subject: * generic/tclInterp.c: Reverted the conversion of [interp] into an * tests/interp.test: ensemble. Such conversion is not necessary * tests/nre.test: (or even all that helpful) in the NRE-enabling of [interp invokehidden], and it has other implications -- including significant forkage of the 8.5 and 8.6 implementations -- that are better off avoided if there's no gain. --- ChangeLog | 7 + generic/tclInterp.c | 1427 ++++++++++++++++----------------------------------- tests/interp.test | 31 +- tests/nre.test | 8 +- 4 files changed, 484 insertions(+), 989 deletions(-) diff --git a/ChangeLog b/ChangeLog index 158889f..095a210 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,12 @@ 2009-02-02 Don Porter + * generic/tclInterp.c: Reverted the conversion of [interp] into an + * tests/interp.test: ensemble. Such conversion is not necessary + * tests/nre.test: (or even all that helpful) in the NRE-enabling + of [interp invokehidden], and it has other implications -- including + significant forkage of the 8.5 and 8.6 implementations -- that are + better off avoided if there's no gain. + * generic/tclStringObj.c (STRING_NOMEM): Add missing cast of NULL to (char *) that upsets some compilers. [Bug 2494093]. diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 7c1b5ba..c6b53c0 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInterp.c,v 1.101 2009/01/29 14:45:13 dgp Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.102 2009/02/02 06:02:41 dgp Exp $ */ #include "tclInt.h" @@ -247,62 +247,6 @@ static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); - -/* - * Table of interp subcommand names and implementations. - */ - -static Tcl_ObjCmdProc InterpAliasCmd; -static Tcl_ObjCmdProc InterpAliasesCmd; -static Tcl_ObjCmdProc InterpBgErrorCmd; -static Tcl_ObjCmdProc InterpCancelCmd; -static Tcl_ObjCmdProc InterpCreateCmd; -static Tcl_ObjCmdProc InterpDeleteCmd; -static Tcl_ObjCmdProc InterpEvalCmd; -static Tcl_ObjCmdProc InterpExistsCmd; -static Tcl_ObjCmdProc InterpExposeCmd; -static Tcl_ObjCmdProc InterpHiddenCmd; -static Tcl_ObjCmdProc InterpHideCmd; -static Tcl_ObjCmdProc InterpInvokeHiddenCmd; -static Tcl_ObjCmdProc InterpIsSafeCmd; -static Tcl_ObjCmdProc InterpLimitCmd; -static Tcl_ObjCmdProc InterpMarkTrustedCmd; -static Tcl_ObjCmdProc InterpRecursionLimitCmd; -static Tcl_ObjCmdProc InterpShareCmd; -static Tcl_ObjCmdProc InterpSlavesCmd; -static Tcl_ObjCmdProc InterpTargetCmd; -static Tcl_ObjCmdProc InterpTransferCmd; - -static int InterpShareTransferCommon(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], int transfer); -/* -static Tcl_ObjCmdProc InterpNREvalCmd; -static Tcl_ObjCmdProc InterpNRInvokeHiddenCmd; -*/ -static const EnsembleImplMap implementationMap[] = { - {"alias", InterpAliasCmd }, - {"aliases", InterpAliasesCmd }, - {"bgerror", InterpBgErrorCmd }, - {"cancel", InterpCancelCmd }, - {"create", InterpCreateCmd }, - {"delete", InterpDeleteCmd }, - {"eval", InterpEvalCmd, NULL, /*InterpNREvalCmd*/ }, - {"exists", InterpExistsCmd }, - {"expose", InterpExposeCmd }, - {"hidden", InterpHiddenCmd }, - {"hide", InterpHideCmd }, - {"invokehidden", InterpInvokeHiddenCmd, NULL, /*InterpNRInvokeHiddenCmd*/ }, - {"issafe", InterpIsSafeCmd }, - {"limit", InterpLimitCmd }, - {"marktrusted", InterpMarkTrustedCmd }, - {"recursionlimit", InterpRecursionLimitCmd }, - {"share", InterpShareCmd }, - {"slaves", InterpSlavesCmd }, - {"target", InterpTargetCmd }, - {"transfer", InterpTransferCmd }, - {NULL} -}; - /* *---------------------------------------------------------------------- @@ -505,7 +449,7 @@ TclInterpInit( slavePtr->interpCmd = NULL; Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); - TclMakeEnsemble(interp, "interp", implementationMap); + Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL); Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL); return TCL_OK; @@ -593,10 +537,10 @@ InterpInfoDeleteProc( /* *---------------------------------------------------------------------- * - * InterpAliasCmd-- + * Tcl_InterpObjCmd -- * - * Implements the "interp alias" Tcl command. - * See the user documentation for details on what it does. + * This function is invoked to process the "interp" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -607,989 +551,530 @@ InterpInfoDeleteProc( *---------------------------------------------------------------------- */ /* ARGSUSED */ -static int -InterpAliasCmd( +int +Tcl_InterpObjCmd( ClientData clientData, /* Unused. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ - { - Tcl_Interp *slaveInterp; + int index; + static const char *const options[] = { + "alias", "aliases", "bgerror", "cancel", + "create", "delete", "eval", "exists", + "expose", "hide", "hidden", "issafe", + "invokehidden", "limit", "marktrusted", "recursionlimit", + "slaves", "share", "target", "transfer", + NULL + }; + enum option { + OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL, + OPT_CREATE, OPT_DELETE, OPT_EVAL, OPT_EXISTS, + OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, + OPT_INVOKEHID, OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, + OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER + }; - if (objc < 3) { - aliasArgs: - Tcl_WrongNumArgs(interp, 1, objv, - "slavePath slaveCmd ?masterPath masterCmd? ?arg ...?"); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } - if (objc == 3) { - return AliasDescribe(interp, slaveInterp, objv[2]); - } - if ((objc == 4) && (TclGetString(objv[3])[0] == '\0')) { - return AliasDelete(interp, slaveInterp, objv[2]); - } - if (objc > 4) { - Tcl_Interp *masterInterp = GetInterp(interp, objv[3]); - if (masterInterp == NULL) { + switch ((enum option) index) { + case OPT_ALIAS: { + Tcl_Interp *slaveInterp, *masterInterp; + + if (objc < 4) { + aliasArgs: + Tcl_WrongNumArgs(interp, 2, objv, + "slavePath slaveCmd ?masterPath masterCmd? ?arg ...?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { return TCL_ERROR; } - if (TclGetString(objv[4])[0] == '\0') { - if (objc == 5) { - return AliasDelete(interp, slaveInterp, objv[2]); + if (objc == 4) { + return AliasDescribe(interp, slaveInterp, objv[3]); + } + if ((objc == 5) && (TclGetString(objv[4])[0] == '\0')) { + return AliasDelete(interp, slaveInterp, objv[3]); + } + if (objc > 5) { + masterInterp = GetInterp(interp, objv[4]); + if (masterInterp == NULL) { + return TCL_ERROR; + } + if (TclGetString(objv[5])[0] == '\0') { + if (objc == 6) { + return AliasDelete(interp, slaveInterp, objv[3]); + } + } else { + return AliasCreate(interp, slaveInterp, masterInterp, objv[3], + objv[5], objc - 6, objv + 6); } - goto aliasArgs; - } else { - return AliasCreate(interp, slaveInterp, masterInterp, objv[2], - objv[4], objc - 5, objv + 5); } + goto aliasArgs; } - /* NOTREACHED */ - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * InterpAliasesCmd-- - * - * Implements the "interp aliases" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpAliasesCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + case OPT_ALIASES: { + Tcl_Interp *slaveInterp; -{ - Tcl_Interp *slaveInterp = GetInterp2(interp, objc, objv); - - if (slaveInterp == NULL) { - return TCL_ERROR; + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return AliasList(interp, slaveInterp); } - return AliasList(interp, slaveInterp); -} - -/* - *---------------------------------------------------------------------- - * - * InterpBgErrorCmd-- - * - * Implements the "interp bgerror" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpBgErrorCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; + case OPT_BGERROR: { + Tcl_Interp *slaveInterp; - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "path ?cmdPrefix?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2); -} - -/* - *---------------------------------------------------------------------- - * - * InterpCancelCmd-- - * - * Implements the "interp cancel" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpCancelCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int i, flags, index; - Tcl_Interp *slaveInterp; - Tcl_Obj *resultObjPtr; - static const char *const options[] = { - "-unwind", "--", NULL - }; - enum option { - OPT_UNWIND, OPT_LAST - }; + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_CANCEL: { + int i, flags; + Tcl_Interp *slaveInterp; + Tcl_Obj *resultObjPtr; + static const char *const options[] = { + "-unwind", "--", NULL + }; + enum option { + OPT_UNWIND, OPT_LAST + }; - if (objc > 5) { - Tcl_WrongNumArgs(interp, 1, objv, "?-unwind? ?--? ?path? ?result?"); - return TCL_ERROR; - } + if (objc > 6) { + Tcl_WrongNumArgs(interp, 2, objv, "?-unwind? ?--? ?path? ?result?"); + return TCL_ERROR; + } - flags = 0; + flags = 0; - for (i = 1; i < objc; i++) { - if (TclGetString(objv[i])[0] != '-') { - break; - } - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) - != TCL_OK) { - return TCL_ERROR; + for (i = 2; i < objc; i++) { + if (TclGetString(objv[i])[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum option) index) { + case OPT_UNWIND: + /* + * The evaluation stack in the target interp is to be + * unwound. + */ + flags |= TCL_CANCEL_UNWIND; + break; + case OPT_LAST: + i++; + goto endOfForLoop; + } } - switch ((enum option) index) { - case OPT_UNWIND: - /* - * The evaluation stack in the target interp is to be - * unwound. - */ - flags |= TCL_CANCEL_UNWIND; - break; - case OPT_LAST: + endOfForLoop: + + /* + * Did they specify a slave interp to cancel the script in + * progress in? If not, use the current interp. + */ + + if (i < objc) { + slaveInterp = GetInterp(interp, objv[i]); i++; - goto endOfForLoop; + } else { + slaveInterp = interp; } - } - endOfForLoop: - - /* - * Did they specify a slave interp to cancel the script in - * progress in? If not, use the current interp. - */ + if (slaveInterp != NULL) { + if (i < objc) { + resultObjPtr = objv[i]; + Tcl_IncrRefCount(resultObjPtr); /* Tcl_CancelEval removes this ref. */ + i++; + } else { + resultObjPtr = NULL; + } - if (i < objc) { - slaveInterp = GetInterp(interp, objv[i]); - if (slaveInterp == NULL) { + return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags); + } else { return TCL_ERROR; } - i++; - } else { - slaveInterp = interp; - } - - if (i < objc) { - resultObjPtr = objv[i]; - Tcl_IncrRefCount(resultObjPtr); /* Tcl_CancelEval removes this ref. */ - } else { - resultObjPtr = NULL; } + case OPT_CREATE: { + int i, last, safe; + Tcl_Obj *slavePtr; + char buf[16 + TCL_INTEGER_SPACE]; + static const char *const options[] = { + "-safe", "--", NULL + }; + enum option { + OPT_SAFE, OPT_LAST + }; - return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags); -} - -/* - *---------------------------------------------------------------------- - * - * InterpCreateCmd-- - * - * Implements the "interp create" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpCreateCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int i, last, safe, index; - Tcl_Obj *slavePtr; - char buf[16 + TCL_INTEGER_SPACE]; - static const char *const options[] = { - "-safe", "--", NULL - }; - enum option { - OPT_SAFE, OPT_LAST - }; - - safe = Tcl_IsSafe(interp); + safe = Tcl_IsSafe(interp); - /* - * TODO: Get rid of this nonsense. - * Weird historical rules: "-safe" is accepted at the end, too. - */ + /* + * Weird historical rules: "-safe" is accepted at the end, too. + */ - slavePtr = NULL; - last = 0; - for (i = 1; i < objc; i++) { - if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, - &index) != TCL_OK) { + slavePtr = NULL; + last = 0; + for (i = 2; i < objc; i++) { + if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + if (index == OPT_SAFE) { + safe = 1; + continue; + } + i++; + last = 1; + } + if (slavePtr != NULL) { + Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?"); return TCL_ERROR; } - if (index == OPT_SAFE) { - safe = 1; - continue; + if (i < objc) { + slavePtr = objv[i]; } - i++; - last = 1; } - if (slavePtr != NULL) { - Tcl_WrongNumArgs(interp, 1, objv, "?-safe? ?--? ?path?"); + buf[0] = '\0'; + if (slavePtr == NULL) { + /* + * Create an anonymous interpreter -- we choose its name and the + * name of the command. We check that the command name that we use + * for the interpreter does not collide with an existing command + * in the master interpreter. + */ + + for (i = 0; ; i++) { + Tcl_CmdInfo cmdInfo; + + sprintf(buf, "interp%d", i); + if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) { + break; + } + } + slavePtr = Tcl_NewStringObj(buf, -1); + } + if (SlaveCreate(interp, slavePtr, safe) == NULL) { + if (buf[0] != '\0') { + Tcl_DecrRefCount(slavePtr); + } return TCL_ERROR; } - if (i < objc) { - slavePtr = objv[i]; + Tcl_SetObjResult(interp, slavePtr); + return TCL_OK; + } + case OPT_DELETE: { + int i; + InterpInfo *iiPtr; + Tcl_Interp *slaveInterp; + + for (i = 2; i < objc; i++) { + slaveInterp = GetInterp(interp, objv[i]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } else if (slaveInterp == interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot delete the current interpreter", -1)); + return TCL_ERROR; + } + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; + Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp, + iiPtr->slave.interpCmd); } + return TCL_OK; } - buf[0] = '\0'; - if (slavePtr == NULL) { - /* - * Create an anonymous interpreter -- we choose its name and the - * name of the command. We check that the command name that we use - * for the interpreter does not collide with an existing command - * in the master interpreter. - */ + case OPT_EVAL: { + Tcl_Interp *slaveInterp; - for (i = 0; ; i++) { - Tcl_CmdInfo cmdInfo; + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_EXISTS: { + int exists; + Tcl_Interp *slaveInterp; - /* - * TODO: Better scheme than this?! Also, verify that - * [interp create] in non-global namespace contexts can't - * lead to a situation where a global command isn't detected, - * and gets stomped on. - */ - sprintf(buf, "interp%d", i); - if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) { - break; + exists = 1; + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + if (objc > 3) { + return TCL_ERROR; } + Tcl_ResetResult(interp); + exists = 0; } - slavePtr = Tcl_NewStringObj(buf, -1); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); + return TCL_OK; } - if (SlaveCreate(interp, slavePtr, safe) == NULL) { - if (buf[0] != '\0') { - Tcl_DecrRefCount(slavePtr); + case OPT_EXPOSE: { + Tcl_Interp *slaveInterp; + + if ((objc < 4) || (objc > 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?"); + return TCL_ERROR; } - return TCL_ERROR; + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); } - Tcl_SetObjResult(interp, slavePtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpDeleteCmd-- - * - * Implements the "interp delete" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpDeleteCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int i; - InterpInfo *iiPtr; - Tcl_Interp *slaveInterp; + case OPT_HIDE: { + Tcl_Interp *slaveInterp; /* A slave. */ - for (i = 1; i < objc; i++) { - slaveInterp = GetInterp(interp, objv[i]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } else if (slaveInterp == interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot delete the current interpreter", -1)); - return TCL_ERROR; - } - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; - Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp, - iiPtr->slave.interpCmd); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpEvalCmd-- - * - * Implements the "interp eval" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpEvalCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "path arg ?arg ...?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveEval(interp, slaveInterp, objc - 2, objv + 2); -} - -/* - *---------------------------------------------------------------------- - * - * InterpExistsCmd-- - * - * Implements the "interp exists" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpExistsCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int exists = 1; - Tcl_Interp *slaveInterp = GetInterp2(interp, objc, objv); - - if (slaveInterp == NULL) { - if (objc > 2) { + if ((objc < 4) || (objc > 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?"); return TCL_ERROR; } - Tcl_ResetResult(interp); - exists = 0; - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpExposeCmd-- - * - * Implements the "interp expose" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpExposeCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; - - if ((objc < 3) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "path hiddenCmdName ?cmdName?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2); -} - -/* - *---------------------------------------------------------------------- - * - * InterpHiddenCmd-- - * - * Implements the "interp hidden" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpHiddenCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp = GetInterp2(interp, objc, objv); - - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveHidden(interp, slaveInterp); -} - -/* - *---------------------------------------------------------------------- - * - * InterpHideCmd-- - * - * Implements the "interp hide" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpHideCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; /* A slave. */ - - if ((objc < 3) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "path cmdName ?hiddenCmdName?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveHide(interp, slaveInterp, objc - 2, objv + 2); -} - -/* - *---------------------------------------------------------------------- - * - * InterpInvokeHiddenCmd-- - * - * Implements the "interp invokehidden" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpInvokeHiddenCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int i, index; - const char *namespaceName; - Tcl_Interp *slaveInterp; - static const char *const hiddenOptions[] = { - "-global", "-namespace", "--", NULL - }; - enum hiddenOption { - OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST - }; - - namespaceName = NULL; - for (i = 2; i < objc; i++) { - if (TclGetString(objv[i])[0] != '-') { - break; - } - if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", 0, - &index) != TCL_OK) { + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { return TCL_ERROR; } - if (index == OPT_GLOBAL) { - namespaceName = "::"; - } else if (index == OPT_NAMESPACE) { - if (++i == objc) { /* There must be more arguments. */ - break; - } else { - namespaceName = TclGetString(objv[i]); - } - } else { - i++; - break; - } - } - if (objc - i < 1) { - Tcl_WrongNumArgs(interp, 1, objv, - "path ?-namespace ns? ?-global? ?--? cmd ?arg ..?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc - i, - objv + i); -} - -/* - *---------------------------------------------------------------------- - * - * InterpIsSafeCmd-- - * - * Implements the "interp issafe" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpIsSafeCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp = GetInterp2(interp, objc, objv); - - if (slaveInterp == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpLimitCmd-- - * - * Implements the "interp limit" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpLimitCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; - static const char *const limitTypes[] = { - "commands", "time", NULL - }; - enum LimitTypes { - LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME - }; - int limitType; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "path limitType ?-option value ...?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0, - &limitType) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum LimitTypes) limitType) { - case LIMIT_TYPE_COMMANDS: - return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv); - case LIMIT_TYPE_TIME: - return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv); - } - /* NOTREACHED */ - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * InterpMarkTrustedCmd-- - * - * Implements the "interp marktrusted" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpMarkTrustedCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "path"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveMarkTrusted(interp, slaveInterp); -} - -/* - *---------------------------------------------------------------------- - * - * InterpRecursionLimitCmd-- - * - * Implements the "interp recursionlimit" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpRecursionLimitCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; - - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "path ?newlimit?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; + return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); } - return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2); -} - -/* - *---------------------------------------------------------------------- - * - * InterpShareCmd-- - * - * Implements the "interp share" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpShareCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return InterpShareTransferCommon(interp, objc, objv, 0); -} - -/* - *---------------------------------------------------------------------- - * - * InterpSlavesCmd-- - * - * Implements the "interp slaves" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpSlavesCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp = GetInterp2(interp, objc, objv); - InterpInfo *iiPtr; - Tcl_Obj *resultPtr; - Tcl_HashEntry *hPtr; - Tcl_HashSearch hashSearch; + case OPT_HIDDEN: { + Tcl_Interp *slaveInterp; /* A slave. */ - if (slaveInterp == NULL) { - return TCL_ERROR; + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveHidden(interp, slaveInterp); } - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; - resultPtr = Tcl_NewObj(); - hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch); - for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { - Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj( - Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr), -1)); + case OPT_ISSAFE: { + Tcl_Interp *slaveInterp; + + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); + return TCL_OK; } - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpShareTransferCommon-- - * - * The common portion of the "interp slaves" and "interp transfer" - * Tcl commands. See the user documentation for details. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpShareTransferCommon( - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[], /* Argument objects. */ - int transfer) /* 1 for transfer, 0 for share */ -{ - Tcl_Interp *slaveInterp; /* A slave. */ - Tcl_Interp *masterInterp; /* Its master. */ - Tcl_Channel chan; + case OPT_INVOKEHID: { + int i, index; + const char *namespaceName; + Tcl_Interp *slaveInterp; + static const char *const hiddenOptions[] = { + "-global", "-namespace", "--", NULL + }; + enum hiddenOption { + OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST + }; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "srcPath channelId destPath"); - return TCL_ERROR; + namespaceName = NULL; + for (i = 3; i < objc; i++) { + if (TclGetString(objv[i])[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + if (index == OPT_GLOBAL) { + namespaceName = "::"; + } else if (index == OPT_NAMESPACE) { + if (++i == objc) { /* There must be more arguments. */ + break; + } else { + namespaceName = TclGetString(objv[i]); + } + } else { + i++; + break; + } + } + if (objc - i < 1) { + Tcl_WrongNumArgs(interp, 2, objv, + "path ?-namespace ns? ?-global? ?--? cmd ?arg ..?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc - i, + objv + i); } - masterInterp = GetInterp(interp, objv[1]); - if (masterInterp == NULL) { - return TCL_ERROR; + case OPT_LIMIT: { + Tcl_Interp *slaveInterp; + static const char *const limitTypes[] = { + "commands", "time", NULL + }; + enum LimitTypes { + LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME + }; + int limitType; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path limitType ?-option value ...?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", 0, + &limitType) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum LimitTypes) limitType) { + case LIMIT_TYPE_COMMANDS: + return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv); + case LIMIT_TYPE_TIME: + return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); + } } - chan = Tcl_GetChannel(masterInterp, TclGetString(objv[2]), NULL); - if (chan == NULL) { - /* TODO: pass TCL_ERROR */ - Tcl_TransferResult(masterInterp, TCL_OK, interp); - return TCL_ERROR; + case OPT_MARKTRUSTED: { + Tcl_Interp *slaveInterp; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "path"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveMarkTrusted(interp, slaveInterp); } - slaveInterp = GetInterp(interp, objv[3]); - if (slaveInterp == NULL) { - return TCL_ERROR; + case OPT_RECLIMIT: { + Tcl_Interp *slaveInterp; + + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_SLAVES: { + Tcl_Interp *slaveInterp; + InterpInfo *iiPtr; + Tcl_Obj *resultPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hashSearch; + char *string; + + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; + resultPtr = Tcl_NewObj(); + hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { + string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, + Tcl_NewStringObj(string, -1)); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; } - Tcl_RegisterChannel(slaveInterp, chan); - if (transfer) { - /* - * When transferring, as opposed to sharing, we must unhitch the - * channel from the interpreter where it started. - */ + case OPT_TRANSFER: + case OPT_SHARE: { + Tcl_Interp *slaveInterp; /* A slave. */ + Tcl_Interp *masterInterp; /* Its master. */ + Tcl_Channel chan; - if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { - /* TODO: pass TCL_ERROR */ + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, objv[2]); + if (masterInterp == NULL) { + return TCL_ERROR; + } + chan = Tcl_GetChannel(masterInterp, TclGetString(objv[3]), NULL); + if (chan == NULL) { Tcl_TransferResult(masterInterp, TCL_OK, interp); return TCL_ERROR; } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpTargetCmd-- - * - * Implements the "interp target" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpTargetCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; - InterpInfo *iiPtr; - Tcl_HashEntry *hPtr; - Alias *aliasPtr; - char *aliasName; + slaveInterp = GetInterp(interp, objv[4]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + Tcl_RegisterChannel(slaveInterp, chan); + if (index == OPT_TRANSFER) { + /* + * When transferring, as opposed to sharing, we must unhitch the + * channel from the interpreter where it started. + */ - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "path alias"); - return TCL_ERROR; + if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { + Tcl_TransferResult(masterInterp, TCL_OK, interp); + return TCL_ERROR; + } + } + return TCL_OK; } + case OPT_TARGET: { + Tcl_Interp *slaveInterp; + InterpInfo *iiPtr; + Tcl_HashEntry *hPtr; + Alias *aliasPtr; + char *aliasName; - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path alias"); + return TCL_ERROR; + } + + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } - aliasName = TclGetString(objv[2]); + aliasName = TclGetString(objv[3]); - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; - hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); - if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" in path \"", - Tcl_GetString(objv[1]), "\" not found", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); - return TCL_ERROR; + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; + hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "alias \"", aliasName, "\" in path \"", + Tcl_GetString(objv[2]), "\" not found", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, + NULL); + return TCL_ERROR; + } + aliasPtr = Tcl_GetHashValue(hPtr); + if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "target interpreter for alias \"", + aliasName, "\" in path \"", Tcl_GetString(objv[2]), + "\" is not my descendant", NULL); + return TCL_ERROR; + } + return TCL_OK; } - aliasPtr = Tcl_GetHashValue(hPtr); - if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "target interpreter for alias \"", - aliasName, "\" in path \"", Tcl_GetString(objv[1]), - "\" is not my descendant", NULL); - return TCL_ERROR; } return TCL_OK; } /* - *---------------------------------------------------------------------- - * - * InterpTransferCmd-- - * - * Implements the "interp transfer" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpTransferCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return InterpShareTransferCommon(interp, objc, objv, 1); -} - -/* *--------------------------------------------------------------------------- * * GetInterp2 -- @@ -1617,12 +1102,12 @@ GetInterp2( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - if (objc == 1) { + if (objc == 2) { return interp; - } else if (objc == 2) { - return GetInterp(interp, objv[1]); + } else if (objc == 3) { + return GetInterp(interp, objv[2]); } else { - Tcl_WrongNumArgs(interp, 1, objv, "?path?"); + Tcl_WrongNumArgs(interp, 2, objv, "?path?"); return NULL; } } diff --git a/tests/interp.test b/tests/interp.test index 6c22b5e..6a5ba41 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: interp.test,v 1.63 2009/01/30 16:01:34 dgp Exp $ +# RCS: @(#) $Id: interp.test,v 1.64 2009/02/02 06:02:41 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -18,7 +18,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } testConstraint testinterpdelete [llength [info commands testinterpdelete]] -testConstraint interpNotEnsemble [expr ![namespace ensemble exists ::interp]] set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source unload} @@ -27,10 +26,10 @@ foreach i [interp slaves] { } # Part 0: Check out options for interp command -test interp-1.1 {options for interp command} interpNotEnsemble { +test interp-1.1 {options for interp command} { list [catch {interp} msg] $msg } {1 {wrong # args: should be "interp cmd ?arg ...?"}} -test interp-1.2 {options for interp command} interpNotEnsemble { +test interp-1.2 {options for interp command} { list [catch {interp frobox} msg] $msg } {1 {bad option "frobox": must be alias, aliases, bgerror, cancel, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} test interp-1.3 {options for interp command} { @@ -48,13 +47,13 @@ test interp-1.5 {options for interp command} { test interp-1.6 {options for interp command} { list [catch {interp slaves foo bar zop} msg] $msg } {1 {wrong # args: should be "interp slaves ?path?"}} -test interp-1.7 {options for interp command} interpNotEnsemble { +test interp-1.7 {options for interp command} { list [catch {interp hello} msg] $msg } {1 {bad option "hello": must be alias, aliases, bgerror, cancel, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} -test interp-1.8 {options for interp command} interpNotEnsemble { +test interp-1.8 {options for interp command} { list [catch {interp -froboz} msg] $msg } {1 {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} -test interp-1.9 {options for interp command} interpNotEnsemble { +test interp-1.9 {options for interp command} { list [catch {interp -froboz -safe} msg] $msg } {1 {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} test interp-1.10 {options for interp command} { @@ -2369,11 +2368,13 @@ test interp-28.2 {master's nsName cache should not cross} -setup { $i eval { set x {namespace children ::} set y [list namespace children ::] - set j [interp create] namespace delete {*}[{*}$y] + set j [interp create] $j eval {namespace delete {*}[namespace children ::]} namespace eval foo {} - list [eval $x] [eval $y] [$j eval $x] [$j eval $y] + set res [list [eval $x] [eval $y] [$j eval $x] [$j eval $y]] + interp delete $j + set res } } -cleanup { interp delete $i @@ -2567,8 +2568,8 @@ test interp-29.3.4 {recursion limit error reporting} { eval { # 3 eval { # 4 eval { # 5 - interp recursionlimit {} [expr {5+[namespace ensemble exists ::interp]}] - set x ok + interp recursionlimit {} 5 + set x ok } } } @@ -2588,8 +2589,8 @@ test interp-29.3.5 {recursion limit error reporting} { eval { # 3 eval { # 4 eval { # 5 - interp recursionlimit {} [expr {4+[namespace ensemble exists ::interp]}] - set x ok + interp recursionlimit {} 4 + set x ok } } } @@ -2609,8 +2610,8 @@ test interp-29.3.6 {recursion limit error reporting} { eval { # 3 eval { # 4 eval { # 5 - interp recursionlimit {} [expr {6+[namespace ensemble exists ::interp]}] - set x ok + interp recursionlimit {} 6 + set x ok } } } diff --git a/tests/nre.test b/tests/nre.test index 873eb14..dd86e18 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: nre.test,v 1.7 2009/01/29 17:13:50 dgp Exp $ +# RCS: @(#) $Id: nre.test,v 1.8 2009/02/02 06:02:41 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -394,11 +394,13 @@ test nre-X.1 {eval in wrong interp} { set res [$i eval { set x {namespace children ::} set y [list namespace children ::] - set j [interp create] namespace delete {*}[{*}$y] + set j [interp create] $j eval {namespace delete {*}[namespace children ::]} namespace eval foo {} - list [eval $x] [eval $y] [$j eval $x] [$j eval $y] + set res [list [eval $x] [eval $y] [$j eval $x] [$j eval $y]] + interp delete $j + set res }] interp delete $i set res -- cgit v0.12