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