TclOO Package

2012-12-21  Donal K. Fellows  <[email protected]>

	=== RELEASE OF TCLOO VERSION 1.0 ===

	This officially corresponds to the version of TclOO that is included
	with Tcl 8.6.0, except for features (notably coroutine support) that
	require the 8.6 runtime and not-officially-observable differences like

2013-02-09  Donal K. Fellows  <[email protected]>

	* generic/tclOOBasic.c (TclOO_Object_VarName): [Bug 3603695]: Change
	the way that the 'varname' method is implemented so that there are no
	longer problems with interactions due to the resolver. Thanks to
	Taylor Venable <[email protected]> for identifying the problem.

2012-12-21  Donal K. Fellows  <[email protected]>

	=== RELEASE OF TCLOO VERSION 1.0 ===

	This officially corresponds to the version of TclOO that is included
	with Tcl 8.6.0, except for features (notably coroutine support) that
	require the 8.6 runtime and not-officially-observable differences like

    ClientData clientData,	/* Ignored. */
    Tcl_Interp *interp,		/* Interpreter in which to create the object;
				 * also used for error reporting. */
    Tcl_ObjectContext context,	/* The object/call context. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const *objv)	/* The actual arguments. */
{
    Interp *iPtr = (Interp *) interp;
    Var *varPtr, *aryVar;
    Tcl_Obj *varNamePtr;


    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"varName");
	return TCL_ERROR;
    }



    /*
     * Switch to the object's namespace for the duration of this call. Like
     * this, the variable is looked up in the namespace of the object, and not
     * in the namespace of the caller. Otherwise this would only work if the
     * caller was a method of the object itself, which might not be true if
     * the method was exported. This is a bit of a hack, but the simplest way
     * to do this (pushing a stack frame would be horribly expensive by

     * comparison, and is only done when we'd otherwise interfere with the
     * global namespace).
     */

    if (iPtr->varFramePtr == NULL) {
	Tcl_CallFrame *dummyFrame;

	TclPushStackFrame(interp, &dummyFrame,
		Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),0);
	varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,
		TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);
	TclPopStackFrame(interp);
    } else {
	Namespace *savedNsPtr;

	savedNsPtr = iPtr->varFramePtr->nsPtr;
	iPtr->varFramePtr->nsPtr = (Namespace *)
		Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
	varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,
		TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);
	iPtr->varFramePtr->nsPtr = savedNsPtr;
    }








    if (varPtr == NULL) {

	return TCL_ERROR;
    }






    varNamePtr = Tcl_NewObj();
    if (aryVar != NULL) {
	Tcl_HashEntry *hPtr;
	Tcl_HashSearch search;

	Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);

    ClientData clientData,	/* Ignored. */
    Tcl_Interp *interp,		/* Interpreter in which to create the object;
				 * also used for error reporting. */
    Tcl_ObjectContext context,	/* The object/call context. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const *objv)	/* The actual arguments. */
{

    Var *varPtr, *aryVar;
    Tcl_Obj *varNamePtr, *argPtr;
    const char *arg;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"varName");
	return TCL_ERROR;
    }
    argPtr = objv[objc-1];
    arg = Tcl_GetString(argPtr);

    /*


     * Convert the variable name to fully-qualified form if it wasn't already.
     * This has to be done prior to lookup because we can run into problems
     * with resolvers otherwise. [Bug 3603695]

     *
     * We still need to do the lookup; the variable could be linked to another
     * variable and we want the target's name.
     */

    if (arg[0] == ':' && arg[1] == ':') {
	varNamePtr = argPtr;






    } else {
	Tcl_Namespace *namespacePtr =



		Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));




	varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
	Tcl_AppendToObj(varNamePtr, "::", 2);
	Tcl_AppendObjToObj(varNamePtr, argPtr);
    }
    Tcl_IncrRefCount(varNamePtr);
    varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
	    TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar);
    Tcl_DecrRefCount(varNamePtr);
    if (varPtr == NULL) {
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, NULL);
	return TCL_ERROR;
    }

    /*
     * Now that we've pinned down what variable we're really talking about
     * (including traversing variable links), convert back to a name.
     */

    varNamePtr = Tcl_NewObj();
    if (aryVar != NULL) {
	Tcl_HashEntry *hPtr;
	Tcl_HashSearch search;

	Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);

    oo::objdefine inst export varname eval
} -body {
    inst eval { variable x; array set x {y z} }
    inst varname x(y)
} -cleanup {
    SpecialClass destroy
} -result ::oo_test::x(y)




















test oo-20.1 {OO: variable method} -body {
    oo::class create testClass {
	constructor {} {
	    my variable ok
	    set ok {}
	}

    oo::objdefine inst export varname eval
} -body {
    inst eval { variable x; array set x {y z} }
    inst varname x(y)
} -cleanup {
    SpecialClass destroy
} -result ::oo_test::x(y)
test oo-19.3 {OO: varname method and variable decl: Bug 3603695} -setup {
    oo::class create testClass {
	variable foo
	export varname
	constructor {} {
	    variable foo x
	}
	method bar {obj} {
	    my varname foo
	    $obj varname foo
	}
    }
} -body {
    testClass create A
    testClass create B
    lsearch [list [A varname foo] [B varname foo]] [B bar A]
} -cleanup {
    testClass destroy
} -result 0

test oo-20.1 {OO: variable method} -body {
    oo::class create testClass {
	constructor {} {
	    my variable ok
	    set ok {}
	}