/*
* nsfShadow.c --
*
* API support for shadowing (overloading) and accessing C-implemented
* Tcl obj-commands.
*
* Copyright (C) 1999-2017 Gustaf Neumann
* Copyright (C) 2019 Stefan Sobernig
*
* Vienna University of Economics and Business
* Institute of Information Systems and New Media
* A-1020, Welthandelsplatz 1
* Vienna, Austria
*
* This work is licensed under the MIT License https://www.opensource.org/licenses/MIT
*
* Copyright:
*
* 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"
static TCL_OBJCMDPROC_T Nsf_InfoFrameObjCmd;
EXTERN TCL_OBJCMDPROC_T NsfProcStub;
static TCL_OBJCMDPROC_T Nsf_InfoBodyObjCmd;
static TCL_OBJCMDPROC_T Nsf_RenameObjCmd;
/*
*----------------------------------------------------------------------
* NsfReplaceCommandCleanup --
*
* Undo the effects of NsfReplaceCommand() for the Tcl command
* referred by name.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
NsfReplaceCommandCleanup(Tcl_Interp *interp, Tcl_Obj *nameObj, NsfShadowTclCommandInfo *ti) {
Tcl_Command cmd;
int result = TCL_OK;
nonnull_assert(interp != NULL);
nonnull_assert(nameObj != NULL);
nonnull_assert(ti != NULL);
/*fprintf(stderr, " cleanup for %s ti=%p in %p\n", NsfGlobalStrings[name], ti, interp);*/
cmd = Tcl_GetCommandFromObj(interp, nameObj);
if (cmd != NULL) {
Tcl_Command_objProc(cmd) = (Tcl_ObjCmdProc*)ti->proc;
if (ti->clientData != NULL) {
Tcl_Command_objClientData(cmd) = ti->clientData;
}
ti->proc = NULL;
ti->clientData = NULL;
} else {
result = TCL_ERROR;
}
return result;
}
/*
*----------------------------------------------------------------------
* NsfReplaceCommandCheck --
*
* Test, whether shadowing is still in effect, and refresh the
* replacement if necessary.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void NsfReplaceCommandCheck(Tcl_Interp *interp, Tcl_Obj *nameObj, TCL_OBJCMDPROC_T *proc,
NsfShadowTclCommandInfo *ti)
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static void
NsfReplaceCommandCheck(Tcl_Interp *interp, Tcl_Obj *nameObj, TCL_OBJCMDPROC_T *proc,
NsfShadowTclCommandInfo *ti) {
Tcl_Command cmd;
nonnull_assert(interp != NULL);
nonnull_assert(nameObj != NULL);
nonnull_assert(proc != NULL);
nonnull_assert(ti != NULL);
cmd = Tcl_GetCommandFromObj(interp, nameObj);
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) = (Tcl_ObjCmdProc*)proc;
}
}
/*
*----------------------------------------------------------------------
* NsfReplaceCommand --
*
* Lookup the objProc of a Tcl command and keep it around for
* efficient calling. Replace the objProc optionally with a newly
* specified one.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
NsfReplaceCommand(Tcl_Interp *interp, Tcl_Obj *nameObj,
TCL_OBJCMDPROC_T *nsfReplacementProc,
ClientData cd,
NsfShadowTclCommandInfo *ti) {
Tcl_Command cmd;
int result = TCL_OK;
nonnull_assert(interp != NULL);
nonnull_assert(nameObj != NULL);
nonnull_assert(ti != NULL);
/* fprintf(stderr, "NsfReplaceCommand %s\n", ObjStr(nameObj)); */
cmd = Tcl_GetCommandFromObj(interp, nameObj);
if (cmd == NULL) {
result = TCL_ERROR;
} else {
TCL_OBJCMDPROC_T *objProc = TCL_COMMAND_OBJPROC(cmd);
if (nsfReplacementProc != objProc) {
ti->proc = objProc;
ti->clientData = Tcl_Command_objClientData(cmd);
if (nsfReplacementProc != NULL) {
Tcl_Command_objProc(cmd) = (Tcl_ObjCmdProc*)nsfReplacementProc;
}
if (cd != NULL) {
Tcl_Command_objClientData(cmd) = cd;
}
}
}
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:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
Nsf_InfoBodyObjCmd(ClientData UNUSED(clientData), Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
Tcl_Command cmd;
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
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 != NULL) {
TCL_OBJCMDPROC_T *proc = TCL_COMMAND_OBJPROC(cmd);
ClientData procClientData = Tcl_Command_objClientData(cmd);
if (proc == NsfProcStub && procClientData != NULL) {
NsfProcClientData *tcd = procClientData;
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:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
Nsf_RenameObjCmd(ClientData UNUSED(clientData), Tcl_Interp *interp, TCL_OBJC_T 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 != NULL) {
TCL_OBJCMDPROC_T *proc = TCL_COMMAND_OBJPROC(cmd);
ClientData procClientData = Tcl_Command_objClientData(cmd);
NsfObject *object = NsfGetObjectFromCmdPtr(cmd);
Tcl_Command parentCmd;
char *newName = ObjStr(objv[2]);
if (proc == NsfProcStub && procClientData != NULL &&
*newName != '\0') {
Tcl_DString fqNewName;
int result;
NsfProcClientData *tcd = procClientData;
Tcl_DStringInit(&fqNewName);
Tcl_DStringAppend(&fqNewName, "::nsf::procs::", 14);
Tcl_DStringAppend(&fqNewName, newName, TCL_INDEX_NONE);
/* fprintf(stderr, "oldName %s newName %s\n", ObjStr(tcd->procName), Tcl_DStringValue(&fqNewName));*/
result = TclRenameCommand(interp, ObjStr(tcd->procName), Tcl_DStringValue(&fqNewName));
if (result == TCL_OK) {
DECR_REF_COUNT2("procNameObj", tcd->procName);
tcd->procName = Tcl_NewStringObj(Tcl_DStringValue(&fqNewName),
Tcl_DStringLength(&fqNewName));
INCR_REF_COUNT2("procNameObj", tcd->procName);
}
Tcl_DStringFree(&fqNewName);
if (result != TCL_OK) {
return TCL_ERROR;
}
} else if (object != NULL) {
Tcl_Obj *methodObj = NsfMethodObj(object, NSF_o_move_idx);
if (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 != NULL) {
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:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
Nsf_InfoFrameObjCmd(ClientData UNUSED(clientData), Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
int result;
result = NsfCallCommand(interp, NSF_INFO_FRAME, objc, objv);
if (result == TCL_OK && objc == 2) {
int level, topLevel;
unsigned int 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. Needed? */
topLevel = (framePtr == NULL) ? 0 : framePtr->level;
if (level > 0) {
level -= topLevel;
}
while (++level <= 0 && varFramePtr && framePtr) {
framePtr = framePtr->nextPtr;
varFramePtr = varFramePtr->callerPtr;
}
frameFlags = (varFramePtr != NULL) ? (unsigned int)Tcl_CallFrame_isProcCallFrame(varFramePtr) : 0u;
/*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;
TCL_SIZE_T oc, i;
listObj = Tcl_NewListObj(0, NULL);
/*
* Remove "proc" element from list, if provided.
*/
Tcl_ListObjGetElements(interp, resultObj, &oc, &ov);
for (i=0; i<oc; i += 2) {
if (!strcmp(ObjStr(ov[i]), "proc")) {
continue;
}
Tcl_ListObjAppendElement(interp, listObj, ov[i]);
Tcl_ListObjAppendElement(interp, listObj, ov[i+1]);
}
Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("object", 6));
Tcl_ListObjAppendElement(interp, listObj, cscPtr->self->cmdName);
Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("class", 5));
Tcl_ListObjAppendElement(interp, listObj, (cscPtr->cl != NULL) ? cscPtr->cl->object.cmdName
: NsfGlobalObjs[NSF_EMPTY]);
Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("method", 6));
Tcl_ListObjAppendElement(interp, listObj,
(cscPtr->cmdPtr != NULL)
? Tcl_NewStringObj(Tcl_GetCommandName(interp, cscPtr->cmdPtr), TCL_INDEX_NONE)
: 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, TCL_INDEX_NONE));
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:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#define CMD_INFO(rst, name) &(rst)->tclCommands[(name)-NSF_EXPR]
int
NsfShadowTclCommands(Tcl_Interp *interp, NsfShadowOperations load) {
int rc = TCL_OK;
NsfRuntimeState *rst;
nonnull_assert(interp != NULL);
rst = RUNTIME_STATE(interp);
if (load == SHADOW_LOAD) {
assert(rst->tclCommands == NULL);
rst->tclCommands = NEW_ARRAY(NsfShadowTclCommandInfo, NSF_RENAME - NSF_EXPR + 1);
#ifdef USE_TCL_STUBS
/*
* When the third argument of NsfReplaceCommand is NULL, the commands are
* not overloaded. However, we use this mechanism to call Tcl commands
* (Tcl_ExprObjCmd(), Tcl_IncrObjCmd() and Tcl_SubstObjCmd()), which cannot be
* called not available in though the stub table.
*/
rc |= NsfReplaceCommand(interp, NsfGlobalObjs[NSF_EXPR], NULL, NULL, CMD_INFO(rst, NSF_EXPR));
#endif
rc |= NsfReplaceCommand(interp, NsfGlobalObjs[NSF_FORMAT], NULL, NULL, CMD_INFO(rst, NSF_FORMAT));
rc |= NsfReplaceCommand(interp, NsfGlobalObjs[NSF_INTERP], NULL, NULL, CMD_INFO(rst, NSF_INTERP));
rc |= NsfReplaceCommand(interp, NsfGlobalObjs[NSF_STRING_IS], NULL, NULL, CMD_INFO(rst, NSF_STRING_IS));
rc |= NsfReplaceCommand(interp, NsfGlobalObjs[NSF_DISASSEMBLE], NULL, NULL, CMD_INFO(rst, NSF_DISASSEMBLE));
/* for the following commands, we have to add our own semantics */
rc |= NsfReplaceCommand(interp, NsfGlobalObjs[NSF_INFO_BODY], Nsf_InfoBodyObjCmd, NULL, CMD_INFO(rst, NSF_INFO_BODY));
rc |= NsfReplaceCommand(interp, NsfGlobalObjs[NSF_INFO_FRAME], Nsf_InfoFrameObjCmd, NULL, CMD_INFO(rst, NSF_INFO_FRAME));
rc |= NsfReplaceCommand(interp, NsfGlobalObjs[NSF_RENAME], Nsf_RenameObjCmd, NULL, CMD_INFO(rst, NSF_RENAME));
} else if (load == SHADOW_REFETCH) {
NsfReplaceCommandCheck(interp, NsfGlobalObjs[NSF_INFO_BODY], Nsf_InfoFrameObjCmd, CMD_INFO(rst, NSF_INFO_BODY));
NsfReplaceCommandCheck(interp, NsfGlobalObjs[NSF_INFO_FRAME], Nsf_InfoFrameObjCmd, CMD_INFO(rst, NSF_INFO_FRAME));
NsfReplaceCommandCheck(interp, NsfGlobalObjs[NSF_RENAME], Nsf_RenameObjCmd, CMD_INFO(rst, NSF_RENAME));
} else {
NsfReplaceCommandCleanup(interp, NsfGlobalObjs[NSF_INFO_BODY], CMD_INFO(rst, NSF_INFO_BODY));
NsfReplaceCommandCleanup(interp, NsfGlobalObjs[NSF_INFO_FRAME], CMD_INFO(rst, NSF_INFO_FRAME));
NsfReplaceCommandCleanup(interp, NsfGlobalObjs[NSF_RENAME], CMD_INFO(rst, NSF_RENAME));
FREE(NsfShadowTclCommandInfo*, rst->tclCommands);
rst->tclCommands = NULL;
}
return rc;
}
/*
*----------------------------------------------------------------------
* NsfCallCommand --
*
* Calls a Tcl Command as direct as possible. The commands have to be
* looked up previously via NsfShadowTclCommands(). The element objv[0]
* is replaced with the predefined command name.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
NsfCallCommand(Tcl_Interp *interp, NsfGlobalNames name,
TCL_OBJC_T 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<objc;i++){fprintf(stderr, "'%s' ", ObjStr(objv[i]));}
fprintf(stderr, "\n");
}
*/
ov[0] = NsfGlobalObjs[name];
if (objc > 1) {
memcpy(ov+1, objv+1, sizeof(Tcl_Obj *) * ((size_t)objc - 1u));
}
result = TCL_NRCALLOBJPROC(interp, ti->proc, ti->clientData, (TCL_SIZE_T)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:
*/