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