Index: doc/index.html =================================================================== diff -u -re61fc14f5c25172a1d1f93bea03be54a772fb4b5 -r1ddb61a407f327672ce64aa1c1610e7043c10ec7 --- doc/index.html (.../index.html) (revision e61fc14f5c25172a1d1f93bea03be54a772fb4b5) +++ doc/index.html (.../index.html) (revision 1ddb61a407f327672ce64aa1c1610e7043c10ec7) @@ -23,7 +23,7 @@

Index: doc/migration1-2.html =================================================================== diff -u -r7050a52ac53992d9a3aec12e48b0fa58a26449e6 -r1ddb61a407f327672ce64aa1c1610e7043c10ec7 --- doc/migration1-2.html (.../migration1-2.html) (revision 7050a52ac53992d9a3aec12e48b0fa58a26449e6) +++ doc/migration1-2.html (.../migration1-2.html) (revision 1ddb61a407f327672ce64aa1c1610e7043c10ec7) @@ -189,6 +189,18 @@

Object Parameters

Method Parameters

Introspection

+ + + + + + + + + + +
XOTcl 1XOTcl 2
someObject info methods ?pattern?someObject info callable ?pattern?
someObject procsearch methodNamesomeObject info callable -which methodName
+

Predefined Methods

Dispatch, Aliases, etc.

Assertions

@@ -236,5 +248,5 @@
- Last modified: Sun Jan 3 18:26:04 CET 2010 + Last modified: Mon Jan 4 21:25:17 CET 2010 Index: generic/xotcl.c =================================================================== diff -u -r0307cf5d5d1715b7aa1ef4bb2eb9f8d76febca3b -r1ddb61a407f327672ce64aa1c1610e7043c10ec7 --- generic/xotcl.c (.../xotcl.c) (revision 0307cf5d5d1715b7aa1ef4bb2eb9f8d76febca3b) +++ generic/xotcl.c (.../xotcl.c) (revision 1ddb61a407f327672ce64aa1c1610e7043c10ec7) @@ -2780,8 +2780,7 @@ -/* append a string of pre and post assertions to a proc - or instproc body */ +/* append a string of pre and post assertions to a method body */ static void AssertionAppendPrePost(Tcl_Interp *interp, Tcl_DString *dsPtr, XOTclProcAssertion *procs) { if (procs) { @@ -3985,8 +3984,8 @@ /* * The search method implements filter search order for filter * and instfilter: first a given name is interpreted as fully - * qualified instproc name. If no instproc is found, a proc is - * search with fully name. Otherwise the simple name is searched + * qualified method name. If no method is found, a proc is + * searched with fully name. Otherwise the simple name is searched * on the heritage order: object (only for * per-object filters), class, meta-class */ @@ -4246,11 +4245,11 @@ /* * if this is not a registered filter, it is an inherited filter, like: - * Class A - * A instproc f ... - * Class B -superclass A - * B instproc {{f {}}} - * B instfilter f + * Class create A + * A method f ... + * Class create B -superclass A + * B method {{f {}}} + * B filter f * -> get the guard from the filter that inherits it (here B->f) */ if (!guardAdded) { @@ -4464,30 +4463,19 @@ if (cl) { Tcl_ListObjAppendElement(interp, list, cl->object.cmdName); - /*fprintf(stderr, "current %p, dispatch %p, forward %p, parametermcd %p, is tcl %p\n", - objProc, XOTclObjDispatch, XOTclForwardMethod, - XOTclSetterMethod, CmdIsProc(cmd)); */ - if (isTcl) { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTPROC]); - } else if (objProc == XOTclForwardMethod) { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTFORWARD]); - } else if (objProc == XOTclSetterMethod) { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTPARAMETERCMD]); - } else { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTCMD]); - } } else { Tcl_ListObjAppendElement(interp, list, obj->cmdName); - if (isTcl) { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_PROC]); - } else if (objProc == XOTclForwardMethod) { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_FORWARD]); - } else if (objProc == XOTclSetterMethod) { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_PARAMETERCMD]); - } else { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_CMD]); - } + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_OBJECT]); } + if (isTcl) { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_METHOD]); + } else if (objProc == XOTclForwardMethod) { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_FORWARD]); + } else if (objProc == XOTclSetterMethod) { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_SETTER]); + } else { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_CMD]); + } Tcl_ListObjAppendElement(interp, list, procObj); return list; } @@ -4740,6 +4728,7 @@ /* search per-object filters */ if (obj->opt && CmdListFindCmdInList(cmd, obj->opt->filters)) { Tcl_ListObjAppendElement(interp, list, obj->cmdName); + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_OBJECT]); Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_FILTER]); Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(Tcl_GetCommandName(interp, cmd), -1)); @@ -4752,7 +4741,7 @@ if (opt && opt->instfilters) { if (CmdListFindCmdInList(cmd, opt->instfilters)) { Tcl_ListObjAppendElement(interp, list, pl->cl->object.cmdName); - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTFILTER]); + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_FILTER]); Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(Tcl_GetCommandName(interp, cmd), -1)); return list; Index: generic/xotclInt.h =================================================================== diff -u -r687ce97e09a55bbe80cf5286b481fcd3ec600c0e -r1ddb61a407f327672ce64aa1c1610e7043c10ec7 --- generic/xotclInt.h (.../xotclInt.h) (revision 687ce97e09a55bbe80cf5286b481fcd3ec600c0e) +++ generic/xotclInt.h (.../xotclInt.h) (revision 1ddb61a407f327672ce64aa1c1610e7043c10ec7) @@ -556,8 +556,8 @@ XOTE_EXIT_HANDLER, XOTE_DEFAULTSUPERCLASS, XOTE_DEFAULTMETACLASS, XOTE_PARAMETER_TYPE_OBJ, XOTE_RESIDUALARGS, XOTE_CLEANUP, XOTE_CONFIGURE, XOTE_FILTER, XOTE_INSTFILTER, - XOTE_INSTPROC, XOTE_PROC, XOTE_INSTFORWARD, XOTE_FORWARD, - XOTE_INSTCMD, XOTE_CMD, XOTE_INSTPARAMETERCMD, XOTE_PARAMETERCMD, + XOTE_METHOD, XOTE_PROC, XOTE_OBJECT, XOTE_FORWARD, + XOTE_INSTCMD, XOTE_CMD, XOTE_SETTER, XOTE_PARAMETERCMD, XOTE_FORMAT, XOTE_INITSLOTS, XOTE_NEWOBJ, XOTE_GUARD_OPTION, XOTE_DEFAULTMETHOD, XOTE___UNKNOWN, XOTE___UNKNOWN__, XOTE_ARGS, XOTE_SPLIT, XOTE_COMMA, @@ -577,8 +577,8 @@ "__exitHandler", "__default_superclass", "__default_metaclass", "::xotcl::parameterType", "residualargs", "cleanup", "configure", "filter", "instfilter", - "instproc", "proc", "instforward", "forward", - "instcmd", "cmd", "instparametercmd", "parametercmd", + "method", "proc", "object", "forward", + "instcmd", "cmd", "setter", "parametercmd", "format", "initslots", "__#", "-guard", "defaultmethod", "__unknown", "__unknown__", "args", "split", ",", Index: library/lib/xotcl1.xotcl =================================================================== diff -u -rbe717fe9ef13e09dcfabf496ca61d75e4c042422 -r1ddb61a407f327672ce64aa1c1610e7043c10ec7 --- library/lib/xotcl1.xotcl (.../xotcl1.xotcl) (revision be717fe9ef13e09dcfabf496ca61d75e4c042422) +++ library/lib/xotcl1.xotcl (.../xotcl1.xotcl) (revision 1ddb61a407f327672ce64aa1c1610e7043c10ec7) @@ -14,7 +14,7 @@ # provide the standard command set for ::xotcl::Object foreach cmd [info command ::xotcl::cmd::Object::*] { set cmdName [namespace tail $cmd] - if {$cmdName in [list "setter"]} continue + if {$cmdName in [list "filtersearch" "setter"]} continue ::xotcl::alias Object $cmdName $cmd } @@ -333,16 +333,30 @@ if {[::info exists pattern]} {lappend cmd $pattern} eval $cmd } + # object filter mapping + .proc filter {o -order:switch -guards:switch pattern:optional} { + set guardsFlag [expr {$guards ? "-guards" : ""}] + set patternArg [expr {[info exists pattern] ? [list $pattern] : ""}] + if {$order && !$guards} { + set def [::xotcl::cmd::ObjectInfo::filter $o -order {*}$guardsFlag {*}$patternArg] + #puts stderr "TO CONVERT: $def" + set def [filterorder_list_to_xotcl1 $def] + } else { + set def [::xotcl::cmd::ObjectInfo::filter $o {*}$guardsFlag {*}$patternArg] + } + #puts stderr " => $def" + return $def + } # assertion handling - .proc check {o} { + .proc check {o} { ::xotcl::checkoption_internal_to_xotcl1 [::xotcl::assertion $o check] } - .proc invar {o} {::xotcl::assertion $o object-invar} + .proc invar {o} {::xotcl::assertion $o object-invar} } foreach cmd [::info command ::xotcl::cmd::ObjectInfo::*] { set cmdName [namespace tail $cmd] - if {$cmdName in [list "callable" "method" "methods"]} continue + if {$cmdName in [list "callable" "filter" "method" "methods"]} continue ::xotcl::alias ::xotcl::objectInfo $cmdName $cmd ::xotcl::alias ::xotcl::classInfo $cmdName $cmd } @@ -372,6 +386,7 @@ # define info methods from objectInfo on classInfo as well ::xotcl::alias classInfo body objectInfo::body ::xotcl::alias classInfo commands objectInfo::commands + ::xotcl::alias classInfo filter objectInfo::filter ::xotcl::alias classInfo methods objectInfo::methods ::xotcl::alias classInfo procs objectInfo::procs ::xotcl::alias classInfo pre objectInfo::pre @@ -429,6 +444,33 @@ } return $options } + proc filterorder_list_to_xotcl1 definitions { + set defs [list] + foreach def $definitions {lappend defs [filterorder_to_xotcl1 $def]} + return $defs + } + proc filterorder_to_xotcl1 definition { + if {$definition ne ""} { + set modifier [lindex $definition 1] + if {$modifier eq "object"} { + set prefix "" + set kind [lindex $definition 2] + set name [lindex $definition 3] + } else { + set prefix "inst" + set kind $modifier + set name [lindex $definition 2] + } + if {$kind eq "method"} { + set kind proc + } elseif {$kind eq "setter"} { + set kind parametercmd + } + set definition [list [lindex $definition 0] ${prefix}$kind $name] + } + return $definition + } + Object instproc check {checkoptions} { ::xotcl::assertion [self] check [::xotcl::checkoption_xotcl1_to_internal $checkoptions] @@ -453,6 +495,10 @@ if {[::xotcl::is [self] mixin $cl]} {return 1} ::xotcl::is [self] type $cl } + Object instproc filtersearch {filter} { + set definition [::xotcl::dispatch [self] ::xotcl::cmd::Object::filtersearch $filter] + return [filterorder_to_xotcl1 $definition] + } Object instproc procsearch {name} { set definition [::xotcl::cmd::ObjectInfo::callable [self] -which $name] if {$definition ne ""} { Index: tests/testx.xotcl =================================================================== diff -u -re61fc14f5c25172a1d1f93bea03be54a772fb4b5 -r1ddb61a407f327672ce64aa1c1610e7043c10ec7 --- tests/testx.xotcl (.../testx.xotcl) (revision e61fc14f5c25172a1d1f93bea03be54a772fb4b5) +++ tests/testx.xotcl (.../testx.xotcl) (revision 1ddb61a407f327672ce64aa1c1610e7043c10ec7) @@ -774,10 +774,11 @@ ::errorCheck [b info filter -order]-[a info filter -order] "{::B instproc f1} {::B instproc f2} {::A instproc f1} {::A instproc fx}-{::a proc x} {::A instproc f1} {::A instproc fx}" \ {[self] -- Filter guard: -order option} - ::errorCheck [b info filter -order -guards]-[a info filter -order -guards] {{f1 -guard {[self] eq "::b"}} {f2 -guard 0} f1 fx-x f1 fx} \ - {[self] -- Filter guard: -order -guards options} + ::errorCheck [b info filter -order -guards] {{f1 -guard {[self] eq "::b"}} {f2 -guard 0}} \ + "filter order guards 1" + ::errorCheck [a info filter -order -guards] {x} \ + "filter order guards 2" - Class Foo Foo instproc init {args} {my set bar hello} Foo instproc baz {args} { @@ -1422,7 +1423,7 @@ next } y n - ::errorCheck $infoNext " ::y+::Y->m*<> ::y+::Y->n*<::X instproc n> ::y+::X->n*<> ::y+->n*<::Y instproc n> ::y+::Y->n*<::X instproc n> ::y+::X->n*<>" \ + ::errorCheck $infoNext " ::y+::Y->m*<> ::y+::Y->n*<::X method n> ::y+::X->n*<> ::y+->n*<::Y method n> ::y+::Y->n*<::X method n> ::y+::X->n*<>" \ "simple self next test" set infoNext "" set result "" @@ -1462,7 +1463,7 @@ X x -test ::errorCheck $result "-::x-::x-" \ "Next Test X -- Wrong result" - ::errorCheck $infoNext " 2::b0+::B->m*<::A instproc m> 2::b+::B->m*<::A instproc m> 1::x+::X->init*<::xotcl::Object instproc init>" \ + ::errorCheck $infoNext " 2::b0+::B->m*<::A method m> 2::b+::B->m*<::A method m> 1::x+::X->init*<::xotcl::Object method init>" \ "self next test 2" X destroy x destroy @@ -1484,7 +1485,7 @@ } set result "" o mProc - ::errorCheck $result "::o-::MIX-::o proc mProc::o--" \ + ::errorCheck $result "::o-::MIX-::o object method mProc::o--" \ "Next Test Proc & Mixin" o destroy; MIX destroy @@ -2025,9 +2026,13 @@ zoom draw Object instfilter "" + +# ::errorCheck $::calling \ +# "{filter f: ::mixinTest {} run draw {::MenuDecorator instproc draw}} {m1 draw: ::mixinTest {} run {::ScrollBarDecorator instproc draw}} {m2 draw: ::mixinTest {} run {::Image instproc draw}} {image draw: ::mixinTest {} run {::GrObject instproc draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run draw {::ScrollBarDecorator instproc draw}} {m2 draw: ::mixinTest {} run {::Image instproc draw}} {image draw: ::mixinTest {} run {::GrObject instproc draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run instfilter {::xotcl::Class instforward instfilter}}" \ +# "Mixin: Calling-Obj/Cl/Proc failed" ::errorCheck $::calling \ - "{filter f: ::mixinTest {} run draw {::MenuDecorator instproc draw}} {m1 draw: ::mixinTest {} run {::ScrollBarDecorator instproc draw}} {m2 draw: ::mixinTest {} run {::Image instproc draw}} {image draw: ::mixinTest {} run {::GrObject instproc draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run draw {::ScrollBarDecorator instproc draw}} {m2 draw: ::mixinTest {} run {::Image instproc draw}} {image draw: ::mixinTest {} run {::GrObject instproc draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run instfilter {::xotcl::Class instforward instfilter}}" \ + "{filter f: ::mixinTest {} run draw {::MenuDecorator method draw}} {m1 draw: ::mixinTest {} run {::ScrollBarDecorator method draw}} {m2 draw: ::mixinTest {} run {::Image method draw}} {image draw: ::mixinTest {} run {::GrObject method draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run draw {::ScrollBarDecorator method draw}} {m2 draw: ::mixinTest {} run {::Image method draw}} {image draw: ::mixinTest {} run {::GrObject method draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run instfilter {::xotcl::Class forward instfilter}}" \ "Mixin: Calling-Obj/Cl/Proc failed" ::errorCheck $::mixinResult \ @@ -2066,10 +2071,14 @@ callingObject callingProc +# ::errorCheck $::calling \ +# {self ::filteredObject {self proc} infoTraceFilter2 {self class} ::InfoTrace2 {self calledproc} set {self callingproc} callingProc {self callingobject} ::callingObject {self callingclass} ::CallingObjectsClass {self filterreg} {::FilterRegClass instfilter infoTraceFilter2} {self next} {::xotcl::Object instcmd set}} \ +# "call stack info" ::errorCheck $::calling \ - {self ::filteredObject {self proc} infoTraceFilter2 {self class} ::InfoTrace2 {self calledproc} set {self callingproc} callingProc {self callingobject} ::callingObject {self callingclass} ::CallingObjectsClass {self filterreg} {::FilterRegClass instfilter infoTraceFilter2} {self next} {::xotcl::Object instcmd set}} \ + {self ::filteredObject {self proc} infoTraceFilter2 {self class} ::InfoTrace2 {self calledproc} set {self callingproc} callingProc {self callingobject} ::callingObject {self callingclass} ::CallingObjectsClass {self filterreg} {::FilterRegClass filter infoTraceFilter2} {self next} {::xotcl::Object cmd set}} \ "call stack info" + Class M1; Class M2; Class M3; Class M4 Class A; Class B -superclass A; B b A instmixin {M1 M2} @@ -3105,13 +3114,13 @@ ::errorCheck [lsort [b info methods]] "__next abstract append array autoname check class cleanup configure contains copy defaultmethod destroy eval exists extractConfigureArg f filter filterguard filtersearch forward hasclass incr info init instvar invar isclass ismetaclass ismixin isobject istype lappend method mixin mixinguard move myProc myProc2 myProcMix1 myProcMix2 noinit objectparameter objproc parametercmd proc procsearch requireNamespace residualargs self set setFilter signature subst trace unknown unset uplevel upvar volatile vwait" "b info methods" - ::errorCheck [lsort [b info methods -nocmds]] "abstract check contains copy defaultmethod extractConfigureArg f hasclass init isclass ismetaclass ismixin isobject istype method move myProc myProc2 myProcMix1 myProcMix2 objectparameter objproc parametercmd proc procsearch self setFilter signature unknown" "b info methods -nocmds" + ::errorCheck [lsort [b info methods -nocmds]] "abstract check contains copy defaultmethod extractConfigureArg f filtersearch hasclass init isclass ismetaclass ismixin isobject istype method move myProc myProc2 myProcMix1 myProcMix2 objectparameter objproc parametercmd proc procsearch self setFilter signature unknown" "b info methods -nocmds" - ::errorCheck [lsort [b info methods -noprocs]] "__next append array autoname class cleanup configure destroy eval exists filter filterguard filtersearch forward incr info instvar invar lappend mixin mixinguard noinit requireNamespace residualargs set subst trace unset uplevel upvar volatile vwait" "b info methods -noprocs" - ::errorCheck [lsort [b info methods -nocmds -nomixins]] "abstract check contains copy defaultmethod extractConfigureArg f hasclass init isclass ismetaclass ismixin isobject istype method move myProc myProc2 objectparameter objproc parametercmd proc procsearch self setFilter signature unknown" "b info methods -nocmds -nomixins" + ::errorCheck [lsort [b info methods -noprocs]] "__next append array autoname class cleanup configure destroy eval exists filter filterguard forward incr info instvar invar lappend mixin mixinguard noinit requireNamespace residualargs set subst trace unset uplevel upvar volatile vwait" "b info methods -noprocs" + ::errorCheck [lsort [b info methods -nocmds -nomixins]] "abstract check contains copy defaultmethod extractConfigureArg f filtersearch hasclass init isclass ismetaclass ismixin isobject istype method move myProc myProc2 objectparameter objproc parametercmd proc procsearch self setFilter signature unknown" "b info methods -nocmds -nomixins" ::errorCheck [b info methods -nocmds -noprocs] "" "b info methods -nocmds -noprocs" - ::errorCheck [lsort [B info methods -nocmds]] "abstract allinstances check contains copy defaultmethod extractConfigureArg f hasclass init instparametercmd instproc isclass ismetaclass ismixin isobject istype method move objectparameter parameter parametercmd proc procsearch self setFilter signature unknown uses" "B info methods -nocmds" + ::errorCheck [lsort [B info methods -nocmds]] "abstract allinstances check contains copy defaultmethod extractConfigureArg f filtersearch hasclass init instparametercmd instproc isclass ismetaclass ismixin isobject istype method move objectparameter parameter parametercmd proc procsearch self setFilter signature unknown uses" "B info methods -nocmds" namespace eval a { proc o args {return o} @@ -3337,7 +3346,7 @@ ::errorCheck [o mixin XY4] ::XY4 " __unknown XY4" } - ::errorCheck [UnknownClass info info] {valid options are: args, body, check, children, class, classchildren, classparent, commands, default, filter, filterguard, forward, hasnamespace, heritage, info, instances, instargs, instbody, instcommands, instdefault, instfilter, instfilterguard, instforward, instinvar, instmixin, instmixinguard, instmixinof, instnonposargs, instparametercmd, instpost, instpre, instprocs, invar, is, methods, mixin, mixinguard, mixinof, nonposargs, parameter, parametercmd, parent, post, pre, precedence, procs, slotobjects, slots, subclass, superclass, vars} "info info" + ::errorCheck [UnknownClass info info] {valid options are: args, body, check, children, class, classchildren, classparent, commands, default, filter, filterguard, forward, hasnamespace, heritage, info, instances, instargs, instbody, instcommands, instdefault, instfilter, instfilterguard, instforward, instinvar, instmixin, instmixinguard, instmixinof, instnonposargs, instparametercmd, instpost, instpre, instprocs, invar, is, methods, mixin, mixinguard, mixinof, nonposargs, parameter, parametercmd, parent, post, pre, precedence, procs, slotobjects, slots, subclass, superclass, vars} "UnknownClass info info" # clear unknown handler to avoid strange results later Class proc __unknown "" ""