os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclTestProcBodyObj.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclTestProcBodyObj.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,319 @@
1.4 +/*
1.5 + * tclTestProcBodyObj.c --
1.6 + *
1.7 + * Implements the "procbodytest" package, which contains commands
1.8 + * to test creation of Tcl procedures whose body argument is a
1.9 + * Tcl_Obj of type "procbody" rather than a string.
1.10 + *
1.11 + * Copyright (c) 1998 by Scriptics Corporation.
1.12 + *
1.13 + * See the file "license.terms" for information on usage and redistribution
1.14 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.15 + *
1.16 + * RCS: @(#) $Id: tclTestProcBodyObj.c,v 1.2 1998/11/10 06:54:44 jingham Exp $
1.17 + */
1.18 +
1.19 +#include "tclInt.h"
1.20 +
1.21 +/*
1.22 + * name and version of this package
1.23 + */
1.24 +
1.25 +static char packageName[] = "procbodytest";
1.26 +static char packageVersion[] = "1.0";
1.27 +
1.28 +/*
1.29 + * Name of the commands exported by this package
1.30 + */
1.31 +
1.32 +static char procCommand[] = "proc";
1.33 +
1.34 +/*
1.35 + * this struct describes an entry in the table of command names and command
1.36 + * procs
1.37 + */
1.38 +
1.39 +typedef struct CmdTable
1.40 +{
1.41 + char *cmdName; /* command name */
1.42 + Tcl_ObjCmdProc *proc; /* command proc */
1.43 + int exportIt; /* if 1, export the command */
1.44 +} CmdTable;
1.45 +
1.46 +/*
1.47 + * Declarations for functions defined in this file.
1.48 + */
1.49 +
1.50 +static int ProcBodyTestProcObjCmd _ANSI_ARGS_((ClientData dummy,
1.51 + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
1.52 +static int ProcBodyTestInitInternal _ANSI_ARGS_((Tcl_Interp *interp,
1.53 + int isSafe));
1.54 +static int RegisterCommand _ANSI_ARGS_((Tcl_Interp* interp,
1.55 + char *namespace, CONST CmdTable *cmdTablePtr));
1.56 +int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp * interp));
1.57 +int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp * interp));
1.58 +
1.59 +/*
1.60 + * List of commands to create when the package is loaded; must go after the
1.61 + * declarations of the enable command procedure.
1.62 + */
1.63 +
1.64 +static CONST CmdTable commands[] =
1.65 +{
1.66 + { procCommand, ProcBodyTestProcObjCmd, 1 },
1.67 +
1.68 + { 0, 0, 0 }
1.69 +};
1.70 +
1.71 +static CONST CmdTable safeCommands[] =
1.72 +{
1.73 + { procCommand, ProcBodyTestProcObjCmd, 1 },
1.74 +
1.75 + { 0, 0, 0 }
1.76 +};
1.77 +
1.78 +/*
1.79 + *----------------------------------------------------------------------
1.80 + *
1.81 + * Procbodytest_Init --
1.82 + *
1.83 + * This procedure initializes the "procbodytest" package.
1.84 + *
1.85 + * Results:
1.86 + * A standard Tcl result.
1.87 + *
1.88 + * Side effects:
1.89 + * None.
1.90 + *
1.91 + *----------------------------------------------------------------------
1.92 + */
1.93 +
1.94 +int
1.95 +Procbodytest_Init(interp)
1.96 + Tcl_Interp *interp; /* the Tcl interpreter for which the package
1.97 + * is initialized */
1.98 +{
1.99 + return ProcBodyTestInitInternal(interp, 0);
1.100 +}
1.101 +
1.102 +/*
1.103 + *----------------------------------------------------------------------
1.104 + *
1.105 + * Procbodytest_SafeInit --
1.106 + *
1.107 + * This procedure initializes the "procbodytest" package.
1.108 + *
1.109 + * Results:
1.110 + * A standard Tcl result.
1.111 + *
1.112 + * Side effects:
1.113 + * None.
1.114 + *
1.115 + *----------------------------------------------------------------------
1.116 + */
1.117 +
1.118 +int
1.119 +Procbodytest_SafeInit(interp)
1.120 + Tcl_Interp *interp; /* the Tcl interpreter for which the package
1.121 + * is initialized */
1.122 +{
1.123 + return ProcBodyTestInitInternal(interp, 1);
1.124 +}
1.125 +
1.126 +/*
1.127 + *----------------------------------------------------------------------
1.128 + *
1.129 + * RegisterCommand --
1.130 + *
1.131 + * This procedure registers a command in the context of the given namespace.
1.132 + *
1.133 + * Results:
1.134 + * A standard Tcl result.
1.135 + *
1.136 + * Side effects:
1.137 + * None.
1.138 + *
1.139 + *----------------------------------------------------------------------
1.140 + */
1.141 +
1.142 +static int RegisterCommand(interp, namespace, cmdTablePtr)
1.143 + Tcl_Interp* interp; /* the Tcl interpreter for which the
1.144 + * operation is performed */
1.145 + char *namespace; /* the namespace in which the command
1.146 + * is registered */
1.147 + CONST CmdTable *cmdTablePtr; /* the command to register */
1.148 +{
1.149 + char buf[128];
1.150 +
1.151 + if (cmdTablePtr->exportIt) {
1.152 + sprintf(buf, "namespace eval %s { namespace export %s }",
1.153 + namespace, cmdTablePtr->cmdName);
1.154 + if (Tcl_Eval(interp, buf) != TCL_OK)
1.155 + return TCL_ERROR;
1.156 + }
1.157 +
1.158 + sprintf(buf, "%s::%s", namespace, cmdTablePtr->cmdName);
1.159 + Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0);
1.160 +
1.161 + return TCL_OK;
1.162 +}
1.163 +
1.164 +/*
1.165 + *----------------------------------------------------------------------
1.166 + *
1.167 + * ProcBodyTestInitInternal --
1.168 + *
1.169 + * This procedure initializes the Loader package.
1.170 + * The isSafe flag is 1 if the interpreter is safe, 0 otherwise.
1.171 + *
1.172 + * Results:
1.173 + * A standard Tcl result.
1.174 + *
1.175 + * Side effects:
1.176 + * None.
1.177 + *
1.178 + *----------------------------------------------------------------------
1.179 + */
1.180 +
1.181 +static int
1.182 +ProcBodyTestInitInternal(interp, isSafe)
1.183 + Tcl_Interp *interp; /* the Tcl interpreter for which the package
1.184 + * is initialized */
1.185 + int isSafe; /* 1 if this is a safe interpreter */
1.186 +{
1.187 + CONST CmdTable *cmdTablePtr;
1.188 +
1.189 + cmdTablePtr = (isSafe) ? &safeCommands[0] : &commands[0];
1.190 + for ( ; cmdTablePtr->cmdName ; cmdTablePtr++) {
1.191 + if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) {
1.192 + return TCL_ERROR;
1.193 + }
1.194 + }
1.195 +
1.196 + return Tcl_PkgProvide(interp, packageName, packageVersion);
1.197 +}
1.198 +
1.199 +/*
1.200 + *----------------------------------------------------------------------
1.201 + *
1.202 + * ProcBodyTestProcObjCmd --
1.203 + *
1.204 + * Implements the "procbodytest::proc" command. Here is the command
1.205 + * description:
1.206 + * procbodytest::proc newName argList bodyName
1.207 + * Looks up a procedure called $bodyName and, if the procedure exists,
1.208 + * constructs a Tcl_Obj of type "procbody" and calls Tcl_ProcObjCmd.
1.209 + * Arguments:
1.210 + * newName the name of the procedure to be created
1.211 + * argList the argument list for the procedure
1.212 + * bodyName the name of an existing procedure from which the
1.213 + * body is to be copied.
1.214 + * This command can be used to trigger the branches in Tcl_ProcObjCmd that
1.215 + * construct a proc from a "procbody", for example:
1.216 + * proc a {x} {return $x}
1.217 + * a 123
1.218 + * procbodytest::proc b {x} a
1.219 + * Note the call to "a 123", which is necessary so that the Proc pointer
1.220 + * for "a" is filled in by the internal compiler; this is a hack.
1.221 + *
1.222 + * Results:
1.223 + * Returns a standard Tcl code.
1.224 + *
1.225 + * Side effects:
1.226 + * A new procedure is created.
1.227 + * Leaves an error message in the interp's result on error.
1.228 + *
1.229 + *----------------------------------------------------------------------
1.230 + */
1.231 +
1.232 +static int
1.233 +ProcBodyTestProcObjCmd (dummy, interp, objc, objv)
1.234 + ClientData dummy; /* context; not used */
1.235 + Tcl_Interp *interp; /* the current interpreter */
1.236 + int objc; /* argument count */
1.237 + Tcl_Obj *CONST objv[]; /* arguments */
1.238 +{
1.239 + char *fullName;
1.240 + Tcl_Command procCmd;
1.241 + Command *cmdPtr;
1.242 + Proc *procPtr = (Proc *) NULL;
1.243 + Tcl_Obj *bodyObjPtr;
1.244 + Tcl_Obj *myobjv[5];
1.245 + int result;
1.246 +
1.247 + if (objc != 4) {
1.248 + Tcl_WrongNumArgs(interp, 1, objv, "newName argsList bodyName");
1.249 + return TCL_ERROR;
1.250 + }
1.251 +
1.252 + /*
1.253 + * Find the Command pointer to this procedure
1.254 + */
1.255 +
1.256 + fullName = Tcl_GetStringFromObj(objv[3], (int *) NULL);
1.257 + procCmd = Tcl_FindCommand(interp, fullName, (Tcl_Namespace *) NULL,
1.258 + TCL_LEAVE_ERR_MSG);
1.259 + if (procCmd == NULL) {
1.260 + return TCL_ERROR;
1.261 + }
1.262 +
1.263 + cmdPtr = (Command *) procCmd;
1.264 +
1.265 + /*
1.266 + * check that this is a procedure and not a builtin command:
1.267 + * If a procedure, cmdPtr->objProc is either 0 or TclObjInterpProc,
1.268 + * and cmdPtr->proc is either 0 or TclProcInterpProc.
1.269 + * Also, the compile proc should be 0, but we don't check for that.
1.270 + */
1.271 +
1.272 + if (((cmdPtr->objProc != NULL)
1.273 + && (cmdPtr->objProc != TclGetObjInterpProc()))
1.274 + || ((cmdPtr->proc != NULL)
1.275 + && (cmdPtr->proc != TclGetInterpProc()))) {
1.276 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.277 + "command \"", fullName,
1.278 + "\" is not a Tcl procedure", (char *) NULL);
1.279 + return TCL_ERROR;
1.280 + }
1.281 +
1.282 + /*
1.283 + * it is a Tcl procedure: the client data is the Proc structure
1.284 + */
1.285 +
1.286 + if (cmdPtr->objProc != NULL) {
1.287 + procPtr = (Proc *) cmdPtr->objClientData;
1.288 + } else if (cmdPtr->proc != NULL) {
1.289 + procPtr = (Proc *) cmdPtr->clientData;
1.290 + }
1.291 +
1.292 + if (procPtr == NULL) {
1.293 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.294 + "procedure \"", fullName,
1.295 + "\" does not have a Proc struct!", (char *) NULL);
1.296 + return TCL_ERROR;
1.297 + }
1.298 +
1.299 + /*
1.300 + * create a new object, initialize our argument vector, call into Tcl
1.301 + */
1.302 +
1.303 + bodyObjPtr = TclNewProcBodyObj(procPtr);
1.304 + if (bodyObjPtr == NULL) {
1.305 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.306 + "failed to create a procbody object for procedure \"",
1.307 + fullName, "\"", (char *) NULL);
1.308 + return TCL_ERROR;
1.309 + }
1.310 + Tcl_IncrRefCount(bodyObjPtr);
1.311 +
1.312 + myobjv[0] = objv[0];
1.313 + myobjv[1] = objv[1];
1.314 + myobjv[2] = objv[2];
1.315 + myobjv[3] = bodyObjPtr;
1.316 + myobjv[4] = (Tcl_Obj *) NULL;
1.317 +
1.318 + result = Tcl_ProcObjCmd((ClientData) NULL, interp, objc, myobjv);
1.319 + Tcl_DecrRefCount(bodyObjPtr);
1.320 +
1.321 + return result;
1.322 +}