/*
 * ------------------------------------------------------------------------
 *      PACKAGE:  [incr Tcl]
 *  DESCRIPTION:  Object-Oriented Extensions to Tcl
 *
 *  [incr Tcl] provides object-oriented extensions to Tcl, much as
 *  C++ provides object-oriented extensions to C.  It provides a means
 *  of encapsulating related procedures together with their shared data
 *  in a local namespace that is hidden from the outside world.  It
 *  promotes code re-use through inheritance.  More than anything else,
 *  it encourages better organization of Tcl applications through the
 *  object-oriented paradigm, leading to code that is easier to
 *  understand and maintain.
 *
 *  Procedures in this file support the new syntax for [incr Tcl]
 *  class definitions:
 *
 *    itcl_class <className> {
 *	inherit <base-class>...
 *
 *	constructor {<arglist>} ?{<init>}? {<body>}
 *	destructor {<body>}
 *
 *	method <name> {<arglist>} {<body>}
 *	proc <name> {<arglist>} {<body>}
 *	variable <name> ?<init>? ?<config>?
 *	common <name> ?<init>?
 *
 *	public <thing> ?<args>...?
 *	protected <thing> ?<args>...?
 *	private <thing> ?<args>...?
 *    }
 *
 * ========================================================================
 *  AUTHOR:  Michael J. McLennan
 *	   Bell Labs Innovations for Lucent Technologies
 *	   mmclennan@lucent.com
 *	   http://www.tcltk.com/itcl
 *
 *  overhauled version author: Arnulf Wiedemann
 * ========================================================================
 *	   Copyright (c) 1993-1998  Lucent Technologies, Inc.
 * ------------------------------------------------------------------------
 * 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 const char initWidgetScript[] =
"namespace eval ::itcl {\n"
"    proc _find_widget_init {} {\n"
"	global env tcl_library\n"
"	variable library\n"
"	variable patchLevel\n"
"	rename _find_widget_init {}\n"
"	if {[info exists library]} {\n"
"	    lappend dirs $library\n"
"	} else {\n"
"	    set dirs {}\n"
"	    if {[info exists env(ITCL_LIBRARY)]} {\n"
"		lappend dirs $env(ITCL_LIBRARY)\n"
"	    }\n"
"	    lappend dirs [file join [file dirname $tcl_library] itcl$patchLevel]\n"
"	    set bindir [file dirname [info nameofexecutable]]\n"
"	    lappend dirs [file join . library]\n"
"	    lappend dirs [file join $bindir .. lib itcl$patchLevel]\n"
"	    lappend dirs [file join $bindir .. library]\n"
"	    lappend dirs [file join $bindir .. .. library]\n"
"	    lappend dirs [file join $bindir .. .. itcl library]\n"
"	    lappend dirs [file join $bindir .. .. .. itcl library]\n"
"	    lappend dirs [file join $bindir .. .. itcl-ng itcl library]\n"
"	    # On MacOSX, check the directories in the tcl_pkgPath\n"
"	    if {[string equal $::tcl_platform(platform) \"unix\"] &&"
"		    [string equal $::tcl_platform(os) \"Darwin\"]} {\n"
"		foreach d $::tcl_pkgPath {\n"
"		    lappend dirs [file join $d itcl$patchLevel]\n"
"		}\n"
"	    }\n"
"	    # On *nix, check the directories in the tcl_pkgPath\n"
"	    if {[string equal $::tcl_platform(platform) \"unix\"]} {\n"
"		foreach d $::tcl_pkgPath {\n"
"		    lappend dirs $d\n"
"		    lappend dirs [file join $d itcl$patchLevel]\n"
"		}\n"
"	    }\n"
"	}\n"
"	foreach i $dirs {\n"
"	    set library $i\n"
"	    set itclfile [file join $i itclWidget.tcl]\n"
"	    if {![catch {uplevel #0 [list source $itclfile]} emsg]} {\n"
"		return\n"
"	    }\n"
"	}\n"
"	set msg \"Can't find a usable itclWidget.tcl in the following directories:\n\"\n"
"	append msg \"    $dirs\n\"\n"
"	append msg \"Last error:\n\"\n"
"	append msg \"    $emsg\n\"\n"
"	append msg \"This probably means that Itcl/Tcl weren't installed properly.\n\"\n"
"	append msg \"If you know where the Itcl library directory was installed,\n\"\n"
"	append msg \"you can set the environment variable ITCL_LIBRARY to point\n\"\n"
"	append msg \"to the library directory.\n\"\n"
"	error $msg\n"
"    }\n"
"    _find_widget_init\n"
"}";

/*
 *  Info needed for public/protected/private commands:
 */
typedef struct ProtectionCmdInfo {
    int pLevel;	       /* protection level */
    ItclObjectInfo *infoPtr;  /* info regarding all known objects */
} ProtectionCmdInfo;

/*
 *  FORWARD DECLARATIONS
 */
static Tcl_CmdDeleteProc ItclFreeParserCommandData;
static void ItclDelObjectInfo(char* cdata);
static int ItclInitClassCommon(Tcl_Interp *interp, ItclClass *iclsPtr,
	ItclVariable *ivPtr, const char *initStr);

static Tcl_ObjCmdProc Itcl_ClassTypeVariableCmd;
static Tcl_ObjCmdProc Itcl_ClassTypeMethodCmd;
static Tcl_ObjCmdProc Itcl_ClassFilterCmd;
static Tcl_ObjCmdProc Itcl_ClassMixinCmd;
static Tcl_ObjCmdProc Itcl_WidgetCmd;
static Tcl_ObjCmdProc Itcl_WidgetAdaptorCmd;
static Tcl_ObjCmdProc Itcl_ClassComponentCmd;
static Tcl_ObjCmdProc Itcl_ClassTypeComponentCmd;
static Tcl_ObjCmdProc Itcl_ClassDelegateMethodCmd;
static Tcl_ObjCmdProc Itcl_ClassDelegateOptionCmd;
static Tcl_ObjCmdProc Itcl_ClassDelegateTypeMethodCmd;
static Tcl_ObjCmdProc Itcl_ClassForwardCmd;
static Tcl_ObjCmdProc Itcl_ClassMethodVariableCmd;
static Tcl_ObjCmdProc Itcl_ClassTypeConstructorCmd;
static Tcl_ObjCmdProc ItclGenericClassCmd;

static const struct {
    const char *name;
    Tcl_ObjCmdProc *objProc;
} parseCmds[] = {
    {"common", Itcl_ClassCommonCmd},
    {"component", Itcl_ClassComponentCmd},
    {"constructor", Itcl_ClassConstructorCmd},
    {"destructor", Itcl_ClassDestructorCmd},
    {"filter", Itcl_ClassFilterCmd},
    {"forward", Itcl_ClassForwardCmd},
    {"handleClass", Itcl_HandleClass},
    {"hulltype", Itcl_ClassHullTypeCmd},
    {"inherit", Itcl_ClassInheritCmd},
    {"method", Itcl_ClassMethodCmd},
    {"methodvariable", Itcl_ClassMethodVariableCmd},
    {"mixin", Itcl_ClassMixinCmd},
    {"option", Itcl_ClassOptionCmd},
    {"proc", Itcl_ClassProcCmd},
    {"typecomponent", Itcl_ClassTypeComponentCmd },
    {"typeconstructor", Itcl_ClassTypeConstructorCmd},
    {"typemethod", Itcl_ClassTypeMethodCmd},
    {"typevariable", Itcl_ClassTypeVariableCmd},
    {"variable", Itcl_ClassVariableCmd},
    {"widgetclass", Itcl_ClassWidgetClassCmd},
    {NULL, NULL}
};

static const struct {
    const char *name;
    Tcl_ObjCmdProc *objProc;
    int protection;
} protectionCmds[] = {
    {"private", Itcl_ClassProtectionCmd, ITCL_PRIVATE},
    {"protected", Itcl_ClassProtectionCmd, ITCL_PROTECTED},
    {"public", Itcl_ClassProtectionCmd, ITCL_PUBLIC},
    {NULL, NULL, 0}
};

/*
 * ------------------------------------------------------------------------
 *  Itcl_ParseInit()
 *
 *  Invoked by Itcl_Init() whenever a new interpreter is created to add
 *  [incr Tcl] facilities.  Adds the commands needed to parse class
 *  definitions.
 * ------------------------------------------------------------------------
 */
int
Itcl_ParseInit(
    Tcl_Interp *interp,     /* interpreter to be updated */
    ItclObjectInfo *infoPtr) /* info regarding all known objects and classes */
{
    Tcl_Namespace *parserNs;
    ProtectionCmdInfo *pInfoPtr;
    Tcl_DString buffer;
    int i;

    /*
     *  Create the "itcl::parser" namespace used to parse class
     *  definitions.
     */
    parserNs = Tcl_CreateNamespace(interp, "::itcl::parser",
	infoPtr, Itcl_ReleaseData);

    if (!parserNs) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    " (cannot initialize itcl parser)",
	    (char *)NULL);
	return TCL_ERROR;
    }
    Itcl_PreserveData(infoPtr);

    /*
     *  Add commands for parsing class definitions.
     */
    Tcl_DStringInit(&buffer);
    for (i=0 ; parseCmds[i].name ; i++) {
	Tcl_DStringAppend(&buffer, "::itcl::parser::", 16);
	Tcl_DStringAppend(&buffer, parseCmds[i].name, TCL_INDEX_NONE);
	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
		parseCmds[i].objProc, infoPtr, NULL);
	Tcl_DStringFree(&buffer);
    }

    for (i=0 ; protectionCmds[i].name ; i++) {
	Tcl_DStringAppend(&buffer, "::itcl::parser::", 16);
	Tcl_DStringAppend(&buffer, protectionCmds[i].name, TCL_INDEX_NONE);
	pInfoPtr = (ProtectionCmdInfo*)Tcl_Alloc(sizeof(ProtectionCmdInfo));
	pInfoPtr->pLevel = protectionCmds[i].protection;
	pInfoPtr->infoPtr = infoPtr;
	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
		protectionCmds[i].objProc, pInfoPtr,
		(Tcl_CmdDeleteProc*) ItclFreeParserCommandData);
	Tcl_DStringFree(&buffer);
    }

    /*
     *  Set the runtime variable resolver for the parser namespace,
     *  to control access to "common" data members while parsing
     *  the class definition.
     */
    if (infoPtr->useOldResolvers) {
	ItclSetParserResolver(parserNs);
    }
    /*
     *  Install the "class" command for defining new classes.
     */
    Tcl_CreateObjCommand(interp, "::itcl::class", Itcl_ClassCmd,
	infoPtr, Itcl_ReleaseData);
    Itcl_PreserveData(infoPtr);

    Tcl_CreateObjCommand(interp, "::itcl::body", Itcl_BodyCmd,
	NULL, NULL);

    Tcl_CreateObjCommand(interp, "::itcl::configbody", Itcl_ConfigBodyCmd,
	NULL, NULL);

    Itcl_EventuallyFree(infoPtr, (Tcl_FreeProc *) ItclDelObjectInfo);

    /*
     *  Create the "itcl::find" command for high-level queries.
     */
    if (Itcl_CreateEnsemble(interp, "::itcl::find") != TCL_OK) {
	return TCL_ERROR;
    }

    if (Itcl_AddEnsemblePart(interp, "::itcl::find",
	    "classes", "?pattern?",
	    Itcl_FindClassesCmd,
	    infoPtr, Itcl_ReleaseData) != TCL_OK) {
	return TCL_ERROR;
    }
    Itcl_PreserveData(infoPtr);

    if (Itcl_AddEnsemblePart(interp, "::itcl::find",
	    "objects", "?-class className? ?-isa className? ?pattern?",
	    Itcl_FindObjectsCmd,
	    infoPtr, Itcl_ReleaseData) != TCL_OK) {
	return TCL_ERROR;
    }
    Itcl_PreserveData(infoPtr);


    /*
     *  Create the "itcl::delete" command to delete objects
     *  and classes.
     */
    if (Itcl_CreateEnsemble(interp, "::itcl::delete") != TCL_OK) {
	return TCL_ERROR;
    }

    if (Itcl_AddEnsemblePart(interp, "::itcl::delete",
	    "class", "name ?name...?",
	    Itcl_DelClassCmd,
	    infoPtr, Itcl_ReleaseData) != TCL_OK) {
	return TCL_ERROR;
    }
    Itcl_PreserveData(infoPtr);

    if (Itcl_AddEnsemblePart(interp, "::itcl::delete",
	    "object", "name ?name...?",
	    Itcl_DelObjectCmd,
	    infoPtr, Itcl_ReleaseData) != TCL_OK) {
	return TCL_ERROR;
    }
    Itcl_PreserveData(infoPtr);

    if (Itcl_AddEnsemblePart(interp, "::itcl::delete",
	    "ensemble", "name ?name...?",
	    Itcl_EnsembleDeleteCmd,
	    infoPtr, Itcl_ReleaseData) != TCL_OK) {
	return TCL_ERROR;
    }
    Itcl_PreserveData(infoPtr);

    /*
     *  Create the "itcl::is" command to test object
     *  and classes existence.
     */
    if (Itcl_CreateEnsemble(interp, "::itcl::is") != TCL_OK) {
	return TCL_ERROR;
    }

    if (Itcl_AddEnsemblePart(interp, "::itcl::is",
	    "class", "name", Itcl_IsClassCmd,
	    infoPtr, Itcl_ReleaseData) != TCL_OK) {
	return TCL_ERROR;
    }
    Itcl_PreserveData(infoPtr);

    if (Itcl_AddEnsemblePart(interp, "::itcl::is",
	    "object", "?-class classname? name", Itcl_IsObjectCmd,
	    infoPtr, Itcl_ReleaseData) != TCL_OK) {
	return TCL_ERROR;
    }
    Itcl_PreserveData(infoPtr);


    /*
     *  Add "code" and "scope" commands for handling scoped values.
     */
    Tcl_CreateObjCommand(interp, "::itcl::code", Itcl_CodeCmd,
	NULL, NULL);

    Tcl_CreateObjCommand(interp, "::itcl::scope", Itcl_ScopeCmd,
	NULL, NULL);

    /*
     *  Add the "filter" commands (add/delete)
     */
    if (Itcl_CreateEnsemble(interp, "::itcl::filter") != TCL_OK) {
	return TCL_ERROR;
    }
    if (Itcl_AddEnsemblePart(interp, "::itcl::filter",
	    "add", "objectOrClass filter ? ... ?", Itcl_FilterAddCmd,
	    infoPtr, Itcl_ReleaseData) != TCL_OK) {
	return TCL_ERROR;
    }
    Itcl_PreserveData(infoPtr);

    if (Itcl_AddEnsemblePart(interp, "::itcl::filter",
	    "delete", "objectOrClass filter ? ... ?", Itcl_FilterDeleteCmd,
	    infoPtr, Itcl_ReleaseData) != TCL_OK) {
	return TCL_ERROR;
    }

    Itcl_PreserveData(infoPtr);

    /*
     *  Add the "forward" commands (add/delete)
     */
    if (Itcl_CreateEnsemble(interp, "::itcl::forward") != TCL_OK) {
	return TCL_ERROR;
    }

    if (Itcl_AddEnsemblePart(interp, "::itcl::forward",
	    "add", "objectOrClass srcCommand targetCommand ? options ... ?",
	    Itcl_ForwardAddCmd, infoPtr,
	    Itcl_ReleaseData) != TCL_OK) {
	return TCL_ERROR;
    }
    Itcl_PreserveData(infoPtr);

    if (Itcl_AddEnsemblePart(interp, "::itcl::forward",
	    "delete", "objectOrClass targetCommand ? ... ?",
	    Itcl_ForwardDeleteCmd, infoPtr,
	    Itcl_ReleaseData) != TCL_OK) {
	return TCL_ERROR;
    }
    Itcl_PreserveData(infoPtr);

    /*
     *  Add the "mixin" (add/delete) commands.
     */
    if (Itcl_CreateEnsemble(interp, "::itcl::mixin") != TCL_OK) {
	return TCL_ERROR;
    }

    if (Itcl_AddEnsemblePart(interp, "::itcl::mixin",
	    "add", "objectOrClass class ? class ... ?",
	    Itcl_MixinAddCmd, infoPtr,
	    Itcl_ReleaseData) != TCL_OK) {
	return TCL_ERROR;
    }
    Itcl_PreserveData(infoPtr);

    if (Itcl_AddEnsemblePart(interp, "::itcl::mixin",
	    "delete", "objectOrClass class ? class ... ?",
	    Itcl_MixinDeleteCmd, infoPtr,
	    Itcl_ReleaseData) != TCL_OK) {
	return TCL_ERROR;
    }
    Itcl_PreserveData(infoPtr);

    /*
     *  Add commands for handling import stubs at the Tcl level.
     */
    if (Itcl_CreateEnsemble(interp, "::itcl::import::stub") != TCL_OK) {
	return TCL_ERROR;
    }

    if (Itcl_AddEnsemblePart(interp, "::itcl::import::stub",
	    "create", "name", Itcl_StubCreateCmd,
	    NULL, NULL) != TCL_OK) {
	return TCL_ERROR;
    }
    if (Itcl_AddEnsemblePart(interp, "::itcl::import::stub",
	    "exists", "name", Itcl_StubExistsCmd,
	    NULL, NULL) != TCL_OK) {
	return TCL_ERROR;
    }

    Tcl_CreateObjCommand(interp, "::itcl::type", Itcl_TypeClassCmd,
	infoPtr, Itcl_ReleaseData);
    Itcl_PreserveData(infoPtr);

    Tcl_CreateObjCommand(interp, "::itcl::widget", Itcl_WidgetCmd,
	infoPtr, Itcl_ReleaseData);
    Itcl_PreserveData(infoPtr);

    Tcl_CreateObjCommand(interp, "::itcl::widgetadaptor", Itcl_WidgetAdaptorCmd,
	infoPtr, Itcl_ReleaseData);
    Itcl_PreserveData(infoPtr);

    Tcl_CreateObjCommand(interp, "::itcl::nwidget", Itcl_NWidgetCmd,
	infoPtr, Itcl_ReleaseData);
    Itcl_PreserveData(infoPtr);

    Tcl_CreateObjCommand(interp, "::itcl::addoption", Itcl_AddOptionCmd,
	infoPtr, Itcl_ReleaseData);
    Itcl_PreserveData(infoPtr);

    Tcl_CreateObjCommand(interp, "::itcl::addobjectoption",
	Itcl_AddObjectOptionCmd,
	infoPtr, Itcl_ReleaseData);
    Itcl_PreserveData(infoPtr);

    Tcl_CreateObjCommand(interp, "::itcl::adddelegatedoption",
	Itcl_AddDelegatedOptionCmd,
	infoPtr, Itcl_ReleaseData);
    Itcl_PreserveData(infoPtr);

    Tcl_CreateObjCommand(interp, "::itcl::adddelegatedmethod",
	Itcl_AddDelegatedFunctionCmd,
	infoPtr, Itcl_ReleaseData);
    Itcl_PreserveData(infoPtr);

    Tcl_CreateObjCommand(interp, "::itcl::addcomponent", Itcl_AddComponentCmd,
	infoPtr, Itcl_ReleaseData);
    Itcl_PreserveData(infoPtr);

    Tcl_CreateObjCommand(interp, "::itcl::setcomponent", Itcl_SetComponentCmd,
	infoPtr, Itcl_ReleaseData);
    Itcl_PreserveData(infoPtr);

    Tcl_CreateObjCommand(interp, "::itcl::extendedclass", Itcl_ExtendedClassCmd,
	infoPtr, Itcl_ReleaseData);
    Itcl_PreserveData(infoPtr);

    Tcl_CreateObjCommand(interp, ITCL_COMMANDS_NAMESPACE "::genericclass",
	ItclGenericClassCmd, infoPtr, Itcl_ReleaseData);
    Itcl_PreserveData(infoPtr);

    /*
     *  Add the "delegate" (method/option) commands.
     */
    if (Itcl_CreateEnsemble(interp, "::itcl::parser::delegate") != TCL_OK) {
	return TCL_ERROR;
    }

    if (Itcl_AddEnsemblePart(interp, "::itcl::parser::delegate",
	    "method", "name to targetName as scipt using script",
	    Itcl_ClassDelegateMethodCmd, infoPtr,
	    Itcl_ReleaseData) != TCL_OK) {
	return TCL_ERROR;
    }
    Itcl_PreserveData(infoPtr);

    if (Itcl_AddEnsemblePart(interp, "::itcl::parser::delegate",
	    "typemethod", "name to targetName as scipt using script",
	    Itcl_ClassDelegateTypeMethodCmd, infoPtr,
	    Itcl_ReleaseData) != TCL_OK) {
	return TCL_ERROR;
    }
    Itcl_PreserveData(infoPtr);

    if (Itcl_AddEnsemblePart(interp, "::itcl::parser::delegate",
	    "option", "option to targetOption as script",
	    Itcl_ClassDelegateOptionCmd, infoPtr,
	    Itcl_ReleaseData) != TCL_OK) {
	return TCL_ERROR;
    }
    Itcl_PreserveData(infoPtr);

    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassCmd()
 *
 *  Invoked by Tcl whenever the user issues an "itcl::class" command to
 *  specify a class definition.  Handles the following syntax:
 *
 *    itcl::class <className> {
 *	inherit <base-class>...
 *
 *	constructor {<arglist>} ?{<init>}? {<body>}
 *	destructor {<body>}
 *
 *	method <name> {<arglist>} {<body>}
 *	proc <name> {<arglist>} {<body>}
 *	variable <varname> ?<init>? ?<config>?
 *	common <varname> ?<init>?
 *
 *	public <args>...
 *	protected <args>...
 *	private <args>...
 *    }
 *
 * ------------------------------------------------------------------------
 */
static int
ItclGenericClassCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    Tcl_Obj *namePtr;
    Tcl_HashEntry *hPtr;
    ItclObjectInfo *infoPtr;
    ItclClass *iclsPtr;
    ItclComponent *icPtr;
    const char *typeStr;
    int result;


    ItclShowArgs(1, "ItclGenericClassCmd", objc-1, objv);
    if (objc != 4) {
	Tcl_AppendResult(interp, "usage: genericclass <classtype> <classname> ",
		"<body>", (char *)NULL);
	return TCL_ERROR;
    }
    infoPtr = (ItclObjectInfo *)clientData;
    typeStr = Tcl_GetString(objv[1]);
    hPtr = Tcl_FindHashEntry(&infoPtr->classTypes, (char *)objv[1]);
    if (hPtr == NULL) {
	Tcl_AppendResult(interp, "genericclass bad classtype \"", typeStr,
		"\"", (char *)NULL);
	return TCL_ERROR;
    }
    result = ItclClassBaseCmd(clientData, interp, PTR2INT(Tcl_GetHashValue(hPtr)),
	    objc - 1, objv + 1, &iclsPtr);
    if (result != TCL_OK) {
	return result;
    }
    if (PTR2INT(Tcl_GetHashValue(hPtr)) == ITCL_WIDGETADAPTOR) {
	/* create the itcl_hull variable */
	namePtr = Tcl_NewStringObj("itcl_hull", TCL_INDEX_NONE);
	if (ItclCreateComponent(interp, iclsPtr, namePtr, ITCL_COMMON,
		&icPtr) != TCL_OK) {
	    return TCL_ERROR;
	}
	iclsPtr->numVariables++;
    }
    Tcl_ResetResult(interp);
    Tcl_AppendResult(interp, Tcl_GetString(iclsPtr->fullNamePtr), (char *)NULL);
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassCmd()
 *
 *  Invoked by Tcl whenever the user issues an "itcl::class" command to
 *  specify a class definition.  Handles the following syntax:
 *
 *    itcl::class <className> {
 *	inherit <base-class>...
 *
 *	constructor {<arglist>} ?{<init>}? {<body>}
 *	destructor {<body>}
 *
 *	method <name> {<arglist>} {<body>}
 *	proc <name> {<arglist>} {<body>}
 *	variable <varname> ?<init>? ?<config>?
 *	common <varname> ?<init>?
 *
 *	public <args>...
 *	protected <args>...
 *	private <args>...
 *    }
 *
 * ------------------------------------------------------------------------
 */
int
Itcl_ClassCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    return ItclClassBaseCmd(clientData, interp, ITCL_CLASS, objc, objv, NULL);
}

/*
 * ------------------------------------------------------------------------
 *  ItclClassBaseCmd()
 *
 * ------------------------------------------------------------------------
 */

static Tcl_MethodCallProc ObjCallProc;
static Tcl_MethodCallProc ArgCallProc;
static Tcl_CloneProc CloneProc;

static const Tcl_MethodType itclObjMethodType = {
    TCL_OO_METHOD_VERSION_CURRENT,
    "itcl objv method",
    ObjCallProc,
    Itcl_ReleaseData,
    CloneProc
};

static const Tcl_MethodType itclArgMethodType = {
    TCL_OO_METHOD_VERSION_CURRENT,
    "itcl argv method",
    ArgCallProc,
    Itcl_ReleaseData,
    CloneProc
};

static int
CloneProc(
    TCL_UNUSED(Tcl_Interp *),
    void *original,
    void **copyPtr)
{
    Itcl_PreserveData((ItclMemberFunc *)original);
    *copyPtr = original;
    return TCL_OK;
}

static int
CallAfterCallMethod(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    void *clientData = data[0];

    Tcl_ObjectContext context = (Tcl_ObjectContext)data[1];

    return ItclAfterCallMethod(clientData, interp, context, NULL, result);
}

static int
ObjCallProc(
    void *clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    ItclMemberFunc *imPtr = (ItclMemberFunc *)clientData;

    if (TCL_ERROR == ItclCheckCallMethod(clientData, interp, context,
	    NULL, NULL)) {
	return TCL_ERROR;
    }

    Tcl_NRAddCallback(interp, CallAfterCallMethod, clientData, context,
	    NULL, NULL);

    if ((imPtr->flags & ITCL_COMMON) == 0) {
	return Itcl_ExecMethod(clientData, interp, objc-1, objv+1);
    } else {
	return Itcl_ExecProc(clientData, interp, objc-1, objv+1);
    }
}

static int
ArgCallProc(
    TCL_UNUSED(void *),
    TCL_UNUSED(Tcl_Interp *),
    TCL_UNUSED(Tcl_ObjectContext),
    TCL_UNUSED(int),
    TCL_UNUSED(Tcl_Obj *const *))
{
    return TCL_ERROR;
}

int
ItclClassBaseCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int flags,	       /* flags: ITCL_CLASS, ITCL_TYPE,
			      * ITCL_WIDGET or ITCL_WIDGETADAPTOR */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[],   /* argument objects */
    ItclClass **iclsPtrPtr)  /* for returning iclsPtr */
{
    Tcl_Obj *argumentPtr;
    Tcl_Obj *bodyPtr;
    FOREACH_HASH_DECLS;
    Tcl_HashEntry *hPtr2;
    Tcl_Namespace *parserNs, *ooNs;
    Tcl_CallFrame frame;
    ItclClass *iclsPtr;
    ItclVariable *ivPtr;
    ItclObjectInfo* infoPtr;
    char *className;
    int isNewEntry;
    int result;
    int noCleanup;
    ItclMemberFunc *imPtr;

    infoPtr = (ItclObjectInfo*)clientData;
    if (iclsPtrPtr != NULL) {
	*iclsPtrPtr = NULL;
    }
    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "name { definition }");
	return TCL_ERROR;
    }
    ItclShowArgs(1, "ItclClassBaseCmd", objc, objv);
    className = Tcl_GetString(objv[1]);

    noCleanup = 0;
    /*
     *  Find the namespace to use as a parser for the class definition.
     *  If for some reason it is destroyed, bail out here.
     */
    parserNs = Tcl_FindNamespace(interp, "::itcl::parser",
	NULL, TCL_LEAVE_ERR_MSG);

    if (parserNs == NULL) {
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (while parsing class definition for \"%s\")",
		className));
	return TCL_ERROR;
    }

    /*
     *  Try to create the specified class and its namespace.
     */
    /* need the workaround with infoPtr->currClassFlags to keep the stubs
     * call interface compatible!
     */
    infoPtr->currClassFlags = flags;
    if (Itcl_CreateClass(interp, className, infoPtr, &iclsPtr) != TCL_OK) {
	infoPtr->currClassFlags = 0;
	return TCL_ERROR;
    }
    infoPtr->currClassFlags = 0;
    iclsPtr->flags = flags;

    /*
     *  Import the built-in commands from the itcl::builtin namespace.
     *  Do this before parsing the class definition, so methods/procs
     *  can override the built-in commands.
     */
    result = Tcl_Import(interp, iclsPtr->nsPtr, "::itcl::builtin::*",
	/* allowOverwrite */ 1);
    ooNs = Tcl_GetObjectNamespace(iclsPtr->oPtr);
    if ( result == TCL_OK && ooNs != iclsPtr->nsPtr) {
	result = Tcl_Import(interp, ooNs, "::itcl::builtin::*", 1);
    }

    if (result != TCL_OK) {
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (while installing built-in commands for class \"%s\")",
		className));
	goto errorReturn;
    }

    /*
     *  Push this class onto the class definition stack so that it
     *  becomes the current context for all commands in the parser.
     *  Activate the parser and evaluate the class definition.
     */
    Itcl_PushStack(iclsPtr, &infoPtr->clsStack);

    result = Itcl_PushCallFrame(interp, &frame, parserNs,
	/* isProcCallFrame */ 0);

    Itcl_SetCallFrameResolver(interp, iclsPtr->resolvePtr);
    if (result == TCL_OK) {
	result = Tcl_EvalObjEx(interp, objv[2], 0);
	Itcl_PopCallFrame(interp);
    }
    Itcl_PopStack(&infoPtr->clsStack);

    noCleanup = 0;
    if (result != TCL_OK) {
	Tcl_Obj *options = Tcl_GetReturnOptions(interp, result);
	Tcl_Obj *key = Tcl_NewStringObj("-errorline", TCL_INDEX_NONE);
	Tcl_Obj *stackTrace = NULL;

	Tcl_IncrRefCount(key);
	Tcl_DictObjGet(NULL, options, key, &stackTrace);
	Tcl_DecrRefCount(key);
	if (stackTrace == NULL) {
	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    error while parsing class \"%s\" body %s",
		    className, Tcl_GetString(objv[2])));
	    noCleanup = 1;
	} else {
	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (class \"%s\" body line %s)",
		    className, Tcl_GetString(stackTrace)));
	}
	Tcl_DecrRefCount(options);
	result = TCL_ERROR;
	goto errorReturn;
    }

    if (Itcl_FirstListElem(&iclsPtr->bases) == NULL) {
	/* No [inherit]. Use default inheritance root. */
	Tcl_Obj *cmdPtr = Tcl_NewListObj(4, NULL);

	Tcl_ListObjAppendElement(NULL, cmdPtr,
		Tcl_NewStringObj("::oo::define", TCL_INDEX_NONE));
	Tcl_ListObjAppendElement(NULL, cmdPtr, iclsPtr->fullNamePtr);
	Tcl_ListObjAppendElement(NULL, cmdPtr,
		Tcl_NewStringObj("superclass", TCL_INDEX_NONE));
	Tcl_ListObjAppendElement(NULL, cmdPtr,
		Tcl_NewStringObj("::itcl::Root", TCL_INDEX_NONE));

	Tcl_IncrRefCount(cmdPtr);
	result = Tcl_EvalObjEx(interp, cmdPtr, 0);
	Tcl_DecrRefCount(cmdPtr);
	if (result == TCL_ERROR) {
	    goto errorReturn;
	}
    }

    /*
     *  At this point, parsing of the class definition has succeeded.
     *  Add built-in methods such as "configure" and "cget"--as long
     *  as they don't conflict with those defined in the class.
     */
    if (Itcl_InstallBiMethods(interp, iclsPtr) != TCL_OK) {
	result = TCL_ERROR;
	goto errorReturn;
    }

    /*
     *  Build the name resolution tables for all data members.
     */
    Itcl_BuildVirtualTables(iclsPtr);

    /* make the methods and procs known to TclOO */
    FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) {
	    void *pmPtr;
	argumentPtr = imPtr->codePtr->argumentPtr;
	bodyPtr = imPtr->codePtr->bodyPtr;

if (imPtr->codePtr->flags & ITCL_IMPLEMENT_OBJCMD) {
    /* Implementation of this member is coded in C expecting Tcl_Obj */

    imPtr->tmPtr = Tcl_NewMethod(interp, iclsPtr->clsPtr, imPtr->namePtr,
	    1, &itclObjMethodType, imPtr);
    Itcl_PreserveData(imPtr);

    if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) {
	imPtr->tmPtr = Tcl_NewInstanceMethod(interp, iclsPtr->oPtr,
		imPtr->namePtr, 1, &itclObjMethodType, imPtr);
	Itcl_PreserveData(imPtr);
    }

} else if (imPtr->codePtr->flags & ITCL_IMPLEMENT_ARGCMD) {
    /* Implementation of this member is coded in C expecting (char *) */

    imPtr->tmPtr = Tcl_NewMethod(interp, iclsPtr->clsPtr, imPtr->namePtr,
	    1, &itclArgMethodType, imPtr);

		Itcl_PreserveData(imPtr);



} else {
	    if (imPtr->codePtr->flags & ITCL_BUILTIN) {
		int isDone;
		isDone = 0;
		if (imPtr->builtinArgumentPtr == NULL) {
/* FIXME next lines are possibly a MEMORY leak not really sure!! */
		    argumentPtr = Tcl_NewStringObj("args", TCL_INDEX_NONE);
		    imPtr->builtinArgumentPtr = argumentPtr;
		    Tcl_IncrRefCount(imPtr->builtinArgumentPtr);
		} else {
		    argumentPtr = imPtr->builtinArgumentPtr;
		}
		bodyPtr = Tcl_NewStringObj("return [", TCL_INDEX_NONE);
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-cget") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::cget", TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-configure") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::configure", TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-isa") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::isa", TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-createhull") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::createhull", TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-keepcomponentoption") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::keepcomponentoption", TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-ignorecomponentoption") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::ignorercomponentoption", TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-renamecomponentoption") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::renamecomponentoption", TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-keepoptioncomponent") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::keepoptioncomponent", TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-ignoreoptioncomponent") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::ignoreoptioncomponent", TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-renameoptioncomponent") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::renameoptioncomponent", TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-setupcomponent") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::setupcomponent", TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-initoptions") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::initoptions", TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-getinstancevar") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::getinstancevar",
			    TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (iclsPtr->flags &
			(ITCL_TYPE|ITCL_WIDGETADAPTOR|
			ITCL_WIDGET|ITCL_ECLASS)) {
		/* now the builtin stuff for snit functionality */
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-mytypemethod") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::mytypemethod",
			    TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-mymethod") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::mymethod", TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-myvar") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::myvar", TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-mytypevar") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::mytypevar", TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-itcl_hull") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::itcl_hull", TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-callinstance") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::callinstance",
			    TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-myproc") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::myproc", TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-installhull") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::installhull",
			    TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-installcomponent") == 0) {
		    Tcl_AppendToObj(bodyPtr,
			    "::itcl::builtin::installcomponent", TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-classunknown") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::classunknown",
			    TCL_INDEX_NONE);
		    isDone = 1;
		}
		if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-destroy") == 0) {
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::destroy", TCL_INDEX_NONE);
		    isDone = 1;
		}
		}
		if (strncmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
			"@itcl-builtin-setget", 20) == 0) {
		    char *cp = Tcl_GetString(imPtr->codePtr->bodyPtr)+20;
		    Tcl_AppendToObj(bodyPtr, "::itcl::builtin::setget ", TCL_INDEX_NONE);
		    Tcl_AppendToObj(bodyPtr, cp, TCL_INDEX_NONE);
		    Tcl_AppendToObj(bodyPtr, " ", 1);
		    isDone = 1;
		}
		if (!isDone) {
		    Tcl_AppendToObj(bodyPtr,
			Tcl_GetString(imPtr->codePtr->bodyPtr), TCL_INDEX_NONE);
		}
		Tcl_AppendToObj(bodyPtr, " {*}$args]", TCL_INDEX_NONE);
	    }
	    imPtr->tmPtr = Itcl_NewProcClassMethod(interp,
		iclsPtr->clsPtr, ItclCheckCallMethod, ItclAfterCallMethod,
		ItclProcErrorProc, imPtr, imPtr->namePtr, argumentPtr,
		bodyPtr, &pmPtr);
	    hPtr2 = Tcl_CreateHashEntry(&iclsPtr->infoPtr->procMethods,
		    (char *)imPtr->tmPtr, &isNewEntry);
	    if (isNewEntry) {
		Tcl_SetHashValue(hPtr2, imPtr);
	    }
	    if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) {
		if (argumentPtr == NULL) {
		    argumentPtr = iclsPtr->infoPtr->typeDestructorArgumentPtr;
		    imPtr->codePtr->argumentPtr = argumentPtr;
		    Tcl_IncrRefCount(argumentPtr);
		}
		/*
		 * We're overwriting the tmPtr field, so yank out the
		 * entry in the procMethods map based on the old one.
		 */
		if (isNewEntry) {
		    Tcl_DeleteHashEntry(hPtr2);
		}
		imPtr->tmPtr = Itcl_NewProcMethod(interp,
		    iclsPtr->oPtr, ItclCheckCallMethod, ItclAfterCallMethod,
		    ItclProcErrorProc, imPtr, imPtr->namePtr, argumentPtr,
		    bodyPtr, &pmPtr);
	    }
}
	    if ((imPtr->flags & ITCL_COMMON) == 0) {
		imPtr->accessCmd = Tcl_CreateObjCommand(interp,
			Tcl_GetString(imPtr->fullNamePtr),
			Itcl_ExecMethod, imPtr, Itcl_ReleaseData);
		Itcl_PreserveData(imPtr);
	    } else {
		imPtr->accessCmd = Tcl_CreateObjCommand(interp,
			Tcl_GetString(imPtr->fullNamePtr),
			Itcl_ExecProc, imPtr, Itcl_ReleaseData);
		Itcl_PreserveData(imPtr);
	    }
    }
    if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) {
	/* initialize the typecomponents and typevariables */
	if (Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr,
		/*isProcCallFrame*/0) != TCL_OK) {
	    result = TCL_ERROR;
	    goto errorReturn;
	}
	FOREACH_HASH_VALUE(ivPtr, &iclsPtr->variables) {
	    if ((ivPtr->flags & ITCL_COMMON) && (ivPtr->init != NULL)) {
		if (Tcl_SetVar2(interp, Tcl_GetString(ivPtr->namePtr), NULL,
			Tcl_GetString(ivPtr->init),
			TCL_NAMESPACE_ONLY) == NULL) {
		    Itcl_PopCallFrame(interp);
		    result = TCL_ERROR;
		    goto errorReturn;
		}
	    }
	}
	Itcl_PopCallFrame(interp);
    }
    if (iclsPtr->typeConstructorPtr != NULL) {
	/* call the typeconstructor body */
	if (Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr,
		/*isProcCallFrame*/0) != TCL_OK) {
	    result = TCL_ERROR;
	    goto errorReturn;
	}
	result = Tcl_EvalObjEx(interp, iclsPtr->typeConstructorPtr,
		TCL_EVAL_DIRECT);
	Itcl_PopCallFrame(interp);
	if (result != TCL_OK) {
	    goto errorReturn;
	}
    }
    result = TCL_OK;
    if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) {
	if (ItclCheckForInitializedComponents(interp, iclsPtr, NULL) !=
		TCL_OK) {
	    result = TCL_ERROR;
	    goto errorReturn;
	}
    }

    if (result == TCL_OK) {
	Tcl_ResetResult(interp);
    }
    if (iclsPtrPtr != NULL) {
	*iclsPtrPtr = iclsPtr;
    }
    ItclAddClassesDictInfo(interp, iclsPtr);
    return result;
errorReturn:
    if (!noCleanup) {
	Tcl_DeleteNamespace(iclsPtr->nsPtr);
    }
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  ItclCheckForInitializedComponents()
 *
 *  check if all components for delegation exist and are initialized
 * ------------------------------------------------------------------------
 */
int
ItclCheckForInitializedComponents(
    Tcl_Interp *interp,
    ItclClass *iclsPtr,
    ItclObject *ioPtr)
{
    FOREACH_HASH_DECLS;
    Tcl_CallFrame frame;
    Tcl_DString buffer;
    ItclDelegatedFunction *idmPtr;
    int result;
    int doCheck;

    result = TCL_OK;
    /* check if the typecomponents are initialized */
    if (Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr,
	    /*isProcCallFrame*/0) != TCL_OK) {
	return TCL_ERROR;
    }
    idmPtr = NULL;
    FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) {
	const char *val;
	/* check here for delegated typemethods only
	 * rest is done in ItclCreateObject
	 */
	doCheck = 1;
	if (ioPtr == NULL) {
	    if (!(idmPtr->flags & ITCL_TYPE_METHOD)) {
		doCheck = 0;
		ioPtr = iclsPtr->infoPtr->currIoPtr;
	    }
	}
	if (doCheck) {
	    if (idmPtr->icPtr != NULL) {
		if (idmPtr->icPtr->ivPtr->flags & ITCL_COMMON) {
		    Tcl_Obj *objPtr;
		    objPtr = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE);
		    Tcl_AppendToObj(objPtr, (Tcl_GetObjectNamespace(
			    idmPtr->icPtr->ivPtr->iclsPtr->oPtr))->fullName,
			    TCL_INDEX_NONE);
		    Tcl_AppendToObj(objPtr, "::", TCL_INDEX_NONE);
		    Tcl_AppendToObj(objPtr, Tcl_GetString(
			    idmPtr->icPtr->ivPtr->namePtr), TCL_INDEX_NONE);
		    val = Tcl_GetVar2(interp, Tcl_GetString(objPtr), NULL, 0);
		    Tcl_DecrRefCount(objPtr);
		} else {
		    Tcl_DStringInit(&buffer);
		    Tcl_DStringAppend(&buffer,
			    Tcl_GetString(ioPtr->varNsNamePtr), TCL_INDEX_NONE);
		    Tcl_DStringAppend(&buffer,
			    Tcl_GetString(idmPtr->icPtr->ivPtr->fullNamePtr),
			    TCL_INDEX_NONE);
		    val = Tcl_GetVar2(interp, Tcl_DStringValue(&buffer),
			    NULL, 0);
		    Tcl_DStringFree(&buffer);
		}
		if ((ioPtr != NULL) && ((val != NULL) && (strlen(val) == 0))) {
		    val = ItclGetInstanceVar(
			    ioPtr->iclsPtr->interp,
			    "itcl_hull", NULL, ioPtr,
			    iclsPtr);
		}
		if ((val == NULL) || (strlen(val) == 0)) {
		    if (iclsPtr->flags & ITCL_WIDGETADAPTOR) {
			if (strcmp (Tcl_GetString(idmPtr->icPtr->namePtr),
				"itcl_hull") == 0) {
			    /* maybe that will be initialized in constructor
			     * later on */
			    continue;
			}
		    }
		    result = TCL_ERROR;
		    break;
		}
	    }
	}
    }
    Itcl_PopCallFrame(interp);
    if (result == TCL_ERROR) {
	const char *startStr;
	const char *sepStr;
	const char *objectStr;
	startStr = "";
	sepStr = "";
	objectStr = "";
	if (ioPtr != NULL) {
	    sepStr = " ";
	    objectStr = Tcl_GetString(ioPtr->origNamePtr);
	}
	if (idmPtr->flags & ITCL_TYPE_METHOD) {
	    startStr = "type";
	}
	/* FIXME there somtimes is a message for widgetadaptor:
	 * can't read "itcl_hull": no such variable
	 * have to check why
	 */
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, Tcl_GetString(iclsPtr->fullNamePtr),
		sepStr, objectStr, " delegates ", startStr, "method \"",
		Tcl_GetString(idmPtr->namePtr),
		"\" to undefined ", startStr, "component \"",
		Tcl_GetString(idmPtr->icPtr->ivPtr->namePtr), "\"", (char *)NULL);
    }
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassInheritCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "inherit" command is invoked to define one or more base classes.
 *  Handles the following syntax:
 *
 *      inherit <baseclass> ?<baseclass>...?
 *
 * ------------------------------------------------------------------------
 */
int
Itcl_ClassInheritCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
    ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
    int result;
    Tcl_Size i;
    int newEntry;
    int haveClasses;
    const char *token;
    Itcl_ListElem *elem;
    Itcl_ListElem *elem2;
    ItclClass *cdPtr;
    ItclClass *baseClsPtr;
    ItclClass *badCdPtr;
    ItclHierIter hier;
    Itcl_Stack stack;
    Tcl_CallFrame frame;
    Tcl_DString buffer;

    ItclShowArgs(2, "Itcl_InheritCmd", objc, objv);

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "class ?class...?");
	return TCL_ERROR;
    }

    if (iclsPtr == NULL) {
	Tcl_AppendResult(interp, "Error: ::itcl::parser::inherit called from",
		" not within a class", (char *)NULL);
	return TCL_ERROR;
    }
    /*
     *  An "inherit" statement can only be included once in a
     *  class definition.
     */
    elem = Itcl_FirstListElem(&iclsPtr->bases);
    if (elem != NULL) {
	Tcl_AppendToObj(Tcl_GetObjResult(interp), "inheritance \"", TCL_INDEX_NONE);

	while (elem) {
	    cdPtr = (ItclClass*)Itcl_GetListValue(elem);
	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		Tcl_GetString(cdPtr->namePtr), " ", (char *)NULL);

	    elem = Itcl_NextListElem(elem);
	}

	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "\" already defined for class \"",
	    Tcl_GetString(iclsPtr->fullNamePtr), "\"",
	    (char *)NULL);
	return TCL_ERROR;
    }

    /*
     *  Validate each base class and add it to the "bases" list.
     */
    result = Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr->parentPtr,
	/* isProcCallFrame */ 0);

    if (result != TCL_OK) {
	return TCL_ERROR;
    }

    for (objc--,objv++; objc > 0; objc--,objv++) {

	/*
	 *  Make sure that the base class name is known in the
	 *  parent namespace (currently active).  If not, try
	 *  to autoload its definition.
	 */
	token = Tcl_GetString(*objv);
	baseClsPtr = Itcl_FindClass(interp, token, /* autoload */ 1);
	if (!baseClsPtr) {
	    Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
	    Tcl_Size errlen;
	    char *errmsg;

	    Tcl_IncrRefCount(resultPtr);
	    errmsg = Tcl_GetStringFromObj(resultPtr, &errlen);

	    Tcl_ResetResult(interp);
	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"cannot inherit from \"", token, "\"",
		(char *)NULL);

	    if (errlen > 0) {
		Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		    " (", errmsg, ")", (char *)NULL);
	    }
	    Tcl_DecrRefCount(resultPtr);
	    goto inheritError;
	}

	/*
	 *  Make sure that the base class is not the same as the
	 *  class that is being built.
	 */
	if (baseClsPtr == iclsPtr) {
	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"class \"", Tcl_GetString(iclsPtr->namePtr),
		"\" cannot inherit from itself",
		(char *)NULL);
	    goto inheritError;
	}

	Itcl_AppendList(&iclsPtr->bases, baseClsPtr);
	ItclPreserveClass(baseClsPtr);
    }

    /*
     *  Scan through the inheritance list to make sure that no
     *  class appears twice.
     */
    elem = Itcl_FirstListElem(&iclsPtr->bases);
    while (elem) {
	elem2 = Itcl_NextListElem(elem);
	while (elem2) {
	    if (Itcl_GetListValue(elem) == Itcl_GetListValue(elem2)) {
		cdPtr = (ItclClass*)Itcl_GetListValue(elem);
		Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		    "class \"", iclsPtr->fullNamePtr,
		    "\" cannot inherit base class \"",
		    cdPtr->fullNamePtr, "\" more than once",
		    (char *)NULL);
		goto inheritError;
	    }
	    elem2 = Itcl_NextListElem(elem2);
	}
	elem = Itcl_NextListElem(elem);
    }

    /*
     *  Add each base class and all of its base classes into
     *  the heritage for the current class.  Along the way, make
     *  sure that no class appears twice in the heritage.
     */
    Itcl_InitHierIter(&hier, iclsPtr);
    cdPtr = Itcl_AdvanceHierIter(&hier);  /* skip the class itself */
    cdPtr = Itcl_AdvanceHierIter(&hier);
    while (cdPtr != NULL) {
	(void) Tcl_CreateHashEntry(&iclsPtr->heritage,
	    (char*)cdPtr, &newEntry);

	if (!newEntry) {
	    break;
	}
	cdPtr = Itcl_AdvanceHierIter(&hier);
    }
    Itcl_DeleteHierIter(&hier);

    /*
     *  Same base class found twice in the hierarchy?
     *  Then flag error.  Show the list of multiple paths
     *  leading to the same base class.
     */
    if (!newEntry) {
	Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);

	badCdPtr = cdPtr;
	Tcl_AppendStringsToObj(resultPtr,
	    "class \"", Tcl_GetString(iclsPtr->fullNamePtr),
	    "\" inherits base class \"",
	    Tcl_GetString(badCdPtr->fullNamePtr), "\" more than once:",
	    NULL);

	cdPtr = iclsPtr;
	Itcl_InitStack(&stack);
	Itcl_PushStack(cdPtr, &stack);

	/*
	 *  Show paths leading to bad base class
	 */
	while (Itcl_GetStackSize(&stack) > 0) {
	    cdPtr = (ItclClass*)Itcl_PopStack(&stack);

	    if (cdPtr == badCdPtr) {
		Tcl_AppendToObj(resultPtr, "\n  ", TCL_INDEX_NONE);
		for (i=0; i < Itcl_GetStackSize(&stack); i++) {
		    if (Itcl_GetStackValue(&stack, i) == NULL) {
			cdPtr = (ItclClass*)Itcl_GetStackValue(&stack, i-1);
			Tcl_AppendStringsToObj(resultPtr,
			    Tcl_GetString(cdPtr->namePtr), "->",
			    (char *)NULL);
		    }
		}
		Tcl_AppendToObj(resultPtr,
			Tcl_GetString(badCdPtr->namePtr), TCL_INDEX_NONE);
	    }
	    else if (!cdPtr) {
		(void)Itcl_PopStack(&stack);
	    }
	    else {
		elem = Itcl_LastListElem(&cdPtr->bases);
		if (elem) {
		    Itcl_PushStack(cdPtr, &stack);
		    Itcl_PushStack(NULL, &stack);
		    while (elem) {
			Itcl_PushStack(Itcl_GetListValue(elem), &stack);
			elem = Itcl_PrevListElem(elem);
		    }
		}
	    }
	}
	Itcl_DeleteStack(&stack);
	goto inheritError;
    }

    /*
     *  At this point, everything looks good.
     *  Finish the installation of the base classes.  Update
     *  each base class to recognize the current class as a
     *  derived class.
     */
    Tcl_DStringInit(&buffer);
    haveClasses = 0;
    elem = Itcl_FirstListElem(&iclsPtr->bases);
    Tcl_DStringAppend(&buffer, "::oo::define ", TCL_INDEX_NONE);
    Tcl_DStringAppend(&buffer, Tcl_GetString(iclsPtr->fullNamePtr), TCL_INDEX_NONE);
    Tcl_DStringAppend(&buffer, " superclass", TCL_INDEX_NONE);
    while (elem) {
	baseClsPtr = (ItclClass*)Itcl_GetListValue(elem);
	haveClasses++;
	Tcl_DStringAppend(&buffer, " ", TCL_INDEX_NONE);
	Tcl_DStringAppend(&buffer, Tcl_GetString(baseClsPtr->fullNamePtr), TCL_INDEX_NONE);

	Itcl_AppendList(&baseClsPtr->derived, iclsPtr);
	ItclPreserveClass(iclsPtr);

	elem = Itcl_NextListElem(elem);
    }
    Itcl_PopCallFrame(interp);
    if (haveClasses) {
	result = Tcl_EvalEx(interp, Tcl_DStringValue(&buffer), TCL_INDEX_NONE, 0);
    }
    Tcl_DStringFree(&buffer);

    Itcl_BuildVirtualTables(iclsPtr);

    return result;


    /*
     *  If the "inherit" list cannot be built properly, tear it
     *  down and return an error.
     */
inheritError:
    Itcl_PopCallFrame(interp);

    elem = Itcl_FirstListElem(&iclsPtr->bases);
    while (elem) {
	ItclReleaseClass( (ItclClass *)Itcl_GetListValue(elem) );
	elem = Itcl_DeleteListElem(elem);
    }
    return TCL_ERROR;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassProtectionCmd()
 *
 *  Invoked by Tcl whenever the user issues a protection setting
 *  command like "public" or "private".  Creates commands and
 *  variables, and assigns a protection level to them.  Protection
 *  levels are defined as follows:
 *
 *    public    => accessible from any namespace
 *    protected => accessible from selected namespaces
 *    private   => accessible only in the namespace where it was defined
 *
 *  Handles the following syntax:
 *
 *    public <command> ?<arg> <arg>...?
 *
 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
int
Itcl_ClassProtectionCmd(
    void *clientData,   /* protection level (public/protected/private) */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    ProtectionCmdInfo *pInfo = (ProtectionCmdInfo*)clientData;
    int result;
    int oldLevel;

    ItclShowArgs(2, "Itcl_ClassProtectionCmd", objc, objv);

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "command ?arg arg...?");
	return TCL_ERROR;
    }

    oldLevel = Itcl_Protection(interp, pInfo->pLevel);

    if (objc == 2) {
	/* something like: public { variable a; variable b } */
	result = Tcl_EvalObjEx(interp, objv[1], 0);
    } else {
	/* something like: public variable a 123 456 */
	result = Itcl_EvalArgs(interp, objc-1, objv+1);
    }

    if (result == TCL_BREAK) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("invoked \"break\" outside of a loop",
		TCL_INDEX_NONE));
	result = TCL_ERROR;
    } else {
	if (result == TCL_CONTINUE) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("invoked \"continue\" outside of a loop",
		    TCL_INDEX_NONE));
	    result = TCL_ERROR;
	} else {
	    if (result != TCL_OK) {
		Tcl_Obj *options = Tcl_GetReturnOptions(interp, result);
		Tcl_Obj *key = Tcl_NewStringObj("-errorline", TCL_INDEX_NONE);
		Tcl_Obj *stackTrace = NULL;

		Tcl_IncrRefCount(key);
		Tcl_DictObjGet(NULL, options, key, &stackTrace);
		Tcl_DecrRefCount(key);
		if (stackTrace == NULL) {
		Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    error while parsing class \"%s\"",
		    Tcl_GetString(objv[0])));
		} else {
		    char *token = Tcl_GetString(objv[0]);
		    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
			"\n    (%.100s body line %s)",
			token, Tcl_GetString(stackTrace)));
		}
	    }
	}
    }

    Itcl_Protection(interp, oldLevel);
    return result;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassConstructorCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "constructor" command is invoked to define the constructor
 *  for an object.  Handles the following syntax:
 *
 *      constructor <arglist> ?<init>? <body>
 *
 * ------------------------------------------------------------------------
 */
int
Itcl_ClassConstructorCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
    ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
    Tcl_Obj *namePtr;
    char *arglist;
    char *body;

    ItclShowArgs(2, "Itcl_ClassConstructorCmd", objc, objv);

    if (objc < 3 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "args ?init? body");
	return TCL_ERROR;
    }

    if (iclsPtr == NULL) {
	Tcl_AppendResult(interp, "Error: ::itcl::parser::constructor called from",
		" not within a class", (char *)(char *)NULL);
	return TCL_ERROR;
    }
    namePtr = objv[0];
    if (Tcl_FindHashEntry(&iclsPtr->functions, (char *)objv[0])) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "\"", Tcl_GetString(namePtr), "\" already defined in class \"",
	    Tcl_GetString(iclsPtr->fullNamePtr), "\"",
	    (char *)NULL);
	return TCL_ERROR;
    }

    /*
     *  If there is an object initialization statement, pick this
     *  out and take the last argument as the constructor body.
     */
    arglist = Tcl_GetString(objv[1]);
    if (objc == 3) {
	body = Tcl_GetString(objv[2]);
    } else {
	iclsPtr->initCode = objv[2];
	Tcl_IncrRefCount(iclsPtr->initCode);
	body = Tcl_GetString(objv[3]);
    }

    if (Itcl_CreateMethod(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) {
	return TCL_ERROR;
    }
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassDestructorCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "destructor" command is invoked to define the destructor
 *  for an object.  Handles the following syntax:
 *
 *      destructor <body>
 *
 * ------------------------------------------------------------------------
 */
int
Itcl_ClassDestructorCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
    ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
    Tcl_Obj *namePtr;
    char *body;

    ItclShowArgs(2, "Itcl_ClassDestructorCmd", objc, objv);

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "body");
	return TCL_ERROR;
    }

    if (iclsPtr == NULL) {
	Tcl_AppendResult(interp, "Error: ::itcl::parser::destructor called from",
		" not within a class", (char *)NULL);
	return TCL_ERROR;
    }
    namePtr = objv[0];
    body = Tcl_GetString(objv[1]);

    if (Tcl_FindHashEntry(&iclsPtr->functions, (char *)namePtr)) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "\"", Tcl_GetString(namePtr), "\" already defined in class \"",
	    Tcl_GetString(iclsPtr->fullNamePtr), "\"",
	    (char *)NULL);
	return TCL_ERROR;
    }

    if (Itcl_CreateMethod(interp, iclsPtr, namePtr, NULL, body)
	!= TCL_OK) {
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassMethodCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "method" command is invoked to define an object method.
 *  Handles the following syntax:
 *
 *      method <name> ?<arglist>? ?<body>?
 *
 * ------------------------------------------------------------------------
 */
int
Itcl_ClassMethodCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    Tcl_Obj *namePtr;
    Tcl_HashEntry *hPtr;
    ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
    ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
    char *arglist;
    char *body;

    ItclShowArgs(2, "Itcl_ClassMethodCmd", objc, objv);

    if (objc < 2 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?");
	return TCL_ERROR;
    }

    if (iclsPtr == NULL) {
	Tcl_AppendResult(interp, "Error: ::itcl::parser::method called from",
		" not within a class", (char *)NULL);
	return TCL_ERROR;
    }
    namePtr = objv[1];

    hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, (char *)objv[1]);
    if (hPtr != NULL) {
	Tcl_AppendResult(interp, "method \"", Tcl_GetString(namePtr),
		"\" has been delegated", (char *)NULL);
	return TCL_ERROR;
    }
    arglist = NULL;
    body = NULL;
    if (objc >= 3) {
	arglist = Tcl_GetString(objv[2]);
    }
    if (objc >= 4) {
	body = Tcl_GetString(objv[3]);
    }

    if (Itcl_CreateMethod(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) {
	return TCL_ERROR;
    }
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassProcCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "proc" command is invoked to define a common class proc.
 *  A "proc" is like a "method", but only has access to "common"
 *  class variables.  Handles the following syntax:
 *
 *      proc <name> ?<arglist>? ?<body>?
 *
 * ------------------------------------------------------------------------
 */
int
Itcl_ClassProcCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    FOREACH_HASH_DECLS;
    Tcl_Obj *namePtr;
    ItclObjectInfo *infoPtr;
    ItclClass *iclsPtr;
    ItclDelegatedFunction *idmPtr;
    char *arglist;
    char *body;

    ItclShowArgs(1, "Itcl_ClassProcCmd", objc, objv);

    if (objc < 2 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?");
	return TCL_ERROR;
    }

    infoPtr = (ItclObjectInfo*)clientData;
    iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
    namePtr = objv[1];

    arglist = NULL;
    body = NULL;
    if (objc >= 3) {
	arglist = Tcl_GetString(objv[2]);
    }
    if (objc >= 4) {
	body = Tcl_GetString(objv[3]);
    }

    if (iclsPtr == NULL) {
	Tcl_AppendResult(interp, "Error: ::itcl::parser::proc called from",
		" not within a class", (char *)NULL);
	return TCL_ERROR;
    }
    if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) {
	const char *name = Tcl_GetString(namePtr);
	/* check if the typemethod is already delegated */
	FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) {
	    if (strcmp(Tcl_GetString(idmPtr->namePtr), name) == 0) {
		Tcl_AppendResult(interp, "Error in \"typemethod ", name,
			"...\", \"", name, "\" has been delegated", (char *)NULL);
		return TCL_ERROR;
	    }
	}
    }
    if (Itcl_CreateProc(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) {
	return TCL_ERROR;
    }
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassTypeMethodCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "proc" command is invoked to define a common class proc.
 *  A "proc" is like a "method", but only has access to "common"
 *  class variables.  Handles the following syntax:
 *
 *      typemethod <name> ?<arglist>? ?<body>?
 *
 * ------------------------------------------------------------------------
 */
static int
Itcl_ClassTypeMethodCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    FOREACH_HASH_DECLS;
    Tcl_Obj *namePtr;
    ItclObjectInfo *infoPtr;
    ItclClass *iclsPtr;
    ItclDelegatedFunction *idmPtr;
    char *arglist;
    char *body;
    ItclMemberFunc *imPtr;

    ItclShowArgs(1, "Itcl_ClassTypeMethodCmd", objc, objv);

    if (objc < 2 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?");
	return TCL_ERROR;
    }

    infoPtr = (ItclObjectInfo*)clientData;
    iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
    if (iclsPtr == NULL) {
	Tcl_AppendResult(interp, "Error: ::itcl::parser::typemethod called from",
		" not within a class", (char *)NULL);
	return TCL_ERROR;
    }
    namePtr = objv[1];

    arglist = NULL;
    body = NULL;
    if (objc >= 3) {
	arglist = Tcl_GetString(objv[2]);
    }
    if (objc >= 4) {
	body = Tcl_GetString(objv[3]);
    }

    if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) {
	const char *name = Tcl_GetString(namePtr);
	/* check if the typemethod is already delegated */
	FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) {
	    if (strcmp(Tcl_GetString(idmPtr->namePtr), name) == 0) {
		Tcl_AppendResult(interp, "Error in \"typemethod ", name,
			"...\", \"", name, "\" has been delegated", (char *)NULL);
		return TCL_ERROR;
	    }
	}
    }
    iclsPtr->infoPtr->functionFlags = ITCL_TYPE_METHOD;
    if (Itcl_CreateProc(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) {
	iclsPtr->infoPtr->functionFlags = 0;
	return TCL_ERROR;
    }
    iclsPtr->infoPtr->functionFlags = 0;
    hPtr = Tcl_FindHashEntry(&iclsPtr->functions, (char *)namePtr);
    imPtr = (ItclMemberFunc *)Tcl_GetHashValue(hPtr);
    imPtr->flags |= ITCL_TYPE_METHOD;
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassVariableCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "variable" command is invoked to define an instance variable.
 *  Handles the following syntax:
 *
 *      variable <varname> ?<init>? ?<config>?
 *
 * ------------------------------------------------------------------------
 */
int
Itcl_ClassVariableCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    Tcl_Obj *namePtr;
    ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
    ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
    ItclVariable *ivPtr;
    char *init;
    char *config;
    char *arrayInitStr;
    const char *usageStr;
    int pLevel;
    int haveError;
    int haveArrayInit;
    int result;

    result = TCL_OK;
    haveError = 0;
    haveArrayInit = 0;
    usageStr = NULL;
    arrayInitStr = NULL;
    ItclShowArgs(1, "Itcl_ClassVariableCmd", objc, objv);
    if (iclsPtr == NULL) {
	Tcl_AppendResult(interp, "Error: ::itcl::parser::variable called from",
		" not within a class", (char *)NULL);
	return TCL_ERROR;
    }
    pLevel = Itcl_Protection(interp, 0);
    if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) {
	if (objc > 2) {
	    if (strcmp(Tcl_GetString(objv[2]), "-array") == 0) {
		if (objc == 4) {
		    arrayInitStr = Tcl_GetString(objv[3]);
		    haveArrayInit = 1;
		} else {
		    haveError = 1;
		    usageStr = "varname ?init|-array init?";
		}
	    }
	}
    }
    if (!haveError && !haveArrayInit) {
	if (pLevel == ITCL_PUBLIC) {
	    if (objc < 2 || objc > 4) {
		usageStr = "name ?init? ?config?";
		haveError = 1;
	    }
	} else {
	    if ((objc < 2) || (objc > 3)) {
		usageStr = "name ?init?";
		haveError = 1;
	    }
	}
    }

    if (haveError) {
	Tcl_WrongNumArgs(interp, 1, objv, usageStr);
	return TCL_ERROR;
    }
    /*
     *  Make sure that the variable name does not contain anything
     *  goofy like a "::" scope qualifier.
     */
    namePtr = objv[1];
    if (strstr(Tcl_GetString(namePtr), "::")) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "bad variable name \"", Tcl_GetString(namePtr), "\"",
	    (char *)NULL);
	return TCL_ERROR;
    }

    init   = NULL;
    config = NULL;
    if (!haveArrayInit) {
	if (objc >= 3) {
	    init = Tcl_GetString(objv[2]);
	}
	if (objc >= 4) {
	    config = Tcl_GetString(objv[3]);
	}
    }

    if (Itcl_CreateVariable(interp, iclsPtr, namePtr, init, config,
	    &ivPtr) != TCL_OK) {
	return TCL_ERROR;
    }
    if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) {
	ivPtr->flags |= ITCL_VARIABLE;
    }
    if (haveArrayInit) {
	ivPtr->arrayInitPtr = Tcl_NewStringObj(arrayInitStr, TCL_INDEX_NONE);
	Tcl_IncrRefCount(ivPtr->arrayInitPtr);
    } else {
	ivPtr->arrayInitPtr = NULL;
    }
    iclsPtr->numVariables++;
    ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr);
    return result;
}


/*
 * ------------------------------------------------------------------------
 *  ItclInitClassCommon()
 *
 *  initialize a class commen variable
 *
 * ------------------------------------------------------------------------
 */
static int
ItclInitClassCommon(
    Tcl_Interp *interp,
    ItclClass *iclsPtr,
    ItclVariable *ivPtr,
    const char *initStr)
{
    Tcl_DString buffer;
    Tcl_CallFrame frame;
    Tcl_Namespace *commonNsPtr;
    Tcl_HashEntry *hPtr;
    Tcl_Var varPtr;
    int result;
    int isNew;

    result = TCL_OK;
    ivPtr->flags |= ITCL_COMMON;
    iclsPtr->numCommons++;

    /*
     *  Create the variable in the namespace associated with the
     *  class.  Do this the hard way, to avoid the variable resolver
     *  procedures.  These procedures won't work until we rebuild
     *  the virtual tables below.
     */
    Tcl_DStringInit(&buffer);
    if (ivPtr->protection != ITCL_PUBLIC) {
	/* public commons go to the class namespace directly the others
	 * go to the variables namespace of the class */
	Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE);
    }
    Tcl_DStringAppend(&buffer,
	    (Tcl_GetObjectNamespace(ivPtr->iclsPtr->oPtr))->fullName, TCL_INDEX_NONE);
    commonNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), NULL, 0);
    if (commonNsPtr == NULL) {
	Tcl_AppendResult(interp, "ITCL: cannot find common variables namespace",
		" for class \"", Tcl_GetString(ivPtr->iclsPtr->fullNamePtr),
		"\"", (char *)NULL);
	return TCL_ERROR;
    }
    varPtr = Tcl_NewNamespaceVar(interp, commonNsPtr,
	    Tcl_GetString(ivPtr->namePtr));
    hPtr = Tcl_CreateHashEntry(&iclsPtr->classCommons, (char *)ivPtr,
	    &isNew);
    if (isNew) {
	Itcl_PreserveVar(varPtr);
	Tcl_SetHashValue(hPtr, varPtr);
    }
    result = Itcl_PushCallFrame(interp, &frame, commonNsPtr,
	/* isProcCallFrame */ 0);
    Itcl_PopCallFrame(interp);

    /*
     *  If an initialization value was specified, then initialize
     *  the variable now, otherwise be sure the variable is uninitialized.
     */

    if (initStr != NULL) {
	const char *val;
	val = Tcl_SetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), NULL,
		initStr, TCL_NAMESPACE_ONLY);
	if (!val) {
	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"cannot initialize common variable \"",
		Tcl_GetString(ivPtr->namePtr), "\"",
		(char *)NULL);
	    return TCL_ERROR;
	}
    } else {
	/* previous var-lookup in class body (in ::itcl::parser) could obtain
	 * inherited common vars, so be sure it does not exists after new
	 * common creation (simply remove this reference). */
	Tcl_UnsetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), NULL,
		TCL_NAMESPACE_ONLY);
    }
    if (ivPtr->arrayInitPtr != NULL) {
	Tcl_Size i;
	Tcl_Size argc;
	const char **argv;
	const char *val;
	result = Tcl_SplitList(interp, Tcl_GetString(ivPtr->arrayInitPtr),
		&argc, &argv);
	for (i = 0; i < argc; i += 2) {
	    val = Tcl_SetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), argv[i],
		    argv[i + 1], TCL_NAMESPACE_ONLY);
	    if (!val) {
		Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		    "cannot initialize common variable \"",
		    Tcl_GetString(ivPtr->namePtr), "\"",
		    (char *)NULL);
		return TCL_ERROR;
	    }
	}
	Tcl_Free(argv);
    }
    Tcl_DStringFree(&buffer);
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassCommonCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "common" command is invoked to define a variable that is
 *  common to all objects in the class.  Handles the following syntax:
 *
 *      common <varname> ?<init>?
 *
 * ------------------------------------------------------------------------
 */
static int
ItclClassCommonCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[],   /* argument objects */
    int protection,
    ItclVariable **ivPtrPtr)
{
    ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
    ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
    ItclVariable *ivPtr;
    Tcl_Obj *namePtr;
    char *arrayInitStr;
    const char *usageStr;
    char *initStr;
    int haveError;
    int haveArrayInit;
    int result;

    result = TCL_OK;
    haveError = 0;
    haveArrayInit = 0;
    usageStr = NULL;
    arrayInitStr = NULL;
    *ivPtrPtr = NULL;
    ItclShowArgs(2, "Itcl_ClassCommonCmd", objc, objv);
    if (iclsPtr == NULL) {
	Tcl_AppendResult(interp, "Error: ::itcl::parser::common called from",
		" not within a class", (char *)NULL);
	return TCL_ERROR;
    }
    if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) {
	if (objc > 2) {
	    if (strcmp(Tcl_GetString(objv[2]), "-array") == 0) {
		if (objc == 4) {
		    arrayInitStr = Tcl_GetString(objv[3]);
		    haveArrayInit = 1;
		} else {
		    haveError = 1;
		    usageStr = "varname ?init|-array init?";
		}
	    }
	}
    }
    if (!haveError && !haveArrayInit) {
	if ((objc < 2) || (objc > 3)) {
	    usageStr = "varname ?init?";
	    haveError = 1;
	}
    }
    if (haveError) {
	Tcl_WrongNumArgs(interp, 1, objv, usageStr);
	return TCL_ERROR;
    }
    /*
     *  Make sure that the variable name does not contain anything
     *  goofy like a "::" scope qualifier.
     */
    namePtr = objv[1];
    if (strstr(Tcl_GetString(namePtr), "::")) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "bad variable name \"", Tcl_GetString(namePtr), "\"",
	    (char *)NULL);
	return TCL_ERROR;
    }

    initStr = NULL;
    if (!haveArrayInit) {
	if (objc >= 3) {
	    initStr = Tcl_GetString(objv[2]);
	}
    }

    if (Itcl_CreateVariable(interp, iclsPtr, namePtr, initStr, NULL,
	    &ivPtr) != TCL_OK) {
	return TCL_ERROR;
    }
    if (protection != 0) {
	ivPtr->protection = protection;
    }
    if (haveArrayInit) {
	ivPtr->arrayInitPtr = Tcl_NewStringObj(arrayInitStr, TCL_INDEX_NONE);
	Tcl_IncrRefCount(ivPtr->arrayInitPtr);
    } else {
	ivPtr->arrayInitPtr = NULL;
    }
    *ivPtrPtr = ivPtr;
    result =  ItclInitClassCommon(interp, iclsPtr, ivPtr, initStr);
    ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr);
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassTypeVariableCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "typevariable" command is invoked to define a variable that is
 *  common to all objects in the class.  Handles the following syntax:
 *
 *      typevariable <varname> ?<init>?
 *
 * ------------------------------------------------------------------------
 */
static int
Itcl_ClassTypeVariableCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    ItclVariable *ivPtr;
    int result;

    ivPtr = NULL;
    ItclShowArgs(1, "Itcl_ClassTypeVariableCmd", objc, objv);
    result = ItclClassCommonCmd(clientData, interp, objc, objv, ITCL_PUBLIC,
	    &ivPtr);
    if (ivPtr != NULL) {
	ivPtr->flags |= ITCL_TYPE_VARIABLE;
	ItclAddClassVariableDictInfo(interp, ivPtr->iclsPtr, ivPtr);
    }
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassCommonCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "common" command is invoked to define a variable that is
 *  common to all objects in the class.  Handles the following syntax:
 *
 *      common <varname> ?<init>?
 *
 * ------------------------------------------------------------------------
 */
int
Itcl_ClassCommonCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    ItclVariable *ivPtr;

    ItclShowArgs(2, "Itcl_ClassTypeVariableCmd", objc, objv);
    return ItclClassCommonCmd(clientData, interp, objc, objv, 0, &ivPtr);
}


/*
 * ------------------------------------------------------------------------
 *  ItclFreeParserCommandData()
 *
 *  This callback will free() up memory dynamically allocated
 *  and passed as the ClientData argument to Tcl_CreateObjCommand.
 *  This callback is required because one can not simply pass
 *  a pointer to the free() or Tcl_Free() to Tcl_CreateObjCommand.
 * ------------------------------------------------------------------------
 */
static void
ItclFreeParserCommandData(
    void *cdata)  /* client data to be destroyed */
{
    Tcl_Free(cdata);
}

/*
 * ------------------------------------------------------------------------
 *  ItclDelObjectInfo()
 *
 *  Invoked when the management info for [incr Tcl] is no longer being
 *  used in an interpreter.  This will only occur when all class
 *  manipulation commands are removed from the interpreter.
 *
 *  See also FreeItclObjectInfo() in itclBase.c
 * ------------------------------------------------------------------------
 */
static void
ItclDelObjectInfo(
    char* cdata)    /* client data for class command */
{
    Tcl_HashSearch place;
    Tcl_HashEntry *hPtr;
    ItclObjectInfo *infoPtr = (ItclObjectInfo*)cdata;
    ItclObject *ioPtr;

    /*
     *  Destroy all known objects by deleting their access
     *  commands.
     */
    hPtr = Tcl_FirstHashEntry(&infoPtr->objects, &place);
    while (hPtr) {
	ioPtr = (ItclObject*)Tcl_GetHashValue(hPtr);
	Tcl_DeleteCommandFromToken(infoPtr->interp, ioPtr->accessCmd);
	    /*
	     * Fix 227804: Whenever an object to delete was found we
	     * have to reset the search to the beginning as the
	     * current entry in the search was deleted and accessing it
	     * is therefore not allowed anymore.
	     */

	    hPtr = Tcl_FirstHashEntry(&infoPtr->objects, &place);
	    /*hPtr = Tcl_NextHashEntry(&place);*/
    }
    Tcl_DeleteHashTable(&infoPtr->objects);
    Tcl_DeleteHashTable(&infoPtr->frameContext);

    Itcl_DeleteStack(&infoPtr->clsStack);
    Itcl_Free(infoPtr);
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassFilterCmd()
 *
 *
 * ------------------------------------------------------------------------
 */
static int
Itcl_ClassFilterCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    Tcl_Obj **newObjv;
    ItclObjectInfo *infoPtr;
    ItclClass *iclsPtr;
    int result;

    ItclShowArgs(1, "Itcl_ClassFilterCmd", objc, objv);
    infoPtr = (ItclObjectInfo*)clientData;
    iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
    if (iclsPtr == NULL) {
	Tcl_AppendResult(interp, "Error: ::itcl::parser::filter called from",
		" not within a class", (char *)NULL);
	return TCL_ERROR;
    }
    if (iclsPtr->flags & ITCL_CLASS) {
	Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr),
		" is no ::itcl::widget/::itcl::widgetadaptor/::itcl::type",
		"/::itcl::extendedclass. Only these can have filters", (char *)NULL);
	return TCL_ERROR;
    }
    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "<filterName> ?<filterName> ...?");
	return TCL_ERROR;
    }
    newObjv = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *)*(objc+2));
    newObjv[0] = Tcl_NewStringObj("::oo::define", TCL_INDEX_NONE);
    Tcl_IncrRefCount(newObjv[0]);
    newObjv[1] = Tcl_NewStringObj(Tcl_GetString(iclsPtr->fullNamePtr), TCL_INDEX_NONE);
    Tcl_IncrRefCount(newObjv[1]);
    newObjv[2] = Tcl_NewStringObj("filter", TCL_INDEX_NONE);
    Tcl_IncrRefCount(newObjv[2]);
    memcpy(newObjv+3, objv+1, sizeof(Tcl_Obj *)*(objc-1));
ItclShowArgs(1, "Itcl_ClassFilterCmd2", objc+2, newObjv);
    result = Tcl_EvalObjv(interp, objc+2, newObjv, 0);
    Tcl_DecrRefCount(newObjv[0]);
    Tcl_DecrRefCount(newObjv[1]);
    Tcl_DecrRefCount(newObjv[2]);
    Tcl_Free(newObjv);
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassMixinCmd()
 *
 *
 * ------------------------------------------------------------------------
 */
static int
Itcl_ClassMixinCmd(
    TCL_UNUSED(void *),      /* info for all known objects */
    TCL_UNUSED(Tcl_Interp *),/* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const *objv)    /* argument objects */
{
    ItclShowArgs(0, "Itcl_ClassMixinCmd", objc, objv);
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_WidgetCmd()
 *
 *  that is just a dummy command to load package ItclWidget
 *  and then to resend the command and execute it in that package
 *  package ItclWidget is renaming the Tcl command!!
 *
 * ------------------------------------------------------------------------
 */
static int
Itcl_WidgetCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    ItclObjectInfo *infoPtr;
    int result;

    ItclShowArgs(1, "Itcl_WidgetCmd", objc-1, objv);
    infoPtr = (ItclObjectInfo *)clientData;
    if (!infoPtr->itclWidgetInitted) {
	result =  Tcl_EvalEx(interp, initWidgetScript, TCL_INDEX_NONE, 0);
	if (result != TCL_OK) {
	    return result;
	}
	infoPtr->itclWidgetInitted = 1;
    }
    return Tcl_EvalObjv(interp, objc, objv, 0);
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_WidgetAdaptorCmd()
 *
 *  that is just a dummy command to load package ItclWidget
 *  and then to resend the command and execute it in that package
 *  package ItclWidget is renaming the Tcl command!!
 *
 * ------------------------------------------------------------------------
 */
static int
Itcl_WidgetAdaptorCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    ItclObjectInfo *infoPtr;
    int result;

    ItclShowArgs(1, "Itcl_WidgetAdaptorCmd", objc-1, objv);
    infoPtr = (ItclObjectInfo *)clientData;
    if (!infoPtr->itclWidgetInitted) {
	result =  Tcl_EvalEx(interp, initWidgetScript, TCL_INDEX_NONE, 0);
	if (result != TCL_OK) {
	    return result;
	}
	infoPtr->itclWidgetInitted = 1;
    }
    return Tcl_EvalObjv(interp, objc, objv, 0);
}

/*
 * ------------------------------------------------------------------------
 *  ItclParseOption()
 *
 *  Invoked by Tcl during the parsing whenever
 *  the "option" command is invoked to define an option
 *  Handles the following syntax:
 *
 *      option
 *
 * ------------------------------------------------------------------------
 */
int
ItclParseOption(
    TCL_UNUSED(ItclObjectInfo *), /* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    size_t objc,		/* number of arguments */
    Tcl_Obj *const objv[],   /* argument objects */
    ItclClass *iclsPtr,
    ItclObject *ioPtr,
    ItclOption **ioptPtrPtr) /* where the otpion info is found */
{
    Tcl_Obj *classNamePtr;
    Tcl_Obj *nameSpecPtr;
    Tcl_Obj **newObjv;
    Tcl_HashEntry *hPtr;
    ItclOption *ioptPtr;
    char *init;
    char *defaultValue;
    char *cgetMethod;
    char *cgetMethodVar;
    char *configureMethod;
    char *configureMethodVar;
    char *validateMethod;
    char *validateMethodVar;
    const char *token;
    const char *usage;
    const char *optionName;
    const char **argv;
    const char *name;
    const char *resourceName;
    const char *className;
    Tcl_Size argc;
    int pLevel;
    int readOnly;
    int newObjc;
    int foundOption;
    int result;
    size_t i;
    const char *cp;

    ItclShowArgs(1, "ItclParseOption", objc, objv);
    pLevel = Itcl_Protection(interp, 0);

    usage = "namespec \
?init? \
?-default value? \
?-readonly? \
?-cgetmethod methodName? \
?-cgetmethodvar varName? \
?-configuremethod methodName? \
?-configuremethodvar varName? \
?-validatemethod methodName? \
?-validatemethodvar varName";

    if (pLevel == ITCL_PUBLIC) {
	if (objc < 2 || objc > 11) {
	    Tcl_WrongNumArgs(interp, 1, objv, usage);
	    return TCL_ERROR;
	}
    } else {
	if ((objc < 2) || (objc > 12)) {
	    Tcl_WrongNumArgs(interp, 1, objv, usage);
	    return TCL_ERROR;
	}
    }

    argv = NULL;
    newObjv = NULL;
    defaultValue = NULL;
    cgetMethod = NULL;
    configureMethod = NULL;
    validateMethod = NULL;
    cgetMethodVar = NULL;
    configureMethodVar = NULL;
    validateMethodVar = NULL;
    readOnly = 0;
    newObjc = 0;
    optionName = Tcl_GetString(objv[1]);
    if (iclsPtr != NULL) {
	/* check for already delegated!! */
	hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedOptions, (char *)objv[1]);
	if (hPtr != NULL) {
	    Tcl_AppendResult(interp, "cannot define option \"", optionName,
		    "\" locally, it has already been delegated", (char *)NULL);
	    result = TCL_ERROR;
	    goto errorOut;
	}
    }
    if (ioPtr != NULL) {
	/* check for already delegated!! */
	hPtr = Tcl_FindHashEntry(&ioPtr->objectDelegatedOptions,
		(char *)objv[1]);
	if (hPtr != NULL) {
	    Tcl_AppendResult(interp, "cannot define option \"", optionName,
		    "\" locally, it has already been delegated", (char *)NULL);
	    result = TCL_ERROR;
	    goto errorOut;
	}
    }
    newObjv = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *)*objc);
    newObjv[newObjc] = objv[1];
    newObjc++;
    for (i=2; i<objc; i++) {
	token = Tcl_GetString(objv[i]);
	foundOption = 0;
	if (*token == '-') {
	    if (objc < i+1) {
		Tcl_WrongNumArgs(interp, 1, objv, usage);
		result = TCL_ERROR;
		goto errorOut;
	    }
	    if (strcmp(token, "-default") == 0) {
		foundOption = 1;
		i++;
		defaultValue = Tcl_GetString(objv[i]);
	    } else {
	      if (strcmp(token, "-readonly") == 0) {
		foundOption = 1;
		readOnly = 1;
	      } else {
		if (strncmp(token, "-cgetmethod", 11) == 0) {
		    if (strcmp(token, "-cgetmethod") == 0) {
			foundOption = 1;
			i++;
			cgetMethod = Tcl_GetString(objv[i]);
		    }
		    if (strcmp(token, "-cgetmethodvar") == 0) {
			foundOption = 1;
			i++;
			cgetMethodVar = Tcl_GetString(objv[i]);
		    }
		} else {
		  if (strncmp(token, "-configuremethod", 16) == 0) {
		      if (strcmp(token, "-configuremethod") == 0) {
			  foundOption = 1;
			  i++;
			  configureMethod = Tcl_GetString(objv[i]);
		      }
		      if (strcmp(token, "-configuremethodvar") == 0) {
			  foundOption = 1;
			  i++;
			  configureMethodVar = Tcl_GetString(objv[i]);
		      }
		  } else {
		    if (strncmp(token, "-validatemethod", 15) == 0) {
			if (strcmp(token, "-validatemethod") == 0) {
			    foundOption = 1;
			    i++;
			    validateMethod = Tcl_GetString(objv[i]);
			}
			if (strcmp(token, "-validatemethodvar") == 0) {
			    foundOption = 1;
			    i++;
			    validateMethodVar = Tcl_GetString(objv[i]);
			}
		    }
		  }
		}
	      }
	    }
	    if (!foundOption) {
		Tcl_AppendResult(interp, "funny option command option: \"",
		    token, "\"", (char *)NULL);
		return TCL_ERROR;
	    }
	}
	if (!foundOption) {
	    newObjv[newObjc] = objv[i];
	    newObjc++;
	}
    }

    if ((cgetMethod != NULL) && (cgetMethodVar != NULL)) {
	Tcl_AppendResult(interp,
		"option -cgetmethod and -cgetmethodvar cannot be used both",
		(char *)NULL);
	result = TCL_ERROR;
	goto errorOut;
    }
    if ((configureMethod != NULL) && (configureMethodVar != NULL)) {
	Tcl_AppendResult(interp,
		"option -configuremethod and -configuremethodvar",
		"cannot be used both",
		(char *)NULL);
	result = TCL_ERROR;
	goto errorOut;
    }
    if ((validateMethod != NULL) && (validateMethodVar != NULL)) {
	Tcl_AppendResult(interp,
		"option -validatemethod and -validatemethodvar",
		"cannot be used both",
		(char *)NULL);
	result = TCL_ERROR;
	goto errorOut;
    }
    if (newObjc < 1) {
	Tcl_AppendResult(interp, "usage: option ", usage, (char *)NULL);
	result = TCL_ERROR;
	goto errorOut;
    }
    resourceName = NULL;
    className = NULL;

    nameSpecPtr = newObjv[0];
    token = Tcl_GetString(nameSpecPtr);
    if (Tcl_SplitList(interp, (const char *)token, &argc, &argv) != TCL_OK) {
	result = TCL_ERROR;
	goto errorOut;
    }
    name = argv[0];
    if (*name != '-') {
	Tcl_AppendResult(interp, "bad option name \"", name,
		"\", options must start with a \"-\"", (char *)NULL);
	result = TCL_ERROR;
	goto errorOut;
    }

    /*
     *  Make sure that the variable name does not contain anything
     *  goofy like a "::" scope qualifier.
     */
    if (strstr(name, "::")) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"bad option name \"", name,
		"\", option names must not contain \"::\"", (char *)NULL);
	result = TCL_ERROR;
	goto errorOut;
    }
    if (strstr(name, " ")) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"bad option name \"", name,
		"\", option names must not contain \" \"", (char *)NULL);
	result = TCL_ERROR;
	goto errorOut;
    }
    cp = name;
    while (*cp) {
	if (isupper(UCHAR(*cp))) {
	    Tcl_AppendResult(interp, "bad option name \"", name, "\" ",
		    ", options must not contain uppercase characters", (char *)NULL);
	    result = TCL_ERROR;
	    goto errorOut;
	}
	cp++;
    }
    if (argc > 1) {
	resourceName = argv[1];
    } else {
	/* resource name defaults to option name minus hyphen */
	resourceName = name+1;
    }
    if (argc > 2) {
	className = argv[2];
    } else {
	/* class name defaults to option name minus hyphen and capitalized */
	className = resourceName;
    }
    classNamePtr = ItclCapitalize(className);
    init = defaultValue;
    if ((newObjc > 1) && (init == NULL)) {
	init = Tcl_GetString(newObjv[1]);
    }

    ioptPtr = (ItclOption*)Itcl_Alloc(sizeof(ItclOption));
    ioptPtr->protection   = Itcl_Protection(interp, 0);
    if (ioptPtr->protection == ITCL_DEFAULT_PROTECT) {
	ioptPtr->protection = ITCL_PROTECTED;
    }
    ioptPtr->namePtr      = Tcl_NewStringObj(name, TCL_INDEX_NONE);
    Tcl_IncrRefCount(ioptPtr->namePtr);
    ioptPtr->resourceNamePtr = Tcl_NewStringObj(resourceName, TCL_INDEX_NONE);
    Tcl_IncrRefCount(ioptPtr->resourceNamePtr);
    ioptPtr->classNamePtr = Tcl_NewStringObj(Tcl_GetString(classNamePtr), TCL_INDEX_NONE);
    Tcl_IncrRefCount(ioptPtr->classNamePtr);
    Tcl_DecrRefCount(classNamePtr);

    if (init) {
	ioptPtr->defaultValuePtr = Tcl_NewStringObj(init, TCL_INDEX_NONE);
	Tcl_IncrRefCount(ioptPtr->defaultValuePtr);
    }
    if (cgetMethod != NULL) {
	ioptPtr->cgetMethodPtr = Tcl_NewStringObj(cgetMethod, TCL_INDEX_NONE);
	Tcl_IncrRefCount(ioptPtr->cgetMethodPtr);
    }
    if (configureMethod != NULL) {
	ioptPtr->configureMethodPtr = Tcl_NewStringObj(configureMethod, TCL_INDEX_NONE);
	Tcl_IncrRefCount(ioptPtr->configureMethodPtr);
    }
    if (validateMethod != NULL) {
	ioptPtr->validateMethodPtr = Tcl_NewStringObj(validateMethod, TCL_INDEX_NONE);
	Tcl_IncrRefCount(ioptPtr->validateMethodPtr);
    }
    if (cgetMethodVar != NULL) {
	ioptPtr->cgetMethodVarPtr = Tcl_NewStringObj(cgetMethodVar, TCL_INDEX_NONE);
	Tcl_IncrRefCount(ioptPtr->cgetMethodVarPtr);
    }
    if (configureMethodVar != NULL) {
	ioptPtr->configureMethodVarPtr = Tcl_NewStringObj(configureMethodVar, TCL_INDEX_NONE);
	Tcl_IncrRefCount(ioptPtr->configureMethodVarPtr);
    }
    if (validateMethodVar != NULL) {
	ioptPtr->validateMethodVarPtr = Tcl_NewStringObj(validateMethodVar, TCL_INDEX_NONE);
	Tcl_IncrRefCount(ioptPtr->validateMethodVarPtr);
    }
    if (readOnly != 0) {
	ioptPtr->flags |= ITCL_OPTION_READONLY;
    }

    *ioptPtrPtr = ioptPtr;
    ItclAddOptionDictInfo(interp, iclsPtr, ioptPtr);
    result = TCL_OK;
errorOut:
    if (argv != NULL) {
	Tcl_Free(argv);
    }
    if (newObjv != NULL) {
	Tcl_Free(newObjv);
    }
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassOptionCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "option" command is invoked to define an option
 *  Handles the following syntax:
 *
 *      option
 *
 * ------------------------------------------------------------------------
 */
int
Itcl_ClassOptionCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    ItclOption *ioptPtr;
    const char *tkPackage;
    const char *tkVersion;
    ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
    ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);

    ItclShowArgs(1, "Itcl_ClassOptionCmd", objc, objv);

    if (iclsPtr == NULL) {
	Tcl_AppendResult(interp, "Error: ::itcl::parser::option called from",
		" not within a class", (char *)NULL);
	return TCL_ERROR;
    }
    if (iclsPtr->flags & ITCL_CLASS) {
	Tcl_AppendResult(interp, "a \"class\" cannot have options", (char *)NULL);
	return TCL_ERROR;
    }

    if ((objc > 1) && (strcmp(Tcl_GetString(objv[1]), "add") == 0)) {
	tkVersion = "8.6";
	tkPackage = Tcl_PkgPresentEx(interp, "Tk", tkVersion, 0, NULL);
	if (tkPackage == NULL) {
	    tkPackage = Tcl_PkgRequireEx(interp, "Tk", tkVersion, 0, NULL);
	}
	if (tkPackage == NULL) {
	    Tcl_AppendResult(interp, "cannot load package Tk", tkVersion,
		    (char *)NULL);
	    return TCL_ERROR;
	}
	return Tcl_EvalObjv(interp, objc, objv, TCL_EVAL_GLOBAL);
    }
    if (ItclParseOption(infoPtr, interp, objc, objv, iclsPtr, NULL,
	    &ioptPtr) != TCL_OK) {
	return TCL_ERROR;
    }

    if (Itcl_CreateOption(interp, iclsPtr, ioptPtr) != TCL_OK) {
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  ItclCreateComponent()
 *
 *
 * ------------------------------------------------------------------------
 */
int
ItclCreateComponent(
    Tcl_Interp *interp,
    ItclClass *iclsPtr,
    Tcl_Obj *componentPtr,
    int type,
    ItclComponent **icPtrPtr)
{
    Tcl_HashEntry *hPtr;
    ItclComponent *icPtr;
    ItclVariable *ivPtr;
    int result;
    int isNew;

    if (iclsPtr == NULL) {
	return TCL_OK;
    }
    hPtr = Tcl_CreateHashEntry(&iclsPtr->components, (char *)componentPtr,
	    &isNew);
    if (isNew) {
	if (Itcl_CreateVariable(interp, iclsPtr, componentPtr, NULL, NULL,
		&ivPtr) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (type & ITCL_COMMON) {
	    result = ItclInitClassCommon(interp, iclsPtr, ivPtr, "");
	    if (result != TCL_OK) {
		return result;
	    }
	}
	if (iclsPtr->flags & (ITCL_WIDGET|ITCL_WIDGETADAPTOR)) {
	    if (strcmp(Tcl_GetString(componentPtr), "itcl_hull") == 0) {
		/* special built in itcl_hull variable */
		ivPtr->initted = 1;
		ivPtr->flags |= ITCL_HULL_VAR;
	    }
	}
	ivPtr->flags |= ITCL_COMPONENT_VAR;
	icPtr = (ItclComponent *)Tcl_Alloc(sizeof(ItclComponent));
	memset(icPtr, 0, sizeof(ItclComponent));
	Tcl_InitObjHashTable(&icPtr->keptOptions);
	icPtr->namePtr = componentPtr;
	Tcl_IncrRefCount(icPtr->namePtr);
	icPtr->ivPtr = ivPtr;
	Tcl_SetHashValue(hPtr, icPtr);
	ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr);
    } else {
	icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr);
    }
    *icPtrPtr = icPtr;
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  ItclHandleClassComponent()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "component" command is invoked to define a component
 *  Handles the following syntax:
 *
 *      component
 *
 * ------------------------------------------------------------------------
 */
static int
ItclHandleClassComponent(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[],   /* argument objects */
    ItclComponent **icPtrPtr)
{
    Tcl_Obj **newObjv;
    ItclObjectInfo *infoPtr;
    ItclClass *iclsPtr;
    ItclComponent *icPtr;
    const char *usage;
    const char *publ;
    int inherit;
    int haveInherit;
    int havePublic;
    int newObjc;
    int haveValue;
    int storageClass;
    int i;

    ItclShowArgs(1, "Itcl_ClassComponentCmd", objc, objv);
    if (icPtrPtr != NULL) {
	*icPtrPtr = NULL;
    }
    infoPtr = (ItclObjectInfo*)clientData;
    iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
    if (iclsPtr == NULL) {
	Tcl_AppendResult(interp, "Error: ::itcl::parser::component called from",
		" not within a class", (char *)NULL);
	return TCL_ERROR;
    }
    usage = "component ?-public <typemethod>? ?-inherit ?<flag>??";
    if (iclsPtr->flags & ITCL_CLASS) {
	Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr),
		" is no ::itcl::extendedclass/::itcl::widget",
		"/::itcl::widgetadaptor/::itcl::type.",
		" Only these can have components", (char *)NULL);
	return TCL_ERROR;
    }
    if ((objc < 2) || (objc > 6)) {
	Tcl_AppendResult(interp, "wrong # args should be: ", usage, (char *)NULL);
	return TCL_ERROR;
    }
    inherit = 0;
    haveInherit = 0;
    publ = NULL;
    havePublic = 0;
    for (i = 2; i < objc; i += 2) {
	if (strcmp(Tcl_GetString(objv[i]), "-inherit") == 0) {
	    if (haveInherit) {
		Tcl_AppendResult(interp, "wrong syntax should be: ",
			usage, (char *)NULL);
		return TCL_ERROR;
	    }
	    haveValue = 0;
	    inherit = 1;
	    if (i < objc - 1) {
		if (strcmp(Tcl_GetString(objv[i + 1]), "yes") == 0) {
		    haveValue = 1;
		}
		if (strcmp(Tcl_GetString(objv[i + 1]), "YES") == 0) {
		    haveValue = 1;
		}
		if (strcmp(Tcl_GetString(objv[i + 1]), "no") == 0) {
		    haveValue = 1;
		    inherit = 0;
		}
		if (strcmp(Tcl_GetString(objv[i + 1]), "NO") == 0) {
		    haveValue = 1;
		    inherit = 0;
		}
	    }
	    if (haveValue) {
		i++;
	    }
	    haveInherit = 1;
	} else {
	    if (strcmp(Tcl_GetString(objv[i]), "-public") == 0) {
		if (havePublic) {
		    Tcl_AppendResult(interp, "wrong syntax should be: ",
			    usage, (char *)NULL);
		    return TCL_ERROR;
		}
		havePublic = 1;
		if (i >= objc - 1) {
		    Tcl_AppendResult(interp, "wrong syntax should be: ",
			    usage, (char *)NULL);
		    return TCL_ERROR;
		}
		publ = Tcl_GetString(objv[i + 1]);
	    } else {
		Tcl_AppendResult(interp, "wrong syntax should be: ",
			usage, (char *)NULL);
		return TCL_ERROR;
	    }
	}
    }
    storageClass = ITCL_COMMON;
    if (iclsPtr->flags & ITCL_ECLASS) {
	storageClass = 0;
    }
    if (ItclCreateComponent(interp, iclsPtr, objv[1], storageClass,
	    &icPtr) != TCL_OK) {
	return TCL_ERROR;
    }
    if (inherit) {
	icPtr->flags |= ITCL_COMPONENT_INHERIT;
	newObjc = 4;
	newObjv = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*)*newObjc);
	newObjv[0] = Tcl_NewStringObj("delegate::option", TCL_INDEX_NONE);
	Tcl_IncrRefCount(newObjv[0]);
	newObjv[1] = Tcl_NewStringObj("*", TCL_INDEX_NONE);
	Tcl_IncrRefCount(newObjv[1]);
	newObjv[2] = Tcl_NewStringObj("to", TCL_INDEX_NONE);
	Tcl_IncrRefCount(newObjv[2]);
	newObjv[3] = objv[1];
	Tcl_IncrRefCount(newObjv[3]);
	if (Itcl_ClassDelegateOptionCmd(infoPtr, interp, newObjc, newObjv)
		!= TCL_OK) {
	    return TCL_ERROR;
	}
	Tcl_SetStringObj(newObjv[0] , "delegate::method", TCL_INDEX_NONE);
	if (Itcl_ClassDelegateMethodCmd(infoPtr, interp, newObjc, newObjv)
		!= TCL_OK) {
	    return TCL_ERROR;
	}
	Tcl_DecrRefCount(newObjv[0]);
	Tcl_DecrRefCount(newObjv[1]);
	Tcl_DecrRefCount(newObjv[2]);
	Tcl_DecrRefCount(newObjv[3]);
	Tcl_Free(newObjv);
    }
    if (publ != NULL) {
	icPtr->flags |= ITCL_COMPONENT_PUBLIC;
	newObjc = 4;
	newObjv = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*)*newObjc);
	newObjv[0] = Tcl_NewStringObj("delegate::method", TCL_INDEX_NONE);
	Tcl_IncrRefCount(newObjv[0]);
	newObjv[1] = Tcl_NewStringObj(publ, TCL_INDEX_NONE);
	Tcl_IncrRefCount(newObjv[1]);
	newObjv[2] = Tcl_NewStringObj("to", TCL_INDEX_NONE);
	Tcl_IncrRefCount(newObjv[2]);
	newObjv[3] = objv[1];
	Tcl_IncrRefCount(newObjv[3]);
	ItclShowArgs(1, "COMPPUB", newObjc, newObjv);
	if (Itcl_ClassDelegateMethodCmd(infoPtr, interp, newObjc, newObjv)
		!= TCL_OK) {
	    return TCL_ERROR;
	}
	Tcl_DecrRefCount(newObjv[0]);
	Tcl_DecrRefCount(newObjv[1]);
	Tcl_DecrRefCount(newObjv[2]);
	Tcl_DecrRefCount(newObjv[3]);
	Tcl_Free(newObjv);
    }
    if (icPtrPtr != NULL) {
	*icPtrPtr = icPtr;
    }
    ItclAddClassComponentDictInfo(interp, iclsPtr, icPtr);
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassComponentCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "component" command is invoked to define a component
 *  Handles the following syntax:
 *
 *      component
 *
 * ------------------------------------------------------------------------
 */
static int
Itcl_ClassComponentCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    ItclComponent *icPtr;

    return ItclHandleClassComponent(clientData, interp, objc, objv, &icPtr);
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassTypeComponentCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "typecomponent" command is invoked to define a typecomponent
 *  Handles the following syntax:
 *
 *      component
 *
 * ------------------------------------------------------------------------
 */
static int
Itcl_ClassTypeComponentCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    ItclComponent *icPtr;
    int result;

    ItclShowArgs(1, "Itcl_ClassTypeComponentCmd", objc, objv);
    result = ItclHandleClassComponent(clientData, interp, objc, objv, &icPtr);
    if (result != TCL_OK) {
       return result;
    }
    icPtr->ivPtr->flags |= ITCL_COMMON;
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  ItclCreateDelegatedFunction()
 *
 *  Install a delegated function for a class
 *
 * ------------------------------------------------------------------------
 */
int
ItclCreateDelegatedFunction(
    Tcl_Interp *interp,
    ItclClass *iclsPtr,
    Tcl_Obj *methodNamePtr,
    ItclComponent *icPtr,
    Tcl_Obj *targetPtr,
    Tcl_Obj *usingPtr,
    Tcl_Obj *exceptionsPtr,
    ItclDelegatedFunction **idmPtrPtr)
{
    ItclDelegatedFunction *idmPtr;
    const char **argv;
    Tcl_Size argc;
    int isNew;
    Tcl_Size i;

    idmPtr = (ItclDelegatedFunction *)Tcl_Alloc(sizeof(ItclDelegatedFunction));
    memset(idmPtr, 0, sizeof(ItclDelegatedFunction));
    Tcl_InitObjHashTable(&idmPtr->exceptions);
    idmPtr->namePtr = Tcl_NewStringObj(Tcl_GetString(methodNamePtr), TCL_INDEX_NONE);
    Tcl_IncrRefCount(idmPtr->namePtr);
    idmPtr->icPtr = icPtr;
    idmPtr->asPtr = targetPtr;
    if (idmPtr->asPtr != NULL) {
	Tcl_IncrRefCount(idmPtr->asPtr);
    }
    idmPtr->usingPtr = usingPtr;
    if (idmPtr->usingPtr != NULL) {
	Tcl_IncrRefCount(idmPtr->usingPtr);
    }
    if (exceptionsPtr != NULL) {
	if (Tcl_SplitList(interp, Tcl_GetString(exceptionsPtr), &argc, &argv)
		!= TCL_OK) {
	    return TCL_ERROR;
	}
	for(i = 0; i < argc; i++) {
	    Tcl_Obj *objPtr;
	    objPtr = Tcl_NewStringObj(argv[i], TCL_INDEX_NONE);
	    Tcl_CreateHashEntry(&idmPtr->exceptions, (char *)objPtr,
		    &isNew);
	}
	Tcl_Free(argv);
    }
    if (idmPtrPtr != NULL) {
	*idmPtrPtr = idmPtr;
    }
    ItclAddClassDelegatedFunctionDictInfo(interp, iclsPtr, idmPtr);
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_HandleDelegateMethodCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "delegate method" command is invoked to define a
 *  Handles the following syntax:
 *
 *      delegate method
 *
 * ------------------------------------------------------------------------
 */
int
Itcl_HandleDelegateMethodCmd(
    Tcl_Interp *interp,      /* current interpreter */
    ItclObject *ioPtr,       /* != NULL for ::itcl::adddelegatedmethod
				otherwise NULL */
    ItclClass *iclsPtr,      /* != NULL for delegate method otherwise NULL */
    ItclDelegatedFunction **idmPtrPtr,
			     /* where to return idoPtr */
    Tcl_Size objc,	   /* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    Tcl_Obj *methodNamePtr;
    Tcl_Obj *componentPtr;
    Tcl_Obj *targetPtr;
    Tcl_Obj *usingPtr;
    Tcl_Obj *exceptionsPtr;
    Tcl_HashEntry *hPtr;
    ItclClass *iclsPtr2;
    ItclComponent *icPtr;
    ItclHierIter hier;
    const char *usageStr;
    const char *methodName;
    const char *component;
    const char *token;
    int result;
    Tcl_Size i;
    int foundOpt;

    ItclShowArgs(1, "Itcl_HandleDelegateMethodCmd", objc, objv);
    usageStr = "delegate method <methodName> to <componentName> ?as <targetName>?\n\
delegate method <methodName> ?to <componentName>? using <pattern>\n\
delegate method * ?to <componentName>? ?using <pattern>? ?except <methods>?";
    if (objc < 4) {
	Tcl_AppendResult(interp, "wrong # args should be ", usageStr, (char *)NULL);
	return TCL_ERROR;
    }
    componentPtr = NULL;
    icPtr = NULL;
    methodName = Tcl_GetString(objv[1]);
    component = NULL;
    targetPtr = NULL;
    usingPtr = NULL;
    exceptionsPtr = NULL;
    for(i=2;i<objc;i++) {
	token = Tcl_GetString(objv[i]);
	if (i+1 == objc) {
	    Tcl_AppendResult(interp, "wrong # args should be ", usageStr, (char *)NULL);
	    return TCL_ERROR;
	}
	foundOpt = 0;
	if (strcmp(token, "to") == 0) {
	    i++;
	    component = Tcl_GetString(objv[i]);
	    componentPtr = objv[i];
	    foundOpt++;
	}
	if (strcmp(token, "as") == 0) {
	    i++;
	    targetPtr = objv[i];
	    foundOpt++;
	}
	if (strcmp(token, "except") == 0) {
	    i++;
	    exceptionsPtr = objv[i];
	    foundOpt++;
	}
	if (strcmp(token, "using") == 0) {
	    i++;
	    usingPtr = objv[i];
	    foundOpt++;
	}
	if (!foundOpt) {
	    Tcl_AppendResult(interp, "bad option \"", token, "\" should be ",
		    usageStr, (char *)NULL);
	    return TCL_ERROR;
	}
    }
    if ((exceptionsPtr != NULL) && (*methodName != '*')) {
	Tcl_AppendResult(interp,
		"can only specify \"except\" with \"delegate method *\"", (char *)NULL);
	return TCL_ERROR;
    }
    if ((component == NULL) && (usingPtr == NULL)) {
	Tcl_AppendResult(interp, "missing to should be: ", usageStr, (char *)NULL);
	return TCL_ERROR;
    }
    if ((*methodName == '*') && (targetPtr != NULL)) {
	Tcl_AppendResult(interp,
		"cannot specify \"as\" with \"delegate method *\"", (char *)NULL);
	return TCL_ERROR;
    }
    /* check for already delegated */
    methodNamePtr = Tcl_NewStringObj(methodName, TCL_INDEX_NONE);
    if (ioPtr != NULL) {
	hPtr = Tcl_FindHashEntry(&ioPtr->objectDelegatedFunctions, (char *)
		methodNamePtr);
    } else {
	hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, (char *)
		methodNamePtr);
    }

    hPtr = NULL;
    if (ioPtr != NULL) {
	if (componentPtr != NULL) {
	    Itcl_InitHierIter(&hier, ioPtr->iclsPtr);
	    while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) {
		hPtr = Tcl_FindHashEntry(&iclsPtr->components,
			(char *)componentPtr);
		if (hPtr != NULL) {
		    break;
		}
	    }
	    Itcl_DeleteHierIter(&hier);
	}
    } else {
	if (componentPtr != NULL) {
	    iclsPtr2 = iclsPtr;
	    Itcl_InitHierIter(&hier, iclsPtr2);
	    while ((iclsPtr2 = Itcl_AdvanceHierIter(&hier)) != NULL) {
		hPtr = Tcl_FindHashEntry(&iclsPtr2->components,
			(char *)componentPtr);
		if (hPtr != NULL) {
		    break;
		}
	    }
	    Itcl_DeleteHierIter(&hier);
	}
    }
    if (hPtr == NULL) {
	if (componentPtr != NULL) {
	    if (ItclCreateComponent(interp, iclsPtr, componentPtr,
		    ITCL_COMMON, &icPtr) != TCL_OK) {
		return TCL_ERROR;
	    }
	    hPtr = Tcl_FindHashEntry(&iclsPtr->components,
		    (char *)componentPtr);
	}
    }
    if (hPtr != NULL) {
	icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr);
    }
    if (*methodName != '*') {
	/* FIXME !!! */
	/* check for locally defined method */
	hPtr = NULL;
	if (ioPtr != NULL) {
	} else {
	    /* FIXME !! have to check the hierarchy !! */
	    hPtr = Tcl_FindHashEntry(&iclsPtr->functions,
		    (char *)methodNamePtr);

	}
	if (hPtr != NULL) {
	    Tcl_AppendResult(interp, "method \"", methodName,
		    "\" has been defined locally", (char *)NULL);
	    result = TCL_ERROR;
	    goto errorOut;
	}
    }
    result = ItclCreateDelegatedFunction(interp, iclsPtr, methodNamePtr, icPtr,
	    targetPtr, usingPtr, exceptionsPtr, idmPtrPtr);
    (*idmPtrPtr)->flags |= ITCL_METHOD;
errorOut:
    Tcl_DecrRefCount(methodNamePtr);
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassDelegateMethodCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "delegate method" command is invoked to define a
 *  Handles the following syntax:
 *
 *      delegate method
 *
 * ------------------------------------------------------------------------
 */
static int
Itcl_ClassDelegateMethodCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    Tcl_HashEntry *hPtr;
    ItclObjectInfo *infoPtr;
    ItclClass *iclsPtr;
    ItclDelegatedFunction *idmPtr;
    int isNew;
    int result;

    ItclShowArgs(1, "Itcl_ClassDelegateMethodCmd", objc, objv);
    infoPtr = (ItclObjectInfo*)clientData;
    iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
    if (iclsPtr == NULL) {
	Tcl_AppendResult(interp, "Error: ::itcl::parser::delegatemethod called from",
		" not within a class", (char *)NULL);
	return TCL_ERROR;
    }
    if (iclsPtr->flags & ITCL_CLASS) {
	Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr),
		" is no ::itcl::widget/::itcl::widgetadaptor/::itcl::type",
		"/::itcl::extendedclass.",
		" Only these can delegate methods", (char *)NULL);
	return TCL_ERROR;
    }
    result = Itcl_HandleDelegateMethodCmd(interp, NULL, iclsPtr, &idmPtr, objc,
	    objv);
    if (result != TCL_OK) {
	return result;
    }
    idmPtr->flags |= ITCL_METHOD;
    hPtr = Tcl_CreateHashEntry(&iclsPtr->delegatedFunctions,
	    (char *)idmPtr->namePtr, &isNew);
    Tcl_SetHashValue(hPtr, idmPtr);
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_HandleDelegateOptionCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "delegate option" command is invoked to define a delegated option
 *  or if ::itcl::adddelegatedoption is called with an itcl object
 *  Handles the following syntax:
 *
 *      delegate option ...
 *
 * ------------------------------------------------------------------------
 */
int
Itcl_HandleDelegateOptionCmd(
    Tcl_Interp *interp,      /* current interpreter */
    ItclObject *ioPtr,       /* != NULL for ::itcl::adddelgatedoption
				otherwise NULL */
    ItclClass *iclsPtr,      /* != NULL for delegate option otherwise NULL */
    ItclDelegatedOption **idoPtrPtr,
			     /* where to return idoPtr */
    Tcl_Size objc,	   /* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */

{
    Tcl_Obj *allOptionNamePtr;
    Tcl_Obj *optionNamePtr;
    Tcl_Obj *componentPtr;
    Tcl_Obj *targetPtr;
    Tcl_Obj *exceptionsPtr;
    Tcl_Obj *resourceNamePtr;
    Tcl_Obj *classNamePtr;
    Tcl_HashEntry *hPtr;
    ItclComponent *icPtr;
    ItclClass *iclsPtr2;
    ItclDelegatedOption *idoPtr;
    ItclHierIter hier;
    const char *usageStr;
    const char *option;
    const char *component;
    const char *token;
    const char **argv;
    int foundOpt;
    Tcl_Size argc;
    int isStarOption;
    int isNew;
    Tcl_Size i;
    const char *cp;

    ItclShowArgs(1, "Itcl_HandleDelegatedOptionCmd", objc, objv);
    usageStr = "<optionDef> to <targetDef> ?as <script>? ?except <script>?";
    if (objc < 4) {
	Tcl_AppendResult(interp, "wrong # args should be ", usageStr, (char *)NULL);
	return TCL_ERROR;
    }
    componentPtr = NULL;
    icPtr = NULL;
    isStarOption = 0;
    token = Tcl_GetString(objv[1]);
    if (Tcl_SplitList(interp, (const char *)token, &argc, &argv) != TCL_OK) {
	return TCL_ERROR;
    }
    option = argv[0];
    if (strcmp(option, "*") == 0) {
	isStarOption = 1;
    }
    if ((argc < 1) || (isStarOption && (argc > 1))) {
	Tcl_AppendResult(interp, "<optionDef> must be either \"*\" or ",
	       "\"<optionName> <resourceName> <className>\"", (char *)NULL);
	Tcl_Free(argv);
	return TCL_ERROR;
    }
    if (isStarOption && (argc > 3)) {
	Tcl_AppendResult(interp, "<optionDef> syntax should be: ",
	       "\"<optionName> <resourceName> <className>\"", (char *)NULL);
	Tcl_Free(argv);
	return TCL_ERROR;
    }
    if ((*option != '-') && !isStarOption) {
	Tcl_AppendResult(interp, "bad delegated option name \"", option,
		"\", options must start with a \"-\"", (char *)NULL);
	Tcl_Free(argv);
	return TCL_ERROR;
    }
    /*
     *  Make sure that the variable name does not contain anything
     *  goofy like a "::" scope qualifier.
     */
    if (strstr(option, "::")) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"bad option name \"", option,
		"\", option names must not contain \"::\"", (char *)NULL);
	Tcl_Free(argv);
	return TCL_ERROR;
    }
    if (strstr(option, " ")) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"bad option name \"", option,
		"\", option names must not contain \" \"", (char *)NULL);
	Tcl_Free(argv);
	return TCL_ERROR;
    }
    cp = option;
    while (*cp) {
	if (isupper(UCHAR(*cp))) {
	    Tcl_AppendResult(interp, "bad option name \"", option, "\" ",
		    ", options must not contain uppercase characters", (char *)NULL);
	    Tcl_Free(argv);
	    return TCL_ERROR;
	}
	cp++;
    }
    optionNamePtr = Tcl_NewStringObj(option, TCL_INDEX_NONE);
    Tcl_IncrRefCount(optionNamePtr);
    resourceNamePtr = NULL;
    classNamePtr = NULL;
    if (argc > 1) {
       resourceNamePtr = Tcl_NewStringObj(argv[1], TCL_INDEX_NONE);
       Tcl_IncrRefCount(resourceNamePtr);
    }
    if (argc > 2) {
       classNamePtr = Tcl_NewStringObj(argv[2], TCL_INDEX_NONE);
    }
    component = NULL;
    targetPtr = NULL;
    exceptionsPtr = NULL;
    for(i=2;i<objc;i++) {
	token = Tcl_GetString(objv[i]);
	if (i+1 == objc) {
	    Tcl_AppendResult(interp, "wrong # args should be ", usageStr, (char *)NULL);
	    goto errorOut1;
	}
	foundOpt = 0;
	if (strcmp(token, "to") == 0) {
	    i++;
	    component = Tcl_GetString(objv[i]);
	    componentPtr = objv[i];
	    foundOpt++;
	}
	if (strcmp(token, "as") == 0) {
	    i++;
	    targetPtr = objv[i];
	    foundOpt++;
	}
	if (strcmp(token, "except") == 0) {
	    i++;
	    exceptionsPtr = objv[i];
	    foundOpt++;
	}
	if (!foundOpt) {
	    Tcl_AppendResult(interp, "bad option \"", token, "\" should be ",
		    usageStr, (char *)NULL);
	    goto errorOut1;
	}
    }
    if (component == NULL) {
	Tcl_AppendResult(interp, "missing to should be: ", usageStr, (char *)NULL);
	goto errorOut1;
    }
    if ((*option == '*') && (targetPtr != NULL)) {
	Tcl_AppendResult(interp,
		"cannot specify \"as\" with \"delegate option *\"", (char *)NULL);
	goto errorOut1;
    }
    /* check for already delegated */
    allOptionNamePtr = Tcl_NewStringObj("*", TCL_INDEX_NONE);
    Tcl_IncrRefCount(allOptionNamePtr);
    if (ioPtr != NULL) {
	hPtr = Tcl_FindHashEntry(&ioPtr->objectDelegatedOptions, (char *)
		allOptionNamePtr);
    } else {
	hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedOptions, (char *)
		allOptionNamePtr);
    }
    Tcl_DecrRefCount(allOptionNamePtr);
    if (hPtr != NULL) {
	Tcl_AppendResult(interp, "option \"", option,
		"\" is already delegated", (char *)NULL);
	goto errorOut1;
    }

    if (ioPtr != NULL) {
	Itcl_InitHierIter(&hier, ioPtr->iclsPtr);
	while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) {
	    hPtr = Tcl_FindHashEntry(&iclsPtr->components,
		    (char *)componentPtr);
	    if (hPtr != NULL) {
		break;
	    }
	}
	Itcl_DeleteHierIter(&hier);
    } else {
	Itcl_InitHierIter(&hier, iclsPtr);
	while ((iclsPtr2 = Itcl_AdvanceHierIter(&hier)) != NULL) {
	    hPtr = Tcl_FindHashEntry(&iclsPtr2->components,
		    (char *)componentPtr);
	    if (hPtr != NULL) {
		break;
	    }
	}
	Itcl_DeleteHierIter(&hier);
    }
    if (hPtr == NULL) {
	if (componentPtr != NULL) {
	    if (ItclCreateComponent(interp, iclsPtr, componentPtr,
		    ITCL_COMMON, &icPtr) != TCL_OK) {
		goto errorOut1;
	    }
	    hPtr = Tcl_FindHashEntry(&iclsPtr->components,
		    (char *)componentPtr);
	}
    }
    if (hPtr != NULL) {
	icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr);
    }
    if (*option != '*') {
	/* FIXME !!! */
	/* check for valid option name */
	if (ioPtr != NULL) {
	    hPtr = Tcl_FindHashEntry(&ioPtr->objectOptions,
		    (char *)optionNamePtr);
	} else {
	    Itcl_InitHierIter(&hier, iclsPtr);
	    while ((iclsPtr2 = Itcl_AdvanceHierIter(&hier)) != NULL) {
		hPtr = Tcl_FindHashEntry(&iclsPtr2->options,
			(char *)optionNamePtr);
		if (hPtr != NULL) {
		    break;
		}
	    }
	}
	if (hPtr != NULL) {
	    Tcl_AppendResult(interp, "option \"", option,
		    "\" has been defined locally", (char *)NULL);
	    goto errorOut1;
	    return TCL_ERROR;
	}
    }
    idoPtr = (ItclDelegatedOption *)Itcl_Alloc(sizeof(ItclDelegatedOption));
    Tcl_InitObjHashTable(&idoPtr->exceptions);
    if (*option != '*') {
	if (targetPtr == NULL) {
	    targetPtr = optionNamePtr;
	}
	if (resourceNamePtr == NULL) {
	    resourceNamePtr = Tcl_NewStringObj(option+1, TCL_INDEX_NONE);
	    Tcl_IncrRefCount(resourceNamePtr);
	}
	if (classNamePtr == NULL) {
	    classNamePtr = ItclCapitalize(Tcl_GetString(resourceNamePtr));
	}
	idoPtr->namePtr = optionNamePtr;
	idoPtr->resourceNamePtr = resourceNamePtr;
	idoPtr->classNamePtr = Tcl_NewStringObj(
		Tcl_GetString(classNamePtr), TCL_INDEX_NONE);
	Tcl_IncrRefCount(idoPtr->classNamePtr);
	Tcl_DecrRefCount(classNamePtr);

    } else {
	idoPtr->namePtr = optionNamePtr;
    }
    Itcl_PreserveData(idoPtr);
    Itcl_EventuallyFree(idoPtr, (Tcl_FreeProc *) ItclDeleteDelegatedOption);
    idoPtr->icPtr = icPtr;
    idoPtr->asPtr = targetPtr;
    if (idoPtr->asPtr != NULL) {
	Tcl_IncrRefCount(idoPtr->asPtr);
    }
    if (exceptionsPtr != NULL) {
	Tcl_Free(argv);
	argv = NULL;
	if (Tcl_SplitList(interp, Tcl_GetString(exceptionsPtr), &argc, &argv)
		!= TCL_OK) {
	    goto errorOut2;
	}
	for(i=0;i<argc;i++) {
	    Tcl_Obj *objPtr;
	    objPtr = Tcl_NewStringObj(argv[i], TCL_INDEX_NONE);
	    hPtr = Tcl_CreateHashEntry(&idoPtr->exceptions, (char *)objPtr,
		    &isNew);
	}
    }
    if (idoPtrPtr != NULL) {
	*idoPtrPtr = idoPtr;
    }
    Tcl_Free(argv);
    ItclAddDelegatedOptionDictInfo(interp, iclsPtr, idoPtr);
    return TCL_OK;
errorOut2:
    Itcl_ReleaseData(idoPtr);
errorOut1:
    Tcl_DecrRefCount(optionNamePtr);
    if (resourceNamePtr != NULL) {
	Tcl_DecrRefCount(resourceNamePtr);
    }
    if (classNamePtr != NULL) {
	Tcl_DecrRefCount(classNamePtr);
    }
    if (argv) {
	Tcl_Free(argv);
    }
    return TCL_ERROR;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassDelegateOptionCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "delegate option" command is invoked to define a
 *  Handles the following syntax:
 *
 *      delegate option
 *
 * ------------------------------------------------------------------------
 */
static int
Itcl_ClassDelegateOptionCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    Tcl_HashEntry *hPtr;
    ItclObjectInfo *infoPtr;
    ItclClass *iclsPtr;
    ItclDelegatedOption *idoPtr;
    const char *usageStr;
    int isNew;
    int result;

    ItclShowArgs(1, "Itcl_ClassDelegateOptionCmd", objc, objv);
    usageStr = "<optionDef> to <targetDef> ?as <script>? ?except <script>?";
    if (objc < 4) {
	Tcl_AppendResult(interp, "wrong # args should be ", usageStr, (char *)NULL);
	return TCL_ERROR;
    }
    infoPtr = (ItclObjectInfo *)clientData;
    iclsPtr = (ItclClass *)Itcl_PeekStack(&infoPtr->clsStack);
    if (iclsPtr == NULL) {
	Tcl_AppendResult(interp, "Error: ::itcl::parser::delegateoption called from",
		" not within a class", (char *)NULL);
	return TCL_ERROR;
    }
    if (iclsPtr->flags & ITCL_CLASS) {
	Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr),
		" is no ::itcl::widget/::itcl::widgetadaptor/::itcl::type",
		"/::itcl::extendedclass.",
		" Only these can delegate options", (char *)NULL);
	return TCL_ERROR;
    }
    result = Itcl_HandleDelegateOptionCmd(interp, NULL, iclsPtr, &idoPtr,
	     objc, objv);
    if (result != TCL_OK) {
	return result;
    }
    hPtr = Tcl_CreateHashEntry(&iclsPtr->delegatedOptions,
	    (char *)idoPtr->namePtr, &isNew);
    Tcl_SetHashValue(hPtr, idoPtr);
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassDelegateTypeMethodCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "delegate typemethod" command is invoked to define a
 *  Handles the following syntax:
 *
 *      delegate typemethod
 *
 * ------------------------------------------------------------------------
 */
static int
Itcl_ClassDelegateTypeMethodCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    Tcl_Obj *typeMethodNamePtr;
    Tcl_Obj *componentPtr;
    Tcl_Obj *targetPtr;
    Tcl_Obj *usingPtr;
    Tcl_Obj *exceptionsPtr;
    Tcl_HashEntry *hPtr;
    ItclObjectInfo *infoPtr;
    ItclClass *iclsPtr;
    ItclComponent *icPtr;
    ItclDelegatedFunction *idmPtr;
    const char *usageStr;
    const char *typeMethodName;
    const char *component;
    const char *token;
    const char **argv;
    int foundOpt;
    Tcl_Size argc;
    int isNew;
    Tcl_Size i;

    ItclShowArgs(1, "Itcl_ClassDelegateTypeMethodCmd", objc, objv);
    usageStr = "delegate typemethod <typeMethodName> to <componentName> ?as <targetName>?\n\
delegate typemethod <typeMethodName> ?to <componentName>? using <pattern>\n\
delegate typemethod * ?to <componentName>? ?using <pattern>? ?except <typemethods>?";
    componentPtr = NULL;
    icPtr = NULL;
    infoPtr = (ItclObjectInfo*)clientData;
    iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
    if (iclsPtr == NULL) {
	Tcl_AppendResult(interp, "Error: ::itcl::parser::delegatetypemethod called from",
		" not within a class", (char *)NULL);
	return TCL_ERROR;
    }
    if (iclsPtr->flags & ITCL_CLASS) {
	Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr),
		" is no ::itcl::widget/::itcl::widgetadaptor/::itcl::type.",
		" Only these can delegate typemethods", (char *)NULL);
	return TCL_ERROR;
    }

    if (objc < 4) {
	Tcl_AppendResult(interp, "wrong # args should be ", usageStr, (char *)NULL);
	return TCL_ERROR;
    }
    typeMethodName = Tcl_GetString(objv[1]);
    /* check if typeMethodName has been delegated */
    component = NULL;
    targetPtr = NULL;
    usingPtr = NULL;
    exceptionsPtr = NULL;
    for(i=2;i<objc;i++) {
	token = Tcl_GetString(objv[i]);
	if (i+1 == objc) {
	    Tcl_AppendResult(interp, "wrong # args should be ", usageStr, NULL);
	    return TCL_ERROR;
	}
	foundOpt = 0;
	if (strcmp(token, "to") == 0) {
	    i++;
	    component = Tcl_GetString(objv[i]);
	    componentPtr = objv[i];
	    foundOpt++;
	}
	if (strcmp(token, "as") == 0) {
	    i++;
	    targetPtr = objv[i];
	    foundOpt++;
	}
	if (strcmp(token, "except") == 0) {
	    i++;
	    exceptionsPtr = objv[i];
	    foundOpt++;
	}
	if (strcmp(token, "using") == 0) {
	    i++;
	    usingPtr = objv[i];
	    foundOpt++;
	}
	if (!foundOpt) {
	    Tcl_AppendResult(interp, "bad option \"", token, "\" should be ",
		    usageStr, (char *)NULL);
	    return TCL_ERROR;
	}
    }
    if ((component == NULL) && (usingPtr == NULL)) {
	Tcl_AppendResult(interp, "missing to should be: ", usageStr, (char *)NULL);
	return TCL_ERROR;
    }
    if ((*typeMethodName == '*') && (targetPtr != NULL)) {
	Tcl_AppendResult(interp,
		"cannot specify \"as\" with \"delegate typemethod *\"", (char *)NULL);
	return TCL_ERROR;
    }
    if (componentPtr != NULL) {
	hPtr = Tcl_FindHashEntry(&iclsPtr->components, (char *)componentPtr);
	if (hPtr == NULL) {
	    if (ItclCreateComponent(interp, iclsPtr, componentPtr,
		    ITCL_COMMON, &icPtr) != TCL_OK) {
		return TCL_ERROR;
	    }
	} else {
	    icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr);
	}
    } else {
	icPtr = NULL;
    }
    idmPtr = (ItclDelegatedFunction *)Tcl_Alloc(sizeof(ItclDelegatedFunction));
    memset(idmPtr, 0, sizeof(ItclDelegatedFunction));
    Tcl_InitObjHashTable(&idmPtr->exceptions);
    typeMethodNamePtr = Tcl_NewStringObj(typeMethodName, TCL_INDEX_NONE);
    if (*typeMethodName != '*') {
	/* FIXME !!! */
	/* check for locally defined typemethod */
	hPtr = Tcl_FindHashEntry(&iclsPtr->functions,
		(char *)typeMethodNamePtr);
	if (hPtr != NULL) {
	    Tcl_AppendResult(interp, "Error in \"delegate typemethod ",
		    typeMethodName, "...\", \"", typeMethodName,
		    "\" has been defined locally.", (char *)NULL);
	    Tcl_DeleteHashTable(&idmPtr->exceptions);
	    Tcl_Free(idmPtr);
	    Tcl_DecrRefCount(typeMethodNamePtr);
	    return TCL_ERROR;
	}
	idmPtr->namePtr = Tcl_NewStringObj(
		Tcl_GetString(typeMethodNamePtr), TCL_INDEX_NONE);
	Tcl_IncrRefCount(idmPtr->namePtr);
    } else {
	Tcl_DecrRefCount(typeMethodNamePtr);
	typeMethodNamePtr = Tcl_NewStringObj("*", TCL_INDEX_NONE);
	Tcl_IncrRefCount(typeMethodNamePtr);
	idmPtr->namePtr = typeMethodNamePtr;
	Tcl_IncrRefCount(typeMethodNamePtr);
	if (exceptionsPtr != NULL) {
	    if (Tcl_SplitList(interp, Tcl_GetString(exceptionsPtr),
		    &argc, &argv) != TCL_OK) {
		return TCL_ERROR;
	    }
	    for(i = 0; i < argc; i++) {
		Tcl_Obj *objPtr;
		objPtr = Tcl_NewStringObj(argv[i], TCL_INDEX_NONE);
		hPtr = Tcl_CreateHashEntry(&idmPtr->exceptions, (char *)objPtr,
			&isNew);
	    }
	    Tcl_Free(argv);
	}
    }
    idmPtr->icPtr = icPtr;
    idmPtr->asPtr = targetPtr;
    if (idmPtr->asPtr != NULL) {
	Tcl_IncrRefCount(idmPtr->asPtr);
    }
    idmPtr->usingPtr = usingPtr;
    if (idmPtr->usingPtr != NULL) {
	Tcl_IncrRefCount(idmPtr->usingPtr);
    }
    idmPtr->flags = ITCL_COMMON|ITCL_TYPE_METHOD;
    hPtr = Tcl_CreateHashEntry(&iclsPtr->delegatedFunctions,
	    (char *)idmPtr->namePtr, &isNew);
    if (!isNew) {
	ItclDeleteDelegatedFunction((ItclDelegatedFunction *)
		Tcl_GetHashValue(hPtr));
    }
    Tcl_SetHashValue(hPtr, idmPtr);
    Tcl_DecrRefCount(typeMethodNamePtr);
    return TCL_OK;
}
/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassForwardCmd()
 *
 *  Used similar to interp alias to forward the call of a method
 *  to another method within the class
 *
 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */

static int
Itcl_ClassForwardCmd(
    void *clientData,	/* unused */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    Tcl_Obj *prefixObj;
    Tcl_Method mPtr;
    ItclObjectInfo *infoPtr;
    ItclClass *iclsPtr;

    ItclShowArgs(1, "Itcl_ClassForwardCmd", objc, objv);
    infoPtr = (ItclObjectInfo*)clientData;
    iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
    if (iclsPtr == NULL) {
	Tcl_AppendResult(interp, "Error: ::itcl::parser::forward called from",
		" not within a class", (char *)NULL);
	return TCL_ERROR;
    }
    if (iclsPtr->flags & ITCL_CLASS) {
	Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr),
		" is no ::itcl::widget/::itcl::widgetadaptor/",
		"::itcl::type/::itcl::extendedclass.",
		" Only these can forward", (char *)NULL);
	return TCL_ERROR;
    }
    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "<forwardName> <targetName> ?<arg> ...?");
	return TCL_ERROR;
    }
    prefixObj = Tcl_NewListObj(objc-2, objv+2);
    mPtr = Itcl_NewForwardClassMethod(interp, iclsPtr->clsPtr, 1,
	    objv[1], prefixObj);
    if (mPtr == NULL) {
	return TCL_ERROR;
    }
    return TCL_OK;
}
/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassMethodVariableCmd()
 *
 *  Used to similar to iterp alias to forward the call of a method
 *  to another method within the class
 *
 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */

static int
Itcl_ClassMethodVariableCmd(
    void *clientData,	/* unused */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    Tcl_Obj *namePtr;
    Tcl_Obj *defaultPtr;
    Tcl_Obj *callbackPtr;
    ItclObjectInfo *infoPtr;
    ItclClass *iclsPtr;
    ItclVariable *ivPtr;
    ItclMemberFunc *imPtr;
    ItclMethodVariable *imvPtr;
    const char *token;
    const char *usageStr;
    int i;
    int foundOpt;
    int result;
    Tcl_Obj *objPtr;

    ItclShowArgs(1, "Itcl_ClassMethodVariableCmd", objc, objv);
    infoPtr = (ItclObjectInfo*)clientData;
    iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
    if (iclsPtr == NULL) {
	Tcl_AppendResult(interp, "Error: ::itcl::parser::methodvariable called from",
		" not within a class", (char *)NULL);
	return TCL_ERROR;
    }
    if (iclsPtr->flags & ITCL_CLASS) {
	Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr),
		" is no ::itcl::widget/::itcl::widgetadaptor/",
		"::itcl::type/::itcl::extendedclass.",
		" Only these can have methodvariables", (char *)NULL);
	return TCL_ERROR;
    }
    usageStr = "<name> ?-default value? ?-callback script?";
    if ((objc < 2) || (objc > 6)) {
	Tcl_WrongNumArgs(interp, 1, objv, usageStr);
	return TCL_ERROR;
    }

    /*
     *  Make sure that the variable name does not contain anything
     *  goofy like a "::" scope qualifier.
     */
    namePtr = objv[1];
    if (strstr(Tcl_GetString(namePtr), "::")) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "bad variable name \"", Tcl_GetString(namePtr), "\"",
	    (char *)NULL);
	return TCL_ERROR;
    }

    defaultPtr = NULL;
    callbackPtr = NULL;
    for (i=2;i<objc;i++) {
	foundOpt = 0;
	token = Tcl_GetString(objv[i]);
	if (strcmp(token, "-default") == 0) {
	    if (i+1 > objc) {
		Tcl_WrongNumArgs(interp, 1, objv, usageStr);
		return TCL_ERROR;
	    }
	    defaultPtr = objv[i+1];
	    i++;
	    foundOpt++;
	}
	if (strcmp(token, "-callback") == 0) {
	    if (i+1 > objc) {
		Tcl_WrongNumArgs(interp, 1, objv, usageStr);
		return TCL_ERROR;
	    }
	    callbackPtr = objv[i+1];
	    i++;
	    foundOpt++;
	}
	if (!foundOpt) {
	    Tcl_WrongNumArgs(interp, 1, objv, usageStr);
	    return TCL_ERROR;
	}
    }

    if (Itcl_CreateVariable(interp, iclsPtr, namePtr,
	    Tcl_GetString(defaultPtr), NULL, &ivPtr) != TCL_OK) {
	return TCL_ERROR;
    }
    iclsPtr->numVariables++;
    result = ItclCreateMethodVariable(interp, ivPtr, defaultPtr,
	    callbackPtr, &imvPtr);
    if (result != TCL_OK) {
	return result;
    }
    objPtr = Tcl_NewStringObj("@itcl-builtin-setget ", TCL_INDEX_NONE);
    Tcl_AppendToObj(objPtr, Tcl_GetString(namePtr), TCL_INDEX_NONE);
    Tcl_AppendToObj(objPtr, " ", 1);
    result = ItclCreateMethod(interp, iclsPtr, namePtr, "args",
	    Tcl_GetString(objPtr), &imPtr);
    if (result != TCL_OK) {
	return result;
    }
    /* install a write trace if callbackPtr != NULL */
    /* FIXME to be done */
    ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr);
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassTypeConstructorCmd()
 *
 *  Invoked by Tcl during the parsing of a type class definition whenever
 *  the "typeconstructor" command is invoked to define the typeconstructor
 *  for an object.  Handles the following syntax:
 *
 *      typeconstructor <body>
 *
 * ------------------------------------------------------------------------
 */
static int
Itcl_ClassTypeConstructorCmd(
    void *clientData,	/* info for all known objects */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
    ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
    Tcl_Obj *namePtr;

    ItclShowArgs(1, "Itcl_ClassTypeConstructorCmd", objc, objv);

    if (iclsPtr == NULL) {
	Tcl_AppendResult(interp, "Error: ::itcl::parser::typeconstructor called from",
		" not within a class", (char *)NULL);
	return TCL_ERROR;
    }
    if (iclsPtr->flags & ITCL_CLASS) {
	Tcl_AppendResult(interp, "a \"class\" cannot have a typeconstructor",
		(char *)NULL);
	return TCL_ERROR;
    }

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "body");
	return TCL_ERROR;
    }

    namePtr = objv[0];
    if (iclsPtr->typeConstructorPtr != NULL) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "\"", Tcl_GetString(namePtr), "\" already defined in class \"",
	    Tcl_GetString(iclsPtr->fullNamePtr), "\"",
	    (char *)NULL);
	return TCL_ERROR;
    }

    iclsPtr->typeConstructorPtr = Tcl_NewStringObj(Tcl_GetString(objv[1]), TCL_INDEX_NONE);
    Tcl_IncrRefCount(iclsPtr->typeConstructorPtr);
    return TCL_OK;
}
