1/* -*- Mode: c++ -*- 2 * $Id: xotclShadow.c,v 1.10 2007/09/05 19:09:23 neumann Exp $ 3 * 4 * Extended Object Tcl (XOTcl) 5 * 6 * Copyright (C) 1999-2008 Gustaf Neumann, Uwe Zdun 7 * 8 * 9 * xotclShadow.c -- 10 * 11 * Shadowing (overloading) and accessing global tcl obj commands 12 * 13 */ 14 15#include "xotclInt.h" 16#include "xotclAccessInt.h" 17 18static int 19XOTclReplaceCommandCleanup(Tcl_Interp *interp, XOTclGlobalNames name) { 20 Tcl_Command cmd; 21 int result = TCL_OK; 22 XOTclShadowTclCommandInfo *ti = &RUNTIME_STATE(interp)->tclCommands[name-XOTE_EXPR]; 23 24 /*fprintf(stderr," cleanup for %s ti=%p in %p\n", XOTclGlobalStrings[name], ti, interp);*/ 25 cmd = Tcl_GetCommandFromObj(interp, XOTclGlobalObjects[name]); 26 if (cmd != NULL) { 27 Tcl_Command_objProc(cmd) = ti->proc; 28 ti->proc = NULL; 29 } else { 30 result = TCL_ERROR; 31 } 32 33 return result; 34} 35 36static void 37XOTclReplaceCommandCheck(Tcl_Interp *interp, XOTclGlobalNames name, Tcl_ObjCmdProc *proc) { 38 Tcl_Command cmd; 39 XOTclShadowTclCommandInfo *ti = &RUNTIME_STATE(interp)->tclCommands[name-XOTE_EXPR]; 40 cmd = Tcl_GetCommandFromObj(interp, XOTclGlobalObjects[name]); 41 42 if (cmd != NULL && ti->proc && Tcl_Command_objProc(cmd) != proc) { 43 /* 44 fprintf(stderr, "we have to do something about %s %p %p\n", 45 XOTclGlobalStrings[name], Tcl_Command_objProc(cmd), proc); 46 */ 47 ti->proc = Tcl_Command_objProc(cmd); 48 ti->cd = Tcl_Command_objClientData(cmd); 49 Tcl_Command_objProc(cmd) = proc; 50 } 51} 52 53static int 54XOTclReplaceCommand(Tcl_Interp *interp, XOTclGlobalNames name, 55 Tcl_ObjCmdProc *xotclReplacementProc, int pass) { 56 Tcl_Command cmd; 57 XOTclShadowTclCommandInfo *ti = &RUNTIME_STATE(interp)->tclCommands[name-XOTE_EXPR]; 58 int result = TCL_OK; 59 60 /*fprintf(stderr,"XOTclReplaceCommand %d\n",name);*/ 61 cmd = Tcl_GetCommandFromObj(interp, XOTclGlobalObjects[name]); 62 63 if (cmd == NULL) { 64 result = TCL_ERROR; 65 } else { 66 Tcl_ObjCmdProc *objProc = Tcl_Command_objProc(cmd); 67 if (xotclReplacementProc != objProc) { 68 if (pass == 0) { /* setting values on first pass (must be locked here) */ 69 ti->proc = objProc; 70 ti->cd = Tcl_Command_objClientData(cmd); 71 } else if (ti->proc != objProc) { 72 /*fprintf(stderr, "we have to refetch command for %s\n",XOTclGlobalStrings[name]);*/ 73 ti->proc = objProc; 74 ti->cd = Tcl_Command_objClientData(cmd); 75 } 76 if (xotclReplacementProc) { 77 Tcl_Command_objProc(cmd) = xotclReplacementProc; 78 /*Tcl_CreateObjCommand(interp, XOTclGlobalStrings[name], xotclReplacementProc, 0, 0);*/ 79 } 80 } 81 } 82 return result; 83} 84 85static int 86XOTcl_RenameObjCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { 87 /* this call the Tcl_RenameObjCmd, but it ensures before that 88 the renamed obj, functions, etc. are not part of XOTcl */ 89 XOTclObject *obj = NULL; 90 Tcl_Command cmd; 91 92 /* wrong # args => normal Tcl ErrMsg*/ 93 if (objc != 3) 94 return XOTclCallCommand(interp, XOTE_RENAME, objc, objv); 95 96 /* if an obj/cl should be renamed => call the XOTcl move method */ 97 cmd = Tcl_FindCommand(interp, ObjStr(objv[1]), (Tcl_Namespace *)NULL,0); 98 99 if (cmd != NULL) { 100 obj = XOTclGetObjectFromCmdPtr(cmd); 101 if (obj) { 102 return XOTclCallMethodWithArgs((ClientData)obj, interp, 103 XOTclGlobalObjects[XOTE_MOVE], objv[2], 1, 0, 0); 104 } 105 } 106 107 /* Actually rename the cmd using Tcl's rename*/ 108 return XOTclCallCommand(interp, XOTE_RENAME, objc, objv); 109} 110 111static int 112XOTcl_InfoObjCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { 113 int result, isBody = 0; 114 if (objc > 1) { 115 char *opt = ObjStr(objv[1]); 116 if (isBodyString(opt) && objc > 2) 117 isBody = 1; 118 } 119 result = XOTclCallCommand(interp, XOTE_INFO, objc, objv); 120 121 if (isBody && result == TCL_OK) { 122 char *body = ObjStr(Tcl_GetObjResult(interp)); 123 if (strncmp(body, "::xotcl::initProcNS\n",20) == 0) 124 body += 20; 125 Tcl_SetObjResult(interp, Tcl_NewStringObj(body, -1)); 126 } 127 return result; 128} 129 130 131/* 132 * Obtain the names of the tcl commands 133 * not available through the stub interface and overload some global commands 134 */ 135int 136XOTclShadowTclCommands(Tcl_Interp *interp, XOTclShadowOperations load) { 137 int rc = TCL_OK; 138 if (load == SHADOW_LOAD) { 139 int initialized = (RUNTIME_STATE(interp)->tclCommands != NULL); 140 assert(initialized == 0); 141 RUNTIME_STATE(interp)->tclCommands = 142 NEW_ARRAY(XOTclShadowTclCommandInfo, XOTE_SUBST - XOTE_EXPR + 1); 143 144 /*fprintf(stderr, "+++ load tcl commands %d %d\n", load, initialized);*/ 145 146#ifdef USE_TCL_STUBS 147 /* no commands are overloaded, these are only used for calling 148 e.g. Tcl_ExprObjCmd(), Tcl_IncrObjCmd() and Tcl_SubstObjCmd(), 149 which are not avalailable in through the stub table */ 150 rc|= XOTclReplaceCommand(interp, XOTE_EXPR, 0, initialized); 151 rc|= XOTclReplaceCommand(interp, XOTE_SUBST, 0, initialized); 152#endif 153 /* for the following commands, we have to add our own semantics */ 154#if 1 155 rc|= XOTclReplaceCommand(interp, XOTE_INFO, XOTcl_InfoObjCmd, initialized); 156#endif 157 rc|= XOTclReplaceCommand(interp, XOTE_RENAME, XOTcl_RenameObjCmd, initialized); 158 159 } else if (load == SHADOW_REFETCH) { 160 XOTclReplaceCommandCheck(interp, XOTE_INFO, XOTcl_InfoObjCmd); 161 XOTclReplaceCommandCheck(interp, XOTE_RENAME, XOTcl_RenameObjCmd); 162 } else { 163 XOTclReplaceCommandCleanup(interp, XOTE_INFO); 164 XOTclReplaceCommandCleanup(interp, XOTE_RENAME); 165 FREE(XOTclShadowTclCommandInfo*, RUNTIME_STATE(interp)->tclCommands); 166 RUNTIME_STATE(interp)->tclCommands = NULL; 167 } 168 return rc; 169} 170 171/* 172 * call a Tcl command with given objv's ... replace objv[0] 173 * with the given command name 174 */ 175int XOTclCallCommand(Tcl_Interp *interp, XOTclGlobalNames name, 176 int objc, Tcl_Obj *CONST objv[]) { 177 int result; 178 XOTclShadowTclCommandInfo *ti = &RUNTIME_STATE(interp)->tclCommands[name-XOTE_EXPR]; 179 ALLOC_ON_STACK(Tcl_Obj*,objc, ov); 180 /* 181 {int i; 182 fprintf(stderr,"calling %s (%p %p) in %p, objc=%d ", 183 XOTclGlobalStrings[name],ti,ti->proc, interp, objc); 184 for(i=0;i<objc;i++){fprintf(stderr, "'%s' ", ObjStr(objv[i]));} 185 fprintf(stderr,"\n"); 186 } 187 */ 188 ov[0] = XOTclGlobalObjects[name]; 189 if (objc > 1) 190 memcpy(ov+1, objv+1, sizeof(Tcl_Obj *)*(objc-1)); 191 192 result = Tcl_NRCallObjProc(interp, ti->proc, ti->cd, objc, ov); 193 194 FREE_ON_STACK(Tcl_Obj *, ov); 195 return result; 196} 197