/* 

  * 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;

 }