Itcl - the [incr Tcl] extension

 *  removed from a class definition to rebuild the member lookup
 *  tables.  There are two tables:
 *
 *  METHODS:  resolveCmds
 *    Used primarily in Itcl_ClassCmdResolver() to resolve all
 *    command references in a namespace.
 *
 *  DATA MEMBERS:  resolveVars
 *    Used primarily in Itcl_ClassVarResolver() to quickly resolve
 *    variable references in each class scope.
 *
 *  These tables store every possible name for each command/variable
 *  (member, class::member, namesp::class::member, etc.).  Members
 *  in a derived class may shadow members with the same name in a
 *  base class.  In that case, the simple name in the resolution

 *  removed from a class definition to rebuild the member lookup
 *  tables.  There are two tables:
 *
 *  METHODS:  resolveCmds
 *    Used primarily in Itcl_ClassCmdResolver() to resolve all
 *    command references in a namespace.
 *
 *  DATA MEMBERS:  resolveVars (built on demand, moved to ItclResolveVarEntry)
 *    Used primarily in Itcl_ClassVarResolver() to quickly resolve
 *    variable references in each class scope.
 *
 *  These tables store every possible name for each command/variable
 *  (member, class::member, namesp::class::member, etc.).  Members
 *  in a derived class may shadow members with the same name in a
 *  base class.  In that case, the simple name in the resolution

        /* create the itcl_hull variable */
        namePtr = Tcl_NewStringObj("itcl_hull", -1);
        if (ItclCreateComponent(interp, iclsPtr, namePtr, ITCL_COMMON,
	        &icPtr) != TCL_OK) {
            return TCL_ERROR;
        }
        iclsPtr->numVariables++;
        Itcl_BuildVirtualTables(iclsPtr);
    }
    Tcl_ResetResult(interp);
    Tcl_AppendResult(interp, Tcl_GetString(iclsPtr->fullNamePtr), NULL);
    return result;
}
 
/*
................................................................................
        Tcl_SetHashValue(hPtr, varPtr);
    }
    result = Itcl_PushCallFrame(interp, &frame, commonNsPtr,
        /* isProcCallFrame */ 0);
    Itcl_PopCallFrame(interp);

    /*
     *  TRICKY NOTE:  Make sure to rebuild the virtual tables for this
     *    class so that this variable is ready to access.  The variable
     *    resolver for the parser namespace needs this info to find the
     *    variable if the developer tries to set it within the class
     *    definition.
     *
     *  If an initialization value was specified, then initialize
     *  the variable now.
     */
    Itcl_BuildVirtualTables(iclsPtr);

    if (initStr != NULL) {
	const char *val;
        Tcl_DStringAppend(&buffer, "::", -1);
        Tcl_DStringAppend(&buffer, Tcl_GetString(ivPtr->namePtr), -1);
        val = Tcl_SetVar2(interp,
	        Tcl_DStringValue(&buffer), NULL, initStr,
                TCL_NAMESPACE_ONLY);

        if (!val) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "cannot initialize common variable \"",
                Tcl_GetString(ivPtr->namePtr), "\"",
                NULL);
            return TCL_ERROR;
        }






    }
    if (ivPtr->arrayInitPtr != NULL) {
	int i;
	int argc;
	const char **argv;
	const char *val;
        Tcl_DStringAppend(&buffer, "::", -1);
        Tcl_DStringAppend(&buffer, Tcl_GetString(ivPtr->namePtr), -1);
	result = Tcl_SplitList(interp, Tcl_GetString(ivPtr->arrayInitPtr),
	        &argc, &argv);
	for (i = 0; i < argc; i++) {
            val = Tcl_SetVar2(interp, Tcl_DStringValue(&buffer), argv[i],
                    argv[i + 1], TCL_NAMESPACE_ONLY);
            if (!val) {
                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                    "cannot initialize common variable \"",
                    Tcl_GetString(ivPtr->namePtr), "\"",
                    NULL);
                return TCL_ERROR;

        /* create the itcl_hull variable */
        namePtr = Tcl_NewStringObj("itcl_hull", -1);
        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), NULL);
    return result;
}
 
/*
................................................................................
        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), "\"",
                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) {
	int i;
	int argc;
	const char **argv;
	const char *val;


	result = Tcl_SplitList(interp, Tcl_GetString(ivPtr->arrayInitPtr),
	        &argc, &argv);
	for (i = 0; i < argc; i++) {
            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), "\"",
                    NULL);
                return TCL_ERROR;

} -result {}

test basic-6.8 {common variables can be redefined
} -body {
    test_arrays0 do set undefined "scalar"
} -result {scalar}

test basic-7.1 {variable lookup before a common creation (bug [777ae99cfb])} -body {

    itcl::class A {
	private common cv "A::cv"
	public proc cv {} {set cv}
    }
    itcl::class B {
	inherit A
	public common res {}
	lappend res [info exists cv]

	#private common cv "B::cv"

	private common cv


	lappend cv "B::cv-add"
	public proc cv {} {set cv}
    }
    lappend B::res [A::cv] [B::cv]
    set B::res











} -result {0 A::cv B::cv-add} -cleanup {












    itcl::delete class B A
}

if {[namespace which test_arrays] ne {}} {
    ::itcl::delete class test_arrays
}
check_itcl_basic_errors
rename check_itcl_basic_errors {}

::tcltest::cleanupTests
return

} -result {}

test basic-6.8 {common variables can be redefined
} -body {
    test_arrays0 do set undefined "scalar"
} -result {scalar}

proc testVarResolver {{access private} {init 0}} {
  eval [string map [list \$access $access \$init $init] {
    itcl::class A {
	$access common cv "A::cv"
	public proc cv {} {set cv}
    }
    itcl::class B {
	inherit A
	public common res {}
	lappend res [info exists cv]
	if {$init} {
	    $access common cv ""
	} else {
	    $access common cv
	}
	lappend res [info exists cv]
	lappend cv "B::cv-add"
	public proc cv {} {set cv}
    }
    lappend B::res [A::cv] [B::cv]
    set B::res
  }]
}
test basic-7.1-a {variable lookup before a common creation (bug [777ae99cfb])} -body {
    # private uninitialized var:
    testVarResolver private 0
} -result {0 0 A::cv B::cv-add} -cleanup {
    itcl::delete class B A
}
test basic-7.1-b {variable lookup before a common creation (bug [777ae99cfb])} -body {
    # public uninitialized var:
    testVarResolver public 0
} -result {1 0 A::cv B::cv-add} -cleanup {
    itcl::delete class B A
}
test basic-7.2-a {variable lookup before a common creation (bug [777ae99cfb])} -body {
    # private initialized var:
    testVarResolver private 1
} -result {0 1 A::cv B::cv-add} -cleanup {
    itcl::delete class B A
}
test basic-7.2-b {variable lookup before a common creation (bug [777ae99cfb])} -body {
    # public initialized var:
    testVarResolver public 1
} -result {1 1 A::cv B::cv-add} -cleanup {
    itcl::delete class B A
}

if {[namespace which test_arrays] ne {}} {
    ::itcl::delete class test_arrays
}
check_itcl_basic_errors
rename check_itcl_basic_errors {}

::tcltest::cleanupTests
return