/* * nsfShadow.c -- * * API support for shadowing (overloading) and accessing C-implemented * Tcl obj-commands. * * Copyright (C) 1999-2014 Gustaf Neumann * * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ #include "nsfInt.h" #include "nsfAccessInt.h" #include "nsfCmdPtr.c" /* *---------------------------------------------------------------------- * NsfReplaceCommandCleanup -- * * Undo the effects of NsfReplaceCommand() for the Tcl command * referred by name. * * Results: * Tcl return code. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int NsfReplaceCommandCleanup(Tcl_Interp *interp, NsfGlobalNames name) nonnull(1); static int NsfReplaceCommandCleanup(Tcl_Interp *interp, NsfGlobalNames name) { Tcl_Command cmd; int result = TCL_OK; NsfShadowTclCommandInfo *ti = &RUNTIME_STATE(interp)->tclCommands[name-NSF_EXPR]; assert(interp); /*fprintf(stderr," cleanup for %s ti=%p in %p\n", NsfGlobalStrings[name], ti, interp);*/ cmd = Tcl_GetCommandFromObj(interp, NsfGlobalObjs[name]); if (cmd != NULL) { Tcl_Command_objProc(cmd) = ti->proc; ti->proc = NULL; } else { result = TCL_ERROR; } return result; } /* *---------------------------------------------------------------------- * NsfReplaceCommandCheck -- * * Test, whether shadowing is still in effect, and refresh the * replacement if necessary. * * Results: * Tcl return code. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void NsfReplaceCommandCheck(Tcl_Interp *interp, NsfGlobalNames name, Tcl_ObjCmdProc *proc) nonnull(1) nonnull(3); static void NsfReplaceCommandCheck(Tcl_Interp *interp, NsfGlobalNames name, Tcl_ObjCmdProc *proc) { NsfShadowTclCommandInfo *ti = &RUNTIME_STATE(interp)->tclCommands[name-NSF_EXPR]; Tcl_Command cmd; assert(interp); assert(proc); cmd = Tcl_GetCommandFromObj(interp, NsfGlobalObjs[name]); if (cmd != NULL && ti->proc && Tcl_Command_objProc(cmd) != proc) { /* fprintf(stderr, "we have to do something about %s %p %p\n", NsfGlobalStrings[name], Tcl_Command_objProc(cmd), proc); */ ti->proc = Tcl_Command_objProc(cmd); ti->clientData = Tcl_Command_objClientData(cmd); Tcl_Command_objProc(cmd) = proc; } } /* *---------------------------------------------------------------------- * NsfReplaceCommandCheck -- * * Lookup the objProc of a Tcl command and keep it around for * efficient calling. Replace the objProc optionally with a newly * specified one. * * Results: * Tcl return code. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int NsfReplaceCommand(Tcl_Interp *interp, NsfGlobalNames name, Tcl_ObjCmdProc *nsfReplacementProc, int pass) nonnull(1); static int NsfReplaceCommand(Tcl_Interp *interp, NsfGlobalNames name, Tcl_ObjCmdProc *nsfReplacementProc, int pass) { Tcl_Command cmd; NsfShadowTclCommandInfo *ti = &RUNTIME_STATE(interp)->tclCommands[name-NSF_EXPR]; int result = TCL_OK; assert(interp); /*fprintf(stderr,"NsfReplaceCommand %d\n", name);*/ cmd = Tcl_GetCommandFromObj(interp, NsfGlobalObjs[name]); if (cmd == NULL) { result = TCL_ERROR; } else { Tcl_ObjCmdProc *objProc = Tcl_Command_objProc(cmd); if (nsfReplacementProc != objProc) { if (pass == 0) { /* setting values on first pass (must be locked here) */ ti->proc = objProc; ti->clientData = Tcl_Command_objClientData(cmd); } else if (ti->proc != objProc) { /*fprintf(stderr, "we have to refetch command for %s\n", NsfGlobalStrings[name]);*/ ti->proc = objProc; ti->clientData = Tcl_Command_objClientData(cmd); } if (nsfReplacementProc) { Tcl_Command_objProc(cmd) = nsfReplacementProc; } } } return result; } /* *---------------------------------------------------------------------- * Nsf_InfoBodyObjCmd -- * * TclObjCmd for shadowing "::tcl::info::body. In case the function * is called with an nsf::proc (which is technically a command, not * a proc), the original command fails ("not a proc"). We catch this * call here and test, whether the body is from an nsf::proc. If * so, we call tcl::info::body with the shadowed body. * * Example: * nsf::proc foo {-a} {puts $a}; info body foo * * Results: * Tcl return code. * * Side effects: * None. * *---------------------------------------------------------------------- */ EXTERN int NsfProcStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) nonnull(1) nonnull(2) nonnull(4); static int Nsf_InfoBodyObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { Tcl_Command cmd; assert(interp); assert(objv); if (objc != 2) { /* wrong # args, let Tcl generate the error */ return NsfCallCommand(interp, NSF_INFO_BODY, objc, objv); } cmd = Tcl_FindCommand(interp, ObjStr(objv[1]), (Tcl_Namespace *)NULL, 0); if (cmd) { Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); ClientData clientData = Tcl_Command_objClientData(cmd); if (proc == NsfProcStub && clientData) { NsfProcClientData *tcd = clientData; Tcl_Obj *ov[2]; /* * The command is from an nsf::proc */ ov[0] = objv[0]; ov[1] = tcd->procName; return NsfCallCommand(interp, NSF_INFO_BODY, objc, ov); } } /* Actually call the cmd using Tcl's info body */ return NsfCallCommand(interp, NSF_INFO_BODY, objc, objv); } /* *---------------------------------------------------------------------- * Nsf_RenameObjCmd -- * * TclObjCmd for shadowing "::rename". We check whether the cmd * refers to an NsfObject. If so we have to destroy and/or "move" * it. Otherwise proceed by calling the shadowed function. * * Results: * Tcl return code. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int Nsf_RenameObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { Tcl_Command cmd; if (objc != 3) { /* wrong # args, let Tcl generate the error */ return NsfCallCommand(interp, NSF_RENAME, objc, objv); } /* if an obj/cl should be renamed => call the Nsf move method */ cmd = Tcl_FindCommand(interp, ObjStr(objv[1]), (Tcl_Namespace *)NULL, 0); if (cmd) { NsfObject *object = NsfGetObjectFromCmdPtr(cmd); Tcl_Obj *methodObj = object ? NsfMethodObj(object, NSF_o_move_idx) : NULL; Tcl_Command parentCmd; if (object && methodObj) { return NsfCallMethodWithArgs(interp, (Nsf_Object *)object, methodObj, objv[2], 1, 0, NSF_CSC_IMMEDIATE); } parentCmd = Tcl_FindCommand(interp, Tcl_Command_nsPtr(cmd)->fullName, (Tcl_Namespace *)NULL, 0); if (parentCmd) { NsfObjectMethodEpochIncr("::rename"); } } /* Actually rename the cmd using Tcl's rename*/ return NsfCallCommand(interp, NSF_RENAME, objc, objv); } /* *---------------------------------------------------------------------- * Nsf_InfoFrameObjCmd -- * * TclObjCmd for shadowing "::tcl::info::frame". First we call the * shadowed method. If it returns OK we check, whether the frame is * an NSF frame. If so, we remove from the result the misleading * "proc" and add "method", "class", "object" and "frametype". * * Results: * Tcl return code. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int Nsf_InfoFrameObjCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { int result; result = NsfCallCommand(interp, NSF_INFO_FRAME, objc, objv); if (result == TCL_OK && objc == 2) { int level, topLevel, frameFlags; CmdFrame *framePtr = Tcl_Interp_cmdFramePtr(interp); CallFrame *varFramePtr = Tcl_Interp_varFramePtr(interp); Tcl_Obj *resultObj = Tcl_GetObjResult(interp); /* level must be ok, otherwise we would not have a TCL_OK */ Tcl_GetIntFromObj(interp, objv[1], &level); /* todo: coroutine level messing is missing */ topLevel = (framePtr == NULL) ? 0 : framePtr->level; if (level > 0) { level -= topLevel; } while (++level <= 0 && varFramePtr && framePtr) { framePtr = framePtr->nextPtr; varFramePtr = varFramePtr->callerPtr; } frameFlags = varFramePtr ? Tcl_CallFrame_isProcCallFrame(varFramePtr) : 0; /*fprintf(stderr, " ... frame %p varFramePtr %p frameFlags %.6x\n", framePtr, varFramePtr, frameFlags); Tcl85showStack(interp);*/ if (frameFlags & (FRAME_IS_NSF_METHOD|FRAME_IS_NSF_CMETHOD)) { NsfCallStackContent *cscPtr = ((NsfCallStackContent *)Tcl_CallFrame_clientData(varFramePtr)); CONST char *frameType; Tcl_Obj *listObj, **ov; int oc, i; listObj = Tcl_NewListObj(0, NULL); /* remove "proc" element from list, if provided */ Tcl_ListObjGetElements(interp, resultObj, &oc, &ov); for (i=0; iself->cmdName); Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("class",5)); Tcl_ListObjAppendElement(interp, listObj, cscPtr->cl ? cscPtr->cl->object.cmdName : NsfGlobalObjs[NSF_EMPTY]); Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("method",6)); Tcl_ListObjAppendElement(interp, listObj, cscPtr->cmdPtr ? Tcl_NewStringObj(Tcl_GetCommandName(interp, cscPtr->cmdPtr), -1) : NsfGlobalObjs[NSF_EMPTY]); Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("frametype",9)); if (cscPtr->frameType == NSF_CSC_TYPE_PLAIN) { frameType = "intrinsic"; } else if (cscPtr->frameType & NSF_CSC_TYPE_ACTIVE_MIXIN) { frameType = "mixin"; } else if (cscPtr->frameType & NSF_CSC_TYPE_ACTIVE_FILTER) { frameType = "filter"; } else if (cscPtr->frameType & NSF_CSC_TYPE_GUARD) { frameType = "guard"; } else { frameType = "unknown"; } Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(frameType,-1)); Tcl_SetObjResult(interp, listObj); } else if (frameFlags & (FRAME_IS_NSF_OBJECT)) { NsfObject *object = (NsfObject *)Tcl_CallFrame_clientData(varFramePtr); /* Tcl_Obj *listObj = Tcl_NewListObj(0, NULL); */ Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("object",6)); Tcl_ListObjAppendElement(interp, resultObj, object->cmdName); Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("frameType",9)); Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("object",6)); Tcl_SetObjResult(interp, resultObj); } } return result; } /* *---------------------------------------------------------------------- * NsfShadowTclCommands -- * * Load/refresh/unload shadowed Tcl commands. Essentially, the * shadowing function serve two things: * (a) lookup some Tcl ObjProcs, which are not available via global * symbols and make these available via NsfCallCommand(). * (b) some Tcl commands are actually shadowed; we perform some * pre- and/or postprocessing on these calls. * * Results: * Tcl return code. * * Side effects: * None. * *---------------------------------------------------------------------- */ int NsfShadowTclCommands(Tcl_Interp *interp, NsfShadowOperations load) { int rc = TCL_OK; assert(interp); if (load == SHADOW_LOAD) { int initialized = (RUNTIME_STATE(interp)->tclCommands != NULL); assert(initialized == 0); RUNTIME_STATE(interp)->tclCommands = NEW_ARRAY(NsfShadowTclCommandInfo, NSF_RENAME - NSF_EXPR + 1); /*fprintf(stderr, "+++ load tcl commands %d %d\n", load, initialized);*/ #ifdef USE_TCL_STUBS /* no commands are overloaded, these are only used for calling e.g. Tcl_ExprObjCmd(), Tcl_IncrObjCmd() and Tcl_SubstObjCmd(), which are not available in though the stub table */ rc |= NsfReplaceCommand(interp, NSF_EXPR, NULL, initialized); #endif rc |= NsfReplaceCommand(interp, NSF_FORMAT, NULL, initialized); rc |= NsfReplaceCommand(interp, NSF_INTERP, NULL, initialized); rc |= NsfReplaceCommand(interp, NSF_STRING_IS, NULL, initialized); /* for the following commands, we have to add our own semantics */ rc |= NsfReplaceCommand(interp, NSF_INFO_BODY, Nsf_InfoBodyObjCmd, initialized); rc |= NsfReplaceCommand(interp, NSF_INFO_FRAME, Nsf_InfoFrameObjCmd, initialized); rc |= NsfReplaceCommand(interp, NSF_RENAME, Nsf_RenameObjCmd, initialized); } else if (load == SHADOW_REFETCH) { NsfReplaceCommandCheck(interp, NSF_INFO_BODY, Nsf_InfoFrameObjCmd); NsfReplaceCommandCheck(interp, NSF_INFO_FRAME, Nsf_InfoFrameObjCmd); NsfReplaceCommandCheck(interp, NSF_RENAME, Nsf_RenameObjCmd); } else { NsfReplaceCommandCleanup(interp, NSF_INFO_BODY); NsfReplaceCommandCleanup(interp, NSF_INFO_FRAME); NsfReplaceCommandCleanup(interp, NSF_RENAME); FREE(NsfShadowTclCommandInfo*, RUNTIME_STATE(interp)->tclCommands); RUNTIME_STATE(interp)->tclCommands = NULL; } return rc; } /* *---------------------------------------------------------------------- * NsfCallCommand -- * * Calls Tcl Commands as direct as possible. The commands have to * be looked up previously via NsfShadowTclCommands(). objv[0] is * replaced with the predefined command name. * * Results: * Tcl return code. * * Side effects: * None. * *---------------------------------------------------------------------- */ int NsfCallCommand(Tcl_Interp *interp, NsfGlobalNames name, int objc, Tcl_Obj *CONST objv[]) { int result; NsfShadowTclCommandInfo *ti = &RUNTIME_STATE(interp)->tclCommands[name-NSF_EXPR]; ALLOC_ON_STACK(Tcl_Obj*, objc, ov); /* {int i; fprintf(stderr,"calling %s (%p %p) in %p, objc=%d ", NsfGlobalStrings[name], ti, ti->proc, interp, objc); for(i=0;i 1) { memcpy(ov+1, objv+1, sizeof(Tcl_Obj *)*(objc-1)); } result = Tcl_NRCallObjProc(interp, ti->proc, ti->clientData, objc, objv); FREE_ON_STACK(Tcl_Obj *, ov); return result; } /* * Local Variables: * mode: c * c-basic-offset: 2 * fill-column: 78 * indent-tabs-mode: nil * End: */