Implementation of TIP #257. Incomplete due to missing Win build support.

1 files changed, 1271 insertions, 0 deletions

diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
new file mode 100644
index 0000000..bded40c
--- /dev/null
+++ b/generic/tclOOInfo.c
@@ -0,0 +1,1271 @@
+/*
+ * tclOODefineCmds.c --
+ *
+ *	This file contains the implementation of the ::oo-related [info]
+ *	subcommands.
+ *
+ * Copyright (c) 2006-2008 by Donal K. Fellows
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclOOInfo.c,v 1.4 2008/05/31 11:42:18 dkf Exp $
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tclInt.h"
+#include "tclOOInt.h"
+
+static Tcl_ObjCmdProc InfoObjectClassCmd;
+static Tcl_ObjCmdProc InfoObjectDefnCmd;
+static Tcl_ObjCmdProc InfoObjectFiltersCmd;
+static Tcl_ObjCmdProc InfoObjectForwardCmd;
+static Tcl_ObjCmdProc InfoObjectIsACmd;
+static Tcl_ObjCmdProc InfoObjectMethodsCmd;
+static Tcl_ObjCmdProc InfoObjectMixinsCmd;
+static Tcl_ObjCmdProc InfoObjectVarsCmd;
+static Tcl_ObjCmdProc InfoClassConstrCmd;
+static Tcl_ObjCmdProc InfoClassDefnCmd;
+static Tcl_ObjCmdProc InfoClassDestrCmd;
+static Tcl_ObjCmdProc InfoClassFiltersCmd;
+static Tcl_ObjCmdProc InfoClassForwardCmd;
+static Tcl_ObjCmdProc InfoClassInstancesCmd;
+static Tcl_ObjCmdProc InfoClassMethodsCmd;
+static Tcl_ObjCmdProc InfoClassMixinsCmd;
+static Tcl_ObjCmdProc InfoClassSubsCmd;
+static Tcl_ObjCmdProc InfoClassSupersCmd;
+
+struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; };
+
+/*
+ * List of commands that are used to implement the [info object] subcommands.
+ */
+
+static const struct NameProcMap infoObjectCmds[] = {
+    {"::oo::InfoObject::class",	     InfoObjectClassCmd},
+    {"::oo::InfoObject::definition", InfoObjectDefnCmd},
+    {"::oo::InfoObject::filters",    InfoObjectFiltersCmd},
+    {"::oo::InfoObject::forward",    InfoObjectForwardCmd},
+    {"::oo::InfoObject::isa",	     InfoObjectIsACmd},
+    {"::oo::InfoObject::methods",    InfoObjectMethodsCmd},
+    {"::oo::InfoObject::mixins",     InfoObjectMixinsCmd},
+    {"::oo::InfoObject::vars",	     InfoObjectVarsCmd},
+    {NULL, NULL}
+};
+
+/*
+ * List of commands that are used to implement the [info class] subcommands.
+ */
+
+static const struct NameProcMap infoClassCmds[] = {
+    {"::oo::InfoClass::constructor",  InfoClassConstrCmd},
+    {"::oo::InfoClass::definition",   InfoClassDefnCmd},
+    {"::oo::InfoClass::destructor",   InfoClassDestrCmd},
+    {"::oo::InfoClass::filters",      InfoClassFiltersCmd},
+    {"::oo::InfoClass::forward",      InfoClassForwardCmd},
+    {"::oo::InfoClass::instances",    InfoClassInstancesCmd},
+    {"::oo::InfoClass::methods",      InfoClassMethodsCmd},
+    {"::oo::InfoClass::mixins",	      InfoClassMixinsCmd},
+    {"::oo::InfoClass::subclasses",   InfoClassSubsCmd},
+    {"::oo::InfoClass::superclasses", InfoClassSupersCmd},
+    {NULL, NULL}
+};
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOInitInfo --
+ *
+ *	Adjusts the Tcl core [info] command to contain subcommands ("object"
+ *	and "class") for introspection of objects and classes.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOInitInfo(
+    Tcl_Interp *interp)
+{
+    Tcl_Namespace *nsPtr;
+    Tcl_Command infoCmd;
+    int i;
+
+    /*
+     * Build the ensemble used to implement [info object].
+     */
+
+    nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoObject", NULL, NULL);
+    Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX);
+    Tcl_Export(interp, nsPtr, "[a-z]*", 1);
+    for (i=0 ; infoObjectCmds[i].name!=NULL ; i++) {
+	Tcl_CreateObjCommand(interp, infoObjectCmds[i].name,
+		infoObjectCmds[i].proc, NULL, NULL);
+    }
+
+    /*
+     * Build the ensemble used to implement [info class].
+     */
+
+    nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoClass", NULL, NULL);
+    Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX);
+    Tcl_Export(interp, nsPtr, "[a-z]*", 1);
+    for (i=0 ; infoClassCmds[i].name!=NULL ; i++) {
+	Tcl_CreateObjCommand(interp, infoClassCmds[i].name,
+		infoClassCmds[i].proc, NULL, NULL);
+    }
+
+    /*
+     * Install into the master [info] ensemble.
+     */
+
+    infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
+    if (infoCmd != NULL && Tcl_IsEnsemble(infoCmd)) {
+	Tcl_Obj *mapDict, *objectObj, *classObj;
+
+	Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict);
+	if (mapDict != NULL) {
+	    objectObj = Tcl_NewStringObj("object", -1);
+	    classObj = Tcl_NewStringObj("class", -1);
+
+	    Tcl_IncrRefCount(objectObj);
+	    Tcl_IncrRefCount(classObj);
+	    Tcl_DictObjPut(NULL, mapDict, objectObj,
+		    Tcl_NewStringObj("::oo::InfoObject", -1));
+	    Tcl_DictObjPut(NULL, mapDict, classObj,
+		    Tcl_NewStringObj("::oo::InfoClass", -1));
+	    Tcl_DecrRefCount(objectObj);
+	    Tcl_DecrRefCount(classObj);
+	    Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict);
+	}
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectClassCmd --
+ *
+ *	Implements [info object class $objName ?$className?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectClassCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Object *oPtr;
+
+    if (objc != 2 && objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "objName ?className?");
+	return TCL_ERROR;
+    }
+
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    if (objc == 2) {
+	Tcl_SetObjResult(interp,
+		TclOOObjectName(interp, oPtr->selfCls->thisPtr));
+	return TCL_OK;
+    } else {
+	Object *o2Ptr;
+	Class *mixinPtr;
+	int i;
+
+	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+	if (o2Ptr == NULL) {
+	    return TCL_ERROR;
+	}
+	if (o2Ptr->classPtr == NULL) {
+	    Tcl_AppendResult(interp, "object \"", TclGetString(objv[2]),
+		    "\" is not a class", NULL);
+	    return TCL_ERROR;
+	}
+
+	FOREACH(mixinPtr, oPtr->mixins) {
+	    if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) {
+		Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+		return TCL_OK;
+	    }
+	}
+	Tcl_SetObjResult(interp, Tcl_NewIntObj(
+		TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)));
+	return TCL_OK;
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectDefnCmd --
+ *
+ *	Implements [info object definition $objName $methodName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectDefnCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Object *oPtr;
+    Tcl_HashEntry *hPtr;
+    Proc *procPtr;
+    CompiledLocal *localPtr;
+    Tcl_Obj *argsObj;
+
+    if (objc != 3) {
+	Tcl_WrongNumArgs(interp, 3, objv, "objName methodName");
+	return TCL_ERROR;
+    }
+
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    if (!oPtr->methodsPtr) {
+	goto unknownMethod;
+    }
+    hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
+    if (hPtr == NULL) {
+    unknownMethod:
+	Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
+		"\"", NULL);
+	return TCL_ERROR;
+    }
+    procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
+    if (procPtr == NULL) {
+	Tcl_AppendResult(interp,
+		"definition not available for this kind of method", NULL);
+	return TCL_ERROR;
+    }
+
+    argsObj = Tcl_NewObj();
+    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
+	    localPtr=localPtr->nextPtr) {
+	if (TclIsVarArgument(localPtr)) {
+	    Tcl_Obj *argObj;
+
+	    argObj = Tcl_NewObj();
+	    Tcl_ListObjAppendElement(NULL, argObj,
+		    Tcl_NewStringObj(localPtr->name, -1));
+	    if (localPtr->defValuePtr != NULL) {
+		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
+	    }
+	    Tcl_ListObjAppendElement(NULL, argsObj, argObj);
+	}
+    }
+    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
+
+    /*
+     * This is copied from the [info body] implementation. See the comments
+     * there for why this copy has to be done here.
+     */
+
+    if (procPtr->bodyPtr->bytes == NULL) {
+	(void) Tcl_GetString(procPtr->bodyPtr);
+    }
+    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+	    Tcl_NewStringObj(procPtr->bodyPtr->bytes,
+	    procPtr->bodyPtr->length));
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectFiltersCmd --
+ *
+ *	Implements [info object filters $objName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectFiltersCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    int i;
+    Tcl_Obj *filterObj;
+    Object *oPtr;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "objName");
+	return TCL_ERROR;
+    }
+
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    FOREACH(filterObj, oPtr->filters) {
+	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj);
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectForwardCmd --
+ *
+ *	Implements [info object forward $objName $methodName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectForwardCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Object *oPtr;
+    Tcl_HashEntry *hPtr;
+    Tcl_Obj *prefixObj;
+
+    if (objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "objName methodName");
+	return TCL_ERROR;
+    }
+
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    if (!oPtr->methodsPtr) {
+	goto unknownMethod;
+    }
+    hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
+    if (hPtr == NULL) {
+    unknownMethod:
+	Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
+		"\"", NULL);
+	return TCL_ERROR;
+    }
+    prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
+    if (prefixObj == NULL) {
+	Tcl_AppendResult(interp,
+		"prefix argument list not available for this kind of method",
+		NULL);
+	return TCL_ERROR;
+    }
+
+    Tcl_SetObjResult(interp, prefixObj);
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectIsACmd --
+ *
+ *	Implements [info object isa $category $objName ...]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectIsACmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    static const char *categories[] = {
+	"class", "metaclass", "mixin", "object", "typeof", NULL
+    };
+    enum IsACats {
+	IsClass, IsMetaclass, IsMixin, IsObject, IsType
+    };
+    Object *oPtr, *o2Ptr;
+    int idx, i;
+
+    if (objc < 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?");
+	return TCL_ERROR;
+    }
+    if (Tcl_GetIndexFromObj(interp, objv[1], categories, "category", 0,
+	    &idx) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    if (idx == IsObject) {
+	int ok = (Tcl_GetObjectFromObj(interp, objv[2]) != NULL);
+
+	if (!ok) {
+	    Tcl_ResetResult(interp);
+	}
+	Tcl_SetObjResult(interp, Tcl_NewIntObj(ok ? 1 : 0));
+	return TCL_OK;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    switch ((enum IsACats) idx) {
+    case IsClass:
+	if (objc != 3) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "objName");
+	    return TCL_ERROR;
+	}
+	Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->classPtr ? 1 : 0));
+	return TCL_OK;
+    case IsMetaclass:
+	if (objc != 3) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "objName");
+	    return TCL_ERROR;
+	}
+	if (oPtr->classPtr == NULL) {
+	    Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+	} else {
+	    Class *classCls = TclOOGetFoundation(interp)->classCls;
+
+	    Tcl_SetObjResult(interp, Tcl_NewIntObj(
+		    TclOOIsReachable(classCls, oPtr->classPtr) ? 1 : 0));
+	}
+	return TCL_OK;
+    case IsMixin:
+	if (objc != 4) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "objName className");
+	    return TCL_ERROR;
+	}
+	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
+	if (o2Ptr == NULL) {
+	    return TCL_ERROR;
+	}
+	if (o2Ptr->classPtr == NULL) {
+	    Tcl_AppendResult(interp, "non-classes cannot be mixins", NULL);
+	    return TCL_ERROR;
+	} else {
+	    Class *mixinPtr;
+
+	    FOREACH(mixinPtr, oPtr->mixins) {
+		if (mixinPtr == o2Ptr->classPtr) {
+		    Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+		    return TCL_OK;
+		}
+	    }
+	}
+	Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+	return TCL_OK;
+    case IsType:
+	if (objc != 4) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "objName className");
+	    return TCL_ERROR;
+	}
+	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
+	if (o2Ptr == NULL) {
+	    return TCL_ERROR;
+	}
+	if (o2Ptr->classPtr == NULL) {
+	    Tcl_AppendResult(interp, "non-classes cannot be types", NULL);
+	    return TCL_ERROR;
+	}
+	if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) {
+	    Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+	} else {
+	    Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+	}
+	return TCL_OK;
+    case IsObject:
+	Tcl_Panic("unexpected fallthrough");
+    }
+    return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectMethodsCmd --
+ *
+ *	Implements [info object methods $objName ?$option ...?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectMethodsCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Object *oPtr;
+    int flag = PUBLIC_METHOD, recurse = 0;
+    FOREACH_HASH_DECLS;
+    Tcl_Obj *namePtr;
+    Method *mPtr;
+    static const char *options[] = {
+	"-all", "-localprivate", "-private", NULL
+    };
+    enum Options {
+	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
+    };
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?");
+	return TCL_ERROR;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (objc != 2) {
+	int i, idx;
+
+	for (i=2 ; i<objc ; i++) {
+	    if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
+		    &idx) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    switch ((enum Options) idx) {
+	    case OPT_ALL:
+		recurse = 1;
+		break;
+	    case OPT_LOCALPRIVATE:
+		flag = PRIVATE_METHOD;
+		break;
+	    case OPT_PRIVATE:
+		flag = 0;
+		break;
+	    }
+	}
+    }
+
+    if (recurse) {
+	const char **names;
+	int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names);
+	Tcl_Obj *resultObj = Tcl_NewObj();
+
+	for (i=0 ; i<numNames ; i++) {
+	    Tcl_ListObjAppendElement(NULL, resultObj,
+		    Tcl_NewStringObj(names[i], -1));
+	}
+	ckfree((char *) names);
+	Tcl_SetObjResult(interp, resultObj);
+	return TCL_OK;
+    }
+
+    if (oPtr->methodsPtr) {
+	FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
+	    if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+		Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+			namePtr);
+	    }
+	}
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectMixinsCmd --
+ *
+ *	Implements [info object mixins $objName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectMixinsCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Class *mixinPtr;
+    Object *oPtr;
+    int i;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 3, objv, "objName");
+	return TCL_ERROR;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    FOREACH(mixinPtr, oPtr->mixins) {
+	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+		TclOOObjectName(interp, mixinPtr->thisPtr));
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectVarsCmd --
+ *
+ *	Implements [info object vars $objName ?$pattern?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectVarsCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Object *oPtr;
+    const char *pattern = NULL;
+    FOREACH_HASH_DECLS;
+    VarInHash *vihPtr;
+    Tcl_Obj *nameObj, *resultObj;
+
+    if (objc != 2 && objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "objName ?pattern?");
+	return TCL_ERROR;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (objc == 3) {
+	pattern = TclGetString(objv[2]);
+    }
+    resultObj = Tcl_NewObj();
+
+    /*
+     * Extract the information we need from the object's namespace's table of
+     * variables. Note that this involves horrific knowledge of the guts of
+     * tclVar.c, so we can't leverage our hash-iteration macros properly.
+     */
+
+    FOREACH_HASH_VALUE(vihPtr,
+	    &((Namespace *) oPtr->namespacePtr)->varTable.table) {
+	nameObj = vihPtr->entry.key.objPtr;
+
+	if (TclIsVarUndefined(&vihPtr->var)
+		|| !TclIsVarNamespaceVar(&vihPtr->var)) {
+	    continue;
+	}
+	if (pattern != NULL
+		&& !Tcl_StringMatch(TclGetString(nameObj), pattern)) {
+	    continue;
+	}
+	Tcl_ListObjAppendElement(NULL, resultObj, nameObj);
+    }
+
+    Tcl_SetObjResult(interp, resultObj);
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassConstrCmd --
+ *
+ *	Implements [info class constructor $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassConstrCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Proc *procPtr;
+    CompiledLocal *localPtr;
+    Tcl_Obj *argsObj;
+    Object *oPtr;
+    Class *clsPtr;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className");
+	return TCL_ERROR;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr->classPtr == NULL) {
+	Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+		"\" is not a class", NULL);
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+
+    if (clsPtr->constructorPtr == NULL) {
+	return TCL_OK;
+    }
+    procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr);
+    if (procPtr == NULL) {
+	Tcl_AppendResult(interp,
+		"definition not available for this kind of method", NULL);
+	return TCL_ERROR;
+    }
+
+    argsObj = Tcl_NewObj();
+    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
+	    localPtr=localPtr->nextPtr) {
+	if (TclIsVarArgument(localPtr)) {
+	    Tcl_Obj *argObj;
+
+	    argObj = Tcl_NewObj();
+	    Tcl_ListObjAppendElement(NULL, argObj,
+		    Tcl_NewStringObj(localPtr->name, -1));
+	    if (localPtr->defValuePtr != NULL) {
+		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
+	    }
+	    Tcl_ListObjAppendElement(NULL, argsObj, argObj);
+	}
+    }
+    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
+    if (procPtr->bodyPtr->bytes == NULL) {
+	(void) Tcl_GetString(procPtr->bodyPtr);
+    }
+    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+	    Tcl_NewStringObj(procPtr->bodyPtr->bytes,
+	    procPtr->bodyPtr->length));
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassDefnCmd --
+ *
+ *	Implements [info class definition $clsName $methodName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassDefnCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Tcl_HashEntry *hPtr;
+    Proc *procPtr;
+    CompiledLocal *localPtr;
+    Tcl_Obj *argsObj;
+    Object *oPtr;
+    Class *clsPtr;
+
+    if (objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
+	return TCL_ERROR;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr->classPtr == NULL) {
+	Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+		"\" is not a class", NULL);
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+
+    hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
+    if (hPtr == NULL) {
+	Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
+		"\"", NULL);
+	return TCL_ERROR;
+    }
+    procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
+    if (procPtr == NULL) {
+	Tcl_AppendResult(interp,
+		"definition not available for this kind of method", NULL);
+	return TCL_ERROR;
+    }
+
+    argsObj = Tcl_NewObj();
+    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
+	    localPtr=localPtr->nextPtr) {
+	if (TclIsVarArgument(localPtr)) {
+	    Tcl_Obj *argObj;
+
+	    argObj = Tcl_NewObj();
+	    Tcl_ListObjAppendElement(NULL, argObj,
+		    Tcl_NewStringObj(localPtr->name, -1));
+	    if (localPtr->defValuePtr != NULL) {
+		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
+	    }
+	    Tcl_ListObjAppendElement(NULL, argsObj, argObj);
+	}
+    }
+    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
+    if (procPtr->bodyPtr->bytes == NULL) {
+	(void) Tcl_GetString(procPtr->bodyPtr);
+    }
+    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+	    Tcl_NewStringObj(procPtr->bodyPtr->bytes,
+	    procPtr->bodyPtr->length));
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassDestrCmd --
+ *
+ *	Implements [info class destructor $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassDestrCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Proc *procPtr;
+    Object *oPtr;
+    Class *clsPtr;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className");
+	return TCL_ERROR;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr->classPtr == NULL) {
+	Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+		"\" is not a class", NULL);
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+
+    if (clsPtr->destructorPtr == NULL) {
+	return TCL_OK;
+    }
+    procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr);
+    if (procPtr == NULL) {
+	Tcl_AppendResult(interp,
+		"definition not available for this kind of method", NULL);
+	return TCL_ERROR;
+    }
+
+    if (procPtr->bodyPtr->bytes == NULL) {
+	(void) Tcl_GetString(procPtr->bodyPtr);
+    }
+    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+	    Tcl_NewStringObj(procPtr->bodyPtr->bytes,
+	    procPtr->bodyPtr->length));
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassFiltersCmd --
+ *
+ *	Implements [info class filters $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassFiltersCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    int i;
+    Tcl_Obj *filterObj;
+    Object *oPtr;
+    Class *clsPtr;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className");
+	return TCL_ERROR;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr->classPtr == NULL) {
+	Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+		"\" is not a class", NULL);
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+
+    FOREACH(filterObj, clsPtr->filters) {
+	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj);
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassForwardCmd --
+ *
+ *	Implements [info class forward $clsName $methodName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassForwardCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Tcl_HashEntry *hPtr;
+    Tcl_Obj *prefixObj;
+    Object *oPtr;
+    Class *clsPtr;
+
+    if (objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
+	return TCL_ERROR;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr->classPtr == NULL) {
+	Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+		"\" is not a class", NULL);
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+
+    hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
+    if (hPtr == NULL) {
+	Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
+		"\"", NULL);
+	return TCL_ERROR;
+    }
+    prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
+    if (prefixObj == NULL) {
+	Tcl_AppendResult(interp,
+		"prefix argument list not available for this kind of method",
+		NULL);
+	return TCL_ERROR;
+    }
+
+    Tcl_SetObjResult(interp, prefixObj);
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassInstancesCmd --
+ *
+ *	Implements [info class instances $clsName ?$pattern?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassInstancesCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Object *oPtr;
+    Class *clsPtr;
+    int i;
+    const char *pattern = NULL;
+
+    if (objc != 2 && objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
+	return TCL_ERROR;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr->classPtr == NULL) {
+	Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+		"\" is not a class", NULL);
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+    if (objc == 3) {
+	pattern = TclGetString(objv[2]);
+    }
+
+    FOREACH(oPtr, clsPtr->instances) {
+	Tcl_Obj *tmpObj = TclOOObjectName(interp, oPtr);
+
+	if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
+	    continue;
+	}
+	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassMethodsCmd --
+ *
+ *	Implements [info class methods $clsName ?-private?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassMethodsCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    int flag = PUBLIC_METHOD, recurse = 0;
+    FOREACH_HASH_DECLS;
+    Tcl_Obj *namePtr;
+    Method *mPtr;
+    Object *oPtr;
+    Class *clsPtr;
+    static const char *options[] = {
+	"-all", "-localprivate", "-private", NULL
+    };
+    enum Options {
+	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
+    };
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?");
+	return TCL_ERROR;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr->classPtr == NULL) {
+	Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+		"\" is not a class", NULL);
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+    if (objc != 2) {
+	int i, idx;
+
+	for (i=2 ; i<objc ; i++) {
+	    if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
+		    &idx) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    switch ((enum Options) idx) {
+	    case OPT_ALL:
+		recurse = 1;
+		break;
+	    case OPT_LOCALPRIVATE:
+		flag = PRIVATE_METHOD;
+		break;
+	    case OPT_PRIVATE:
+		flag = 0;
+		break;
+	    }
+	}
+    }
+
+    if (recurse) {
+	const char **names;
+	int i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names);
+	Tcl_Obj *resultObj = Tcl_NewObj();
+
+	for (i=0 ; i<numNames ; i++) {
+	    Tcl_ListObjAppendElement(NULL, resultObj,
+		    Tcl_NewStringObj(names[i], -1));
+	}
+	ckfree((char *) names);
+	Tcl_SetObjResult(interp, resultObj);
+	return TCL_OK;
+    }
+
+    FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
+	if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), namePtr);
+	}
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassMixinsCmd --
+ *
+ *	Implements [info class mixins $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassMixinsCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Object *oPtr;
+    Class *clsPtr, *mixinPtr;
+    int i;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className");
+	return TCL_ERROR;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr->classPtr == NULL) {
+	Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+		"\" is not a class", NULL);
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+
+    FOREACH(mixinPtr, clsPtr->mixins) {
+	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+		TclOOObjectName(interp, mixinPtr->thisPtr));
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassSubsCmd --
+ *
+ *	Implements [info class subclasses $clsName ?$pattern?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassSubsCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Object *oPtr;
+    Class *clsPtr, *subclassPtr;
+    int i;
+    const char *pattern = NULL;
+
+    if (objc != 2 && objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
+	return TCL_ERROR;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr->classPtr == NULL) {
+	Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+		"\" is not a class", NULL);
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+    if (objc == 3) {
+	pattern = TclGetString(objv[2]);
+    }
+
+    FOREACH(subclassPtr, clsPtr->subclasses) {
+	Tcl_Obj *tmpObj = TclOOObjectName(interp, subclassPtr->thisPtr);
+
+	if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
+	    continue;
+	}
+	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+    }
+    FOREACH(subclassPtr, clsPtr->mixinSubs) {
+	Tcl_Obj *tmpObj = TclOOObjectName(interp, subclassPtr->thisPtr);
+
+	if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
+	    continue;
+	}
+	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassSupersCmd --
+ *
+ *	Implements [info class superclasses $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassSupersCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Object *oPtr;
+    Class *clsPtr, *superPtr;
+    int i;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className");
+	return TCL_ERROR;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr->classPtr == NULL) {
+	Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+		"\" is not a class", NULL);
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+
+    FOREACH(superPtr, clsPtr->superclasses) {
+	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+		TclOOObjectName(interp, superPtr->thisPtr));
+    }
+    return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */