util/src/TclTk/tcl8.6.12/generic/tclTestProcBodyObj.c

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