232 lines
7.0 KiB
C
232 lines
7.0 KiB
C
/*
|
||
* itclStubs.c --
|
||
*
|
||
* This file contains the C-implemeted part of Itcl object-system
|
||
* Itcl
|
||
*
|
||
* Copyright (c) 2006 by Arnulf P. Wiedemann
|
||
*
|
||
* See the file "license.terms" for information on usage and redistribution of
|
||
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||
*/
|
||
|
||
#include "itclInt.h"
|
||
|
||
static void ItclDeleteStub(ClientData cdata);
|
||
static int ItclHandleStubCmd(ClientData clientData, Tcl_Interp *interp,
|
||
int objc, Tcl_Obj *const objv[]);
|
||
|
||
|
||
/*
|
||
* ------------------------------------------------------------------------
|
||
* Itcl_IsStub()
|
||
*
|
||
* Checks the given Tcl command to see if it represents an autoloading
|
||
* stub created by the "stub create" command. Returns non-zero if
|
||
* the command is indeed a stub.
|
||
* ------------------------------------------------------------------------
|
||
*/
|
||
int
|
||
Itcl_IsStub(
|
||
Tcl_Command cmdPtr) /* command being tested */
|
||
{
|
||
Tcl_CmdInfo cmdInfo;
|
||
|
||
/*
|
||
* This may be an imported command, but don't try to get the
|
||
* original. Just check to see if this particular command
|
||
* is a stub. If we really want the original command, we'll
|
||
* find it at a higher level.
|
||
*/
|
||
if (Tcl_GetCommandInfoFromToken(cmdPtr, &cmdInfo) == 1) {
|
||
if (cmdInfo.deleteProc == ItclDeleteStub) {
|
||
return 1;
|
||
}
|
||
}
|
||
return 0;
|
||
}
|
||
|
||
/*
|
||
* ------------------------------------------------------------------------
|
||
* Itcl_StubCreateCmd()
|
||
*
|
||
* Invoked by Tcl whenever the user issues a "stub create" command to
|
||
* create an autoloading stub for imported commands. Handles the
|
||
* following syntax:
|
||
*
|
||
* stub create <name>
|
||
*
|
||
* Creates a command called <name>. Executing this command will cause
|
||
* the real command <name> to be autoloaded.
|
||
* ------------------------------------------------------------------------
|
||
*/
|
||
int
|
||
Itcl_StubCreateCmd(
|
||
TCL_UNUSED(ClientData), /* not used */
|
||
Tcl_Interp *interp, /* current interpreter */
|
||
int objc, /* number of arguments */
|
||
Tcl_Obj *const objv[]) /* argument objects */
|
||
{
|
||
Tcl_Command cmdPtr;
|
||
char *cmdName;
|
||
Tcl_CmdInfo cmdInfo;
|
||
|
||
ItclShowArgs(1, "Itcl_StubCreateCmd", objc, objv);
|
||
if (objc != 2) {
|
||
Tcl_WrongNumArgs(interp, 1, objv, "name");
|
||
return TCL_ERROR;
|
||
}
|
||
cmdName = Tcl_GetString(objv[1]);
|
||
|
||
/*
|
||
* Create a stub command with the characteristic ItclDeleteStub
|
||
* procedure. That way, we can recognize this command later
|
||
* on as a stub. Save the cmd token as client data, so we can
|
||
* get the full name of this command later on.
|
||
*/
|
||
cmdPtr = Tcl_CreateObjCommand(interp, cmdName,
|
||
ItclHandleStubCmd, NULL,
|
||
(Tcl_CmdDeleteProc*)ItclDeleteStub);
|
||
|
||
Tcl_GetCommandInfoFromToken(cmdPtr, &cmdInfo);
|
||
cmdInfo.objClientData = cmdPtr;
|
||
Tcl_SetCommandInfoFromToken(cmdPtr, &cmdInfo);
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
|
||
/*
|
||
* ------------------------------------------------------------------------
|
||
* Itcl_StubExistsCmd()
|
||
*
|
||
* Invoked by Tcl whenever the user issues a "stub exists" command to
|
||
* see if an existing command is an autoloading stub. Handles the
|
||
* following syntax:
|
||
*
|
||
* stub exists <name>
|
||
*
|
||
* Looks for a command called <name> and checks to see if it is an
|
||
* autoloading stub. Returns a boolean result.
|
||
* ------------------------------------------------------------------------
|
||
*/
|
||
int
|
||
Itcl_StubExistsCmd(
|
||
TCL_UNUSED(ClientData), /* not used */
|
||
Tcl_Interp *interp, /* current interpreter */
|
||
int objc, /* number of arguments */
|
||
Tcl_Obj *const objv[]) /* argument objects */
|
||
{
|
||
Tcl_Command cmdPtr;
|
||
char *cmdName;
|
||
|
||
if (objc != 2) {
|
||
Tcl_WrongNumArgs(interp, 1, objv, "name");
|
||
return TCL_ERROR;
|
||
}
|
||
cmdName = Tcl_GetString(objv[1]);
|
||
|
||
cmdPtr = Tcl_FindCommand(interp, cmdName, NULL, 0);
|
||
|
||
if ((cmdPtr != NULL) && Itcl_IsStub(cmdPtr)) {
|
||
Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 1);
|
||
} else {
|
||
Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 0);
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* ------------------------------------------------------------------------
|
||
* ItclHandleStubCmd()
|
||
*
|
||
* Invoked by Tcl to handle commands created by "stub create".
|
||
* Calls "auto_load" with the full name of the current command to
|
||
* trigger autoloading of the real implementation. Then, calls the
|
||
* command to handle its function. If successful, this command
|
||
* returns TCL_OK along with the result from the real implementation
|
||
* of this command. Otherwise, it returns TCL_ERROR, along with an
|
||
* error message in the interpreter.
|
||
* ------------------------------------------------------------------------
|
||
*/
|
||
static int
|
||
ItclHandleStubCmd(
|
||
ClientData clientData, /* command token for this stub */
|
||
Tcl_Interp *interp, /* current interpreter */
|
||
int objc, /* number of arguments */
|
||
Tcl_Obj *const objv[]) /* argument objects */
|
||
{
|
||
Tcl_Command cmdPtr;
|
||
Tcl_Obj **cmdlinev;
|
||
Tcl_Obj *objAutoLoad[2];
|
||
Tcl_Obj *objPtr;
|
||
Tcl_Obj *cmdNamePtr;
|
||
Tcl_Obj *cmdlinePtr;
|
||
char *cmdName;
|
||
int result;
|
||
int loaded;
|
||
int cmdlinec;
|
||
|
||
ItclShowArgs(1, "ItclHandleStubCmd", objc, objv);
|
||
cmdPtr = (Tcl_Command) clientData;
|
||
cmdNamePtr = Tcl_NewStringObj(NULL, 0);
|
||
Tcl_IncrRefCount(cmdNamePtr);
|
||
Tcl_GetCommandFullName(interp, cmdPtr, cmdNamePtr);
|
||
cmdName = Tcl_GetString(cmdNamePtr);
|
||
|
||
/*
|
||
* Try to autoload the real command for this stub.
|
||
*/
|
||
objAutoLoad[0] = Tcl_NewStringObj("::auto_load", -1);
|
||
objAutoLoad[1] = cmdNamePtr;
|
||
result = Tcl_EvalObjv(interp, 2, objAutoLoad, 0);
|
||
if (result != TCL_OK) {
|
||
Tcl_DecrRefCount(cmdNamePtr);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
objPtr = Tcl_GetObjResult(interp);
|
||
result = Tcl_GetIntFromObj(interp, objPtr, &loaded);
|
||
if ((result != TCL_OK) || !loaded) {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
||
"can't autoload \"", cmdName, "\"", NULL);
|
||
Tcl_DecrRefCount(cmdNamePtr);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* At this point, the real implementation has been loaded.
|
||
* Invoke the command again with the arguments passed in.
|
||
*/
|
||
cmdlinePtr = Itcl_CreateArgs(interp, cmdName, objc - 1, objv + 1);
|
||
(void) Tcl_ListObjGetElements(NULL, cmdlinePtr,
|
||
&cmdlinec, &cmdlinev);
|
||
|
||
Tcl_DecrRefCount(cmdNamePtr);
|
||
Tcl_ResetResult(interp);
|
||
ItclShowArgs(1, "ItclHandleStubCmd", cmdlinec - 1, cmdlinev + 1);
|
||
result = Tcl_EvalObjv(interp, cmdlinec - 1, cmdlinev + 1, TCL_EVAL_DIRECT);
|
||
Tcl_DecrRefCount(cmdlinePtr);
|
||
Tcl_DecrRefCount(objAutoLoad[0]);
|
||
return result;
|
||
}
|
||
|
||
|
||
/*
|
||
* ------------------------------------------------------------------------
|
||
* ItclDeleteStub()
|
||
*
|
||
* Invoked by Tcl whenever a stub command is deleted. This procedure
|
||
* does nothing, but its presence identifies a command as a stub.
|
||
* ------------------------------------------------------------------------
|
||
*/
|
||
/* ARGSUSED */
|
||
static void
|
||
ItclDeleteStub(
|
||
TCL_UNUSED(ClientData)) /* not used */
|
||
{
|
||
/* do nothing */
|
||
}
|
||
|