Index: generic/predefined.h =================================================================== diff -u -rf0260303acd3dd10018bbcbb28fc5d954dca2dc6 -re591522c92d208c4942888e632546262fd7641ad --- generic/predefined.h (.../predefined.h) (revision f0260303acd3dd10018bbcbb28fc5d954dca2dc6) +++ generic/predefined.h (.../predefined.h) (revision e591522c92d208c4942888e632546262fd7641ad) @@ -203,7 +203,9 @@ "{elementtype ::xotcl2::Class}}\n" "::xotcl::relation ::xotcl::InfoSlot superclass ::xotcl::Slot\n" "::xotcl::InfoSlot method get {obj -per-object:switch prop} {\n" -"$obj info {*}[expr {${per-object} ? \"-per-object\" : \"\"}] $prop}\n" +"if {[::xotcl::is $obj type ::xotcl2::Object]} {\n" +"$obj info {*}[expr {${per-object} ? \"-per-object\" : \"\"}] $prop} else {\n" +"$obj info $prop}}\n" "::xotcl::InfoSlot method add {obj -per-object:switch prop value {pos 0}} {\n" "puts stderr infoslot-add-[self args]\n" "if {![set .multivalued]} {\n" @@ -231,6 +233,8 @@ "::xotcl::relation ::xotcl::InterceptorSlot superclass ::xotcl::InfoSlot\n" "::xotcl::alias ::xotcl::InterceptorSlot set ::xotcl::relation ;# for backwards compatibility\n" "::xotcl::alias ::xotcl::InterceptorSlot assign ::xotcl::relation\n" +"::xotcl::InterceptorSlot method get {obj -per-object:switch prop} {\n" +"::xotcl::relation $obj {*}[expr {${per-object} ? \"-per-object\" : \"\"}] $prop}\n" "::xotcl::InterceptorSlot method add {obj -per-object:switch prop value {pos 0}} {\n" "puts stderr interceptorslot-add-obj=$obj,per-object=${per-object},prop=$prop,value=$value,pos=$pos\n" "if {![set .multivalued]} {\n" Index: generic/predefined.xotcl =================================================================== diff -u -rf0260303acd3dd10018bbcbb28fc5d954dca2dc6 -re591522c92d208c4942888e632546262fd7641ad --- generic/predefined.xotcl (.../predefined.xotcl) (revision f0260303acd3dd10018bbcbb28fc5d954dca2dc6) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision e591522c92d208c4942888e632546262fd7641ad) @@ -405,7 +405,13 @@ } ::xotcl::relation ::xotcl::InfoSlot superclass ::xotcl::Slot ::xotcl::InfoSlot method get {obj -per-object:switch prop} { - $obj info {*}[expr {${per-object} ? "-per-object" : ""}] $prop + # this check is not nice, but one has to care about cases + # where get is used an xotcl1 objects + if {[::xotcl::is $obj type ::xotcl2::Object]} { + $obj info {*}[expr {${per-object} ? "-per-object" : ""}] $prop + } else { + $obj info $prop + } } ::xotcl::InfoSlot method add {obj -per-object:switch prop value {pos 0}} { puts stderr infoslot-add-[self args] @@ -453,17 +459,16 @@ ::xotcl::alias ::xotcl::InterceptorSlot set ::xotcl::relation ;# for backwards compatibility ::xotcl::alias ::xotcl::InterceptorSlot assign ::xotcl::relation +::xotcl::InterceptorSlot method get {obj -per-object:switch prop} { + ::xotcl::relation $obj {*}[expr {${per-object} ? "-per-object" : ""}] $prop +} ::xotcl::InterceptorSlot method add {obj -per-object:switch prop value {pos 0}} { puts stderr interceptorslot-add-obj=$obj,per-object=${per-object},prop=$prop,value=$value,pos=$pos if {![set .multivalued]} { error "Property $prop of ${.domain}->$obj ist not multivalued" } set perObject [expr {${per-object} ? "-per-object" : ""}] - #puts stderr "perObject=$perObject // ${per-object} // ${.per-object}" set oldSetting [::xotcl::relation $obj {*}$perObject $prop] - #set oldSetting [$obj info $prop -guards] - #puts stderr "BEFORE: $obj info $perObject $prop -guards => '$oldSetting', pos=$pos, value=$value" - #puts stderr "CALL $obj $prop [list [linsert $oldSetting $pos $value]]" $obj $prop {*}$perObject [linsert $oldSetting $pos $value] } Index: tests/info-method.xotcl =================================================================== diff -u --- tests/info-method.xotcl (revision 0) +++ tests/info-method.xotcl (revision e591522c92d208c4942888e632546262fd7641ad) @@ -0,0 +1,63 @@ +package req XOTcl +package require xotcl::test + +proc ? {cmd expected {msg ""}} { + set count 10 + if {$msg ne ""} { + set t [Test new -cmd $cmd -count $count -msg $msg] + } else { + set t [Test new -cmd $cmd -count $count] + } + $t expected $expected + $t run +} +#::xotcl::use xotcl1 +::xotcl::use xotcl2 + +Object create o { + .alias set ::set +} + +Class create C { + .method m {x} {return proc-[self proc]} + .method -per-object mpo {} {return instproc-[self proc]} + .method m-with-assertions {} {return proc-[self proc]} -precondition 1 -postcondition 2 + + .forward addOne expr 1 + + .forward -per-object add1 expr 1 + + .forward -per-object fpo ::o + + .setter s + .setter -per-object spo + + .alias a ::set + .alias -per-object apo ::puts +} + +? {lsort [C info methods -defined]} "a addOne m m-with-assertions s" + +? {C info method name m} "::xotcl::classes::C::m" +? {C info -per-object method name mpo} "::C::mpo" + +? {C info method definition m} {::C method m x {return proc-[self proc]}} +? {C info method def m} {::C method m x {return proc-[self proc]}} +? {C info -per-object method definition mpo} {::C method -per-object mpo {} {return instproc-[self proc]}} +? {C info method definition m-with-assertions} \ + {::C method m-with-assertions {} {return proc-[self proc]} -precondition 1 -postcondition 2} +? {C info method parameter m} {x} +? {Class info method parameter method} \ + {-inner-namespace -per-object -protected name args body -precondition -postcondition} +? {Object info method parameter alias} \ + {{-objscope:switch 0} {-protected:switch 0} methodName cmd} +# raises currently an error +? {catch {C info method parameter a}} 1 + +? {C info method definition addOne} "::C forward addOne expr 1 +" +? {C info -per-object method definition add1} "::C forward -per-object add1 expr 1 +" +? {C info -per-object method definition fpo} "::C forward -per-object fpo ::o" + +? {C info method definition s} "::C setter s" +? {C info -per-object method definition spo} "::C setter -per-object spo" + +? {C info method definition a} "::C alias a ::set" +? {C info -per-object method definition apo} "::C alias -per-object apo ::puts" Index: tests/interceptor-slot.xotcl =================================================================== diff -u --- tests/interceptor-slot.xotcl (revision 0) +++ tests/interceptor-slot.xotcl (revision e591522c92d208c4942888e632546262fd7641ad) @@ -0,0 +1,96 @@ +package require XOTcl +package require xotcl::test + + +proc ? {cmd expected {msg ""}} { + set count 10 + if {$msg ne ""} { + set t [Test new -cmd $cmd -count $count -msg $msg] + } else { + set t [Test new -cmd $cmd -count $count] + } + $t expected $expected + $t run +} + +::xotcl::use xotcl2 +puts stderr START +Class create M { + .method mfoo {} {puts [self proc]} +} +Class create M2 +Class create C +? {C procsearch mixin} "::xotcl2::Object instforward mixin" +C mixin M +? {C info precedence} "::xotcl2::Class ::xotcl2::Object" +? {C mixin} "::M" +? {C info mixin} "::M" +C create c1 +? {c1 info precedence} "::M ::C ::xotcl2::Object" +C mixin add M2 +? {c1 info precedence} "::M2 ::M ::C ::xotcl2::Object" +C mixin delete M2 +? {c1 info precedence} "::M ::C ::xotcl2::Object" +C mixin delete M +? {c1 info precedence} "::C ::xotcl2::Object" +c1 mixin add M +? {c1 info precedence} "::M ::C ::xotcl2::Object" +c1 mixin add M2 +? {c1 info precedence} "::M2 ::M ::C ::xotcl2::Object" +c1 mixin delete M +? {c1 info precedence} "::M2 ::C ::xotcl2::Object" +c1 mixin delete M2 +? {c1 info precedence} "::C ::xotcl2::Object" + +# +# adding, removing per-object mixins for classes through relation +# +::xotcl::relation C -per-object mixin M +? {C info precedence} "::M ::xotcl2::Class ::xotcl2::Object" +? {C info -per-object mixin} "::M" +::xotcl::relation C -per-object mixin "" +? {C info precedence} "::xotcl2::Class ::xotcl2::Object" + +# +# adding per-object mixins for classes via "mixin -per-object add M" +# +C mixin -per-object add M +? {C info precedence} "::M ::xotcl2::Class ::xotcl2::Object" +C mixin -per-object "" +? {C info precedence} "::xotcl2::Class ::xotcl2::Object" + +# +# adding per-object mixins for classes via "mixin -per-object M" +# +C mixin -per-object M +? {C info precedence} "::M ::xotcl2::Class ::xotcl2::Object" + +# forwarder with 0 arguments + flag +? {C mixin -per-object} "::M" + +puts stderr "==================== XOTcl 1" +::xotcl::use xotcl1 + +Class create M1 +Class create M11 +M1 instproc mfoo {} {puts [self proc]} +Class create C1 +? {C1 procsearch mixin} "::xotcl::Object instforward mixin" +C1 mixin M1 +? {C1 info precedence} "::M1 ::xotcl::Class ::xotcl::Object" +C1 create c11 +? {c11 info precedence} "::C1 ::xotcl::Object" +C1 mixin add M11 +? {C1 info precedence} "::M11 ::M1 ::xotcl::Class ::xotcl::Object" +puts stderr ===obj-create+add +Object o -mixin M1 +puts stderr ====[o info class]-[o procsearch mixin]-[Object info instforward -definition mixin] +? {o info precedence} "::M1 ::xotcl::Object" +puts stderr ===class-create+add +Class O +O mixin M1 +? {O info precedence} "::M1 ::xotcl::Class ::xotcl::Object" +puts stderr ===class-create+add-via-parameter +Class O -mixin M1 +puts stderr ====[O info class] +? {O info precedence} "::M1 ::xotcl::Class ::xotcl::Object" \ No newline at end of file