/*
|
/*
|
* tclTestProcBodyObj.c --
|
* tclTestProcBodyObj.c --
|
*
|
*
|
* Implements the "procbodytest" package, which contains commands
|
* Implements the "procbodytest" package, which contains commands
|
* to test creation of Tcl procedures whose body argument is a
|
* to test creation of Tcl procedures whose body argument is a
|
* Tcl_Obj of type "procbody" rather than a string.
|
* Tcl_Obj of type "procbody" rather than a string.
|
*
|
*
|
* Copyright (c) 1998 by Scriptics Corporation.
|
* Copyright (c) 1998 by Scriptics Corporation.
|
*
|
*
|
* See the file "license.terms" for information on usage and redistribution
|
* See the file "license.terms" for information on usage and redistribution
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
*
|
*
|
* RCS: @(#) $Id: tclTestProcBodyObj.c,v 1.1.1.1 2002-01-16 10:25:29 markom Exp $
|
* RCS: @(#) $Id: tclTestProcBodyObj.c,v 1.1.1.1 2002-01-16 10:25:29 markom Exp $
|
*/
|
*/
|
|
|
#include "tclInt.h"
|
#include "tclInt.h"
|
|
|
/*
|
/*
|
* name and version of this package
|
* name and version of this package
|
*/
|
*/
|
|
|
static char packageName[] = "procbodytest";
|
static char packageName[] = "procbodytest";
|
static char packageVersion[] = "1.0";
|
static char packageVersion[] = "1.0";
|
|
|
/*
|
/*
|
* Name of the commands exported by this package
|
* Name of the commands exported by this package
|
*/
|
*/
|
|
|
static char procCommand[] = "proc";
|
static char procCommand[] = "proc";
|
|
|
/*
|
/*
|
* this struct describes an entry in the table of command names and command
|
* this struct describes an entry in the table of command names and command
|
* procs
|
* procs
|
*/
|
*/
|
|
|
typedef struct CmdTable
|
typedef struct CmdTable
|
{
|
{
|
char *cmdName; /* command name */
|
char *cmdName; /* command name */
|
Tcl_ObjCmdProc *proc; /* command proc */
|
Tcl_ObjCmdProc *proc; /* command proc */
|
int exportIt; /* if 1, export the command */
|
int exportIt; /* if 1, export the command */
|
} CmdTable;
|
} CmdTable;
|
|
|
/*
|
/*
|
* Declarations for functions defined in this file.
|
* Declarations for functions defined in this file.
|
*/
|
*/
|
|
|
static int ProcBodyTestProcObjCmd _ANSI_ARGS_((ClientData dummy,
|
static int ProcBodyTestProcObjCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
|
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
|
static int ProcBodyTestInitInternal _ANSI_ARGS_((Tcl_Interp *interp,
|
static int ProcBodyTestInitInternal _ANSI_ARGS_((Tcl_Interp *interp,
|
int isSafe));
|
int isSafe));
|
static int RegisterCommand _ANSI_ARGS_((Tcl_Interp* interp,
|
static int RegisterCommand _ANSI_ARGS_((Tcl_Interp* interp,
|
char *namespace, CONST CmdTable *cmdTablePtr));
|
char *namespace, CONST CmdTable *cmdTablePtr));
|
int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp * interp));
|
int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp * interp));
|
int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp * interp));
|
int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp * interp));
|
|
|
/*
|
/*
|
* List of commands to create when the package is loaded; must go after the
|
* List of commands to create when the package is loaded; must go after the
|
* declarations of the enable command procedure.
|
* declarations of the enable command procedure.
|
*/
|
*/
|
|
|
static CONST CmdTable commands[] =
|
static CONST CmdTable commands[] =
|
{
|
{
|
{ procCommand, ProcBodyTestProcObjCmd, 1 },
|
{ procCommand, ProcBodyTestProcObjCmd, 1 },
|
|
|
{ 0, 0, 0 }
|
{ 0, 0, 0 }
|
};
|
};
|
|
|
static CONST CmdTable safeCommands[] =
|
static CONST CmdTable safeCommands[] =
|
{
|
{
|
{ procCommand, ProcBodyTestProcObjCmd, 1 },
|
{ procCommand, ProcBodyTestProcObjCmd, 1 },
|
|
|
{ 0, 0, 0 }
|
{ 0, 0, 0 }
|
};
|
};
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Procbodytest_Init --
|
* Procbodytest_Init --
|
*
|
*
|
* This procedure initializes the "procbodytest" package.
|
* This procedure initializes the "procbodytest" package.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Procbodytest_Init(interp)
|
Procbodytest_Init(interp)
|
Tcl_Interp *interp; /* the Tcl interpreter for which the package
|
Tcl_Interp *interp; /* the Tcl interpreter for which the package
|
* is initialized */
|
* is initialized */
|
{
|
{
|
return ProcBodyTestInitInternal(interp, 0);
|
return ProcBodyTestInitInternal(interp, 0);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Procbodytest_SafeInit --
|
* Procbodytest_SafeInit --
|
*
|
*
|
* This procedure initializes the "procbodytest" package.
|
* This procedure initializes the "procbodytest" package.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Procbodytest_SafeInit(interp)
|
Procbodytest_SafeInit(interp)
|
Tcl_Interp *interp; /* the Tcl interpreter for which the package
|
Tcl_Interp *interp; /* the Tcl interpreter for which the package
|
* is initialized */
|
* is initialized */
|
{
|
{
|
return ProcBodyTestInitInternal(interp, 1);
|
return ProcBodyTestInitInternal(interp, 1);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* RegisterCommand --
|
* RegisterCommand --
|
*
|
*
|
* This procedure registers a command in the context of the given namespace.
|
* This procedure registers a command in the context of the given namespace.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int RegisterCommand(interp, namespace, cmdTablePtr)
|
static int RegisterCommand(interp, namespace, cmdTablePtr)
|
Tcl_Interp* interp; /* the Tcl interpreter for which the
|
Tcl_Interp* interp; /* the Tcl interpreter for which the
|
* operation is performed */
|
* operation is performed */
|
char *namespace; /* the namespace in which the command
|
char *namespace; /* the namespace in which the command
|
* is registered */
|
* is registered */
|
CONST CmdTable *cmdTablePtr; /* the command to register */
|
CONST CmdTable *cmdTablePtr; /* the command to register */
|
{
|
{
|
char buf[128];
|
char buf[128];
|
|
|
if (cmdTablePtr->exportIt) {
|
if (cmdTablePtr->exportIt) {
|
sprintf(buf, "namespace eval %s { namespace export %s }",
|
sprintf(buf, "namespace eval %s { namespace export %s }",
|
namespace, cmdTablePtr->cmdName);
|
namespace, cmdTablePtr->cmdName);
|
if (Tcl_Eval(interp, buf) != TCL_OK)
|
if (Tcl_Eval(interp, buf) != TCL_OK)
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
sprintf(buf, "%s::%s", namespace, cmdTablePtr->cmdName);
|
sprintf(buf, "%s::%s", namespace, cmdTablePtr->cmdName);
|
Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0);
|
Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0);
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* ProcBodyTestInitInternal --
|
* ProcBodyTestInitInternal --
|
*
|
*
|
* This procedure initializes the Loader package.
|
* This procedure initializes the Loader package.
|
* The isSafe flag is 1 if the interpreter is safe, 0 otherwise.
|
* The isSafe flag is 1 if the interpreter is safe, 0 otherwise.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
ProcBodyTestInitInternal(interp, isSafe)
|
ProcBodyTestInitInternal(interp, isSafe)
|
Tcl_Interp *interp; /* the Tcl interpreter for which the package
|
Tcl_Interp *interp; /* the Tcl interpreter for which the package
|
* is initialized */
|
* is initialized */
|
int isSafe; /* 1 if this is a safe interpreter */
|
int isSafe; /* 1 if this is a safe interpreter */
|
{
|
{
|
CONST CmdTable *cmdTablePtr;
|
CONST CmdTable *cmdTablePtr;
|
|
|
cmdTablePtr = (isSafe) ? &safeCommands[0] : &commands[0];
|
cmdTablePtr = (isSafe) ? &safeCommands[0] : &commands[0];
|
for ( ; cmdTablePtr->cmdName ; cmdTablePtr++) {
|
for ( ; cmdTablePtr->cmdName ; cmdTablePtr++) {
|
if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) {
|
if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
return Tcl_PkgProvide(interp, packageName, packageVersion);
|
return Tcl_PkgProvide(interp, packageName, packageVersion);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* ProcBodyTestProcObjCmd --
|
* ProcBodyTestProcObjCmd --
|
*
|
*
|
* Implements the "procbodytest::proc" command. Here is the command
|
* Implements the "procbodytest::proc" command. Here is the command
|
* description:
|
* description:
|
* procbodytest::proc newName argList bodyName
|
* procbodytest::proc newName argList bodyName
|
* Looks up a procedure called $bodyName and, if the procedure exists,
|
* Looks up a procedure called $bodyName and, if the procedure exists,
|
* constructs a Tcl_Obj of type "procbody" and calls Tcl_ProcObjCmd.
|
* constructs a Tcl_Obj of type "procbody" and calls Tcl_ProcObjCmd.
|
* Arguments:
|
* Arguments:
|
* newName the name of the procedure to be created
|
* newName the name of the procedure to be created
|
* argList the argument list for the procedure
|
* argList the argument list for the procedure
|
* bodyName the name of an existing procedure from which the
|
* bodyName the name of an existing procedure from which the
|
* body is to be copied.
|
* body is to be copied.
|
* This command can be used to trigger the branches in Tcl_ProcObjCmd that
|
* This command can be used to trigger the branches in Tcl_ProcObjCmd that
|
* construct a proc from a "procbody", for example:
|
* construct a proc from a "procbody", for example:
|
* proc a {x} {return $x}
|
* proc a {x} {return $x}
|
* a 123
|
* a 123
|
* procbodytest::proc b {x} a
|
* procbodytest::proc b {x} a
|
* Note the call to "a 123", which is necessary so that the Proc pointer
|
* Note the call to "a 123", which is necessary so that the Proc pointer
|
* for "a" is filled in by the internal compiler; this is a hack.
|
* for "a" is filled in by the internal compiler; this is a hack.
|
*
|
*
|
* Results:
|
* Results:
|
* Returns a standard Tcl code.
|
* Returns a standard Tcl code.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* A new procedure is created.
|
* A new procedure is created.
|
* Leaves an error message in the interp's result on error.
|
* Leaves an error message in the interp's result on error.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
ProcBodyTestProcObjCmd (dummy, interp, objc, objv)
|
ProcBodyTestProcObjCmd (dummy, interp, objc, objv)
|
ClientData dummy; /* context; not used */
|
ClientData dummy; /* context; not used */
|
Tcl_Interp *interp; /* the current interpreter */
|
Tcl_Interp *interp; /* the current interpreter */
|
int objc; /* argument count */
|
int objc; /* argument count */
|
Tcl_Obj *CONST objv[]; /* arguments */
|
Tcl_Obj *CONST objv[]; /* arguments */
|
{
|
{
|
char *fullName;
|
char *fullName;
|
Tcl_Command procCmd;
|
Tcl_Command procCmd;
|
Command *cmdPtr;
|
Command *cmdPtr;
|
Proc *procPtr = (Proc *) NULL;
|
Proc *procPtr = (Proc *) NULL;
|
Tcl_Obj *bodyObjPtr;
|
Tcl_Obj *bodyObjPtr;
|
Tcl_Obj *myobjv[5];
|
Tcl_Obj *myobjv[5];
|
int result;
|
int result;
|
|
|
if (objc != 4) {
|
if (objc != 4) {
|
Tcl_WrongNumArgs(interp, 1, objv, "newName argsList bodyName");
|
Tcl_WrongNumArgs(interp, 1, objv, "newName argsList bodyName");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Find the Command pointer to this procedure
|
* Find the Command pointer to this procedure
|
*/
|
*/
|
|
|
fullName = Tcl_GetStringFromObj(objv[3], (int *) NULL);
|
fullName = Tcl_GetStringFromObj(objv[3], (int *) NULL);
|
procCmd = Tcl_FindCommand(interp, fullName, (Tcl_Namespace *) NULL,
|
procCmd = Tcl_FindCommand(interp, fullName, (Tcl_Namespace *) NULL,
|
TCL_LEAVE_ERR_MSG);
|
TCL_LEAVE_ERR_MSG);
|
if (procCmd == NULL) {
|
if (procCmd == NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
cmdPtr = (Command *) procCmd;
|
cmdPtr = (Command *) procCmd;
|
|
|
/*
|
/*
|
* check that this is a procedure and not a builtin command:
|
* check that this is a procedure and not a builtin command:
|
* If a procedure, cmdPtr->objProc is either 0 or TclObjInterpProc,
|
* If a procedure, cmdPtr->objProc is either 0 or TclObjInterpProc,
|
* and cmdPtr->proc is either 0 or TclProcInterpProc.
|
* and cmdPtr->proc is either 0 or TclProcInterpProc.
|
* Also, the compile proc should be 0, but we don't check for that.
|
* Also, the compile proc should be 0, but we don't check for that.
|
*/
|
*/
|
|
|
if (((cmdPtr->objProc != NULL)
|
if (((cmdPtr->objProc != NULL)
|
&& (cmdPtr->objProc != TclGetObjInterpProc()))
|
&& (cmdPtr->objProc != TclGetObjInterpProc()))
|
|| ((cmdPtr->proc != NULL)
|
|| ((cmdPtr->proc != NULL)
|
&& (cmdPtr->proc != TclGetInterpProc()))) {
|
&& (cmdPtr->proc != TclGetInterpProc()))) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"command \"", fullName,
|
"command \"", fullName,
|
"\" is not a Tcl procedure", (char *) NULL);
|
"\" is not a Tcl procedure", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* it is a Tcl procedure: the client data is the Proc structure
|
* it is a Tcl procedure: the client data is the Proc structure
|
*/
|
*/
|
|
|
if (cmdPtr->objProc != NULL) {
|
if (cmdPtr->objProc != NULL) {
|
procPtr = (Proc *) cmdPtr->objClientData;
|
procPtr = (Proc *) cmdPtr->objClientData;
|
} else if (cmdPtr->proc != NULL) {
|
} else if (cmdPtr->proc != NULL) {
|
procPtr = (Proc *) cmdPtr->clientData;
|
procPtr = (Proc *) cmdPtr->clientData;
|
}
|
}
|
|
|
if (procPtr == NULL) {
|
if (procPtr == NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"procedure \"", fullName,
|
"procedure \"", fullName,
|
"\" does not have a Proc struct!", (char *) NULL);
|
"\" does not have a Proc struct!", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* create a new object, initialize our argument vector, call into Tcl
|
* create a new object, initialize our argument vector, call into Tcl
|
*/
|
*/
|
|
|
bodyObjPtr = TclNewProcBodyObj(procPtr);
|
bodyObjPtr = TclNewProcBodyObj(procPtr);
|
if (bodyObjPtr == NULL) {
|
if (bodyObjPtr == NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"failed to create a procbody object for procedure \"",
|
"failed to create a procbody object for procedure \"",
|
fullName, "\"", (char *) NULL);
|
fullName, "\"", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Tcl_IncrRefCount(bodyObjPtr);
|
Tcl_IncrRefCount(bodyObjPtr);
|
|
|
myobjv[0] = objv[0];
|
myobjv[0] = objv[0];
|
myobjv[1] = objv[1];
|
myobjv[1] = objv[1];
|
myobjv[2] = objv[2];
|
myobjv[2] = objv[2];
|
myobjv[3] = bodyObjPtr;
|
myobjv[3] = bodyObjPtr;
|
myobjv[4] = (Tcl_Obj *) NULL;
|
myobjv[4] = (Tcl_Obj *) NULL;
|
|
|
result = Tcl_ProcObjCmd((ClientData) NULL, interp, objc, myobjv);
|
result = Tcl_ProcObjCmd((ClientData) NULL, interp, objc, myobjv);
|
Tcl_DecrRefCount(bodyObjPtr);
|
Tcl_DecrRefCount(bodyObjPtr);
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
