mTk/tclGeneric/tclTestProcBodyObj.c

/*
 * tclTestProcBodyObj.c --
 *
 *	Implements the "procbodytest" package, which contains commands
 *	to test creation of Tcl procedures whose body argument is a
 *	Tcl_Obj of type "procbody" rather than a string.
 *
 * Copyright (c) 1998 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTestProcBodyObj.c,v 1.2 1998/11/10 06:54:44 jingham Exp $
 */

#include "tclInt.h"

/*
 * name and version of this package
 */

static char packageName[] = "procbodytest";
static char packageVersion[] = "1.0";

/*
 * Name of the commands exported by this package
 */

static char procCommand[] = "proc";

/*
 * this struct describes an entry in the table of command names and command
 * procs
 */

typedef struct CmdTable
{
    char *cmdName;		/* command name */
    Tcl_ObjCmdProc *proc;	/* command proc */
    int exportIt;		/* if 1, export the command */
} CmdTable;

/*
 * Declarations for functions defined in this file.
 */

static int	ProcBodyTestProcObjCmd _ANSI_ARGS_((ClientData dummy,
			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
static int	ProcBodyTestInitInternal _ANSI_ARGS_((Tcl_Interp *interp,
			int isSafe));
static int	RegisterCommand _ANSI_ARGS_((Tcl_Interp* interp,
			char *namespace, CONST CmdTable *cmdTablePtr));
int             Procbodytest_Init _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
 * declarations of the enable command procedure.
 */

static CONST CmdTable commands[] =
{
    { procCommand,	ProcBodyTestProcObjCmd,	1 },

    { 0, 0, 0 }
};

static CONST CmdTable safeCommands[] =
{
    { procCommand,	ProcBodyTestProcObjCmd,	1 },

    { 0, 0, 0 }
};

/*
 *----------------------------------------------------------------------
 *
 * Procbodytest_Init --
 *
 *  This procedure initializes the "procbodytest" package.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

int
Procbodytest_Init(interp)
    Tcl_Interp *interp;		/* the Tcl interpreter for which the package
                                 * is initialized */
{
    return ProcBodyTestInitInternal(interp, 0);
}

/*
 *----------------------------------------------------------------------
 *
 * Procbodytest_SafeInit --
 *
 *  This procedure initializes the "procbodytest" package.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

int
Procbodytest_SafeInit(interp)
    Tcl_Interp *interp;		/* the Tcl interpreter for which the package
                                 * is initialized */
{
    return ProcBodyTestInitInternal(interp, 1);
}

/*
 *----------------------------------------------------------------------
 *
 * RegisterCommand --
 *
 *  This procedure registers a command in the context of the given namespace.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int RegisterCommand(interp, namespace, cmdTablePtr)
    Tcl_Interp* interp;			/* the Tcl interpreter for which the
                                         * operation is performed */
    char *namespace;			/* the namespace in which the command
                                         * is registered */
    CONST CmdTable *cmdTablePtr;	/* the command to register */
{
    char buf[128];

    if (cmdTablePtr->exportIt) {
        sprintf(buf, "namespace eval %s { namespace export %s }",
                namespace, cmdTablePtr->cmdName);
        if (Tcl_Eval(interp, buf) != TCL_OK)
            return TCL_ERROR;
    }

    sprintf(buf, "%s::%s", namespace, cmdTablePtr->cmdName);
    Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ProcBodyTestInitInternal --
 *
 *  This procedure initializes the Loader package.
 *  The isSafe flag is 1 if the interpreter is safe, 0 otherwise.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
ProcBodyTestInitInternal(interp, isSafe)
    Tcl_Interp *interp;		/* the Tcl interpreter for which the package
                                 * is initialized */
    int isSafe;			/* 1 if this is a safe interpreter */
{
    CONST CmdTable *cmdTablePtr;

    cmdTablePtr = (isSafe) ? &safeCommands[0] : &commands[0];
    for ( ; cmdTablePtr->cmdName ; cmdTablePtr++) {
        if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) {
            return TCL_ERROR;
        }
    }

    return Tcl_PkgProvide(interp, packageName, packageVersion);
}

/*
 *----------------------------------------------------------------------
 *
 * ProcBodyTestProcObjCmd --
 *
 *  Implements the "procbodytest::proc" command. Here is the command
 *  description:
 *	procbodytest::proc newName argList bodyName
 *  Looks up a procedure called $bodyName and, if the procedure exists,
 *  constructs a Tcl_Obj of type "procbody" and calls Tcl_ProcObjCmd.
 *  Arguments:
 *    newName		the name of the procedure to be created
 *    argList		the argument list for the procedure
 *    bodyName		the name of an existing procedure from which the
 *			body is to be copied.
 *  This command can be used to trigger the branches in Tcl_ProcObjCmd that
 *  construct a proc from a "procbody", for example:
 *	proc a {x} {return $x}
 *	a 123
 *	procbodytest::proc b {x} a
 *  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.
 *
 * Results:
 *  Returns a standard Tcl code.
 *
 * Side effects:
 *  A new procedure is created.
 *  Leaves an error message in the interp's result on error.
 *
 *----------------------------------------------------------------------
 */

static int
ProcBodyTestProcObjCmd (dummy, interp, objc, objv)
    ClientData dummy;		/* context; not used */
    Tcl_Interp *interp;		/* the current interpreter */
    int objc;			/* argument count */
    Tcl_Obj *CONST objv[];	/* arguments */
{
    char *fullName;
    Tcl_Command procCmd;
    Command *cmdPtr;
    Proc *procPtr = (Proc *) NULL;
    Tcl_Obj *bodyObjPtr;
    Tcl_Obj *myobjv[5];
    int result;

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "newName argsList bodyName");
	return TCL_ERROR;
    }

    /*
     * Find the Command pointer to this procedure
     */

    fullName = Tcl_GetStringFromObj(objv[3], (int *) NULL);
    procCmd = Tcl_FindCommand(interp, fullName, (Tcl_Namespace *) NULL,
            TCL_LEAVE_ERR_MSG);
    if (procCmd == NULL) {
        return TCL_ERROR;
    }

    cmdPtr = (Command *) procCmd;

    /*
     * check that this is a procedure and not a builtin command:
     * If a procedure, cmdPtr->objProc is either 0 or TclObjInterpProc,
     * and cmdPtr->proc is either 0 or TclProcInterpProc.
     * Also, the compile proc should be 0, but we don't check for that.
     */

    if (((cmdPtr->objProc != NULL)
            && (cmdPtr->objProc != TclGetObjInterpProc()))
            || ((cmdPtr->proc != NULL)
                    && (cmdPtr->proc != TclGetInterpProc()))) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"command \"", fullName,
		"\" is not a Tcl procedure", (char *) NULL);
        return TCL_ERROR;
    }

    /*
     * it is a Tcl procedure: the client data is the Proc structure
     */

    if (cmdPtr->objProc != NULL) {
        procPtr = (Proc *) cmdPtr->objClientData;
    } else if (cmdPtr->proc != NULL) {
        procPtr = (Proc *) cmdPtr->clientData;
    }

    if (procPtr == NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"procedure \"", fullName,
		"\" does not have a Proc struct!", (char *) NULL);
        return TCL_ERROR;
    }

    /*
     * create a new object, initialize our argument vector, call into Tcl
     */

    bodyObjPtr = TclNewProcBodyObj(procPtr);
    if (bodyObjPtr == NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"failed to create a procbody object for procedure \"",
                fullName, "\"", (char *) NULL);
        return TCL_ERROR;
    }
    Tcl_IncrRefCount(bodyObjPtr);

    myobjv[0] = objv[0];
    myobjv[1] = objv[1];
    myobjv[2] = objv[2];
    myobjv[3] = bodyObjPtr;
    myobjv[4] = (Tcl_Obj *) NULL;

    result = Tcl_ProcObjCmd((ClientData) NULL, interp, objc, myobjv);
    Tcl_DecrRefCount(bodyObjPtr);

    return result;
}