URL
https://opencores.org/ocsvn/or1k/or1k/trunk
Subversion Repositories or1k
[/] [or1k/] [trunk/] [insight/] [tcl/] [generic/] [tclBasic.c] - Rev 1765
Compare with Previous | Blame | View Log
/* * tclBasic.c -- * * Contains the basic facilities for TCL command interpretation, * including interpreter creation and deletion, command creation * and deletion, and command parsing and execution. * * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998 by Scriptics Corporation. * * 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.1.1.1 2002-01-16 10:25:25 markom Exp $ */ #include "tclInt.h" #include "tclCompile.h" #ifndef TCL_GENERIC_ONLY # include "tclPort.h" #endif /* * Static procedures in this file: */ static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); static void HiddenCmdsDeleteProc _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp)); /* * The following structure defines the commands in the Tcl core. */ typedef struct { char *name; /* Name of object-based command. */ Tcl_CmdProc *proc; /* String-based procedure for command. */ Tcl_ObjCmdProc *objProc; /* Object-based procedure for command. */ CompileProc *compileProc; /* Procedure called to compile command. */ int isSafe; /* If non-zero, command will be present * in safe interpreter. Otherwise it will * be hidden. */ } CmdInfo; /* * The built-in commands, and the procedures that implement them: */ static CmdInfo builtInCmds[] = { /* * Commands in the generic core. Note that at least one of the proc or * objProc members should be non-NULL. This avoids infinitely recursive * calls between TclInvokeObjectCommand and TclInvokeStringCommand if a * command name is computed at runtime and results in the name of a * compiled command. */ {"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd, (CompileProc *) NULL, 1}, {"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd, (CompileProc *) NULL, 1}, {"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd, (CompileProc *) NULL, 1}, {"break", Tcl_BreakCmd, (Tcl_ObjCmdProc *) NULL, TclCompileBreakCmd, 1}, {"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd, (CompileProc *) NULL, 1}, {"catch", (Tcl_CmdProc *) NULL, Tcl_CatchObjCmd, TclCompileCatchCmd, 1}, {"clock", (Tcl_CmdProc *) NULL, Tcl_ClockObjCmd, (CompileProc *) NULL, 1}, {"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd, (CompileProc *) NULL, 1}, {"continue", Tcl_ContinueCmd, (Tcl_ObjCmdProc *) NULL, TclCompileContinueCmd, 1}, {"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd, (CompileProc *) NULL, 1}, {"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd, (CompileProc *) NULL, 1}, {"exit", (Tcl_CmdProc *) NULL, Tcl_ExitObjCmd, (CompileProc *) NULL, 0}, {"expr", (Tcl_CmdProc *) NULL, Tcl_ExprObjCmd, TclCompileExprCmd, 1}, {"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd, (CompileProc *) NULL, 1}, {"fileevent", Tcl_FileEventCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 1}, {"for", Tcl_ForCmd, (Tcl_ObjCmdProc *) NULL, TclCompileForCmd, 1}, {"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd, TclCompileForeachCmd, 1}, {"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd, (CompileProc *) NULL, 1}, {"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd, (CompileProc *) NULL, 1}, {"if", Tcl_IfCmd, (Tcl_ObjCmdProc *) NULL, TclCompileIfCmd, 1}, {"incr", Tcl_IncrCmd, (Tcl_ObjCmdProc *) NULL, TclCompileIncrCmd, 1}, {"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd, (CompileProc *) NULL, 1}, {"interp", (Tcl_CmdProc *) NULL, Tcl_InterpObjCmd, (CompileProc *) NULL, 1}, {"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd, (CompileProc *) NULL, 1}, {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd, (CompileProc *) NULL, 1}, {"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd, (CompileProc *) NULL, 1}, {"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd, (CompileProc *) NULL, 1}, {"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd, (CompileProc *) NULL, 1}, {"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd, (CompileProc *) NULL, 1}, {"load", Tcl_LoadCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0}, {"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd, (CompileProc *) NULL, 1}, {"lreplace", (Tcl_CmdProc *) NULL, Tcl_LreplaceObjCmd, (CompileProc *) NULL, 1}, {"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd, (CompileProc *) NULL, 1}, {"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd, (CompileProc *) NULL, 1}, {"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd, (CompileProc *) NULL, 1}, {"package", Tcl_PackageCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 1}, {"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd, (CompileProc *) NULL, 1}, {"regexp", Tcl_RegexpCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 1}, {"regsub", Tcl_RegsubCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 1}, {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd, (CompileProc *) NULL, 1}, {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd, (CompileProc *) NULL, 1}, {"scan", Tcl_ScanCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 1}, {"set", Tcl_SetCmd, (Tcl_ObjCmdProc *) NULL, TclCompileSetCmd, 1}, {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd, (CompileProc *) NULL, 1}, {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd, (CompileProc *) NULL, 1}, {"subst", Tcl_SubstCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 1}, {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd, (CompileProc *) NULL, 1}, {"trace", Tcl_TraceCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 1}, {"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd, (CompileProc *) NULL, 1}, {"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd, (CompileProc *) NULL, 1}, {"upvar", (Tcl_CmdProc *) NULL, Tcl_UpvarObjCmd, (CompileProc *) NULL, 1}, {"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd, (CompileProc *) NULL, 1}, {"while", Tcl_WhileCmd, (Tcl_ObjCmdProc *) NULL, TclCompileWhileCmd, 1}, /* * Commands in the UNIX core: */ #ifndef TCL_GENERIC_ONLY {"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd, (CompileProc *) NULL, 1}, {"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd, (CompileProc *) NULL, 0}, {"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd, (CompileProc *) NULL, 1}, {"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd, (CompileProc *) NULL, 1}, {"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd, (CompileProc *) NULL, 1}, {"fconfigure", Tcl_FconfigureCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0}, {"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd, (CompileProc *) NULL, 0}, {"flush", (Tcl_CmdProc *) NULL, Tcl_FlushObjCmd, (CompileProc *) NULL, 1}, {"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd, (CompileProc *) NULL, 1}, {"glob", Tcl_GlobCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0}, {"open", Tcl_OpenCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0}, {"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd, (CompileProc *) NULL, 1}, {"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd, (CompileProc *) NULL, 1}, {"pwd", Tcl_PwdCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0}, {"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd, (CompileProc *) NULL, 1}, {"seek", Tcl_SeekCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 1}, {"socket", Tcl_SocketCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0}, {"tell", Tcl_TellCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 1}, {"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd, (CompileProc *) NULL, 1}, {"update", Tcl_UpdateCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 1}, {"vwait", Tcl_VwaitCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 1}, #ifdef MAC_TCL {"beep", (Tcl_CmdProc *) NULL, Tcl_BeepObjCmd, (CompileProc *) NULL, 0}, {"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0}, {"ls", Tcl_LsCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0}, {"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd, (CompileProc *) NULL, 1}, {"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd, (CompileProc *) NULL, 0}, #else {"exec", Tcl_ExecCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0}, {"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd, (CompileProc *) NULL, 0}, #endif /* MAC_TCL */ #endif /* TCL_GENERIC_ONLY */ {NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0} }; /* *---------------------------------------------------------------------- * * Tcl_CreateInterp -- * * Create a new TCL command interpreter. * * Results: * The return value is a token for the interpreter, which may be * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or * Tcl_DeleteInterp. * * Side effects: * The command interpreter is initialized with an empty variable * table and the built-in commands. * *---------------------------------------------------------------------- */ Tcl_Interp * Tcl_CreateInterp() { register Interp *iPtr; register Command *cmdPtr; register CmdInfo *cmdInfoPtr; union { char c[sizeof(short)]; short s; } order; int i; /* * Panic if someone updated the CallFrame structure without * also updating the Tcl_CallFrame structure (or vice versa). */ if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) { /*NOTREACHED*/ panic("Tcl_CallFrame and CallFrame are not the same size"); } /* * Initialize support for namespaces and create the global namespace * (whose name is ""; an alias is "::"). This also initializes the * Tcl object type table and other object management code. */ TclInitNamespaces(); iPtr = (Interp *) ckalloc(sizeof(Interp)); iPtr->result = iPtr->resultSpace; iPtr->freeProc = 0; iPtr->objResultPtr = Tcl_NewObj(); /* an empty object */ Tcl_IncrRefCount(iPtr->objResultPtr); iPtr->errorLine = 0; Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS); iPtr->numLevels = 0; iPtr->maxNestingDepth = 1000; iPtr->framePtr = NULL; iPtr->varFramePtr = NULL; iPtr->activeTracePtr = NULL; iPtr->returnCode = TCL_OK; iPtr->errorInfo = NULL; iPtr->errorCode = NULL; iPtr->appendResult = NULL; iPtr->appendAvl = 0; iPtr->appendUsed = 0; for (i = 0; i < NUM_REGEXPS; i++) { iPtr->patterns[i] = NULL; iPtr->patLengths[i] = -1; iPtr->regexps[i] = NULL; } Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; iPtr->cmdCount = 0; iPtr->termOffset = 0; iPtr->compileEpoch = 0; iPtr->compiledProcPtr = NULL; iPtr->resolverPtr = NULL; iPtr->evalFlags = 0; iPtr->scriptFile = NULL; iPtr->flags = 0; iPtr->tracePtr = NULL; iPtr->assocData = (Tcl_HashTable *) NULL; iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ Tcl_IncrRefCount(iPtr->emptyObjPtr); iPtr->resultSpace[0] = 0; iPtr->globalNsPtr = NULL; /* force creation of global ns below */ iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace( (Tcl_Interp *) iPtr, "", (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); if (iPtr->globalNsPtr == NULL) { panic("Tcl_CreateInterp: can't create global namespace"); } /* * Initialize support for code compilation. Do this after initializing * namespaces since TclCreateExecEnv will try to reference a Tcl * variable (it links to the Tcl "tcl_traceExec" variable). */ iPtr->execEnvPtr = TclCreateExecEnv((Tcl_Interp *) iPtr); /* * Create the core commands. Do it here, rather than calling * Tcl_CreateCommand, because it's faster (there's no need to check for * a pre-existing command by the same name). If a command has a * Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to * TclInvokeStringCommand. This is an object-based wrapper procedure * that extracts strings, calls the string procedure, and creates an * object for the result. Similarly, if a command has a Tcl_ObjCmdProc * but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand. */ for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { int new; Tcl_HashEntry *hPtr; if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) && (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) { panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n"); } hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, cmdInfoPtr->name, &new); if (new) { cmdPtr = (Command *) ckalloc(sizeof(Command)); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = iPtr->globalNsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = cmdInfoPtr->compileProc; if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) { cmdPtr->proc = TclInvokeObjectCommand; cmdPtr->clientData = (ClientData) cmdPtr; } else { cmdPtr->proc = cmdInfoPtr->proc; cmdPtr->clientData = (ClientData) NULL; } if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { cmdPtr->objProc = TclInvokeStringCommand; cmdPtr->objClientData = (ClientData) cmdPtr; } else { cmdPtr->objProc = cmdInfoPtr->objProc; cmdPtr->objClientData = (ClientData) NULL; } cmdPtr->deleteProc = NULL; cmdPtr->deleteData = (ClientData) NULL; cmdPtr->deleted = 0; cmdPtr->importRefPtr = NULL; Tcl_SetHashValue(hPtr, cmdPtr); } } /* * Initialize/Create "errorInfo" and "errorCode" global vars * (because some part of the C code assume they exists * and we can get a seg fault otherwise (in multiple * interps loading of extensions for instance) --dl) */ /* * We can't assume that because we initialize * the variables here, they won't be unset later. * so we had 2 choices: * + Check every place where a GetVar of those is used * and the NULL result is not checked (like in tclLoad.c) * + Make SetVar,... NULL friendly * We choosed the second option because : * + It is easy and low cost to check for NULL pointer before * calling strlen() * + It can be helpfull to other people using those API * + Passing a NULL value to those closest 'meaning' is empty string * (specially with the new objects where 0 bytes strings are ok) * So the following init is commented out: -- dl */ /* (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, "", TCL_GLOBAL_ONLY); (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, "NONE", TCL_GLOBAL_ONLY); */ #ifndef TCL_GENERIC_ONLY TclSetupEnv((Tcl_Interp *) iPtr); #endif /* * Do Multiple/Safe Interps Tcl init stuff */ (void) TclInterpInit((Tcl_Interp *)iPtr); /* * Set up variables such as tcl_version. */ TclPlatformInit((Tcl_Interp *)iPtr); Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, TclPrecTraceProc, (ClientData) NULL); /* * Compute the byte order of this machine. */ order.s = 1; Tcl_SetVar2((Tcl_Interp *) iPtr, "tcl_platform", "byteOrder", (order.c[0] == 1) ? "littleEndian" : "bigEndian", TCL_GLOBAL_ONLY); /* * Register Tcl's version number. */ Tcl_PkgProvide((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION); return (Tcl_Interp *) iPtr; } /* *---------------------------------------------------------------------- * * TclHideUnsafeCommands -- * * Hides base commands that are not marked as safe from this * interpreter. * * Results: * TCL_OK if it succeeds, TCL_ERROR else. * * Side effects: * Hides functionality in an interpreter. * *---------------------------------------------------------------------- */ int TclHideUnsafeCommands(interp) Tcl_Interp *interp; /* Hide commands in this interpreter. */ { register CmdInfo *cmdInfoPtr; if (interp == (Tcl_Interp *) NULL) { return TCL_ERROR; } for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { if (!cmdInfoPtr->isSafe) { Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); } } return TCL_OK; } /* *-------------------------------------------------------------- * * Tcl_CallWhenDeleted -- * * Arrange for a procedure to be called before a given * interpreter is deleted. The procedure is called as soon * as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is * called on an interpreter that has already been deleted, * the procedure will be called when the last Tcl_Release is * done on the interpreter. * * Results: * None. * * Side effects: * When Tcl_DeleteInterp is invoked to delete interp, * proc will be invoked. See the manual entry for * details. * *-------------------------------------------------------------- */ void Tcl_CallWhenDeleted(interp, proc, clientData) Tcl_Interp *interp; /* Interpreter to watch. */ Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter * is about to be deleted. */ ClientData clientData; /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; static int assocDataCounter = 0; int new; char buffer[128]; AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); Tcl_HashEntry *hPtr; sprintf(buffer, "Assoc Data Key #%d", assocDataCounter); assocDataCounter++; if (iPtr->assocData == (Tcl_HashTable *) NULL) { iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new); dPtr->proc = proc; dPtr->clientData = clientData; Tcl_SetHashValue(hPtr, dPtr); } /* *-------------------------------------------------------------- * * Tcl_DontCallWhenDeleted -- * * Cancel the arrangement for a procedure to be called when * a given interpreter is deleted. * * Results: * None. * * Side effects: * If proc and clientData were previously registered as a * callback via Tcl_CallWhenDeleted, they are unregistered. * If they weren't previously registered then nothing * happens. * *-------------------------------------------------------------- */ void Tcl_DontCallWhenDeleted(interp, proc, clientData) Tcl_Interp *interp; /* Interpreter to watch. */ Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter * is about to be deleted. */ ClientData clientData; /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; Tcl_HashTable *hTablePtr; Tcl_HashSearch hSearch; Tcl_HashEntry *hPtr; AssocData *dPtr; hTablePtr = iPtr->assocData; if (hTablePtr == (Tcl_HashTable *) NULL) { return; } for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { dPtr = (AssocData *) Tcl_GetHashValue(hPtr); if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { ckfree((char *) dPtr); Tcl_DeleteHashEntry(hPtr); return; } } } /* *---------------------------------------------------------------------- * * Tcl_SetAssocData -- * * Creates a named association between user-specified data, a delete * function and this interpreter. If the association already exists * the data is overwritten with the new data. The delete function will * be invoked when the interpreter is deleted. * * Results: * None. * * Side effects: * Sets the associated data, creates the association if needed. * *---------------------------------------------------------------------- */ void Tcl_SetAssocData(interp, name, proc, clientData) Tcl_Interp *interp; /* Interpreter to associate with. */ char *name; /* Name for association. */ Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is * about to be deleted. */ ClientData clientData; /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; Tcl_HashEntry *hPtr; int new; if (iPtr->assocData == (Tcl_HashTable *) NULL) { iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new); if (new == 0) { dPtr = (AssocData *) Tcl_GetHashValue(hPtr); } else { dPtr = (AssocData *) ckalloc(sizeof(AssocData)); } dPtr->proc = proc; dPtr->clientData = clientData; Tcl_SetHashValue(hPtr, dPtr); } /* *---------------------------------------------------------------------- * * Tcl_DeleteAssocData -- * * Deletes a named association of user-specified data with * the specified interpreter. * * Results: * None. * * Side effects: * Deletes the association. * *---------------------------------------------------------------------- */ void Tcl_DeleteAssocData(interp, name) Tcl_Interp *interp; /* Interpreter to associate with. */ char *name; /* Name of association. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; Tcl_HashEntry *hPtr; if (iPtr->assocData == (Tcl_HashTable *) NULL) { return; } hPtr = Tcl_FindHashEntry(iPtr->assocData, name); if (hPtr == (Tcl_HashEntry *) NULL) { return; } dPtr = (AssocData *) Tcl_GetHashValue(hPtr); if (dPtr->proc != NULL) { (dPtr->proc) (dPtr->clientData, interp); } ckfree((char *) dPtr); Tcl_DeleteHashEntry(hPtr); } /* *---------------------------------------------------------------------- * * Tcl_GetAssocData -- * * Returns the client data associated with this name in the * specified interpreter. * * Results: * The client data in the AssocData record denoted by the named * association, or NULL. * * Side effects: * None. * *---------------------------------------------------------------------- */ ClientData Tcl_GetAssocData(interp, name, procPtr) Tcl_Interp *interp; /* Interpreter associated with. */ char *name; /* Name of association. */ Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address * of current deletion callback. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; Tcl_HashEntry *hPtr; if (iPtr->assocData == (Tcl_HashTable *) NULL) { return (ClientData) NULL; } hPtr = Tcl_FindHashEntry(iPtr->assocData, name); if (hPtr == (Tcl_HashEntry *) NULL) { return (ClientData) NULL; } dPtr = (AssocData *) Tcl_GetHashValue(hPtr); if (procPtr != (Tcl_InterpDeleteProc **) NULL) { *procPtr = dPtr->proc; } return dPtr->clientData; } /* *---------------------------------------------------------------------- * * DeleteInterpProc -- * * Helper procedure to delete an interpreter. This procedure is * called when the last call to Tcl_Preserve on this interpreter * is matched by a call to Tcl_Release. The procedure cleans up * all resources used in the interpreter and calls all currently * registered interpreter deletion callbacks. * * Results: * None. * * Side effects: * Whatever the interpreter deletion callbacks do. Frees resources * used by the interpreter. * *---------------------------------------------------------------------- */ static void DeleteInterpProc(interp) Tcl_Interp *interp; /* Interpreter to delete. */ { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *hTablePtr; AssocData *dPtr; ResolverScheme *resPtr, *nextResPtr; int i; /* * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. */ if (iPtr->numLevels > 0) { panic("DeleteInterpProc called with active evals"); } /* * The interpreter should already be marked deleted; otherwise how * did we get here? */ if (!(iPtr->flags & DELETED)) { panic("DeleteInterpProc called on interpreter not marked deleted"); } /* * Dismantle everything in the global namespace except for the * "errorInfo" and "errorCode" variables. These remain until the * namespace is actually destroyed, in case any errors occur. * * Dismantle the namespace here, before we clear the assocData. If any * background errors occur here, they will be deleted below. */ TclTeardownNamespace(iPtr->globalNsPtr); /* * Tear down the math function table. */ for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { ckfree((char *) Tcl_GetHashValue(hPtr)); } Tcl_DeleteHashTable(&iPtr->mathFuncTable); /* * Invoke deletion callbacks; note that a callback can create new * callbacks, so we iterate. */ while (iPtr->assocData != (Tcl_HashTable *) NULL) { hTablePtr = iPtr->assocData; iPtr->assocData = (Tcl_HashTable *) NULL; for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); hPtr != NULL; hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { dPtr = (AssocData *) Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); if (dPtr->proc != NULL) { (*dPtr->proc)(dPtr->clientData, interp); } ckfree((char *) dPtr); } Tcl_DeleteHashTable(hTablePtr); ckfree((char *) hTablePtr); } /* * Finish deleting the global namespace. */ Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); /* * Free up the result *after* deleting variables, since variable * deletion could have transferred ownership of the result string * to Tcl. */ Tcl_FreeResult(interp); interp->result = NULL; Tcl_DecrRefCount(iPtr->objResultPtr); iPtr->objResultPtr = NULL; if (iPtr->errorInfo != NULL) { ckfree(iPtr->errorInfo); iPtr->errorInfo = NULL; } if (iPtr->errorCode != NULL) { ckfree(iPtr->errorCode); iPtr->errorCode = NULL; } if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); iPtr->appendResult = NULL; } for (i = 0; i < NUM_REGEXPS; i++) { if (iPtr->patterns[i] == NULL) { break; } ckfree(iPtr->patterns[i]); ckfree((char *) iPtr->regexps[i]); iPtr->regexps[i] = NULL; } TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { Trace *nextPtr = iPtr->tracePtr->nextPtr; ckfree((char *) iPtr->tracePtr); iPtr->tracePtr = nextPtr; } if (iPtr->execEnvPtr != NULL) { TclDeleteExecEnv(iPtr->execEnvPtr); } Tcl_DecrRefCount(iPtr->emptyObjPtr); iPtr->emptyObjPtr = NULL; resPtr = iPtr->resolverPtr; while (resPtr) { nextResPtr = resPtr->nextPtr; ckfree(resPtr->name); ckfree((char *) resPtr); resPtr = nextResPtr; } ckfree((char *) iPtr); } /* *---------------------------------------------------------------------- * * Tcl_InterpDeleted -- * * Returns nonzero if the interpreter has been deleted with a call * to Tcl_DeleteInterp. * * Results: * Nonzero if the interpreter is deleted, zero otherwise. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_InterpDeleted(interp) Tcl_Interp *interp; { return (((Interp *) interp)->flags & DELETED) ? 1 : 0; } /* *---------------------------------------------------------------------- * * Tcl_DeleteInterp -- * * Ensures that the interpreter will be deleted eventually. If there * are no Tcl_Preserve calls in effect for this interpreter, it is * deleted immediately, otherwise the interpreter is deleted when * the last Tcl_Preserve is matched by a call to Tcl_Release. In either * case, the procedure runs the currently registered deletion callbacks. * * Results: * None. * * Side effects: * The interpreter is marked as deleted. The caller may still use it * safely if there are calls to Tcl_Preserve in effect for the * interpreter, but further calls to Tcl_Eval etc in this interpreter * will fail. * *---------------------------------------------------------------------- */ void Tcl_DeleteInterp(interp) Tcl_Interp *interp; /* Token for command interpreter (returned * by a previous call to Tcl_CreateInterp). */ { Interp *iPtr = (Interp *) interp; /* * If the interpreter has already been marked deleted, just punt. */ if (iPtr->flags & DELETED) { return; } /* * Mark the interpreter as deleted. No further evals will be allowed. */ iPtr->flags |= DELETED; /* * Ensure that the interpreter is eventually deleted. */ Tcl_EventuallyFree((ClientData) interp, (Tcl_FreeProc *) DeleteInterpProc); } /* *---------------------------------------------------------------------- * * HiddenCmdsDeleteProc -- * * Called on interpreter deletion to delete all the hidden * commands in an interpreter. * * Results: * None. * * Side effects: * Frees up memory. * *---------------------------------------------------------------------- */ static void HiddenCmdsDeleteProc(clientData, interp) ClientData clientData; /* The hidden commands hash table. */ Tcl_Interp *interp; /* The interpreter being deleted. */ { Tcl_HashTable *hiddenCmdTblPtr; Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; Command *cmdPtr; hiddenCmdTblPtr = (Tcl_HashTable *) clientData; for (hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch); hPtr != NULL; hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch)) { /* * Cannot use Tcl_DeleteCommand because (a) the command is not * in the command hash table, and (b) that table has already been * deleted above. Hence we emulate what it does, below. */ cmdPtr = (Command *) Tcl_GetHashValue(hPtr); /* * The code here is tricky. We can't delete the hash table entry * before invoking the deletion callback because there are cases * where the deletion callback needs to invoke the command (e.g. * object systems such as OTcl). However, this means that the * callback could try to delete or rename the command. The deleted * flag allows us to detect these cases and skip nested deletes. */ if (cmdPtr->deleted) { /* * Another deletion is already in progress. Remove the hash * table entry now, but don't invoke a callback or free the * command structure. */ Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; continue; } cmdPtr->deleted = 1; if (cmdPtr->deleteProc != NULL) { (*cmdPtr->deleteProc)(cmdPtr->deleteData); } /* * Bump the command epoch counter. This will invalidate all cached * references that refer to this command. */ cmdPtr->cmdEpoch++; /* * Don't use hPtr to delete the hash entry here, because it's * possible that the deletion callback renamed the command. * Instead, use cmdPtr->hptr, and make sure that no-one else * has already deleted the hash entry. */ if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); } /* * Now free the Command structure, unless there is another reference * to it from a CmdName Tcl object in some ByteCode code * sequence. In that case, delay the cleanup until all references * are either discarded (when a ByteCode is freed) or replaced by a * new reference (when a cached CmdName Command reference is found * to be invalid and TclExecuteByteCode looks up the command in the * command hashtable). */ TclCleanupCommand(cmdPtr); } Tcl_DeleteHashTable(hiddenCmdTblPtr); ckfree((char *) hiddenCmdTblPtr); } /* *---------------------------------------------------------------------- * * Tcl_HideCommand -- * * Makes a command hidden so that it cannot be invoked from within * an interpreter, only from within an ancestor. * * Results: * A standard Tcl result; also leaves a message in interp->result * if an error occurs. * * Side effects: * Removes a command from the command table and create an entry * into the hidden command table under the specified token name. * *---------------------------------------------------------------------- */ int Tcl_HideCommand(interp, cmdName, hiddenCmdToken) Tcl_Interp *interp; /* Interpreter in which to hide command. */ char *cmdName; /* Name of command to hide. */ char *hiddenCmdToken; /* Token name of the to-be-hidden command. */ { Interp *iPtr = (Interp *) interp; Tcl_Command cmd; Command *cmdPtr; Tcl_HashTable *hTblPtr; Tcl_HashEntry *hPtr; int new; if (iPtr->flags & DELETED) { /* * The interpreter is being deleted. Do not create any new * structures, because it is not safe to modify the interpreter. */ return TCL_ERROR; } /* * Disallow hiding of commands that are currently in a namespace or * renaming (as part of hiding) into a namespace. * * (because the current implementation with a single global table * and the needed uniqueness of names cause problems with namespaces) * * we don't need to check for "::" in cmdName because the real check is * on the nsPtr below. * * hiddenCmdToken is just a string which is not interpreted in any way. * It may contain :: but the string is not interpreted as a namespace * qualifier command name. Thus, hiding foo::bar to foo::bar and then * trying to expose or invoke ::foo::bar will NOT work; but if the * application always uses the same strings it will get consistent * behaviour. * * But as we currently limit ourselves to the global namespace only * for the source, in order to avoid potential confusion, * lets prevent "::" in the token too. --dl */ if (strstr(hiddenCmdToken, "::") != NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot use namespace qualifiers as hidden command", "token (rename)", (char *) NULL); return TCL_ERROR; } /* * Find the command to hide. An error is returned if cmdName can't * be found. Look up the command only from the global namespace. * Full path of the command must be given if using namespaces. */ cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); if (cmd == (Tcl_Command) NULL) { return TCL_ERROR; } cmdPtr = (Command *) cmd; /* * Check that the command is really in global namespace */ if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can only hide global namespace commands", " (use rename then hide)", (char *) NULL); return TCL_ERROR; } /* * Initialize the hidden command table if necessary. */ hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds", NULL); if (hTblPtr == (Tcl_HashTable *) NULL) { hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); Tcl_SetAssocData(interp, "tclHiddenCmds", HiddenCmdsDeleteProc, (ClientData) hTblPtr); } /* * It is an error to move an exposed command to a hidden command with * hiddenCmdToken if a hidden command with the name hiddenCmdToken already * exists. */ hPtr = Tcl_CreateHashEntry(hTblPtr, hiddenCmdToken, &new); if (!new) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "hidden command named \"", hiddenCmdToken, "\" already exists", (char *) NULL); return TCL_ERROR; } /* * Nb : This code is currently 'like' a rename to a specialy set apart * name table. Changes here and in TclRenameCommand must * be kept in synch untill the common parts are actually * factorized out. */ /* * Remove the hash entry for the command from the interpreter command * table. This is like deleting the command, so bump its command epoch; * this invalidates any cached references that point to the command. */ if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = (Tcl_HashEntry *) NULL; cmdPtr->cmdEpoch++; } /* * Now link the hash table entry with the command structure. * We ensured above that the nsPtr was right. */ cmdPtr->hPtr = hPtr; Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); /* * If the command being hidden has a compile procedure, increment the * interpreter's compileEpoch to invalidate its compiled code. This * makes sure that we don't later try to execute old code compiled with * command-specific (i.e., inline) bytecodes for the now-hidden * command. This field is checked in Tcl_EvalObj and ObjInterpProc, * and code whose compilation epoch doesn't match is recompiled. */ if (cmdPtr->compileProc != NULL) { iPtr->compileEpoch++; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ExposeCommand -- * * Makes a previously hidden command callable from inside the * interpreter instead of only by its ancestors. * * Results: * A standard Tcl result. If an error occurs, a message is left * in interp->result. * * Side effects: * Moves commands from one hash table to another. * *---------------------------------------------------------------------- */ int Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) Tcl_Interp *interp; /* Interpreter in which to make command * callable. */ char *hiddenCmdToken; /* Name of hidden command. */ char *cmdName; /* Name of to-be-exposed command. */ { Interp *iPtr = (Interp *) interp; Command *cmdPtr; Namespace *nsPtr; Tcl_HashEntry *hPtr; Tcl_HashTable *hTblPtr; int new; if (iPtr->flags & DELETED) { /* * The interpreter is being deleted. Do not create any new * structures, because it is not safe to modify the interpreter. */ return TCL_ERROR; } /* * Check that we have a regular name for the command * (that the user is not trying to do an expose and a rename * (to another namespace) at the same time) */ if (strstr(cmdName, "::") != NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can not expose to a namespace ", "(use expose to toplevel, then rename)", (char *) NULL); return TCL_ERROR; } /* * Find the hash table for the hidden commands; error out if there * is none. */ hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds", NULL); if (hTblPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown hidden command \"", hiddenCmdToken, "\"", (char *) NULL); return TCL_ERROR; } /* * Get the command from the hidden command table: */ hPtr = Tcl_FindHashEntry(hTblPtr, hiddenCmdToken); if (hPtr == (Tcl_HashEntry *) NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown hidden command \"", hiddenCmdToken, "\"", (char *) NULL); return TCL_ERROR; } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); /* * Check that we have a true global namespace * command (enforced by Tcl_HideCommand() but let's double * check. (If it was not, we would not really know how to * handle it). */ if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { /* * This case is theoritically impossible, * we might rather panic() than 'nicely' erroring out ? */ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "trying to expose a non global command name space command", (char *) NULL); return TCL_ERROR; } /* This is the global table */ nsPtr = cmdPtr->nsPtr; /* * It is an error to overwrite an existing exposed command as a result * of exposing a previously hidden command. */ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new); if (!new) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "exposed command \"", cmdName, "\" already exists", (char *) NULL); return TCL_ERROR; } /* * Remove the hash entry for the command from the interpreter hidden * command table. */ if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; } /* * Now link the hash table entry with the command structure. * This is like creating a new command, so deal with any shadowing * of commands in the global namespace. */ cmdPtr->hPtr = hPtr; Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); /* * Not needed as we are only in the global namespace * (but would be needed again if we supported namespace command hiding) * * TclResetShadowedCmdRefs(interp, cmdPtr); */ /* * If the command being exposed has a compile procedure, increment * interpreter's compileEpoch to invalidate its compiled code. This * makes sure that we don't later try to execute old code compiled * assuming the command is hidden. This field is checked in Tcl_EvalObj * and ObjInterpProc, and code whose compilation epoch doesn't match is * recompiled. */ if (cmdPtr->compileProc != NULL) { iPtr->compileEpoch++; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_CreateCommand -- * * Define a new command in a command table. * * Results: * The return value is a token for the command, which can * be used in future calls to Tcl_GetCommandName. * * Side effects: * If a command named cmdName already exists for interp, it is deleted. * In the future, when cmdName is seen as the name of a command by * Tcl_Eval, proc will be called. To support the bytecode interpreter, * the command is created with a wrapper Tcl_ObjCmdProc * (TclInvokeStringCommand) that eventially calls proc. When the * command is deleted from the table, deleteProc will be called. * See the manual entry for details on the calling sequence. * *---------------------------------------------------------------------- */ Tcl_Command Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) Tcl_Interp *interp; /* Token for command interpreter returned by * a previous call to Tcl_CreateInterp. */ char *cmdName; /* Name of command. If it contains namespace * qualifiers, the new command is put in the * specified namespace; otherwise it is put * in the global namespace. */ Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */ ClientData clientData; /* Arbitrary value passed to string proc. */ Tcl_CmdDeleteProc *deleteProc; /* If not NULL, gives a procedure to call * when this command is deleted. */ { Interp *iPtr = (Interp *) interp; ImportRef *oldRefPtr = NULL; Namespace *nsPtr, *dummy1, *dummy2; Command *cmdPtr, *refCmdPtr; Tcl_HashEntry *hPtr; char *tail; int new, result; ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { /* * The interpreter is being deleted. Don't create any new * commands; it's not safe to muck with the interpreter anymore. */ return (Tcl_Command) NULL; } /* * Determine where the command should reside. If its name contains * namespace qualifiers, we put it in the specified namespace; * otherwise, we always put it in the global namespace. */ if (strstr(cmdName, "::") != NULL) { result = TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); if ((result != TCL_OK) || (nsPtr == NULL) || (tail == NULL)) { return (Tcl_Command) NULL; } } else { nsPtr = iPtr->globalNsPtr; tail = cmdName; } hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); if (!new) { /* * Command already exists. Delete the old one. * Be careful to preserve any existing import links so we can * restore them down below. That way, you can redefine a * command and its import status will remain intact. */ cmdPtr = (Command *) Tcl_GetHashValue(hPtr); oldRefPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = NULL; Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); if (!new) { /* * If the deletion callback recreated the command, just throw * away the new command (if we try to delete it again, we * could get stuck in an infinite loop). */ ckfree((char*) cmdPtr); } } cmdPtr = (Command *) ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = (CompileProc *) NULL; cmdPtr->objProc = TclInvokeStringCommand; cmdPtr->objClientData = (ClientData) cmdPtr; cmdPtr->proc = proc; cmdPtr->clientData = clientData; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; cmdPtr->deleted = 0; cmdPtr->importRefPtr = NULL; /* * Plug in any existing import references found above. Be sure * to update all of these references to point to the new command. */ if (oldRefPtr != NULL) { cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { refCmdPtr = oldRefPtr->importedCmdPtr; dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; } } /* * We just created a command, so in its namespace and all of its parent * namespaces, it may shadow global commands with the same name. If any * shadowed commands are found, invalidate all cached command references * in the affected namespaces. */ TclResetShadowedCmdRefs(interp, cmdPtr); return (Tcl_Command) cmdPtr; } /* *---------------------------------------------------------------------- * * Tcl_CreateObjCommand -- * * Define a new object-based command in a command table. * * Results: * The return value is a token for the command, which can * be used in future calls to Tcl_NameOfCommand. * * Side effects: * If no command named "cmdName" already exists for interp, one is * created. Otherwise, if a command does exist, then if the * object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume * Tcl_CreateCommand was called previously for the same command and * just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we * delete the old command. * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based * Tcl_ObjCmdProc proc will be called. When the command is deleted from * the table, deleteProc will be called. See the manual entry for * details on the calling sequence. * *---------------------------------------------------------------------- */ Tcl_Command Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) Tcl_Interp *interp; /* Token for command interpreter (returned * by previous call to Tcl_CreateInterp). */ char *cmdName; /* Name of command. If it contains namespace * qualifiers, the new command is put in the * specified namespace; otherwise it is put * in the global namespace. */ Tcl_ObjCmdProc *proc; /* Object-based procedure to associate with * name. */ ClientData clientData; /* Arbitrary value to pass to object * procedure. */ Tcl_CmdDeleteProc *deleteProc; /* If not NULL, gives a procedure to call * when this command is deleted. */ { Interp *iPtr = (Interp *) interp; ImportRef *oldRefPtr = NULL; Namespace *nsPtr, *dummy1, *dummy2; Command *cmdPtr, *refCmdPtr; Tcl_HashEntry *hPtr; char *tail; int new, result; ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { /* * The interpreter is being deleted. Don't create any new * commands; it's not safe to muck with the interpreter anymore. */ return (Tcl_Command) NULL; } /* * Determine where the command should reside. If its name contains * namespace qualifiers, we put it in the specified namespace; * otherwise, we always put it in the global namespace. */ if (strstr(cmdName, "::") != NULL) { result = TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); if ((result != TCL_OK) || (nsPtr == NULL) || (tail == NULL)) { return (Tcl_Command) NULL; } } else { nsPtr = iPtr->globalNsPtr; tail = cmdName; } hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); if (!new) { cmdPtr = (Command *) Tcl_GetHashValue(hPtr); /* * Command already exists. If its object-based Tcl_ObjCmdProc is * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the * argument "proc". Otherwise, we delete the old command. */ if (cmdPtr->objProc == TclInvokeStringCommand) { cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; return (Tcl_Command) cmdPtr; } /* * Otherwise, we delete the old command. Be careful to preserve * any existing import links so we can restore them down below. * That way, you can redefine a command and its import status * will remain intact. */ oldRefPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = NULL; Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); if (!new) { /* * If the deletion callback recreated the command, just throw * away the new command (if we try to delete it again, we * could get stuck in an infinite loop). */ ckfree((char *) Tcl_GetHashValue(hPtr)); } } cmdPtr = (Command *) ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = (CompileProc *) NULL; cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; cmdPtr->proc = TclInvokeObjectCommand; cmdPtr->clientData = (ClientData) cmdPtr; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; cmdPtr->deleted = 0; cmdPtr->importRefPtr = NULL; /* * Plug in any existing import references found above. Be sure * to update all of these references to point to the new command. */ if (oldRefPtr != NULL) { cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { refCmdPtr = oldRefPtr->importedCmdPtr; dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; } } /* * We just created a command, so in its namespace and all of its parent * namespaces, it may shadow global commands with the same name. If any * shadowed commands are found, invalidate all cached command references * in the affected namespaces. */ TclResetShadowedCmdRefs(interp, cmdPtr); return (Tcl_Command) cmdPtr; } /* *---------------------------------------------------------------------- * * TclInvokeStringCommand -- * * "Wrapper" Tcl_ObjCmdProc used to call an existing string-based * Tcl_CmdProc if no object-based procedure exists for a command. A * pointer to this procedure is stored as the Tcl_ObjCmdProc in a * Command structure. It simply turns around and calls the string * Tcl_CmdProc in the Command structure. * * Results: * A standard Tcl object result value. * * Side effects: * Besides those side effects of the called Tcl_CmdProc, * TclInvokeStringCommand allocates and frees storage. * *---------------------------------------------------------------------- */ int TclInvokeStringCommand(clientData, interp, objc, objv) ClientData clientData; /* Points to command's Command structure. */ Tcl_Interp *interp; /* Current interpreter. */ register int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { register Command *cmdPtr = (Command *) clientData; register int i; int result; /* * This procedure generates an argv array for the string arguments. It * starts out with stack-allocated space but uses dynamically-allocated * storage if needed. */ #define NUM_ARGS 20 char *(argStorage[NUM_ARGS]); char **argv = argStorage; /* * Create the string argument array "argv". Make sure argv is large * enough to hold the objc arguments plus 1 extra for the zero * end-of-argv word. * THIS FAILS IF ANY ARGUMENT OBJECT CONTAINS AN EMBEDDED NULL. */ if ((objc + 1) > NUM_ARGS) { argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); } for (i = 0; i < objc; i++) { argv[i] = Tcl_GetStringFromObj(objv[i], (int *) NULL); } argv[objc] = 0; /* * Invoke the command's string-based Tcl_CmdProc. */ result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv); /* * Free the argv array if malloc'ed storage was used. */ if (argv != argStorage) { ckfree((char *) argv); } return result; #undef NUM_ARGS } /* *---------------------------------------------------------------------- * * TclInvokeObjectCommand -- * * "Wrapper" Tcl_CmdProc used to call an existing object-based * Tcl_ObjCmdProc if no string-based procedure exists for a command. * A pointer to this procedure is stored as the Tcl_CmdProc in a * Command structure. It simply turns around and calls the object * Tcl_ObjCmdProc in the Command structure. * * Results: * A standard Tcl string result value. * * Side effects: * Besides those side effects of the called Tcl_CmdProc, * TclInvokeStringCommand allocates and frees storage. * *---------------------------------------------------------------------- */ int TclInvokeObjectCommand(clientData, interp, argc, argv) ClientData clientData; /* Points to command's Command structure. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ register char **argv; /* Argument strings. */ { Command *cmdPtr = (Command *) clientData; register Tcl_Obj *objPtr; register int i; int length, result; /* * This procedure generates an objv array for object arguments that hold * the argv strings. It starts out with stack-allocated space but uses * dynamically-allocated storage if needed. */ #define NUM_ARGS 20 Tcl_Obj *(argStorage[NUM_ARGS]); register Tcl_Obj **objv = argStorage; /* * Create the object argument array "objv". Make sure objv is large * enough to hold the objc arguments plus 1 extra for the zero * end-of-objv word. */ if ((argc + 1) > NUM_ARGS) { objv = (Tcl_Obj **) ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *)); } for (i = 0; i < argc; i++) { length = strlen(argv[i]); TclNewObj(objPtr); TclInitStringRep(objPtr, argv[i], length); Tcl_IncrRefCount(objPtr); objv[i] = objPtr; } objv[argc] = 0; /* * Invoke the command's object-based Tcl_ObjCmdProc. */ result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv); /* * Move the interpreter's object result to the string result, * then reset the object result. * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULL BYTES. */ Tcl_SetResult(interp, TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), TCL_VOLATILE); /* * Decrement the ref counts for the argument objects created above, * then free the objv array if malloc'ed storage was used. */ for (i = 0; i < argc; i++) { objPtr = objv[i]; Tcl_DecrRefCount(objPtr); } if (objv != argStorage) { ckfree((char *) objv); } return result; #undef NUM_ARGS } /* *---------------------------------------------------------------------- * * TclRenameCommand -- * * Called to give an existing Tcl command a different name. Both the * old command name and the new command name can have "::" namespace * qualifiers. If the new command has a different namespace context, * the command will be moved to that namespace and will execute in * the context of that new namespace. * * If the new command name is NULL or the null string, the command is * deleted. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * If anything goes wrong, an error message is returned in the * interpreter's result object. * *---------------------------------------------------------------------- */ int TclRenameCommand(interp, oldName, newName) Tcl_Interp *interp; /* Current interpreter. */ char *oldName; /* Existing command name. */ char *newName; /* New command name. */ { Interp *iPtr = (Interp *) interp; char *newTail; Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2; Tcl_Command cmd; Command *cmdPtr; Tcl_HashEntry *hPtr, *oldHPtr; int new, result; /* * Find the existing command. An error is returned if cmdName can't * be found. */ cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL, /*flags*/ 0); cmdPtr = (Command *) cmd; if (cmdPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ", ((newName == NULL)||(*newName == '\0'))? "delete":"rename", " \"", oldName, "\": command doesn't exist", (char *) NULL); return TCL_ERROR; } cmdNsPtr = cmdPtr->nsPtr; /* * If the new command name is NULL or empty, delete the command. Do this * with Tcl_DeleteCommandFromToken, since we already have the command. */ if ((newName == NULL) || (*newName == '\0')) { Tcl_DeleteCommandFromToken(interp, cmd); return TCL_OK; } /* * Make sure that the destination command does not already exist. * The rename operation is like creating a command, so we should * automatically create the containing namespaces just like * Tcl_CreateCommand would. */ result = TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL, (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), &newNsPtr, &dummy1, &dummy2, &newTail); if (result != TCL_OK) { return result; } if ((newNsPtr == NULL) || (newTail == NULL)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't rename to \"", newName, "\": bad command name", (char *) NULL); return TCL_ERROR; } if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't rename to \"", newName, "\": command already exists", (char *) NULL); return TCL_ERROR; } /* * Warning: any changes done in the code here are likely * to be needed in Tcl_HideCommand() code too. * (until the common parts are extracted out) --dl */ /* * Put the command in the new namespace so we can check for an alias * loop. Since we are adding a new command to a namespace, we must * handle any shadowing of the global commands that this might create. */ oldHPtr = cmdPtr->hPtr; hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new); Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = newNsPtr; TclResetShadowedCmdRefs(interp, cmdPtr); /* * Now check for an alias loop. If we detect one, put everything back * the way it was and report the error. */ result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr); if (result != TCL_OK) { Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = oldHPtr; cmdPtr->nsPtr = cmdNsPtr; return result; } /* * The new command name is okay, so remove the command from its * current namespace. This is like deleting the command, so bump * the cmdEpoch to invalidate any cached references to the command. */ Tcl_DeleteHashEntry(oldHPtr); cmdPtr->cmdEpoch++; /* * If the command being renamed has a compile procedure, increment the * interpreter's compileEpoch to invalidate its compiled code. This * makes sure that we don't later try to execute old code compiled for * the now-renamed command. */ if (cmdPtr->compileProc != NULL) { iPtr->compileEpoch++; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SetCommandInfo -- * * Modifies various information about a Tcl command. Note that * this procedure will not change a command's namespace; use * Tcl_RenameCommand to do that. Also, the isNativeObjectProc * member of *infoPtr is ignored. * * Results: * If cmdName exists in interp, then the information at *infoPtr * is stored with the command in place of the current information * and 1 is returned. If the command doesn't exist then 0 is * returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_SetCommandInfo(interp, cmdName, infoPtr) Tcl_Interp *interp; /* Interpreter in which to look * for command. */ char *cmdName; /* Name of desired command. */ Tcl_CmdInfo *infoPtr; /* Where to store information about * command. */ { Tcl_Command cmd; Command *cmdPtr; cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, /*flags*/ 0); if (cmd == (Tcl_Command) NULL) { return 0; } /* * The isNativeObjectProc and nsPtr members of *infoPtr are ignored. */ cmdPtr = (Command *) cmd; cmdPtr->proc = infoPtr->proc; cmdPtr->clientData = infoPtr->clientData; if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { cmdPtr->objProc = TclInvokeStringCommand; cmdPtr->objClientData = (ClientData) cmdPtr; } else { cmdPtr->objProc = infoPtr->objProc; cmdPtr->objClientData = infoPtr->objClientData; } cmdPtr->deleteProc = infoPtr->deleteProc; cmdPtr->deleteData = infoPtr->deleteData; return 1; } /* *---------------------------------------------------------------------- * * Tcl_GetCommandInfo -- * * Returns various information about a Tcl command. * * Results: * If cmdName exists in interp, then *infoPtr is modified to * hold information about cmdName and 1 is returned. If the * command doesn't exist then 0 is returned and *infoPtr isn't * modified. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetCommandInfo(interp, cmdName, infoPtr) Tcl_Interp *interp; /* Interpreter in which to look * for command. */ char *cmdName; /* Name of desired command. */ Tcl_CmdInfo *infoPtr; /* Where to store information about * command. */ { Tcl_Command cmd; Command *cmdPtr; cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, /*flags*/ 0); if (cmd == (Tcl_Command) NULL) { return 0; } /* * Set isNativeObjectProc 1 if objProc was registered by a call to * Tcl_CreateObjCommand. Otherwise set it to 0. */ cmdPtr = (Command *) cmd; infoPtr->isNativeObjectProc = (cmdPtr->objProc != TclInvokeStringCommand); infoPtr->objProc = cmdPtr->objProc; infoPtr->objClientData = cmdPtr->objClientData; infoPtr->proc = cmdPtr->proc; infoPtr->clientData = cmdPtr->clientData; infoPtr->deleteProc = cmdPtr->deleteProc; infoPtr->deleteData = cmdPtr->deleteData; infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; return 1; } /* *---------------------------------------------------------------------- * * Tcl_GetCommandName -- * * Given a token returned by Tcl_CreateCommand, this procedure * returns the current name of the command (which may have changed * due to renaming). * * Results: * The return value is the name of the given command. * * Side effects: * None. * *---------------------------------------------------------------------- */ char * Tcl_GetCommandName(interp, command) Tcl_Interp *interp; /* Interpreter containing the command. */ Tcl_Command command; /* Token for command returned by a previous * call to Tcl_CreateCommand. The command * must not have been deleted. */ { Command *cmdPtr = (Command *) command; if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) { /* * This should only happen if command was "created" after the * interpreter began to be deleted, so there isn't really any * command. Just return an empty string. */ return ""; } return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); } /* *---------------------------------------------------------------------- * * Tcl_GetCommandFullName -- * * Given a token returned by, e.g., Tcl_CreateCommand or * Tcl_FindCommand, this procedure appends to an object the command's * full name, qualified by a sequence of parent namespace names. The * command's fully-qualified name may have changed due to renaming. * * Results: * None. * * Side effects: * The command's fully-qualified name is appended to the string * representation of objPtr. * *---------------------------------------------------------------------- */ void Tcl_GetCommandFullName(interp, command, objPtr) Tcl_Interp *interp; /* Interpreter containing the command. */ Tcl_Command command; /* Token for command returned by a previous * call to Tcl_CreateCommand. The command * must not have been deleted. */ Tcl_Obj *objPtr; /* Points to the object onto which the * command's full name is appended. */ { Interp *iPtr = (Interp *) interp; register Command *cmdPtr = (Command *) command; char *name; /* * Add the full name of the containing namespace, followed by the "::" * separator, and the command name. */ if (cmdPtr != NULL) { if (cmdPtr->nsPtr != NULL) { Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1); if (cmdPtr->nsPtr != iPtr->globalNsPtr) { Tcl_AppendToObj(objPtr, "::", 2); } } if (cmdPtr->hPtr != NULL) { name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); Tcl_AppendToObj(objPtr, name, -1); } } } /* *---------------------------------------------------------------------- * * Tcl_DeleteCommand -- * * Remove the given command from the given interpreter. * * Results: * 0 is returned if the command was deleted successfully. * -1 is returned if there didn't exist a command by that name. * * Side effects: * cmdName will no longer be recognized as a valid command for * interp. * *---------------------------------------------------------------------- */ int Tcl_DeleteCommand(interp, cmdName) Tcl_Interp *interp; /* Token for command interpreter (returned * by a previous Tcl_CreateInterp call). */ char *cmdName; /* Name of command to remove. */ { Tcl_Command cmd; /* * Find the desired command and delete it. */ cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, /*flags*/ 0); if (cmd == (Tcl_Command) NULL) { return -1; } return Tcl_DeleteCommandFromToken(interp, cmd); } /* *---------------------------------------------------------------------- * * Tcl_DeleteCommandFromToken -- * * Removes the given command from the given interpreter. This procedure * resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead * of a command name for efficiency. * * Results: * 0 is returned if the command was deleted successfully. * -1 is returned if there didn't exist a command by that name. * * Side effects: * The command specified by "cmd" will no longer be recognized as a * valid command for "interp". * *---------------------------------------------------------------------- */ int Tcl_DeleteCommandFromToken(interp, cmd) Tcl_Interp *interp; /* Token for command interpreter returned by * a previous call to Tcl_CreateInterp. */ Tcl_Command cmd; /* Token for command to delete. */ { Interp *iPtr = (Interp *) interp; Command *cmdPtr = (Command *) cmd; ImportRef *refPtr, *nextRefPtr; Tcl_Command importCmd; /* * The code here is tricky. We can't delete the hash table entry * before invoking the deletion callback because there are cases * where the deletion callback needs to invoke the command (e.g. * object systems such as OTcl). However, this means that the * callback could try to delete or rename the command. The deleted * flag allows us to detect these cases and skip nested deletes. */ if (cmdPtr->deleted) { /* * Another deletion is already in progress. Remove the hash * table entry now, but don't invoke a callback or free the * command structure. */ Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; return 0; } /* * If the command being deleted has a compile procedure, increment the * interpreter's compileEpoch to invalidate its compiled code. This * makes sure that we don't later try to execute old code compiled with * command-specific (i.e., inline) bytecodes for the now-deleted * command. This field is checked in Tcl_EvalObj and ObjInterpProc, and * code whose compilation epoch doesn't match is recompiled. */ if (cmdPtr->compileProc != NULL) { iPtr->compileEpoch++; } cmdPtr->deleted = 1; if (cmdPtr->deleteProc != NULL) { /* * Delete the command's client data. If this was an imported command * created when a command was imported into a namespace, this client * data will be a pointer to a ImportedCmdData structure describing * the "real" command that this imported command refers to. */ (*cmdPtr->deleteProc)(cmdPtr->deleteData); } /* * Bump the command epoch counter. This will invalidate all cached * references that point to this command. */ cmdPtr->cmdEpoch++; /* * If this command was imported into other namespaces, then imported * commands were created that refer back to this command. Delete these * imported commands now. */ for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; refPtr = nextRefPtr) { nextRefPtr = refPtr->nextPtr; importCmd = (Tcl_Command) refPtr->importedCmdPtr; Tcl_DeleteCommandFromToken(interp, importCmd); } /* * Don't use hPtr to delete the hash entry here, because it's * possible that the deletion callback renamed the command. * Instead, use cmdPtr->hptr, and make sure that no-one else * has already deleted the hash entry. */ if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); } /* * Mark the Command structure as no longer valid. This allows * TclExecuteByteCode to recognize when a Command has logically been * deleted and a pointer to this Command structure cached in a CmdName * object is invalid. TclExecuteByteCode will look up the command again * in the interpreter's command hashtable. */ cmdPtr->objProc = NULL; /* * Now free the Command structure, unless there is another reference to * it from a CmdName Tcl object in some ByteCode code sequence. In that * case, delay the cleanup until all references are either discarded * (when a ByteCode is freed) or replaced by a new reference (when a * cached CmdName Command reference is found to be invalid and * TclExecuteByteCode looks up the command in the command hashtable). */ TclCleanupCommand(cmdPtr); return 0; } /* *---------------------------------------------------------------------- * * TclCleanupCommand -- * * This procedure frees up a Command structure unless it is still * referenced from an interpreter's command hashtable or from a CmdName * Tcl object representing the name of a command in a ByteCode * instruction sequence. * * Results: * None. * * Side effects: * Memory gets freed unless a reference to the Command structure still * exists. In that case the cleanup is delayed until the command is * deleted or when the last ByteCode referring to it is freed. * *---------------------------------------------------------------------- */ void TclCleanupCommand(cmdPtr) register Command *cmdPtr; /* Points to the Command structure to * be freed. */ { cmdPtr->refCount--; if (cmdPtr->refCount <= 0) { ckfree((char *) cmdPtr); } } /* *---------------------------------------------------------------------- * * Tcl_Eval -- * * Execute a Tcl command in a string. * * Results: * The return value is one of the return codes defined in tcl.h * (such as TCL_OK), and interp->result contains a string value * to supplement the return code. The value of interp->result * will persist only until the next call to Tcl_Eval or Tcl_EvalObj: * you must copy it or lose it! * * Side effects: * The string is compiled to produce a ByteCode object that holds the * command's bytecode instructions. However, this ByteCode object is * lost after executing the command. The command's execution will * almost certainly have side effects. interp->termOffset is set to the * offset of the character in "string" just after the last one * successfully compiled or executed. * *---------------------------------------------------------------------- */ int Tcl_Eval(interp, string) Tcl_Interp *interp; /* Token for command interpreter (returned * by previous call to Tcl_CreateInterp). */ char *string; /* Pointer to TCL command to execute. */ { register Tcl_Obj *cmdPtr; int length = strlen(string); int result; if (length > 0) { /* * Initialize a Tcl object from the command string. */ TclNewObj(cmdPtr); TclInitStringRep(cmdPtr, string, length); Tcl_IncrRefCount(cmdPtr); /* * Compile and execute the bytecodes. */ result = Tcl_EvalObj(interp, cmdPtr); /* * Move the interpreter's object result to the string result, * then reset the object result. * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. */ Tcl_SetResult(interp, TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), TCL_VOLATILE); /* * Discard the Tcl object created to hold the command and its code. */ Tcl_DecrRefCount(cmdPtr); } else { /* * An empty string. Just reset the interpreter's result. */ Tcl_ResetResult(interp); result = TCL_OK; } return result; } /* *---------------------------------------------------------------------- * * Tcl_EvalObj -- * * Execute Tcl commands stored in a Tcl object. These commands are * compiled into bytecodes if necessary. * * Results: * The return value is one of the return codes defined in tcl.h * (such as TCL_OK), and the interpreter's result contains a value * to supplement the return code. * * Side effects: * The object is converted, if necessary, to a ByteCode object that * holds the bytecode instructions for the commands. Executing the * commands will almost certainly have side effects that depend * on those commands. * * Just as in Tcl_Eval, interp->termOffset is set to the offset of the * last character executed in the objPtr's string. * *---------------------------------------------------------------------- */ #undef Tcl_EvalObj int Tcl_EvalObj(interp, objPtr) Tcl_Interp *interp; /* Token for command interpreter * (returned by a previous call to * Tcl_CreateInterp). */ Tcl_Obj *objPtr; /* Pointer to object containing * commands to execute. */ { register Interp *iPtr = (Interp *) interp; int flags; /* Interp->evalFlags value when the * procedure was called. */ register ByteCode* codePtr; /* Tcl Internal type of bytecode. */ int oldCount = iPtr->cmdCount; /* Used to tell whether any commands * at all were executed. */ int numSrcChars; register int result; Namespace *namespacePtr; /* * Reset both the interpreter's string and object results and clear out * any error information. This makes sure that we return an empty * result if there are no commands in the command string. */ Tcl_ResetResult(interp); /* * Check depth of nested calls to Tcl_Eval: if this gets too large, * it's probably because of an infinite loop somewhere. */ iPtr->numLevels++; if (iPtr->numLevels > iPtr->maxNestingDepth) { iPtr->numLevels--; Tcl_AppendToObj(Tcl_GetObjResult(interp), "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); return TCL_ERROR; } /* * On the Mac, we will never reach the default recursion limit before blowing * the stack. So we need to do a check here. */ if (TclpCheckStackSpace() == 0) { /*NOTREACHED*/ iPtr->numLevels--; Tcl_AppendToObj(Tcl_GetObjResult(interp), "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); return TCL_ERROR; } /* * If the interpreter has been deleted, return an error. */ if (iPtr->flags & DELETED) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "attempt to call eval in deleted interpreter", -1); Tcl_SetErrorCode(interp, "CORE", "IDELETE", "attempt to call eval in deleted interpreter", (char *) NULL); iPtr->numLevels--; return TCL_ERROR; } /* * Get the ByteCode from the object. If it exists, make sure it hasn't * been invalidated by, e.g., someone redefining a command with a * compile procedure (this might make the compiled code wrong). If * necessary, convert the object to be a ByteCode object and compile it. * Also, if the code was compiled in/for a different interpreter, * or for a different namespace, or for the same namespace but * with different name resolution rules, we recompile it. * * Precompiled objects, however, are immutable and therefore * they are not recompiled, even if the epoch has changed. */ if (iPtr->varFramePtr != NULL) { namespacePtr = iPtr->varFramePtr->nsPtr; } else { namespacePtr = iPtr->globalNsPtr; } if (objPtr->typePtr == &tclByteCodeType) { codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; if ((codePtr->iPtr != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { if (codePtr->iPtr != iPtr) { panic("Tcl_EvalObj: compiled script jumped interps"); } codePtr->compileEpoch = iPtr->compileEpoch; } else { tclByteCodeType.freeIntRepProc(objPtr); } } } if (objPtr->typePtr != &tclByteCodeType) { /* * First reset any error line number information. */ iPtr->errorLine = 1; /* no correct line # information yet */ result = tclByteCodeType.setFromAnyProc(interp, objPtr); if (result != TCL_OK) { iPtr->numLevels--; return result; } } codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; /* * Extract then reset the compilation flags in the interpreter. * Resetting the flags must be done after any compilation. */ flags = iPtr->evalFlags; iPtr->evalFlags = 0; /* * Execute the commands. If the code was compiled from an empty string, * don't bother executing the code. */ numSrcChars = codePtr->numSrcChars; if ((numSrcChars > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { /* * Increment the code's ref count while it is being executed. If * afterwards no references to it remain, free the code. */ codePtr->refCount++; result = TclExecuteByteCode(interp, codePtr); codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } } else { Tcl_ResetResult(interp); result = TCL_OK; } /* * If no commands at all were executed, check for asynchronous * handlers so that they at least get one change to execute. * This is needed to handle event loops written in Tcl with * empty bodies. */ if ((oldCount == iPtr->cmdCount) && (Tcl_AsyncReady())) { result = Tcl_AsyncInvoke(interp, result); } /* * Free up any extra resources that were allocated. */ iPtr->numLevels--; if (iPtr->numLevels == 0) { if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } if ((result != TCL_OK) && (result != TCL_ERROR) && !(flags & TCL_ALLOW_EXCEPTIONS)) { Tcl_ResetResult(interp); if (result == TCL_BREAK) { Tcl_AppendToObj(Tcl_GetObjResult(interp), "invoked \"break\" outside of a loop", -1); } else if (result == TCL_CONTINUE) { Tcl_AppendToObj(Tcl_GetObjResult(interp), "invoked \"continue\" outside of a loop", -1); } else { char buf[50]; sprintf(buf, "command returned bad code: %d", result); Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); } result = TCL_ERROR; } } /* * If an error occurred, record information about what was being * executed when the error occurred. */ if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { char buf[200]; char *ellipsis = ""; char *bytes; int length; /* * Figure out how much of the command to print in the error * message (up to a certain number of characters, or up to * the first new-line). * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL. */ bytes = Tcl_GetStringFromObj(objPtr, &length); length = TclMin(numSrcChars, length); if (length > 150) { length = 150; ellipsis = " ..."; } if (!(iPtr->flags & ERR_IN_PROGRESS)) { sprintf(buf, "\n while executing\n\"%.*s%s\"", length, bytes, ellipsis); } else { sprintf(buf, "\n invoked from within\n\"%.*s%s\"", length, bytes, ellipsis); } Tcl_AddObjErrorInfo(interp, buf, -1); } /* * Set the interpreter's termOffset member to the offset of the * character just after the last one executed. We approximate the offset * of the last character executed by using the number of characters * compiled. */ iPtr->termOffset = numSrcChars; iPtr->flags &= ~ERR_ALREADY_LOGGED; return result; } /* *-------------------------------------------------------------- * * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- * * Procedures to evaluate an expression and return its value in a * particular form. * * Results: * Each of the procedures below returns a standard Tcl result. If an * error occurs then an error message is left in interp->result. * Otherwise the value of the expression, in the appropriate form, is * stored at *ptr. If the expression had a result that was * incompatible with the desired form then an error is returned. * * Side effects: * None. * *-------------------------------------------------------------- */ int Tcl_ExprLong(interp, string, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ char *string; /* Expression to evaluate. */ long *ptr; /* Where to store result. */ { register Tcl_Obj *exprPtr; Tcl_Obj *resultPtr; int length = strlen(string); int result = TCL_OK; if (length > 0) { exprPtr = Tcl_NewStringObj(string, length); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprObj(interp, exprPtr, &resultPtr); if (result == TCL_OK) { /* * Store an integer based on the expression result. */ if (resultPtr->typePtr == &tclIntType) { *ptr = resultPtr->internalRep.longValue; } else if (resultPtr->typePtr == &tclDoubleType) { *ptr = (long) resultPtr->internalRep.doubleValue; } else { Tcl_SetResult(interp, "expression didn't have numeric value", TCL_STATIC); result = TCL_ERROR; } Tcl_DecrRefCount(resultPtr); /* discard the result object */ } else { /* * Move the interpreter's object result to the string result, * then reset the object result. * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ Tcl_SetResult(interp, TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), TCL_VOLATILE); } Tcl_DecrRefCount(exprPtr); /* discard the expression object */ } else { /* * An empty string. Just set the result integer to 0. */ *ptr = 0; } return result; } int Tcl_ExprDouble(interp, string, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ char *string; /* Expression to evaluate. */ double *ptr; /* Where to store result. */ { register Tcl_Obj *exprPtr; Tcl_Obj *resultPtr; int length = strlen(string); int result = TCL_OK; if (length > 0) { exprPtr = Tcl_NewStringObj(string, length); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprObj(interp, exprPtr, &resultPtr); if (result == TCL_OK) { /* * Store a double based on the expression result. */ if (resultPtr->typePtr == &tclIntType) { *ptr = (double) resultPtr->internalRep.longValue; } else if (resultPtr->typePtr == &tclDoubleType) { *ptr = resultPtr->internalRep.doubleValue; } else { Tcl_SetResult(interp, "expression didn't have numeric value", TCL_STATIC); result = TCL_ERROR; } Tcl_DecrRefCount(resultPtr); /* discard the result object */ } else { /* * Move the interpreter's object result to the string result, * then reset the object result. * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ Tcl_SetResult(interp, TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), TCL_VOLATILE); } Tcl_DecrRefCount(exprPtr); /* discard the expression object */ } else { /* * An empty string. Just set the result double to 0.0. */ *ptr = 0.0; } return result; } int Tcl_ExprBoolean(interp, string, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ char *string; /* Expression to evaluate. */ int *ptr; /* Where to store 0/1 result. */ { register Tcl_Obj *exprPtr; Tcl_Obj *resultPtr; int length = strlen(string); int result = TCL_OK; if (length > 0) { exprPtr = Tcl_NewStringObj(string, length); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprObj(interp, exprPtr, &resultPtr); if (result == TCL_OK) { /* * Store a boolean based on the expression result. */ if (resultPtr->typePtr == &tclIntType) { *ptr = (resultPtr->internalRep.longValue != 0); } else if (resultPtr->typePtr == &tclDoubleType) { *ptr = (resultPtr->internalRep.doubleValue != 0.0); } else { result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); } Tcl_DecrRefCount(resultPtr); /* discard the result object */ } if (result != TCL_OK) { /* * Move the interpreter's object result to the string result, * then reset the object result. * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ Tcl_SetResult(interp, TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), TCL_VOLATILE); } Tcl_DecrRefCount(exprPtr); /* discard the expression object */ } else { /* * An empty string. Just set the result boolean to 0 (false). */ *ptr = 0; } return result; } /* *-------------------------------------------------------------- * * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj -- * * Procedures to evaluate an expression in an object and return its * value in a particular form. * * Results: * Each of the procedures below returns a standard Tcl result * object. If an error occurs then an error message is left in the * interpreter's result. Otherwise the value of the expression, in the * appropriate form, is stored at *ptr. If the expression had a result * that was incompatible with the desired form then an error is * returned. * * Side effects: * None. * *-------------------------------------------------------------- */ int Tcl_ExprLongObj(interp, objPtr, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ register Tcl_Obj *objPtr; /* Expression to evaluate. */ long *ptr; /* Where to store long result. */ { Tcl_Obj *resultPtr; int result; result = Tcl_ExprObj(interp, objPtr, &resultPtr); if (result == TCL_OK) { if (resultPtr->typePtr == &tclIntType) { *ptr = resultPtr->internalRep.longValue; } else if (resultPtr->typePtr == &tclDoubleType) { *ptr = (long) resultPtr->internalRep.doubleValue; } else { result = Tcl_GetLongFromObj(interp, resultPtr, ptr); if (result != TCL_OK) { return result; } } Tcl_DecrRefCount(resultPtr); /* discard the result object */ } return result; } int Tcl_ExprDoubleObj(interp, objPtr, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ register Tcl_Obj *objPtr; /* Expression to evaluate. */ double *ptr; /* Where to store double result. */ { Tcl_Obj *resultPtr; int result; result = Tcl_ExprObj(interp, objPtr, &resultPtr); if (result == TCL_OK) { if (resultPtr->typePtr == &tclIntType) { *ptr = (double) resultPtr->internalRep.longValue; } else if (resultPtr->typePtr == &tclDoubleType) { *ptr = resultPtr->internalRep.doubleValue; } else { result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr); if (result != TCL_OK) { return result; } } Tcl_DecrRefCount(resultPtr); /* discard the result object */ } return result; } int Tcl_ExprBooleanObj(interp, objPtr, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ register Tcl_Obj *objPtr; /* Expression to evaluate. */ int *ptr; /* Where to store 0/1 result. */ { Tcl_Obj *resultPtr; int result; result = Tcl_ExprObj(interp, objPtr, &resultPtr); if (result == TCL_OK) { if (resultPtr->typePtr == &tclIntType) { *ptr = (resultPtr->internalRep.longValue != 0); } else if (resultPtr->typePtr == &tclDoubleType) { *ptr = (resultPtr->internalRep.doubleValue != 0.0); } else { result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); if (result != TCL_OK) { return result; } } Tcl_DecrRefCount(resultPtr); /* discard the result object */ } return result; } /* *---------------------------------------------------------------------- * * TclInvoke -- * * Invokes a Tcl command, given an argv/argc, from either the * exposed or the hidden sets of commands in the given interpreter. * NOTE: The command is invoked in the current stack frame of * the interpreter, thus it can modify local variables. * * Results: * A standard Tcl result. * * Side effects: * Whatever the command does. * *---------------------------------------------------------------------- */ int TclInvoke(interp, argc, argv, flags) Tcl_Interp *interp; /* Where to invoke the command. */ int argc; /* Count of args. */ register char **argv; /* The arg strings; argv[0] is the name of * the command to invoke. */ int flags; /* Combination of flags controlling the * call: TCL_INVOKE_HIDDEN and * TCL_INVOKE_NO_UNKNOWN. */ { register Tcl_Obj *objPtr; register int i; int length, result; /* * This procedure generates an objv array for object arguments that hold * the argv strings. It starts out with stack-allocated space but uses * dynamically-allocated storage if needed. */ #define NUM_ARGS 20 Tcl_Obj *(objStorage[NUM_ARGS]); register Tcl_Obj **objv = objStorage; /* * Create the object argument array "objv". Make sure objv is large * enough to hold the objc arguments plus 1 extra for the zero * end-of-objv word. */ if ((argc + 1) > NUM_ARGS) { objv = (Tcl_Obj **) ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *)); } for (i = 0; i < argc; i++) { length = strlen(argv[i]); objv[i] = Tcl_NewStringObj(argv[i], length); Tcl_IncrRefCount(objv[i]); } objv[argc] = 0; /* * Use TclObjInterpProc to actually invoke the command. */ result = TclObjInvoke(interp, argc, objv, flags); /* * Move the interpreter's object result to the string result, * then reset the object result. * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. */ Tcl_SetResult(interp, TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), TCL_VOLATILE); /* * Decrement the ref counts on the objv elements since we are done * with them. */ for (i = 0; i < argc; i++) { objPtr = objv[i]; Tcl_DecrRefCount(objPtr); } /* * Free the objv array if malloc'ed storage was used. */ if (objv != objStorage) { ckfree((char *) objv); } return result; #undef NUM_ARGS } /* *---------------------------------------------------------------------- * * TclGlobalInvoke -- * * Invokes a Tcl command, given an argv/argc, from either the * exposed or hidden sets of commands in the given interpreter. * NOTE: The command is invoked in the global stack frame of * the interpreter, thus it cannot see any current state on * the stack for that interpreter. * * Results: * A standard Tcl result. * * Side effects: * Whatever the command does. * *---------------------------------------------------------------------- */ int TclGlobalInvoke(interp, argc, argv, flags) Tcl_Interp *interp; /* Where to invoke the command. */ int argc; /* Count of args. */ register char **argv; /* The arg strings; argv[0] is the name of * the command to invoke. */ int flags; /* Combination of flags controlling the * call: TCL_INVOKE_HIDDEN and * TCL_INVOKE_NO_UNKNOWN. */ { register Interp *iPtr = (Interp *) interp; int result; CallFrame *savedVarFramePtr; savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = NULL; result = TclInvoke(interp, argc, argv, flags); iPtr->varFramePtr = savedVarFramePtr; return result; } /* *---------------------------------------------------------------------- * * TclObjInvokeGlobal -- * * Object version: Invokes a Tcl command, given an objv/objc, from * either the exposed or hidden set of commands in the given * interpreter. * NOTE: The command is invoked in the global stack frame of the * interpreter, thus it cannot see any current state on the * stack of that interpreter. * * Results: * A standard Tcl result. * * Side effects: * Whatever the command does. * *---------------------------------------------------------------------- */ int TclObjInvokeGlobal(interp, objc, objv, flags) Tcl_Interp *interp; /* Interpreter in which command is * to be invoked. */ int objc; /* Count of arguments. */ Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0] * points to the name of the * command to invoke. */ int flags; /* Combination of flags controlling * the call: TCL_INVOKE_HIDDEN and * TCL_INVOKE_NO_UNKNOWN. */ { register Interp *iPtr = (Interp *) interp; int result; CallFrame *savedVarFramePtr; savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = NULL; result = TclObjInvoke(interp, objc, objv, flags); iPtr->varFramePtr = savedVarFramePtr; return result; } /* *---------------------------------------------------------------------- * * TclObjInvoke -- * * Invokes a Tcl command, given an objv/objc, from either the * exposed or the hidden sets of commands in the given interpreter. * * Results: * A standard Tcl object result. * * Side effects: * Whatever the command does. * *---------------------------------------------------------------------- */ int TclObjInvoke(interp, objc, objv, flags) Tcl_Interp *interp; /* Interpreter in which command is * to be invoked. */ int objc; /* Count of arguments. */ Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0] * points to the name of the * command to invoke. */ int flags; /* Combination of flags controlling * the call: TCL_INVOKE_HIDDEN and * TCL_INVOKE_NO_UNKNOWN. */ { register Interp *iPtr = (Interp *) interp; Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ char *cmdName; /* Name of the command from objv[0]. */ register Tcl_HashEntry *hPtr; Tcl_Command cmd; Command *cmdPtr; int localObjc; /* Used to invoke "unknown" if the */ Tcl_Obj **localObjv = NULL; /* command is not found. */ register int i; int length, result; char *bytes; if (interp == (Tcl_Interp *) NULL) { return TCL_ERROR; } if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) { Tcl_AppendToObj(Tcl_GetObjResult(interp), "illegal argument vector", -1); return TCL_ERROR; } /* * THE FOLLOWING CODE FAILS IF THE STRING REP CONTAINS NULLS. */ cmdName = Tcl_GetStringFromObj(objv[0], (int *) NULL); if (flags & TCL_INVOKE_HIDDEN) { /* * Find the table of hidden commands; error out if none. */ hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds", NULL); if (hTblPtr == (Tcl_HashTable *) NULL) { badhiddenCmdToken: Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid hidden command name \"", cmdName, "\"", (char *) NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); /* * We never invoke "unknown" for hidden commands. */ if (hPtr == NULL) { goto badhiddenCmdToken; } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); } else { cmdPtr = NULL; cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); if (cmd != (Tcl_Command) NULL) { cmdPtr = (Command *) cmd; } if (cmdPtr == NULL) { if (!(flags & TCL_INVOKE_NO_UNKNOWN)) { cmd = Tcl_FindCommand(interp, "unknown", (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); if (cmd != (Tcl_Command) NULL) { cmdPtr = (Command *) cmd; } if (cmdPtr != NULL) { localObjc = (objc + 1); localObjv = (Tcl_Obj **) ckalloc((unsigned) (sizeof(Tcl_Obj *) * localObjc)); localObjv[0] = Tcl_NewStringObj("unknown", -1); Tcl_IncrRefCount(localObjv[0]); for (i = 0; i < objc; i++) { localObjv[i+1] = objv[i]; } objc = localObjc; objv = localObjv; } } /* * Check again if we found the command. If not, "unknown" is * not present and we cannot help, or the caller said not to * call "unknown" (they specified TCL_INVOKE_NO_UNKNOWN). */ if (cmdPtr == NULL) { Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid command name \"", cmdName, "\"", (char *) NULL); return TCL_ERROR; } } } /* * Invoke the command procedure. First reset the interpreter's string * and object results to their default empty values since they could * have gotten changed by earlier invocations. */ Tcl_ResetResult(interp); iPtr->cmdCount++; result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); /* * If an error occurred, record information about what was being * executed when the error occurred. */ if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { Tcl_DString ds; Tcl_DStringInit(&ds); if (!(iPtr->flags & ERR_IN_PROGRESS)) { Tcl_DStringAppend(&ds, "\n while invoking\n\"", -1); } else { Tcl_DStringAppend(&ds, "\n invoked from within\n\"", -1); } for (i = 0; i < objc; i++) { bytes = Tcl_GetStringFromObj(objv[i], &length); Tcl_DStringAppend(&ds, bytes, length); if (i < (objc - 1)) { Tcl_DStringAppend(&ds, " ", -1); } else if (Tcl_DStringLength(&ds) > 100) { Tcl_DStringSetLength(&ds, 100); Tcl_DStringAppend(&ds, "...", -1); break; } } Tcl_DStringAppend(&ds, "\"", -1); Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&ds), -1); Tcl_DStringFree(&ds); iPtr->flags &= ~ERR_ALREADY_LOGGED; } /* * Free any locally allocated storage used to call "unknown". */ if (localObjv != (Tcl_Obj **) NULL) { ckfree((char *) localObjv); } return result; } /* *-------------------------------------------------------------- * * Tcl_ExprString -- * * Evaluate an expression in a string and return its value in string * form. * * Results: * A standard Tcl result. If the result is TCL_OK, then the * interpreter's result is set to the string value of the * expression. If the result is TCL_OK, then interp->result * contains an error message. * * Side effects: * A Tcl object is allocated to hold a copy of the expression string. * This expression object is passed to Tcl_ExprObj and then * deallocated. * *-------------------------------------------------------------- */ int Tcl_ExprString(interp, string) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ char *string; /* Expression to evaluate. */ { register Tcl_Obj *exprPtr; Tcl_Obj *resultPtr; int length = strlen(string); char buf[100]; int result = TCL_OK; if (length > 0) { TclNewObj(exprPtr); TclInitStringRep(exprPtr, string, length); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprObj(interp, exprPtr, &resultPtr); if (result == TCL_OK) { /* * Set the interpreter's string result from the result object. */ if (resultPtr->typePtr == &tclIntType) { sprintf(buf, "%ld", resultPtr->internalRep.longValue); Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if (resultPtr->typePtr == &tclDoubleType) { Tcl_PrintDouble((Tcl_Interp *) NULL, resultPtr->internalRep.doubleValue, buf); Tcl_SetResult(interp, buf, TCL_VOLATILE); } else { /* * Set interpreter's string result from the result object. * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ Tcl_SetResult(interp, TclGetStringFromObj(resultPtr, (int *) NULL), TCL_VOLATILE); } Tcl_DecrRefCount(resultPtr); /* discard the result object */ } else { /* * Move the interpreter's object result to the string result, * then reset the object result. * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ Tcl_SetResult(interp, TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), TCL_VOLATILE); } Tcl_DecrRefCount(exprPtr); /* discard the expression object */ } else { /* * An empty string. Just set the interpreter's result to 0. */ Tcl_SetResult(interp, "0", TCL_VOLATILE); } return result; } /* *-------------------------------------------------------------- * * Tcl_ExprObj -- * * Evaluate an expression in a Tcl_Obj. * * Results: * A standard Tcl object result. If the result is other than TCL_OK, * then the interpreter's result contains an error message. If the * result is TCL_OK, then a pointer to the expression's result value * object is stored in resultPtrPtr. In that case, the object's ref * count is incremented to reflect the reference returned to the * caller; the caller is then responsible for the resulting object * and must, for example, decrement the ref count when it is finished * with the object. * * Side effects: * Any side effects caused by subcommands in the expression, if any. * The interpreter result is not modified unless there is an error. * *-------------------------------------------------------------- */ int Tcl_ExprObj(interp, objPtr, resultPtrPtr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ register Tcl_Obj *objPtr; /* Points to Tcl object containing * expression to evaluate. */ Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression * result is stored if no errors occur. */ { Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure * allocated in frame. */ register ByteCode *codePtr = NULL; /* Tcl Internal type of bytecode. * Initialized to avoid compiler warning. */ AuxData *auxDataPtr; Interp dummy; Tcl_Obj *saveObjPtr; char *string; int result; int i; /* * Get the ByteCode from the object. If it exists, make sure it hasn't * been invalidated by, e.g., someone redefining a command with a * compile procedure (this might make the compiled code wrong). If * necessary, convert the object to be a ByteCode object and compile it. * Also, if the code was compiled in/for a different interpreter, we * recompile it. * * Precompiled expressions, however, are immutable and therefore * they are not recompiled, even if the epoch has changed. * * THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE. */ if (objPtr->typePtr == &tclByteCodeType) { codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; if ((codePtr->iPtr != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch)) { if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { if (codePtr->iPtr != iPtr) { panic("Tcl_ExprObj: compiled expression jumped interps"); } codePtr->compileEpoch = iPtr->compileEpoch; } else { tclByteCodeType.freeIntRepProc(objPtr); objPtr->typePtr = (Tcl_ObjType *) NULL; } } } if (objPtr->typePtr != &tclByteCodeType) { int length; string = Tcl_GetStringFromObj(objPtr, &length); TclInitCompileEnv(interp, &compEnv, string); result = TclCompileExpr(interp, string, string + length, /*flags*/ 0, &compEnv); if (result == TCL_OK) { /* * If the expression yielded no instructions (e.g., was empty), * push an integer zero object as the expressions's result. */ if (compEnv.codeNext == NULL) { int objIndex = TclObjIndexForString("0", 0, /*allocStrRep*/ 0, /*inHeap*/ 0, &compEnv); Tcl_Obj *objPtr = compEnv.objArrayPtr[objIndex]; Tcl_InvalidateStringRep(objPtr); objPtr->internalRep.longValue = 0; objPtr->typePtr = &tclIntType; TclEmitPush(objIndex, &compEnv); } /* * Add done instruction at the end of the instruction sequence. */ TclEmitOpcode(INST_DONE, &compEnv); TclInitByteCodeObj(objPtr, &compEnv); codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; if (tclTraceCompile == 2) { TclPrintByteCodeObj(interp, objPtr); } TclFreeCompileEnv(&compEnv); } else { /* * Compilation errors. Decrement the ref counts on any objects * in the object array before freeing the compilation * environment. */ for (i = 0; i < compEnv.objArrayNext; i++) { Tcl_Obj *elemPtr = compEnv.objArrayPtr[i]; Tcl_DecrRefCount(elemPtr); } auxDataPtr = compEnv.auxDataArrayPtr; for (i = 0; i < compEnv.auxDataArrayNext; i++) { if (auxDataPtr->type->freeProc != NULL) { auxDataPtr->type->freeProc(auxDataPtr->clientData); } auxDataPtr++; } TclFreeCompileEnv(&compEnv); return result; } } /* * Execute the expression after first saving the interpreter's result. */ dummy.objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(dummy.objResultPtr); if (interp->freeProc == 0) { dummy.freeProc = (Tcl_FreeProc *) 0; dummy.result = ""; Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE); } else { dummy.freeProc = interp->freeProc; dummy.result = interp->result; interp->freeProc = (Tcl_FreeProc *) 0; } saveObjPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(saveObjPtr); /* * Increment the code's ref count while it is being executed. If * afterwards no references to it remain, free the code. */ codePtr->refCount++; result = TclExecuteByteCode(interp, codePtr); codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } /* * If the expression evaluated successfully, store a pointer to its * value object in resultPtrPtr then restore the old interpreter result. * We increment the object's ref count to reflect the reference that we * are returning to the caller. We also decrement the ref count of the * interpreter's result object after calling Tcl_SetResult since we * next store into that field directly. */ if (result == TCL_OK) { *resultPtrPtr = iPtr->objResultPtr; Tcl_IncrRefCount(iPtr->objResultPtr); Tcl_SetResult(interp, dummy.result, ((dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc)); Tcl_DecrRefCount(iPtr->objResultPtr); iPtr->objResultPtr = saveObjPtr; } else { Tcl_DecrRefCount(saveObjPtr); Tcl_FreeResult((Tcl_Interp *) &dummy); } Tcl_DecrRefCount(dummy.objResultPtr); dummy.objResultPtr = NULL; return result; } /* *---------------------------------------------------------------------- * * Tcl_CreateTrace -- * * Arrange for a procedure to be called to trace command execution. * * Results: * The return value is a token for the trace, which may be passed * to Tcl_DeleteTrace to eliminate the trace. * * Side effects: * From now on, proc will be called just before a command procedure * is called to execute a Tcl command. Calls to proc will have the * following form: * * void * proc(clientData, interp, level, command, cmdProc, cmdClientData, * argc, argv) * ClientData clientData; * Tcl_Interp *interp; * int level; * char *command; * int (*cmdProc)(); * ClientData cmdClientData; * int argc; * char **argv; * { * } * * The clientData and interp arguments to proc will be the same * as the corresponding arguments to this procedure. Level gives * the nesting level of command interpretation for this interpreter * (0 corresponds to top level). Command gives the ASCII text of * the raw command, cmdProc and cmdClientData give the procedure that * will be called to process the command and the ClientData value it * will receive, and argc and argv give the arguments to the * command, after any argument parsing and substitution. Proc * does not return a value. * *---------------------------------------------------------------------- */ Tcl_Trace Tcl_CreateTrace(interp, level, proc, clientData) Tcl_Interp *interp; /* Interpreter in which to create trace. */ int level; /* Only call proc for commands at nesting * level<=argument level (1=>top level). */ Tcl_CmdTraceProc *proc; /* Procedure to call before executing each * command. */ ClientData clientData; /* Arbitrary value word to pass to proc. */ { register Trace *tracePtr; register Interp *iPtr = (Interp *) interp; /* * Invalidate existing compiled code for this interpreter and arrange * (by setting the DONT_COMPILE_CMDS_INLINE flag) that when compiling * new code, no commands will be compiled inline (i.e., into an inline * sequence of instructions). We do this because commands that were * compiled inline will never result in a command trace being called. */ iPtr->compileEpoch++; iPtr->flags |= DONT_COMPILE_CMDS_INLINE; tracePtr = (Trace *) ckalloc(sizeof(Trace)); tracePtr->level = level; tracePtr->proc = proc; tracePtr->clientData = clientData; tracePtr->nextPtr = iPtr->tracePtr; iPtr->tracePtr = tracePtr; return (Tcl_Trace) tracePtr; } /* *---------------------------------------------------------------------- * * Tcl_DeleteTrace -- * * Remove a trace. * * Results: * None. * * Side effects: * From now on there will be no more calls to the procedure given * in trace. * *---------------------------------------------------------------------- */ void Tcl_DeleteTrace(interp, trace) Tcl_Interp *interp; /* Interpreter that contains trace. */ Tcl_Trace trace; /* Token for trace (returned previously by * Tcl_CreateTrace). */ { register Interp *iPtr = (Interp *) interp; register Trace *tracePtr = (Trace *) trace; register Trace *tracePtr2; if (iPtr->tracePtr == tracePtr) { iPtr->tracePtr = tracePtr->nextPtr; ckfree((char *) tracePtr); } else { for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL; tracePtr2 = tracePtr2->nextPtr) { if (tracePtr2->nextPtr == tracePtr) { tracePtr2->nextPtr = tracePtr->nextPtr; ckfree((char *) tracePtr); break; } } } if (iPtr->tracePtr == NULL) { /* * When compiling new code, allow commands to be compiled inline. */ iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE; } } /* *---------------------------------------------------------------------- * * Tcl_AddErrorInfo -- * * Add information to the "errorInfo" variable that describes the * current error. * * Results: * None. * * Side effects: * The contents of message are added to the "errorInfo" variable. * If Tcl_Eval has been called since the current value of errorInfo * was set, errorInfo is cleared before adding the new message. * If we are just starting to log an error, errorInfo is initialized * from the error message in the interpreter's result. * *---------------------------------------------------------------------- */ void Tcl_AddErrorInfo(interp, message) Tcl_Interp *interp; /* Interpreter to which error information * pertains. */ char *message; /* Message to record. */ { Tcl_AddObjErrorInfo(interp, message, -1); } /* *---------------------------------------------------------------------- * * Tcl_AddObjErrorInfo -- * * Add information to the "errorInfo" variable that describes the * current error. This routine differs from Tcl_AddErrorInfo by * taking a byte pointer and length. * * Results: * None. * * Side effects: * "length" bytes from "message" are added to the "errorInfo" variable. * If "length" is negative, use bytes up to the first NULL byte. * If Tcl_EvalObj has been called since the current value of errorInfo * was set, errorInfo is cleared before adding the new message. * If we are just starting to log an error, errorInfo is initialized * from the error message in the interpreter's result. * *---------------------------------------------------------------------- */ void Tcl_AddObjErrorInfo(interp, message, length) Tcl_Interp *interp; /* Interpreter to which error information * pertains. */ char *message; /* Points to the first byte of an array of * bytes of the message. */ register int length; /* The number of bytes in the message. * If < 0, then append all bytes up to a * NULL byte. */ { register Interp *iPtr = (Interp *) interp; Tcl_Obj *namePtr, *messagePtr; /* * If we are just starting to log an error, errorInfo is initialized * from the error message in the interpreter's result. */ namePtr = Tcl_NewStringObj("errorInfo", -1); Tcl_IncrRefCount(namePtr); if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */ iPtr->flags |= ERR_IN_PROGRESS; if (iPtr->result[0] == 0) { (void) Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, iPtr->objResultPtr, TCL_GLOBAL_ONLY); } else { /* use the string result */ Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result, TCL_GLOBAL_ONLY); } /* * If the errorCode variable wasn't set by the code that generated * the error, set it to "NONE". */ if (!(iPtr->flags & ERROR_CODE_SET)) { (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE", TCL_GLOBAL_ONLY); } } /* * Now append "message" to the end of errorInfo. */ if (length != 0) { messagePtr = Tcl_NewStringObj(message, length); Tcl_IncrRefCount(messagePtr); Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, messagePtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); Tcl_DecrRefCount(messagePtr); /* free msg object appended above */ } Tcl_DecrRefCount(namePtr); /* free the name object */ } /* *---------------------------------------------------------------------- * * Tcl_VarEval -- * * Given a variable number of string arguments, concatenate them * all together and execute the result as a Tcl command. * * Results: * A standard Tcl return result. An error message or other * result may be left in interp->result. * * Side effects: * Depends on what was done by the command. * *---------------------------------------------------------------------- */ /* VARARGS2 */ /* ARGSUSED */ int Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) { va_list argList; Tcl_DString buf; char *string; Tcl_Interp *interp; int result; /* * Copy the strings one after the other into a single larger * string. Use stack-allocated space for small commands, but if * the command gets too large than call ckalloc to create the * space. */ interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); Tcl_DStringInit(&buf); while (1) { string = va_arg(argList, char *); if (string == NULL) { break; } Tcl_DStringAppend(&buf, string, -1); } va_end(argList); result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); Tcl_DStringFree(&buf); return result; } /* *---------------------------------------------------------------------- * * Tcl_GlobalEval -- * * Evaluate a command at global level in an interpreter. * * Results: * A standard Tcl result is returned, and interp->result is * modified accordingly. * * Side effects: * The command string is executed in interp, and the execution * is carried out in the variable context of global level (no * procedures active), just as if an "uplevel #0" command were * being executed. * *---------------------------------------------------------------------- */ int Tcl_GlobalEval(interp, command) Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ char *command; /* Command to evaluate. */ { register Interp *iPtr = (Interp *) interp; int result; CallFrame *savedVarFramePtr; savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = NULL; result = Tcl_Eval(interp, command); iPtr->varFramePtr = savedVarFramePtr; return result; } /* *---------------------------------------------------------------------- * * Tcl_GlobalEvalObj -- * * Execute Tcl commands stored in a Tcl object at global level in * an interpreter. These commands are compiled into bytecodes if * necessary. * * Results: * A standard Tcl result is returned, and the interpreter's result * contains a Tcl object value to supplement the return code. * * Side effects: * The object is converted, if necessary, to a ByteCode object that * holds the bytecode instructions for the commands. Executing the * commands will almost certainly have side effects that depend on * those commands. * * The commands are executed in interp, and the execution * is carried out in the variable context of global level (no * procedures active), just as if an "uplevel #0" command were * being executed. * *---------------------------------------------------------------------- */ int Tcl_GlobalEvalObj(interp, objPtr) Tcl_Interp *interp; /* Interpreter in which to evaluate * commands. */ Tcl_Obj *objPtr; /* Pointer to object containing commands * to execute. */ { register Interp *iPtr = (Interp *) interp; int result; CallFrame *savedVarFramePtr; savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = NULL; result = Tcl_EvalObj(interp, objPtr); iPtr->varFramePtr = savedVarFramePtr; return result; } /* *---------------------------------------------------------------------- * * Tcl_SetRecursionLimit -- * * Set the maximum number of recursive calls that may be active * for an interpreter at once. * * Results: * The return value is the old limit on nesting for interp. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_SetRecursionLimit(interp, depth) Tcl_Interp *interp; /* Interpreter whose nesting limit * is to be set. */ int depth; /* New value for maximimum depth. */ { Interp *iPtr = (Interp *) interp; int old; old = iPtr->maxNestingDepth; if (depth > 0) { iPtr->maxNestingDepth = depth; } return old; } /* *---------------------------------------------------------------------- * * Tcl_AllowExceptions -- * * Sets a flag in an interpreter so that exceptions can occur * in the next call to Tcl_Eval without them being turned into * errors. * * Results: * None. * * Side effects: * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's * evalFlags structure. See the reference documentation for * more details. * *---------------------------------------------------------------------- */ void Tcl_AllowExceptions(interp) Tcl_Interp *interp; /* Interpreter in which to set flag. */ { Interp *iPtr = (Interp *) interp; iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS; }