diff options
Diffstat (limited to 'generic/tclTestProcBodyObj.c')
| -rw-r--r-- | generic/tclTestProcBodyObj.c | 158 |
1 files changed, 57 insertions, 101 deletions
diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index 2139b81..644179b 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -5,38 +5,35 @@ * creation of Tcl procedures whose body argument is a Tcl_Obj of type * "procbody" rather than a string. * - * Copyright © 1998 Scriptics Corporation. + * 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. */ -#ifndef USE_TCL_STUBS -# define USE_TCL_STUBS -#endif #include "tclInt.h" /* * name and version of this package */ -static const char packageName[] = "tcl::procbodytest"; -static const char packageVersion[] = "1.1"; +static const char packageName[] = "procbodytest"; +static const char packageVersion[] = "1.0"; /* * Name of the commands exported by this package */ static const char procCommand[] = "proc"; -static const char checkCommand[] = "check"; /* * this struct describes an entry in the table of command names and command * procs */ -typedef struct { - const char *cmdName; /* command name */ +typedef struct CmdTable +{ + const char *cmdName; /* command name */ Tcl_ObjCmdProc *proc; /* command proc */ int exportIt; /* if 1, export the command */ } CmdTable; @@ -45,26 +42,26 @@ typedef struct { * Declarations for functions defined in this file. */ -static Tcl_ObjCmdProc ProcBodyTestProcObjCmd; -static Tcl_ObjCmdProc ProcBodyTestCheckObjCmd; +static int ProcBodyTestProcObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe); static int RegisterCommand(Tcl_Interp* interp, - const char *namesp, const CmdTable *cmdTablePtr); + const char *namespace, const CmdTable *cmdTablePtr); +int Procbodytest_Init(Tcl_Interp * interp); +int Procbodytest_SafeInit(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[] = { +static CONST CmdTable commands[] = { { procCommand, ProcBodyTestProcObjCmd, 1 }, - { checkCommand, ProcBodyTestCheckObjCmd, 1 }, { 0, 0, 0 } }; -static const CmdTable safeCommands[] = { +static CONST CmdTable safeCommands[] = { { procCommand, ProcBodyTestProcObjCmd, 1 }, - { checkCommand, ProcBodyTestCheckObjCmd, 1 }, { 0, 0, 0 } }; @@ -73,13 +70,13 @@ static const CmdTable safeCommands[] = { * * Procbodytest_Init -- * - * This function initializes the "tcl::procbodytest" package. + * This function initializes the "procbodytest" package. * * Results: - * A standard Tcl result. + * A standard Tcl result. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ @@ -87,7 +84,7 @@ static const CmdTable safeCommands[] = { int Procbodytest_Init( Tcl_Interp *interp) /* the Tcl interpreter for which the package - * is initialized */ + * is initialized */ { return ProcBodyTestInitInternal(interp, 0); } @@ -97,13 +94,13 @@ Procbodytest_Init( * * Procbodytest_SafeInit -- * - * This function initializes the "tcl::procbodytest" package. + * This function initializes the "procbodytest" package. * * Results: - * A standard Tcl result. + * A standard Tcl result. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ @@ -111,7 +108,7 @@ Procbodytest_Init( int Procbodytest_SafeInit( Tcl_Interp *interp) /* the Tcl interpreter for which the package - * is initialized */ + * is initialized */ { return ProcBodyTestInitInternal(interp, 1); } @@ -121,38 +118,36 @@ Procbodytest_SafeInit( * * RegisterCommand -- * - * This function registers a command in the context of the given - * namespace. + * This function registers a command in the context of the given namespace. * * Results: - * A standard Tcl result. + * A standard Tcl result. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ -static int -RegisterCommand( - Tcl_Interp* interp, /* the Tcl interpreter for which the operation +static int RegisterCommand(interp, namespace, cmdTablePtr) + Tcl_Interp* interp; /* the Tcl interpreter for which the operation * is performed */ - const char *namesp, /* the namespace in which the command is + const char *namespace; /* the namespace in which the command is * registered */ - const CmdTable *cmdTablePtr)/* the command to register */ + const CmdTable *cmdTablePtr;/* the command to register */ { char buf[128]; if (cmdTablePtr->exportIt) { - snprintf(buf, sizeof(buf), "namespace eval %s { namespace export %s }", - namesp, cmdTablePtr->cmdName); - if (Tcl_EvalEx(interp, buf, -1, 0) != TCL_OK) { - return TCL_ERROR; - } + sprintf(buf, "namespace eval %s { namespace export %s }", + namespace, cmdTablePtr->cmdName); + if (Tcl_Eval(interp, buf) != TCL_OK) + return TCL_ERROR; } - snprintf(buf, sizeof(buf), "%s::%s", namesp, cmdTablePtr->cmdName); + sprintf(buf, "%s::%s", namespace, cmdTablePtr->cmdName); Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0); + return TCL_OK; } @@ -176,19 +171,19 @@ RegisterCommand( static int ProcBodyTestInitInternal( Tcl_Interp *interp, /* the Tcl interpreter for which the package - * is initialized */ + * is initialized */ int isSafe) /* 1 if this is a safe interpreter */ { - const CmdTable *cmdTablePtr; + CONST CmdTable *cmdTablePtr; cmdTablePtr = (isSafe) ? &safeCommands[0] : &commands[0]; for ( ; cmdTablePtr->cmdName ; cmdTablePtr++) { - if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) { - return TCL_ERROR; - } + if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) { + return TCL_ERROR; + } } - return Tcl_PkgProvideEx(interp, packageName, packageVersion, NULL); + return Tcl_PkgProvide(interp, packageName, packageVersion); } /* @@ -226,12 +221,12 @@ ProcBodyTestInitInternal( static int ProcBodyTestProcObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* context; not used */ Tcl_Interp *interp, /* the current interpreter */ int objc, /* argument count */ Tcl_Obj *const objv[]) /* arguments */ { - const char *fullName; + char *fullName; Tcl_Command procCmd; Command *cmdPtr; Proc *procPtr = NULL; @@ -248,23 +243,23 @@ ProcBodyTestProcObjCmd( * Find the Command pointer to this procedure */ - fullName = Tcl_GetString(objv[3]); + fullName = Tcl_GetStringFromObj(objv[3], NULL); procCmd = Tcl_FindCommand(interp, fullName, NULL, TCL_LEAVE_ERR_MSG); if (procCmd == NULL) { - return TCL_ERROR; + return TCL_ERROR; } cmdPtr = (Command *) procCmd; /* * check that this is a procedure and not a builtin command: - * If a procedure, cmdPtr->objClientData is TclIsProc(cmdPtr). + * If a procedure, cmdPtr->objProc is TclObjInterpProc. */ - if (cmdPtr->objClientData != TclIsProc(cmdPtr)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "command \"", fullName, "\" is not a Tcl procedure", (void *)NULL); - return TCL_ERROR; + if (cmdPtr->objProc != TclGetObjInterpProc()) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "command \"", fullName, "\" is not a Tcl procedure", NULL); + return TCL_ERROR; } /* @@ -273,9 +268,10 @@ ProcBodyTestProcObjCmd( procPtr = (Proc *) cmdPtr->objClientData; if (procPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "procedure \"", - fullName, "\" does not have a Proc struct!", (void *)NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", fullName, + "\" does not have a Proc struct!", NULL); + return TCL_ERROR; } /* @@ -284,10 +280,10 @@ ProcBodyTestProcObjCmd( bodyObjPtr = TclNewProcBodyObj(procPtr); if (bodyObjPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "failed to create a procbody object for procedure \"", - fullName, "\"", (void *)NULL); - return TCL_ERROR; + fullName, "\"", NULL); + return TCL_ERROR; } Tcl_IncrRefCount(bodyObjPtr); @@ -297,53 +293,13 @@ ProcBodyTestProcObjCmd( myobjv[3] = bodyObjPtr; myobjv[4] = NULL; - result = Tcl_ProcObjCmd(NULL, interp, objc, myobjv); + result = Tcl_ProcObjCmd((ClientData) NULL, interp, objc, myobjv); Tcl_DecrRefCount(bodyObjPtr); return result; } /* - *---------------------------------------------------------------------- - * - * ProcBodyTestCheckObjCmd -- - * - * Implements the "procbodytest::check" command. Here is the command - * description: - * procbodytest::check - * - * Performs an internal check that the Tcl_PkgPresent() command returns - * the same version number as was registered when the tcl::procbodytest package - * was provided. Places a boolean in the interp result indicating the - * test outcome. - * - * Results: - * Returns a standard Tcl code. - * - *---------------------------------------------------------------------- - */ - -static int -ProcBodyTestCheckObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* the current interpreter */ - int objc, /* argument count */ - Tcl_Obj *const objv[]) /* arguments */ -{ - const char *version; - - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, ""); - return TCL_ERROR; - } - - version = Tcl_PkgPresentEx(interp, packageName, packageVersion, 1, NULL); - Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - strcmp(version, packageVersion) == 0)); - return TCL_OK; -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 |