Itcl - the [incr Tcl] extension

    Tcl_Namespace *itclNs;
    Tcl_HashEntry *hPtr;
    ItclObjectInfo *infoPtr;
    const char * ret;
    char *res_option;
    int opt;
    int isNew;
    Tcl_Class tclCls;
    Tcl_Object clazzObjectPtr, root;
    Tcl_Obj *objPtr, *resPtr;

    if (Tcl_InitStubs(interp, "8.6", 0) == NULL) {
        return TCL_ERROR;
    }

    Itcl_PreserveData((ClientData)infoPtr);

#ifdef NEW_PROTO_RESOLVER
    ItclVarsAndCommandResolveInit(interp);
#endif

    objPtr = Tcl_NewStringObj("::oo::class", -1);
    Tcl_IncrRefCount(objPtr);
    clazzObjectPtr = Tcl_GetObjectFromObj(interp, objPtr);
    if (!clazzObjectPtr || !(tclCls = Tcl_GetObjectAsClass(clazzObjectPtr))) {
	Tcl_DecrRefCount(objPtr);
        return TCL_ERROR;
    }
    Tcl_DecrRefCount(objPtr);
    root = Tcl_NewObjectInstance(interp, tclCls, "::itcl::Root",

	    NULL, 0, NULL, 0);


    Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root),
	    Tcl_NewStringObj("unknown", -1), 0, &itclRootMethodType,
	    ItclUnknownGuts);
    Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root),
	    Tcl_NewStringObj("ItclConstructBase", -1), 0,
	    &itclRootMethodType, ItclConstructGuts);

    }

    /* work around for SF bug #254 needed because of problem in TclOO 1.0.2 !! */
    if (Tcl_PkgPresent(interp, "TclOO", "1.0.2", 1) != NULL) {
	Itcl_IncrObjectRefCount(clazzObjectPtr);
    }

    infoPtr->clazzObjectPtr = clazzObjectPtr;
    infoPtr->clazzClassPtr = Tcl_GetObjectAsClass(clazzObjectPtr);

    /*
     *  Initialize the ensemble package first, since we need this
     *  for other parts of [incr Tcl].
     */

	    Tcl_SetEnsembleMappingDict(interp, cmdPtr, mapDict);
        }
    }
    /* FIXME have to figure out why the refCount of
     * ::itcl::builtin::Info
     * and ::itcl::builtin::Info::vars and vars is 2 here !! */
    /* seems to be as the tclOO commands are not yet deleted ?? */
    if (infoPtr->infoVars3Ptr) {
	Tcl_DecrRefCount(infoPtr->infoVars3Ptr);
    }
    if (infoPtr->infoVars4Ptr) {
	Tcl_DecrRefCount(infoPtr->infoVars4Ptr);
    }
    if (checkMemoryLeaks) {
        if (infoPtr->infoVars3Ptr) {
	    Tcl_DecrRefCount(infoPtr->infoVars3Ptr);
	}
	if (infoPtr->infoVars4Ptr) {
	    Tcl_DecrRefCount(infoPtr->infoVars4Ptr);
	}
    /* see comment above */
    }
    infoPtr->infoVars3Ptr = NULL;
    infoPtr->infoVars4Ptr = NULL;

    Tcl_DecrRefCount(infoPtr->typeDestructorArgumentPtr);

    Tcl_EvalEx(infoPtr->interp,
            "::oo::define ::itcl::clazz deletemethod unknown", -1, 0);

    /* first have to look for the remaining memory leaks, then remove the next ifdef */

    ItclVariable *ivPtr;
    Tcl_HashEntry *hPtr;
    void *callbackPtr;
    int result;
    int newEntry;
    ItclResolveInfo *resolveInfoPtr;
    Tcl_Obj *cmdNamePtr;

    if (!infoPtr->clazzClassPtr
	|| Tcl_ObjectDeleted(infoPtr->clazzObjectPtr)
    ) {
	Tcl_AppendResult(interp, "oo-subsystem is deleted", NULL);
	return TCL_ERROR;
    }

    /*
     * check for an empty class name to avoid a crash
     */
    if (strlen(path) == 0) {
	Tcl_AppendResult(interp, "invalid class name \"\"", NULL);
        return TCL_ERROR;

				     * otherwise NULL */
    Tcl_ObjectMetadataType *class_meta_type;
                                    /* type for getting the Itcl class info
                                     * from a TclOO Tcl_Object */
    const Tcl_ObjectMetadataType *object_meta_type;
                                    /* type for getting the Itcl object info
                                     * from a TclOO Tcl_Object */
    Tcl_Object clazzObjectPtr;      /* the root object of Itcl */
    Tcl_Class clazzClassPtr;        /* the root class of Itcl */
    struct EnsembleInfo *ensembleInfo;
    struct ItclClass *currContextIclsPtr;
                                    /* context class for delegated option
                                     * handling */
    int currClassFlags;             /* flags for the class just in creation */
    int buildingWidget;             /* set if in construction of a widget */

       }
    }

    [foo #auto] kerplunk hello world
} -result {{foo0 kerplunk hello world} {foo0 kerplunk hello world} {foo0 kerplunk hello world}} \
  -cleanup {::itcl::delete class foo}

test sfbug-254.1 { SF bug #254 + bug [1dc2d851eb]
} -body {
    set interp [interp create]
    set ::test_status ""
    $interp eval {
      oo::class destroy
    }
    lappend ::test_status "::oo::class destroy worked"
    if {[catch {
      $interp eval [::tcltest::loadScript]
      $interp eval {
        package require itcl
      }
    } msg]} {
      lappend ::test_status $msg
    }
} -result {{::oo::class destroy worked} {::oo::class does not refer to an object}} \
  -cleanup {interp delete $interp}

test sfbug-254.2 { SF bug #254 + bug [1dc2d851eb]
} -body {
    set interp [interp create]
    set ::test_status ""
    $interp eval [::tcltest::loadScript]
    $interp eval {
      package require itcl

      oo::class destroy
    }
    lappend ::test_status "::oo::class destroy worked"
    if {[catch {
      $interp eval {
        ::itcl::class ::test {}
      }
    } msg]} {
      lappend ::test_status $msg
    }
} -result {{::oo::class destroy worked} {oo-subsystem is deleted}} \
  -cleanup {interp delete $interp}

test sfbug-254.3 { delete oo-subsystem should remove all classes + summary of bug [1dc2d851eb]
} -body {
    set interp [interp create]
    set ::test_status ""
    $interp eval [::tcltest::loadScript]
    $interp eval {
      package require itcl

      ::itcl::class ::test {}
    }
    lappend ::test_status "::test class created"
    $interp eval {
      oo::class destroy
    }
    lappend ::test_status "::oo::class destroy worked"
    if {[catch {
      $interp eval {
        ::test x
      }
    } msg]} {
      lappend ::test_status $msg
    }
    if {[catch {
      $interp eval {
        ::itcl::class ::test2 {inherit ::test}
      }
    } msg]} {
      lappend ::test_status $msg
    }
} -result {{::test class created} {::oo::class destroy worked} {invalid command name "::test"} {oo-subsystem is deleted}} \
  -cleanup {interp delete $interp}

test sfbug-255 { SF bug #255
} -body {
    set ::test_status ""

    proc ::sfbug_255_do_uplevel { body } {
        uplevel 1 $body