1/* 2 * tclTestProcBodyObj.c -- 3 * 4 * Implements the "procbodytest" package, which contains commands to test 5 * creation of Tcl procedures whose body argument is a Tcl_Obj of type 6 * "procbody" rather than a string. 7 * 8 * Copyright (c) 1998 by Scriptics Corporation. 9 * 10 * See the file "license.terms" for information on usage and redistribution of 11 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 * 13 * RCS: @(#) $Id: tclTestProcBodyObj.c,v 1.5 2007/04/16 13:36:35 dkf Exp $ 14 */ 15 16#include "tclInt.h" 17 18/* 19 * name and version of this package 20 */ 21 22static char packageName[] = "procbodytest"; 23static char packageVersion[] = "1.0"; 24 25/* 26 * Name of the commands exported by this package 27 */ 28 29static char procCommand[] = "proc"; 30 31/* 32 * this struct describes an entry in the table of command names and command 33 * procs 34 */ 35 36typedef struct CmdTable 37{ 38 char *cmdName; /* command name */ 39 Tcl_ObjCmdProc *proc; /* command proc */ 40 int exportIt; /* if 1, export the command */ 41} CmdTable; 42 43/* 44 * Declarations for functions defined in this file. 45 */ 46 47static int ProcBodyTestProcObjCmd(ClientData dummy, 48 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); 49static int ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe); 50static int RegisterCommand(Tcl_Interp* interp, 51 char *namespace, CONST CmdTable *cmdTablePtr); 52int Procbodytest_Init(Tcl_Interp * interp); 53int Procbodytest_SafeInit(Tcl_Interp * interp); 54 55/* 56 * List of commands to create when the package is loaded; must go after the 57 * declarations of the enable command procedure. 58 */ 59 60static CONST CmdTable commands[] = { 61 { procCommand, ProcBodyTestProcObjCmd, 1 }, 62 { 0, 0, 0 } 63}; 64 65static CONST CmdTable safeCommands[] = { 66 { procCommand, ProcBodyTestProcObjCmd, 1 }, 67 { 0, 0, 0 } 68}; 69 70/* 71 *---------------------------------------------------------------------- 72 * 73 * Procbodytest_Init -- 74 * 75 * This function initializes the "procbodytest" package. 76 * 77 * Results: 78 * A standard Tcl result. 79 * 80 * Side effects: 81 * None. 82 * 83 *---------------------------------------------------------------------- 84 */ 85 86int 87Procbodytest_Init( 88 Tcl_Interp *interp) /* the Tcl interpreter for which the package 89 * is initialized */ 90{ 91 return ProcBodyTestInitInternal(interp, 0); 92} 93 94/* 95 *---------------------------------------------------------------------- 96 * 97 * Procbodytest_SafeInit -- 98 * 99 * This function initializes the "procbodytest" package. 100 * 101 * Results: 102 * A standard Tcl result. 103 * 104 * Side effects: 105 * None. 106 * 107 *---------------------------------------------------------------------- 108 */ 109 110int 111Procbodytest_SafeInit( 112 Tcl_Interp *interp) /* the Tcl interpreter for which the package 113 * is initialized */ 114{ 115 return ProcBodyTestInitInternal(interp, 1); 116} 117 118/* 119 *---------------------------------------------------------------------- 120 * 121 * RegisterCommand -- 122 * 123 * This function registers a command in the context of the given namespace. 124 * 125 * Results: 126 * A standard Tcl result. 127 * 128 * Side effects: 129 * None. 130 * 131 *---------------------------------------------------------------------- 132 */ 133 134static int RegisterCommand(interp, namespace, cmdTablePtr) 135 Tcl_Interp* interp; /* the Tcl interpreter for which the operation 136 * is performed */ 137 char *namespace; /* the namespace in which the command is 138 * registered */ 139 CONST CmdTable *cmdTablePtr;/* the command to register */ 140{ 141 char buf[128]; 142 143 if (cmdTablePtr->exportIt) { 144 sprintf(buf, "namespace eval %s { namespace export %s }", 145 namespace, cmdTablePtr->cmdName); 146 if (Tcl_Eval(interp, buf) != TCL_OK) 147 return TCL_ERROR; 148 } 149 150 sprintf(buf, "%s::%s", namespace, cmdTablePtr->cmdName); 151 Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0); 152 153 return TCL_OK; 154} 155 156/* 157 *---------------------------------------------------------------------- 158 * 159 * ProcBodyTestInitInternal -- 160 * 161 * This function initializes the Loader package. 162 * The isSafe flag is 1 if the interpreter is safe, 0 otherwise. 163 * 164 * Results: 165 * A standard Tcl result. 166 * 167 * Side effects: 168 * None. 169 * 170 *---------------------------------------------------------------------- 171 */ 172 173static int 174ProcBodyTestInitInternal( 175 Tcl_Interp *interp, /* the Tcl interpreter for which the package 176 * is initialized */ 177 int isSafe) /* 1 if this is a safe interpreter */ 178{ 179 CONST CmdTable *cmdTablePtr; 180 181 cmdTablePtr = (isSafe) ? &safeCommands[0] : &commands[0]; 182 for ( ; cmdTablePtr->cmdName ; cmdTablePtr++) { 183 if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) { 184 return TCL_ERROR; 185 } 186 } 187 188 return Tcl_PkgProvide(interp, packageName, packageVersion); 189} 190 191/* 192 *---------------------------------------------------------------------- 193 * 194 * ProcBodyTestProcObjCmd -- 195 * 196 * Implements the "procbodytest::proc" command. Here is the command 197 * description: 198 * procbodytest::proc newName argList bodyName 199 * Looks up a procedure called $bodyName and, if the procedure exists, 200 * constructs a Tcl_Obj of type "procbody" and calls Tcl_ProcObjCmd. 201 * Arguments: 202 * newName the name of the procedure to be created 203 * argList the argument list for the procedure 204 * bodyName the name of an existing procedure from which the 205 * body is to be copied. 206 * This command can be used to trigger the branches in Tcl_ProcObjCmd that 207 * construct a proc from a "procbody", for example: 208 * proc a {x} {return $x} 209 * a 123 210 * procbodytest::proc b {x} a 211 * Note the call to "a 123", which is necessary so that the Proc pointer 212 * for "a" is filled in by the internal compiler; this is a hack. 213 * 214 * Results: 215 * Returns a standard Tcl code. 216 * 217 * Side effects: 218 * A new procedure is created. 219 * Leaves an error message in the interp's result on error. 220 * 221 *---------------------------------------------------------------------- 222 */ 223 224static int 225ProcBodyTestProcObjCmd( 226 ClientData dummy, /* context; not used */ 227 Tcl_Interp *interp, /* the current interpreter */ 228 int objc, /* argument count */ 229 Tcl_Obj *const objv[]) /* arguments */ 230{ 231 char *fullName; 232 Tcl_Command procCmd; 233 Command *cmdPtr; 234 Proc *procPtr = NULL; 235 Tcl_Obj *bodyObjPtr; 236 Tcl_Obj *myobjv[5]; 237 int result; 238 239 if (objc != 4) { 240 Tcl_WrongNumArgs(interp, 1, objv, "newName argsList bodyName"); 241 return TCL_ERROR; 242 } 243 244 /* 245 * Find the Command pointer to this procedure 246 */ 247 248 fullName = Tcl_GetStringFromObj(objv[3], NULL); 249 procCmd = Tcl_FindCommand(interp, fullName, NULL, TCL_LEAVE_ERR_MSG); 250 if (procCmd == NULL) { 251 return TCL_ERROR; 252 } 253 254 cmdPtr = (Command *) procCmd; 255 256 /* 257 * check that this is a procedure and not a builtin command: 258 * If a procedure, cmdPtr->objProc is TclObjInterpProc. 259 */ 260 261 if (cmdPtr->objProc != TclGetObjInterpProc()) { 262 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 263 "command \"", fullName, "\" is not a Tcl procedure", NULL); 264 return TCL_ERROR; 265 } 266 267 /* 268 * it is a Tcl procedure: the client data is the Proc structure 269 */ 270 271 procPtr = (Proc *) cmdPtr->objClientData; 272 if (procPtr == NULL) { 273 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 274 "procedure \"", fullName, 275 "\" does not have a Proc struct!", NULL); 276 return TCL_ERROR; 277 } 278 279 /* 280 * create a new object, initialize our argument vector, call into Tcl 281 */ 282 283 bodyObjPtr = TclNewProcBodyObj(procPtr); 284 if (bodyObjPtr == NULL) { 285 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 286 "failed to create a procbody object for procedure \"", 287 fullName, "\"", NULL); 288 return TCL_ERROR; 289 } 290 Tcl_IncrRefCount(bodyObjPtr); 291 292 myobjv[0] = objv[0]; 293 myobjv[1] = objv[1]; 294 myobjv[2] = objv[2]; 295 myobjv[3] = bodyObjPtr; 296 myobjv[4] = NULL; 297 298 result = Tcl_ProcObjCmd((ClientData) NULL, interp, objc, myobjv); 299 Tcl_DecrRefCount(bodyObjPtr); 300 301 return result; 302} 303 304/* 305 * Local Variables: 306 * mode: c 307 * c-basic-offset: 4 308 * fill-column: 78 309 * End: 310 */ 311