tclTestProcBodyObj.c

Go to the documentation of this file.
00001 /*
00002  * tclTestProcBodyObj.c --
00003  *
00004  *      Implements the "procbodytest" package, which contains commands to test
00005  *      creation of Tcl procedures whose body argument is a Tcl_Obj of type
00006  *      "procbody" rather than a string.
00007  *
00008  * Copyright (c) 1998 by Scriptics Corporation.
00009  *
00010  * See the file "license.terms" for information on usage and redistribution of
00011  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
00012  *
00013  * RCS: @(#) $Id: tclTestProcBodyObj.c,v 1.5 2007/04/16 13:36:35 dkf Exp $
00014  */
00015 
00016 #include "tclInt.h"
00017 
00018 /*
00019  * name and version of this package
00020  */
00021 
00022 static char packageName[] = "procbodytest";
00023 static char packageVersion[] = "1.0";
00024 
00025 /*
00026  * Name of the commands exported by this package
00027  */
00028 
00029 static char procCommand[] = "proc";
00030 
00031 /*
00032  * this struct describes an entry in the table of command names and command
00033  * procs
00034  */
00035 
00036 typedef struct CmdTable
00037 {
00038     char *cmdName;              /* command name */
00039     Tcl_ObjCmdProc *proc;       /* command proc */
00040     int exportIt;               /* if 1, export the command */
00041 } CmdTable;
00042 
00043 /*
00044  * Declarations for functions defined in this file.
00045  */
00046 
00047 static int      ProcBodyTestProcObjCmd(ClientData dummy,
00048                         Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
00049 static int      ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe);
00050 static int      RegisterCommand(Tcl_Interp* interp,
00051                         char *namespace, CONST CmdTable *cmdTablePtr);
00052 int             Procbodytest_Init(Tcl_Interp * interp);
00053 int             Procbodytest_SafeInit(Tcl_Interp * interp);
00054 
00055 /*
00056  * List of commands to create when the package is loaded; must go after the
00057  * declarations of the enable command procedure.
00058  */
00059 
00060 static CONST CmdTable commands[] = {
00061     { procCommand,      ProcBodyTestProcObjCmd, 1 },
00062     { 0, 0, 0 }
00063 };
00064 
00065 static CONST CmdTable safeCommands[] = {
00066     { procCommand,      ProcBodyTestProcObjCmd, 1 },
00067     { 0, 0, 0 }
00068 };
00069 
00070 /*
00071  *----------------------------------------------------------------------
00072  *
00073  * Procbodytest_Init --
00074  *
00075  *  This function initializes the "procbodytest" package.
00076  *
00077  * Results:
00078  *  A standard Tcl result.
00079  *
00080  * Side effects:
00081  *  None.
00082  *
00083  *----------------------------------------------------------------------
00084  */
00085 
00086 int
00087 Procbodytest_Init(
00088     Tcl_Interp *interp)         /* the Tcl interpreter for which the package
00089                                  * is initialized */
00090 {
00091     return ProcBodyTestInitInternal(interp, 0);
00092 }
00093 
00094 /*
00095  *----------------------------------------------------------------------
00096  *
00097  * Procbodytest_SafeInit --
00098  *
00099  *  This function initializes the "procbodytest" package.
00100  *
00101  * Results:
00102  *  A standard Tcl result.
00103  *
00104  * Side effects:
00105  *  None.
00106  *
00107  *----------------------------------------------------------------------
00108  */
00109 
00110 int
00111 Procbodytest_SafeInit(
00112     Tcl_Interp *interp)         /* the Tcl interpreter for which the package
00113                                  * is initialized */
00114 {
00115     return ProcBodyTestInitInternal(interp, 1);
00116 }
00117 
00118 /*
00119  *----------------------------------------------------------------------
00120  *
00121  * RegisterCommand --
00122  *
00123  *  This function registers a command in the context of the given namespace.
00124  *
00125  * Results:
00126  *  A standard Tcl result.
00127  *
00128  * Side effects:
00129  *  None.
00130  *
00131  *----------------------------------------------------------------------
00132  */
00133 
00134 static int RegisterCommand(interp, namespace, cmdTablePtr)
00135     Tcl_Interp* interp;         /* the Tcl interpreter for which the operation
00136                                  * is performed */
00137     char *namespace;            /* the namespace in which the command is
00138                                  * registered */
00139     CONST CmdTable *cmdTablePtr;/* the command to register */
00140 {
00141     char buf[128];
00142 
00143     if (cmdTablePtr->exportIt) {
00144         sprintf(buf, "namespace eval %s { namespace export %s }",
00145                 namespace, cmdTablePtr->cmdName);
00146         if (Tcl_Eval(interp, buf) != TCL_OK)
00147             return TCL_ERROR;
00148     }
00149 
00150     sprintf(buf, "%s::%s", namespace, cmdTablePtr->cmdName);
00151     Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0);
00152 
00153     return TCL_OK;
00154 }
00155 
00156 /*
00157  *----------------------------------------------------------------------
00158  *
00159  * ProcBodyTestInitInternal --
00160  *
00161  *  This function initializes the Loader package.
00162  *  The isSafe flag is 1 if the interpreter is safe, 0 otherwise.
00163  *
00164  * Results:
00165  *  A standard Tcl result.
00166  *
00167  * Side effects:
00168  *  None.
00169  *
00170  *----------------------------------------------------------------------
00171  */
00172 
00173 static int
00174 ProcBodyTestInitInternal(
00175     Tcl_Interp *interp,         /* the Tcl interpreter for which the package
00176                                  * is initialized */
00177     int isSafe)                 /* 1 if this is a safe interpreter */
00178 {
00179     CONST CmdTable *cmdTablePtr;
00180 
00181     cmdTablePtr = (isSafe) ? &safeCommands[0] : &commands[0];
00182     for ( ; cmdTablePtr->cmdName ; cmdTablePtr++) {
00183         if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) {
00184             return TCL_ERROR;
00185         }
00186     }
00187 
00188     return Tcl_PkgProvide(interp, packageName, packageVersion);
00189 }
00190 
00191 /*
00192  *----------------------------------------------------------------------
00193  *
00194  * ProcBodyTestProcObjCmd --
00195  *
00196  *  Implements the "procbodytest::proc" command. Here is the command
00197  *  description:
00198  *      procbodytest::proc newName argList bodyName
00199  *  Looks up a procedure called $bodyName and, if the procedure exists,
00200  *  constructs a Tcl_Obj of type "procbody" and calls Tcl_ProcObjCmd.
00201  *  Arguments:
00202  *    newName           the name of the procedure to be created
00203  *    argList           the argument list for the procedure
00204  *    bodyName          the name of an existing procedure from which the
00205  *                      body is to be copied.
00206  *  This command can be used to trigger the branches in Tcl_ProcObjCmd that
00207  *  construct a proc from a "procbody", for example:
00208  *      proc a {x} {return $x}
00209  *      a 123
00210  *      procbodytest::proc b {x} a
00211  *  Note the call to "a 123", which is necessary so that the Proc pointer
00212  *  for "a" is filled in by the internal compiler; this is a hack.
00213  *
00214  * Results:
00215  *  Returns a standard Tcl code.
00216  *
00217  * Side effects:
00218  *  A new procedure is created.
00219  *  Leaves an error message in the interp's result on error.
00220  *
00221  *----------------------------------------------------------------------
00222  */
00223 
00224 static int
00225 ProcBodyTestProcObjCmd(
00226     ClientData dummy,           /* context; not used */
00227     Tcl_Interp *interp,         /* the current interpreter */
00228     int objc,                   /* argument count */
00229     Tcl_Obj *const objv[])      /* arguments */
00230 {
00231     char *fullName;
00232     Tcl_Command procCmd;
00233     Command *cmdPtr;
00234     Proc *procPtr = NULL;
00235     Tcl_Obj *bodyObjPtr;
00236     Tcl_Obj *myobjv[5];
00237     int result;
00238 
00239     if (objc != 4) {
00240         Tcl_WrongNumArgs(interp, 1, objv, "newName argsList bodyName");
00241         return TCL_ERROR;
00242     }
00243 
00244     /*
00245      * Find the Command pointer to this procedure
00246      */
00247 
00248     fullName = Tcl_GetStringFromObj(objv[3], NULL);
00249     procCmd = Tcl_FindCommand(interp, fullName, NULL, TCL_LEAVE_ERR_MSG);
00250     if (procCmd == NULL) {
00251         return TCL_ERROR;
00252     }
00253 
00254     cmdPtr = (Command *) procCmd;
00255 
00256     /*
00257      * check that this is a procedure and not a builtin command:
00258      * If a procedure, cmdPtr->objProc is TclObjInterpProc.
00259      */
00260 
00261     if (cmdPtr->objProc != TclGetObjInterpProc()) {
00262         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
00263                 "command \"", fullName, "\" is not a Tcl procedure", NULL);
00264         return TCL_ERROR;
00265     }
00266 
00267     /*
00268      * it is a Tcl procedure: the client data is the Proc structure
00269      */
00270 
00271     procPtr = (Proc *) cmdPtr->objClientData;
00272     if (procPtr == NULL) {
00273         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
00274                 "procedure \"", fullName,
00275                 "\" does not have a Proc struct!", NULL);
00276         return TCL_ERROR;
00277     }
00278 
00279     /*
00280      * create a new object, initialize our argument vector, call into Tcl
00281      */
00282 
00283     bodyObjPtr = TclNewProcBodyObj(procPtr);
00284     if (bodyObjPtr == NULL) {
00285         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
00286                 "failed to create a procbody object for procedure \"",
00287                 fullName, "\"", NULL);
00288         return TCL_ERROR;
00289     }
00290     Tcl_IncrRefCount(bodyObjPtr);
00291 
00292     myobjv[0] = objv[0];
00293     myobjv[1] = objv[1];
00294     myobjv[2] = objv[2];
00295     myobjv[3] = bodyObjPtr;
00296     myobjv[4] = NULL;
00297 
00298     result = Tcl_ProcObjCmd((ClientData) NULL, interp, objc, myobjv);
00299     Tcl_DecrRefCount(bodyObjPtr);
00300 
00301     return result;
00302 }
00303 
00304 /*
00305  * Local Variables:
00306  * mode: c
00307  * c-basic-offset: 4
00308  * fill-column: 78
00309  * End:
00310  */



Generated on Wed Mar 12 12:18:22 2008 by  doxygen 1.5.1