TclOO Package

Check-in [5fa1374aa0]
Login
Core Home Timeline Branches Tags Tickets Wiki

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Implement TIP 436: Improve TclOO isa Introspection
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 5fa1374aa026d4c7f7a28b3dc266867a0a43c622
User & Date: dkf 2015-07-10 13:02:26
Context
2015-08-18
17:48
Backport of minor docfixes from tcl:465213d171, tcl:2c509f6291 and tcl:d06b029d9d. check-in: 8887ba1542 user: dkf tags: trunk
2015-07-10
13:02
Implement TIP 436: Improve TclOO isa Introspection check-in: 5fa1374aa0 user: dkf tags: trunk
2015-05-17
12:55
tcl:ad6696285c Correction of description of filter behaviour with 'unknown'. check-in: e4da01d791 user: dkf tags: trunk
Changes
Unified Diff Ignore Whitespace Patch
Changes to generic/tclOOInfo.c.
︙︙
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446

447
448

449
450
451
452
453
454
455
456
457
458

459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508



























509
510
511
512
513

514



515
516









517
518

519
520
521

522
523
524
525



526
527
528
529
530
531
532
533

    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 --
 *








|










<
<
|
>
|
<
>
|
<
<
<
<
<
<
<
<

>

<
<
<
<
<
<





<
<
<
<
|
<
<
<
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<





>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


|

|
>
|
>
>
>
|
|
>
>
>
>
>
>
>
>
>
|
<
>
|
<
|
>
|
<
<
|
>
>
>
|








426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443


444
445
446

447
448








449
450
451






452
453
454
455
456




457




458























459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512

513
514

515
516
517


518
519
520
521
522
523
524
525
526
527
528
529

    static const char *categories[] = {
	"class", "metaclass", "mixin", "object", "typeof", NULL
    };
    enum IsACats {
	IsClass, IsMetaclass, IsMixin, IsObject, IsType
    };
    Object *oPtr, *o2Ptr;
    int idx, i, result = 0;

    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;
    }



    /*
     * Now we know what test we are doing, we can check we've got the right
     * number of arguments.

     */









    switch ((enum IsACats) idx) {
    case IsObject:
    case IsClass:






    case IsMetaclass:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "objName");
	    return TCL_ERROR;
	}




	break;




    case IsMixin:























    case IsType:
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "objName className");
	    return TCL_ERROR;
	}
	break;
    }

    /*
     * Perform the check. Note that we can guarantee that we will not fail
     * from here on; "failures" result in a false-TCL_OK result.
     */

    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
    if (oPtr == NULL) {
	goto failPrecondition;
    }

    switch ((enum IsACats) idx) {
    case IsObject:
	result = 1;
	break;
    case IsClass:
	result = (oPtr->classPtr != NULL);
	break;
    case IsMetaclass:
	if (oPtr->classPtr != NULL) {
	    result = TclOOIsReachable(TclOOGetFoundation(interp)->classCls,
		    oPtr->classPtr);
	}
	break;
    case IsMixin:
	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
	if (o2Ptr == NULL) {
	    goto failPrecondition;
	}
	if (o2Ptr->classPtr != NULL) {
	    Class *mixinPtr;

	    FOREACH(mixinPtr, oPtr->mixins) {
		if (mixinPtr == o2Ptr->classPtr) {
		    result = 1;
		    break;
		}
	    }
	}
	break;
    case IsType:
	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
	if (o2Ptr == NULL) {
	    goto failPrecondition;
	}
	if (o2Ptr->classPtr != NULL) {
	    result = TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls);

	}
	break;

    }
    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
    return TCL_OK;



  failPrecondition:
    Tcl_ResetResult(interp);
    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * InfoObjectMethodsCmd --
 *
︙︙
Changes to tests/oo.test.
︙︙
1991
1992
1993
1994
1995
1996
1997
























1998
1999
2000
2001
2002
2003
2004

    oo::object create foo
} -cleanup {
    rename foo {}
} -body {
    oo::objdefine foo method Bar {} {return "ok in foo"}
    [info object namespace foo]::my Bar
} -result "ok in foo"

























test oo-17.1 {OO: class introspection} -body {
    info class
} -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?argument ...?\""
test oo-17.2 {OO: class introspection} -body {
    info class superclass NOTANOBJECT
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028

    oo::object create foo
} -cleanup {
    rename foo {}
} -body {
    oo::objdefine foo method Bar {} {return "ok in foo"}
    [info object namespace foo]::my Bar
} -result "ok in foo"
test oo-16.14 {OO: object introspection: TIP #436} -setup {
    oo::class create meta { superclass oo::class }
    [meta create instance1] create instance2
} -body {
    list class [list [info object isa class NOTANOBJECT] \
		    [info object isa class list]] \
	meta [list [info object isa metaclass NOTANOBJECT] \
		  [info object isa metaclass list] \
		  [info object isa metaclass oo::object]] \
	type [list [info object isa typeof oo::object NOTANOBJECT] \
		  [info object isa typeof NOTANOBJECT oo::object] \
		  [info object isa typeof list NOTANOBJECT] \
		  [info object isa typeof NOTANOBJECT list] \
		  [info object isa typeof oo::object list] \
		  [info object isa typeof list oo::object]] \
	mix [list [info object isa mixin oo::object NOTANOBJECT] \
		 [info object isa mixin NOTANOBJECT oo::object] \
		 [info object isa mixin list NOTANOBJECT] \
		 [info object isa mixin NOTANOBJECT list] \
		 [info object isa mixin oo::object list] \
		 [info object isa mixin list oo::object]]
} -cleanup {
    meta destroy
} -result {class {0 0} meta {0 0 0} type {0 0 0 0 0 0} mix {0 0 0 0 0 0}}

test oo-17.1 {OO: class introspection} -body {
    info class
} -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?argument ...?\""
test oo-17.2 {OO: class introspection} -body {
    info class superclass NOTANOBJECT
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
︙︙
This page was generated in about 0.015s by Fossil 2.26 [1b55133f9e] 2024-12-19 19:33:17